aboutsummaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/app/Main.hs11
-rw-r--r--compiler/src/Compiler.hs18
-rw-r--r--compiler/src/Config.hs4
-rw-r--r--compiler/src/Files.hs15
-rw-r--r--compiler/src/Input.hs13
-rw-r--r--compiler/src/Processors.hs15
-rw-r--r--compiler/src/Resource.hs16
7 files changed, 45 insertions, 47 deletions
diff --git a/compiler/app/Main.hs b/compiler/app/Main.hs
index 061fab7..e71e0db 100644
--- a/compiler/app/Main.hs
+++ b/compiler/app/Main.hs
@@ -21,6 +21,7 @@ module Main where
21import GHC.Generics (Generic) 21import GHC.Generics (Generic)
22import Paths_ldgallery_compiler (version, getDataFileName) 22import Paths_ldgallery_compiler (version, getDataFileName)
23import Control.Monad (when) 23import Control.Monad (when)
24import Data.Functor ((<&>))
24import Data.Maybe (isJust) 25import Data.Maybe (isJust)
25import Data.Version (showVersion) 26import Data.Version (showVersion)
26import Data.Aeson (ToJSON) 27import Data.Aeson (ToJSON)
@@ -32,7 +33,7 @@ import Compiler
32import Files (readDirectory, copyTo, remove) 33import Files (readDirectory, copyTo, remove)
33 34
34 35
35data ViewerConfig = ViewerConfig 36newtype ViewerConfig = ViewerConfig
36 { galleryRoot :: String 37 { galleryRoot :: String
37 } deriving (Generic, Show, ToJSON) 38 } deriving (Generic, Show, ToJSON)
38 39
@@ -92,7 +93,7 @@ options = Options
92 &= help "Deploy either the bundled or the given static web viewer to the output directory" 93 &= help "Deploy either the bundled or the given static web viewer to the output directory"
93 } 94 }
94 95
95 &= summary ("ldgallery v" ++ (showVersion version) ++ " - a static web gallery generator with tags") 96 &= summary ("ldgallery v" ++ showVersion version ++ " - a static web gallery generator with tags")
96 &= program "ldgallery" 97 &= program "ldgallery"
97 &= help "Compile a gallery" 98 &= help "Compile a gallery"
98 &= helpArg [explicit, name "h", name "help"] 99 &= helpArg [explicit, name "h", name "help"]
@@ -146,7 +147,7 @@ main =
146 147
147 deployViewer :: FilePath -> Options -> IO () 148 deployViewer :: FilePath -> Options -> IO ()
148 deployViewer distPath Options{outputDir, cleanOutput} = 149 deployViewer distPath Options{outputDir, cleanOutput} =
149 (when cleanOutput $ cleanViewerDir outputDir) 150 when cleanOutput (cleanViewerDir outputDir)
150 >> copyViewer distPath outputDir 151 >> copyViewer distPath outputDir
151 >> writeJSON (outputDir </> "config.json") viewerConfig 152 >> writeJSON (outputDir </> "config.json") viewerConfig
152 153
@@ -154,8 +155,8 @@ main =
154 cleanViewerDir :: FilePath -> IO () 155 cleanViewerDir :: FilePath -> IO ()
155 cleanViewerDir target = 156 cleanViewerDir target =
156 listDirectory target 157 listDirectory target
157 >>= return . filter (/= gallerySubdir) 158 <&> filter (/= gallerySubdir)
158 >>= mapM_ remove . map (target </>) 159 >>= mapM_ (remove . (target </>))
159 160
160 copyViewer :: FilePath -> FilePath -> IO () 161 copyViewer :: FilePath -> FilePath -> IO ()
161 copyViewer dist target = 162 copyViewer dist target =
diff --git a/compiler/src/Compiler.hs b/compiler/src/Compiler.hs
index 749872d..2bb27f9 100644
--- a/compiler/src/Compiler.hs
+++ b/compiler/src/Compiler.hs
@@ -81,16 +81,16 @@ writeJSON outputPath object =
81(|||) = liftM2 (||) 81(|||) = liftM2 (||)
82 82
83anyPattern :: [String] -> String -> Bool 83anyPattern :: [String] -> String -> Bool
84anyPattern patterns string = any (flip Glob.match string) (map Glob.compile patterns) 84anyPattern patterns string = any (flip Glob.match string . Glob.compile) patterns
85 85
86galleryDirFilter :: GalleryConfig -> [FilePath] -> FSNode -> Bool 86galleryDirFilter :: GalleryConfig -> [FilePath] -> FSNode -> Bool
87galleryDirFilter config excludedCanonicalDirs = 87galleryDirFilter config excludedCanonicalDirs =
88 (not . isHidden) 88 (not . isHidden)
89 &&& (not . isExcludedDir) 89 &&& (not . isExcludedDir)
90 &&& ((matchesDir $ anyPattern $ includedDirectories config) ||| 90 &&& (matchesDir (anyPattern $ includedDirectories config) |||
91 (matchesFile $ anyPattern $ includedFiles config)) 91 matchesFile (anyPattern $ includedFiles config))
92 &&& (not . ((matchesDir $ anyPattern $ excludedDirectories config) ||| 92 &&& (not . (matchesDir (anyPattern $ excludedDirectories config) |||
93 (matchesFile $ anyPattern $ excludedFiles config))) 93 matchesFile (anyPattern $ excludedFiles config)))
94 94
95 where 95 where
96 matchesDir :: (FileName -> Bool) -> FSNode -> Bool 96 matchesDir :: (FileName -> Bool) -> FSNode -> Bool
@@ -102,17 +102,17 @@ galleryDirFilter config excludedCanonicalDirs =
102 matchesFile _ Dir{} = False 102 matchesFile _ Dir{} = False
103 103
104 isExcludedDir :: FSNode -> Bool 104 isExcludedDir :: FSNode -> Bool
105 isExcludedDir Dir{canonicalPath} = any (canonicalPath ==) excludedCanonicalDirs 105 isExcludedDir Dir{canonicalPath} = canonicalPath `elem` excludedCanonicalDirs
106 isExcludedDir File{} = False 106 isExcludedDir File{} = False
107 107
108inputTreeFilter :: GalleryConfig -> InputTree -> Bool 108inputTreeFilter :: GalleryConfig -> InputTree -> Bool
109inputTreeFilter GalleryConfig{includedTags, excludedTags} = 109inputTreeFilter GalleryConfig{includedTags, excludedTags} =
110 (hasTagMatching $ anyPattern includedTags) 110 hasTagMatching (anyPattern includedTags)
111 &&& (not . (hasTagMatching $ anyPattern excludedTags)) 111 &&& (not . hasTagMatching (anyPattern excludedTags))
112 112
113 where 113 where
114 hasTagMatching :: (String -> Bool) -> InputTree -> Bool 114 hasTagMatching :: (String -> Bool) -> InputTree -> Bool
115 hasTagMatching cond = (any cond) . (fromMaybe [""] . tags) . sidecar 115 hasTagMatching cond = any cond . (fromMaybe [""] . tags) . sidecar
116 116
117 117
118compileGallery :: FilePath -> FilePath -> FilePath -> FilePath -> [FilePath] -> Bool -> Bool -> IO () 118compileGallery :: FilePath -> FilePath -> FilePath -> FilePath -> [FilePath] -> Bool -> Bool -> IO ()
diff --git a/compiler/src/Config.hs b/compiler/src/Config.hs
index 0ae0fa1..3c38a17 100644
--- a/compiler/src/Config.hs
+++ b/compiler/src/Config.hs
@@ -73,8 +73,8 @@ instance FromJSON GalleryConfig where
73 <*> v .:? "includedTags" .!= ["*"] 73 <*> v .:? "includedTags" .!= ["*"]
74 <*> v .:? "excludedTags" .!= [] 74 <*> v .:? "excludedTags" .!= []
75 <*> v .:? "tagCategories" .!= [] 75 <*> v .:? "tagCategories" .!= []
76 <*> v .:? "tagsFromDirectories" .!= (TagsFromDirectoriesConfig 0 "") 76 <*> v .:? "tagsFromDirectories" .!= TagsFromDirectoriesConfig 0 ""
77 <*> v .:? "thumbnailMaxResolution" .!= (Resolution 400 300) 77 <*> v .:? "thumbnailMaxResolution" .!= Resolution 400 300
78 <*> v .:? "pictureMaxResolution" 78 <*> v .:? "pictureMaxResolution"
79 79
80readConfig :: FileName -> IO GalleryConfig 80readConfig :: FileName -> IO GalleryConfig
diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs
index c769815..40149e1 100644
--- a/compiler/src/Files.hs
+++ b/compiler/src/Files.hs
@@ -30,6 +30,7 @@ module Files
30 30
31import Data.List (isPrefixOf, length, subsequences, sortOn) 31import Data.List (isPrefixOf, length, subsequences, sortOn)
32import Data.Function ((&)) 32import Data.Function ((&))
33import Data.Functor ((<&>))
33import Data.Text (pack) 34import Data.Text (pack)
34import Data.Aeson (ToJSON) 35import Data.Aeson (ToJSON)
35import qualified Data.Aeson as JSON 36import qualified Data.Aeson as JSON
@@ -53,7 +54,7 @@ type LocalPath = String
53type WebPath = String 54type WebPath = String
54 55
55-- | Reversed path component list 56-- | Reversed path component list
56data Path = Path [FileName] deriving Show 57newtype Path = Path [FileName] deriving Show
57 58
58instance ToJSON Path where 59instance ToJSON Path where
59 toJSON = JSON.String . pack . webPath 60 toJSON = JSON.String . pack . webPath
@@ -120,7 +121,7 @@ isHidden = hiddenName . nodeName
120-- | DFS with intermediate dirs first. 121-- | DFS with intermediate dirs first.
121flattenDir :: FSNode -> [FSNode] 122flattenDir :: FSNode -> [FSNode]
122flattenDir file@File{} = [file] 123flattenDir file@File{} = [file]
123flattenDir dir@Dir{items} = dir:(concatMap flattenDir items) 124flattenDir dir@Dir{items} = dir:concatMap flattenDir items
124 125
125-- | Filters a dir tree. The root is always returned. 126-- | Filters a dir tree. The root is always returned.
126filterDir :: (FSNode -> Bool) -> AnchoredFSNode -> AnchoredFSNode 127filterDir :: (FSNode -> Bool) -> AnchoredFSNode -> AnchoredFSNode
@@ -133,7 +134,7 @@ filterDir cond (AnchoredFSNode anchor root) =
133 filter cond items & map filterNode & Dir path canonicalPath 134 filter cond items & map filterNode & Dir path canonicalPath
134 135
135readDirectory :: LocalPath -> IO AnchoredFSNode 136readDirectory :: LocalPath -> IO AnchoredFSNode
136readDirectory root = mkNode (Path []) >>= return . AnchoredFSNode root 137readDirectory root = AnchoredFSNode root <$> mkNode (Path [])
137 where 138 where
138 mkNode :: Path -> IO FSNode 139 mkNode :: Path -> IO FSNode
139 mkNode path = 140 mkNode path =
@@ -151,10 +152,10 @@ readDirectory root = mkNode (Path []) >>= return . AnchoredFSNode root
151 152
152 mkDirNode :: Path -> FilePath -> IO FSNode 153 mkDirNode :: Path -> FilePath -> IO FSNode
153 mkDirNode path canonicalPath = 154 mkDirNode path canonicalPath =
154 (listDirectory $ localPath (root /> path)) 155 listDirectory (localPath (root /> path))
155 >>= mapM (mkNode . ((</) path)) 156 >>= mapM (mkNode . (path </))
156 >>= return . sortOn nodeName 157 <&> sortOn nodeName
157 >>= return . Dir path canonicalPath 158 <&> Dir path canonicalPath
158 159
159copyTo :: FilePath -> AnchoredFSNode -> IO () 160copyTo :: FilePath -> AnchoredFSNode -> IO ()
160copyTo target AnchoredFSNode{anchor, root} = copyNode root 161copyTo target AnchoredFSNode{anchor, root} = copyNode root
diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs
index 6ed7471..1316cdd 100644
--- a/compiler/src/Input.hs
+++ b/compiler/src/Input.hs
@@ -27,6 +27,7 @@ import GHC.Generics (Generic)
27import Control.Exception (Exception, AssertionFailed(..), throw, throwIO) 27import Control.Exception (Exception, AssertionFailed(..), throw, throwIO)
28import Control.Monad.IO.Class (MonadIO, liftIO) 28import Control.Monad.IO.Class (MonadIO, liftIO)
29import Data.Function ((&)) 29import Data.Function ((&))
30import Data.Functor ((<&>))
30import Data.Maybe (catMaybes) 31import Data.Maybe (catMaybes)
31import Data.Bool (bool) 32import Data.Bool (bool)
32import Data.List (find) 33import Data.List (find)
@@ -90,7 +91,7 @@ readSidecarFile :: FilePath -> IO Sidecar
90readSidecarFile filepath = 91readSidecarFile filepath =
91 doesFileExist filepath 92 doesFileExist filepath
92 >>= bool (return Nothing) (decodeYamlFile filepath) 93 >>= bool (return Nothing) (decodeYamlFile filepath)
93 >>= return . maybe emptySidecar id 94 <&> maybe emptySidecar id
94 95
95 96
96readInputTree :: AnchoredFSNode -> IO InputTree 97readInputTree :: AnchoredFSNode -> IO InputTree
@@ -100,13 +101,13 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root
100 where 101 where
101 mkInputNode :: FSNode -> IO (Maybe InputTree) 102 mkInputNode :: FSNode -> IO (Maybe InputTree)
102 mkInputNode file@File{path} 103 mkInputNode file@File{path}
103 | (not $ isSidecar file) && (not $ isThumbnail file) = 104 | not (isSidecar file) && not (isThumbnail file) =
104 do 105 do
105 sidecar <- readSidecarFile $ localPath (anchor /> path <.> sidecarExt) 106 sidecar <- readSidecarFile $ localPath (anchor /> path <.> sidecarExt)
106 modTime <- getModificationTime $ localPath (anchor /> path) 107 modTime <- getModificationTime $ localPath (anchor /> path)
107 return $ Just $ InputFile path modTime sidecar 108 return $ Just $ InputFile path modTime sidecar