aboutsummaryrefslogtreecommitdiff
path: root/compiler/src
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/src')
-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
6 files changed, 39 insertions, 42 deletions
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
108 mkInputNode File{} = return Nothing 109 mkInputNode File{} = return Nothing
109 mkInputNode dir@Dir{} = mkDirNode dir >>= return . Just 110 mkInputNode dir@Dir{} = Just <$> mkDirNode dir
110 111
111 mkDirNode :: FSNode -> IO InputTree 112 mkDirNode :: FSNode -> IO InputTree
112 mkDirNode File{} = throw $ AssertionFailed "Input directory is a file" 113 mkDirNode File{} = throw $ AssertionFailed "Input directory is a file"
@@ -121,17 +122,17 @@ readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root
121 isSidecar Dir{} = False 122 isSidecar Dir{} = False
122 isSidecar File{path} = 123 isSidecar File{path} =
123 fileName path 124 fileName path
124 & (maybe False $ isExtensionOf sidecarExt) 125 & maybe False (isExtensionOf sidecarExt)
125 126
126 isThumbnail :: FSNode -> Bool 127 isThumbnail :: FSNode -> Bool
127 isThumbnail Dir{} = False 128 isThumbnail Dir{} = False
128 isThumbnail File{path} = 129 isThumbnail File{path} =
129 fileName path 130 fileName path
130 & fmap dropExtension 131 & fmap dropExtension
131 & (maybe False (dirPropFile ==)) 132 & maybe False (dirPropFile ==)
132 133
133 findThumbnail :: [FSNode] -> Maybe Path 134 findThumbnail :: [FSNode] -> Maybe Path
134 findThumbnail = (fmap Files.path) . (find isThumbnail) 135 findThumbnail = fmap Files.path . find isThumbnail
135 136
136-- | Filters an InputTree. The root is always returned. 137-- | Filters an InputTree. The root is always returned.
137filterInputTree :: (InputTree -> Bool) -> InputTree -> InputTree 138filterInputTree :: (InputTree -> Bool) -> InputTree -> InputTree
diff --git a/compiler/src/Processors.hs b/compiler/src/Processors.hs
index 0efbf6d..73529ee 100644
--- a/compiler/src/Processors.hs
+++ b/compiler/src/Processors.hs
@@ -57,10 +57,7 @@ data Format =
57 57
58formatFromPath :: Path -> Format 58formatFromPath :: Path -> Format
59formatFromPath = 59formatFromPath =
60 maybe Unknown fromExt 60 maybe Unknown ((fromExt . map toLower) . takeExtension) . fileName
61 . fmap (map toLower)
62 . fmap takeExtension
63 . fileName
64 where 61 where
65 fromExt :: String -> Format 62 fromExt :: String -> Format
66 fromExt ext = case ext of 63 fromExt ext = case ext of
@@ -97,12 +94,12 @@ type FileProcessor =
97 94
98copyFileProcessor :: FileProcessor 95copyFileProcessor :: FileProcessor
99copyFileProcessor inputPath outputPath = 96copyFileProcessor inputPath outputPath =
100 (putStrLn $ "Copying:\t" ++ outputPath) 97 putStrLn