diff options
Diffstat (limited to 'compiler/src')
-rw-r--r-- | compiler/src/Compiler.hs | 18 | ||||
-rw-r--r-- | compiler/src/Config.hs | 4 | ||||
-rw-r--r-- | compiler/src/Files.hs | 15 | ||||
-rw-r--r-- | compiler/src/Input.hs | 13 | ||||
-rw-r--r-- | compiler/src/Processors.hs | 15 | ||||
-rw-r--r-- | compiler/src/Resource.hs | 16 |
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 | ||
83 | anyPattern :: [String] -> String -> Bool | 83 | anyPattern :: [String] -> String -> Bool |
84 | anyPattern patterns string = any (flip Glob.match string) (map Glob.compile patterns) | 84 | anyPattern patterns string = any (flip Glob.match string . Glob.compile) patterns |
85 | 85 | ||
86 | galleryDirFilter :: GalleryConfig -> [FilePath] -> FSNode -> Bool | 86 | galleryDirFilter :: GalleryConfig -> [FilePath] -> FSNode -> Bool |
87 | galleryDirFilter config excludedCanonicalDirs = | 87 | galleryDirFilter 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 | ||
108 | inputTreeFilter :: GalleryConfig -> InputTree -> Bool | 108 | inputTreeFilter :: GalleryConfig -> InputTree -> Bool |
109 | inputTreeFilter GalleryConfig{includedTags, excludedTags} = | 109 | inputTreeFilter 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 | ||
118 | compileGallery :: FilePath -> FilePath -> FilePath -> FilePath -> [FilePath] -> Bool -> Bool -> IO () | 118 | compileGallery :: 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 | ||
80 | readConfig :: FileName -> IO GalleryConfig | 80 | readConfig :: 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 | ||
31 | import Data.List (isPrefixOf, length, subsequences, sortOn) | 31 | import Data.List (isPrefixOf, length, subsequences, sortOn) |
32 | import Data.Function ((&)) | 32 | import Data.Function ((&)) |
33 | import Data.Functor ((<&>)) | ||
33 | import Data.Text (pack) | 34 | import Data.Text (pack) |
34 | import Data.Aeson (ToJSON) | 35 | import Data.Aeson (ToJSON) |
35 | import qualified Data.Aeson as JSON | 36 | import qualified Data.Aeson as JSON |
@@ -53,7 +54,7 @@ type LocalPath = String | |||
53 | type WebPath = String | 54 | type WebPath = String |
54 | 55 | ||
55 | -- | Reversed path component list | 56 | -- | Reversed path component list |
56 | data Path = Path [FileName] deriving Show | 57 | newtype Path = Path [FileName] deriving Show |
57 | 58 | ||
58 | instance ToJSON Path where | 59 | instance 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. |
121 | flattenDir :: FSNode -> [FSNode] | 122 | flattenDir :: FSNode -> [FSNode] |
122 | flattenDir file@File{} = [file] | 123 | flattenDir file@File{} = [file] |
123 | flattenDir dir@Dir{items} = dir:(concatMap flattenDir items) | 124 | flattenDir 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. |
126 | filterDir :: (FSNode -> Bool) -> AnchoredFSNode -> AnchoredFSNode | 127 | filterDir :: (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 | ||
135 | readDirectory :: LocalPath -> IO AnchoredFSNode | 136 | readDirectory :: LocalPath -> IO AnchoredFSNode |
136 | readDirectory root = mkNode (Path []) >>= return . AnchoredFSNode root | 137 | readDirectory 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 | ||
159 | copyTo :: FilePath -> AnchoredFSNode -> IO () | 160 | copyTo :: FilePath -> AnchoredFSNode -> IO () |
160 | copyTo target AnchoredFSNode{anchor, root} = copyNode root | 161 | copyTo 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) | |||
27 | import Control.Exception (Exception, AssertionFailed(..), throw, throwIO) | 27 | import Control.Exception (Exception, AssertionFailed(..), throw, throwIO) |
28 | import Control.Monad.IO.Class (MonadIO, liftIO) | 28 | import Control.Monad.IO.Class (MonadIO, liftIO) |
29 | import Data.Function ((&)) | 29 | import Data.Function ((&)) |
30 | import Data.Functor ((<&>)) | ||
30 | import Data.Maybe (catMaybes) | 31 | import Data.Maybe (catMaybes) |
31 | import Data.Bool (bool) | 32 | import Data.Bool (bool) |
32 | import Data.List (find) | 33 | import Data.List (find) |
@@ -90,7 +91,7 @@ readSidecarFile :: FilePath -> IO Sidecar | |||
90 | readSidecarFile filepath = | 91 | readSidecarFile 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 | ||
96 | readInputTree :: AnchoredFSNode -> IO InputTree | 97 | readInputTree :: 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. |
137 | filterInputTree :: (InputTree -> Bool) -> InputTree -> InputTree | 138 | filterInputTree :: (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 | ||
58 | formatFromPath :: Path -> Format | 58 | formatFromPath :: Path -> Format |
59 | formatFromPath = | 59 | formatFromPath = |
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 | ||
98 | copyFileProcessor :: FileProcessor | 95 | copyFileProcessor :: FileProcessor |
99 | copyFileProcessor inputPath outputPath = | 96 | copyFileProcessor inputPath outputPath = |
100 | (putStrLn $ "Copying:\t" ++ outputPath) | 97 | putStrLn ("Copying:\t" ++ outputPath) |
101 | >> ensureParentDir (flip System.Directory.copyFile) outputPath inputPath |