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/Files.hs | 49 ++++++++++++++++++++++++++++++-------------------
 1 file changed, 30 insertions(+), 19 deletions(-)

(limited to 'compiler/src/Files.hs')

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