aboutsummaryrefslogtreecommitdiff
path: root/compiler/src
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/src')
-rw-r--r--compiler/src/Compiler.hs20
-rw-r--r--compiler/src/Files.hs49
-rw-r--r--compiler/src/Processors.hs6
-rw-r--r--compiler/src/Resource.hs21
4 files changed, 62 insertions, 34 deletions
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)
26import Data.List (any) 26import Data.List (any)
27import System.FilePath ((</>)) 27import System.FilePath ((</>))
28import qualified System.FilePath.Glob as Glob 28import qualified System.FilePath.Glob as Glob
29import System.Directory (canonicalizePath)
29 30
30import Data.Aeson (ToJSON) 31import Data.Aeson (ToJSON)
31import qualified Data.Aeson as JSON 32import qualified Data.Aeson as JSON
@@ -52,9 +53,6 @@ galleryConf = "gallery.yaml"
52indexFile :: String 53indexFile :: String
53indexFile = "index.json" 54indexFile = "index.json"
54 55
55viewerMainFile :: String
56viewerMainFile = "index.html"
57
58viewerConfFile :: String 56viewerConfFile :: String
59viewerConfFile = "viewer.json" 57viewerConfFile = "viewer.json"
60 58
@@ -72,11 +70,11 @@ writeJSON outputPath object =
72 ensureParentDir JSON.encodeFile outputPath object 70 ensureParentDir JSON.encodeFile outputPath object
73 71
74 72
75galleryDirFilter :: CompilerConfig -> FSNode -> Bool 73galleryDirFilter :: CompilerConfig -> FilePath -> FSNode -> Bool
76galleryDirFilter config = 74galleryDirFilter config outputDir =
77 (not . isHidden) 75 (not . isHidden)
76 &&& (not . isOutputGallery)
78 &&& (not . matchesFile (== galleryConf)) 77 &&& (not . matchesFile (== galleryConf))
79 &&& (not . containsOutputGallery)
80 &&& ((matchesDir $ anyPattern $ includedDirectories config) ||| 78 &&& ((matchesDir $ anyPattern $ includedDirectories config) |||
81 (matchesFile $ anyPattern $ includedFiles config)) 79 (matchesFile $ anyPattern $ includedFiles config))
82 &&& (not . ((matchesDir $ anyPattern $ excludedDirectories config) ||| 80 &&& (not . ((matchesDir $ anyPattern $ excludedDirectories config) |||
@@ -97,10 +95,9 @@ galleryDirFilter config =
97 anyPattern :: [String] -> FileName -> Bool 95 anyPattern :: [String] -> FileName -> Bool
98 anyPattern patterns filename = any (flip Glob.match filename) (map Glob.compile patterns) 96 anyPattern patterns filename = any (flip Glob.match filename) (map Glob.compile patterns)
99 97
100 containsOutputGallery :: FSNode -> Bool 98 isOutputGallery :: FSNode -> Bool
101 containsOutputGallery File{} = False 99 isOutputGallery Dir{canonicalPath} = canonicalPath == outputDir
102 containsOutputGallery Dir{items} = 100 isOutputGallery File{} = False
103 any (matchesFile (== indexFile) ||| matchesFile (== viewerMainFile)) items
104 101
105 102
106compileGallery :: FilePath -> FilePath -> Bool -> Bool -> IO () 103compileGallery :: FilePath -> FilePath -> Bool -> Bool -> IO ()
@@ -110,7 +107,8 @@ compileGallery inputDirPath outputDirPath rebuildAll cleanOutput =
110 let config = compiler fullConfig 107 let config = compiler fullConfig
111 108
112 inputDir <- readDirectory inputDirPath 109 inputDir <- readDirectory inputDirPath
113 let sourceFilter = galleryDirFilter config 110 canonicalOutPath <- canonicalizePath outputDirPath
111 let sourceFilter = galleryDirFilter config canonicalOutPath
114 let sourceTree = filterDir sourceFilter inputDir 112 let sourceTree = filterDir sourceFilter inputDir
115 inputTree <- readInputTree sourceTree 113 inputTree <- readInputTree sourceTree
116 114
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
29 29
30 30
31import Control.Monad (mapM) 31import Control.Monad (mapM)
32import Data.Bool (bool)
33import Data.List (isPrefixOf, length, subsequences) 32import Data.List (isPrefixOf, length, subsequences)
34import Data.Function ((&)) 33import Data.Function ((&))
35import Data.Text (pack) 34import Data.Text (pack)
@@ -39,6 +38,7 @@ import qualified Data.Aeson as JSON
39import System.Directory 38import System.Directory
40 ( doesDirectoryExist 39 ( doesDirectoryExist
41 , doesPathExist 40 , doesPathExist
41 , canonicalizePath
42 , getModificationTime 42 , getModificationTime
43 , listDirectory 43 , listDirectory
44 , createDirectoryIfMissing 44 , createDirectoryIfMissing
@@ -94,8 +94,13 @@ webPath (Path path) = System.FilePath.Posix.joinPath $ reverse path
94 94
95 95
96data FSNode = 96data FSNode =
97 File { path :: Path } 97 File
98 | Dir { path :: Path, items :: [FSNode] } 98 { path :: Path
99 , canonicalPath :: FilePath }
100 | Dir
101 { path :: Path
102 , canonicalPath :: FilePath
103 , items :: [FSNode] }
99 deriving Show 104 deriving Show
100 105
101data AnchoredFSNode = AnchoredFSNode 106data AnchoredFSNode = AnchoredFSNode
@@ -115,8 +120,8 @@ isHidden = hiddenName . nodeName
115 120
116-- | DFS with intermediate dirs first. 121-- | DFS with intermediate dirs first.
117flattenDir :: FSNode -> [FSNode] 122flattenDir :: FSNode -> [FSNode]
118flattenDir file@(File _) = [file] 123flattenDir file@File{} = [file]
119flattenDir dir@(Dir _ items) = dir:(concatMap flattenDir items) 124flattenDir dir@Dir{items} = dir:(concatMap flattenDir items)
120 125
121-- | Filters a dir tree. The root is always returned. 126-- | Filters a dir tree. The root is always returned.
122filterDir :: (FSNode -> Bool) -> AnchoredFSNode -> AnchoredFSNode 127filterDir :: (FSNode -> Bool) -> AnchoredFSNode -> AnchoredFSNode
@@ -124,35 +129,41 @@ filterDir cond (AnchoredFSNode anchor root) =
124 AnchoredFSNode anchor (filterNode root) 129 AnchoredFSNode anchor (filterNode root)
125 where 130 where
126 filterNode :: FSNode -> FSNode 131 filterNode :: FSNode -> FSNode
127 filterNode file@(File _) = file 132 filterNode file@File{} = file
128 filterNode (Dir path items) = 133 filterNode Dir{path, canonicalPath, items} =
129 filter cond items & map filterNode & Dir path 134 filter cond items & map filterNode & Dir path canonicalPath
130 135
131readDirectory :: LocalPath -> IO AnchoredFSNode 136readDirectory :: LocalPath -> IO AnchoredFSNode
132readDirectory root = mkNode (Path []) >>= return . AnchoredFSNode root 137readDirectory root = mkNode (Path []) >>= return . AnchoredFSNode root
133 where 138 where
134 mkNode :: Path -> IO FSNode 139 mkNode :: Path -> IO FSNode
135 mkNode path = 140 mkNode path =
136 (doesDirectoryExist $ localPath (root /> path)) 141 do
137 >>= bool (mkFileNode path) (mkDirNode path) 142 let relPath = localPath (root /> path)
138 143 canonicalPath <- canonicalizePath relPath
139 mkFileNode :: Path -> IO FSNode 144 isDir <- doesDirectoryExist relPath
140 mkFileNode path = return $ File path 145 if isDir then
141 146 mkDirNode path canonicalPath
142 mkDirNode :: Path -> IO FSNode 147 else
143 mkDirNode path = 148 mkFileNode path canonicalPath
149
150 mkFileNode :: Path -> FilePath -> IO FSNode
151 mkFileNode path canonicalPath = return $ File path canonicalPath
152
153 mkDirNode :: Path -> FilePath -> IO FSNode
154 mkDirNode path canonicalPath =
144 (listDirectory $ localPath (root /> path)) 155 (listDirectory $ localPath (root /> path))
145 >>= mapM (mkNode . ((</) path)) 156 >>= mapM (mkNode . ((</) path))
146 >>= return . Dir path 157 >>= return . Dir path canonicalPath
147 158
148copyTo :: FilePath -> AnchoredFSNode -> IO () 159copyTo :: FilePath -> AnchoredFSNode -> IO ()
149copyTo target AnchoredFSNode{anchor, root} = copyNode root 160copyTo target AnchoredFSNode{anchor, root} = copyNode root
150 where 161 where
151 copyNode :: FSNode -> IO () 162 copyNode :: FSNode -> IO ()
152 copyNode (File path) = 163 copyNode File{path} =
153 copyFile (localPath $ anchor /> path) (localPath $ target /> path) 164 copyFile (localPath $ anchor /> path) (localPath $ target /> path)
154 165
155 copyNode (Dir path items) = 166 copyNode Dir{path, items} =
156 createDirectoryIfMissing True (localPath $ target /> path) 167 createDirectoryIfMissing True (localPath $ target /> path)
157 >> mapM_ copyNode items 168 >> mapM_ copyNode items
158 169
diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs
index 9ddc6ee..fc719af 100644
--- a/compiler/src/Processors.hs
+++ b/compiler/src/Processors.hs
@@ -87,7 +87,11 @@ resizePictureUpTo maxResolution inputPath outputPath =
87 maxSize Resolution{width, height} = show width ++ "x" ++ show height ++ ">" 87 maxSize Resolution{width, height} = show width ++ "x" ++ show height ++ ">"
88 88
89 resize :: FileName -> FileName -> IO () 89 resize :: FileName -> FileName -> IO ()
90 resize input output = callProcess "magick" [input, "-resize", maxSize maxResolution, output] 90 resize input output = callProcess "magick"
91 [ input
92 , "-auto-orient"
93 , "-resize", maxSize maxResolution
94 , output ]
91 95
92 96
93type Cache = FileProcessor -> FileProcessor 97type Cache = FileProcessor -> FileProcessor
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 33f3cf0..400e18a 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -24,8 +24,8 @@ module Resource
24 24
25 25
26import Control.Concurrent.ParallelIO.Global (parallel) 26import Control.Concurrent.ParallelIO.Global (parallel)
27import Data.List ((\\), sortBy) 27import Data.List (sortOn)
28import Data.Ord (comparing) 28import Data.List.Ordered (minusBy)
29import Data.Char (toLower) 29import Data.Char (toLower)
30import Data.Maybe (mapMaybe, fromMaybe, maybeToList) 30import Data.Maybe (mapMaybe, fromMaybe, maybeToList)
31import Data.Function ((&)) 31import Data.Function ((&))
@@ -218,11 +218,26 @@ galleryOutputDiff resources ref =
218 . map (resource :: (Thumbnail -> Resource)) 218 . map (resource :: (Thumbnail -> Resource))
219 . mapMaybe thumbnail 219 . mapMaybe thumbnail
220 220
221 (\\) :: [Path] -> [Path] -> [Path]
222 a \\ b = minusOn orderedForm (sortOn orderedForm a) (sortOn orderedForm b)
223 where
224 orderedForm :: Path -> WebPath
225 orderedForm = webPath
226
227 minusOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
228 minusOn f l r = map snd $ minusBy comparingFst (packRef f l) (packRef f r)
229
230 packRef :: (a -> b) -> [a] -> [(b, a)]
231 packRef f = map (\x -> let y = f x in y `seq` (y, x))
232
233 comparingFst :: Ord b => (b, a) -> (b, a) -> Ordering
234 comparingFst