From 4fde03c7654dcdad11a8c91ba2bcbb2706695e11 Mon Sep 17 00:00:00 2001
From: pacien
Date: Thu, 30 Jan 2020 16:03:54 +0100
Subject: compiler: properly exclude out directory

Use canonical paths to exclude the output directory if it is located
inside the input directory instead of guessing based on special files.

GitHub: closes #54
---
 compiler/src/Compiler.hs | 20 +++++++++-----------
 compiler/src/Files.hs    | 49 +++++++++++++++++++++++++++++-------------------
 2 files changed, 39 insertions(+), 30 deletions(-)

(limited to 'compiler/src')

diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs
index 8819ffc..d392f74 100644
--- a/compiler/src/Compiler.hs
+++ b/compiler/src/Compiler.hs
@@ -26,6 +26,7 @@ import Control.Monad (liftM2)
 import Data.List (any)
 import System.FilePath ((</>))
 import qualified System.FilePath.Glob as Glob
+import System.Directory (canonicalizePath)
 
 import Data.Aeson (ToJSON)
 import qualified Data.Aeson as JSON
@@ -52,9 +53,6 @@ galleryConf = "gallery.yaml"
 indexFile :: String
 indexFile = "index.json"
 
-viewerMainFile :: String
-viewerMainFile = "index.html"
-
 viewerConfFile :: String
 viewerConfFile = "viewer.json"
 
@@ -72,11 +70,11 @@ writeJSON outputPath object =
     ensureParentDir JSON.encodeFile outputPath object
 
 
-galleryDirFilter :: CompilerConfig -> FSNode -> Bool
-galleryDirFilter config =
+galleryDirFilter :: CompilerConfig -> FilePath -> FSNode -> Bool
+galleryDirFilter config outputDir =
       (not . isHidden)
+  &&& (not . isOutputGallery)
   &&& (not . matchesFile (== galleryConf))
-  &&& (not . containsOutputGallery)
   &&& ((matchesDir $ anyPattern $ includedDirectories config) |||
        (matchesFile $ anyPattern $ includedFiles config))
   &&& (not . ((matchesDir $ anyPattern $ excludedDirectories config) |||
@@ -97,10 +95,9 @@ galleryDirFilter config =
     anyPattern :: [String] -> FileName -> Bool
     anyPattern patterns filename = any (flip Glob.match filename) (map Glob.compile patterns)
 
-    containsOutputGallery :: FSNode -> Bool
-    containsOutputGallery File{} = False
-    containsOutputGallery Dir{items} =
-      any (matchesFile (== indexFile) ||| matchesFile (== viewerMainFile)) items
+    isOutputGallery :: FSNode -> Bool
+    isOutputGallery Dir{canonicalPath} = canonicalPath == outputDir
+    isOutputGallery File{} = False
 
 
 compileGallery :: FilePath -> FilePath -> Bool -> Bool -> IO ()
@@ -110,7 +107,8 @@ compileGallery inputDirPath outputDirPath rebuildAll cleanOutput =
     let config = compiler fullConfig
 
     inputDir <- readDirectory inputDirPath
-    let sourceFilter = galleryDirFilter config
+    canonicalOutPath <- canonicalizePath outputDirPath
+    let sourceFilter = galleryDirFilter config canonicalOutPath
     let sourceTree = filterDir sourceFilter inputDir
     inputTree <- readInputTree sourceTree
 
diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs
index 41fc5a8..8ea943f 100644
--- a/compiler/src/Files.hs
+++ b/compiler/src/Files.hs
@@ -29,7 +29,6 @@ module Files
 
 
 import Control.Monad (mapM)
-import Data.Bool (bool)
 import Data.List (isPrefixOf, length, subsequences)
 import Data.Function ((&))
 import Data.Text (pack)
@@ -39,6 +38,7 @@ import qualified Data.Aeson as JSON
 import System.Directory
   ( doesDirectoryExist
   , doesPathExist
+  , canonicalizePath
   , getModificationTime
   , listDirectory
   , createDirectoryIfMissing
@@ -94,8 +94,13 @@ webPath (Path path) = System.FilePath.Posix.joinPath $ reverse path
 
 
 data FSNode =
-    File { path :: Path }
-  | Dir { path :: Path, items :: [FSNode] }
+    File
+      { path :: Path
+      , canonicalPath :: FilePath }
+  | Dir
+      { path :: Path
+      , canonicalPath :: FilePath
+      , items :: [FSNode] }
   deriving Show
 
 data AnchoredFSNode = AnchoredFSNode
@@ -115,8 +120,8 @@ isHidden = hiddenName . nodeName
 
 -- | DFS with intermediate dirs first.
 flattenDir :: FSNode -> [FSNode]
-flattenDir file@(File _) = [file]
-flattenDir dir@(Dir _ items) = dir:(concatMap flattenDir items)
+flattenDir file@File{} = [file]
+flattenDir dir@Dir{items} = dir:(concatMap flattenDir items)
 
 -- | Filters a dir tree. The root is always returned.
 filterDir :: (FSNode -> Bool) -> AnchoredFSNode -> AnchoredFSNode
@@ -124,35 +129,41 @@ filterDir cond (AnchoredFSNode anchor root) =
   AnchoredFSNode anchor (filterNode root)
   where
   filterNode :: FSNode -> FSNode
-  filterNode file@(File _) = file
-  filterNode (Dir path items) =
-    filter cond items & map filterNode & Dir path
+  filterNode file@File{} = file
+  filterNode Dir{path, canonicalPath, items} =
+    filter cond items & map filterNode & Dir path canonicalPath
 
 readDirectory :: LocalPath -> IO AnchoredFSNode
 readDirectory root = mkNode (Path []) >>= return . AnchoredFSNode root
   where
     mkNode :: Path -> IO FSNode
     mkNode path =
-      (doesDirectoryExist $ localPath (root /> path))
-      >>= bool (mkFileNode path) (mkDirNode path)
-
-    mkFileNode :: Path -> IO FSNode
-    mkFileNode path = return $ File path
-
-    mkDirNode :: Path -> IO FSNode
-    mkDirNode path =
+      do
+        let relPath = localPath (root /> path)
+        canonicalPath <- canonicalizePath relPath
+        isDir <- doesDirectoryExist relPath
+        if isDir then
+          mkDirNode path canonicalPath
+        else
+          mkFileNode path canonicalPath
+
+    mkFileNode :: Path -> FilePath -> IO FSNode
+    mkFileNode path canonicalPath = return $ File path canonicalPath
+
+    mkDirNode :: Path -> FilePath -> IO FSNode
+    mkDirNode path canonicalPath =
       (listDirectory $ localPath (root /> path))
       >>= mapM (mkNode . ((</) path))
-      >>= return . Dir path
+      >>= return . Dir path canonicalPath
 
 copyTo :: FilePath -> AnchoredFSNode -> IO ()
 copyTo target AnchoredFSNode{anchor, root} = copyNode root
   where
     copyNode :: FSNode -> IO ()
-    copyNode (File path) =
+    copyNode File{path} =
       copyFile (localPath $ anchor /> path) (localPath $ target /> path)
 
-    copyNode (Dir path items) =
+    copyNode Dir{path, items} =
       createDirectoryIfMissing True (localPath $ target /> path)
       >> mapM_ copyNode items
 
-- 
cgit v1.2.3