aboutsummaryrefslogtreecommitdiff
path: root/compiler/src/Lib.hs
diff options
context:
space:
mode:
authorpacien2019-12-23 11:19:33 +0100
committerpacien2019-12-23 11:19:33 +0100
commit139e2b76d23b13d2b3bb70fb1d5c1ea9dc255513 (patch)
tree0ed3be3b0e6e23e97526a37dfcb60dbdd9146a37 /compiler/src/Lib.hs
parent81cfb110248a8f98cd084533f00a98a507d9518b (diff)
downloadldgallery-139e2b76d23b13d2b3bb70fb1d5c1ea9dc255513.tar.gz
compiler: export aggregated json index
Diffstat (limited to 'compiler/src/Lib.hs')
-rw-r--r--compiler/src/Lib.hs68
1 files changed, 47 insertions, 21 deletions
diff --git a/compiler/src/Lib.hs b/compiler/src/Lib.hs
index 6cecfc5..e21751c 100644
--- a/compiler/src/Lib.hs
+++ b/compiler/src/Lib.hs
@@ -40,7 +40,7 @@ import Data.Text (Text, empty, pack)
40import Data.Yaml (ParseException, decodeFileEither) 40import Data.Yaml (ParseException, decodeFileEither)
41import Data.Aeson 41import Data.Aeson
42 42
43import System.FilePath (isExtensionOf) 43import System.FilePath ((</>), dropFileName, dropExtension, isExtensionOf)
44import qualified System.FilePath.Posix (joinPath) 44import qualified System.FilePath.Posix (joinPath)
45import System.Directory.Tree 45import System.Directory.Tree
46import System.Directory 46import System.Directory
@@ -147,44 +147,70 @@ joinURLPath :: [FileName] -> Text
147joinURLPath = pack . System.FilePath.Posix.joinPath 147joinURLPath = pack . System.FilePath.Posix.joinPath
148 148
149 149
150toItemTree :: (MonadIO m) => FilePath -> FilePath -> DirTree SidecarItemMetadata -> m Item 150toItemTree :: (MonadIO m) => FilePath -> FilePath -> DirTree SidecarItemMetadata -> m (Item, DirTree SidecarItemMetadata)
151toItemTree itemsDir thumbnailsDir = nodeToItem [] 151toItemTree itemsDir thumbnailsDir = nodeToItem []
152 where 152 where
153 nodeToItem pathTo d@(Dir dname dcontents) = 153 nodeToItem pathTo d@(Dir dname dcontents) =
154 mapM (nodeToItem path) dcontents 154 mapM (nodeToItem path) dcontents
155 >>= \items -> return Item 155 >>= return . unzip
156 { title = pack dname 156 >>= \(items, _) -> return
157 , date = empty 157 ( Item
158 , description = empty 158 { title = pack dname
159 , tags = aggregateTags items 159 , date = empty
160 , path = joinURLPath $ itemsDir:path 160 , description = empty
161 , thumbnail = Nothing 161 , tags = aggregateTags items
162 , properties = Directory { items = items } } 162 , path = joinURLPath $ itemsDir:path
163 , thumbnail = Nothing
164 , properties = Directory { items = items } }
165 , d)
163 where 166 where
164 path = pathTo ++ [dname] 167 path = pathTo ++ [dname]
165 aggregateTags = unique . concatMap (\item -> tags (item::Item)) 168 aggregateTags = unique . concatMap (\item -> tags (item::Item))
166 169
167 nodeToItem pathTo f@(File fname metadata) = 170 nodeToItem pathTo f@(File fname metadata) =
168 return Item 171 return
169 { title = optMeta title (pack fname) 172 ( Item
170 , date = optMeta date empty -- TODO: check and normalise dates 173 { title = optMeta title $ pack $ dropExtension fname
171 , description = optMeta description empty 174 , date = optMeta date empty -- TODO: check and normalise dates
172 , tags = optMeta tags [] 175 , description = optMeta description empty
173 , path = joinURLPath $ itemsDir:path 176 , tags = optMeta tags []
174 , thumbnail = Just $ joinURLPath $ thumbnailsDir:path 177 , path = joinURLPath $ itemsDir:path
175 , properties = Unknown } -- TODO 178 , thumbnail = Just $ joinURLPath $ thumbnailsDir:path
179 , properties = Unknown } -- TODO
180 , f)
176 where 181 where
177 path = pathTo ++ [fname] 182 path = pathTo ++ [fname]
178 optMeta get fallback = fromMaybe fallback $ get (metadata::SidecarItemMetadata) 183 optMeta get fallback = fromMaybe fallback $ get (metadata::SidecarItemMetadata)
179 184
180 185
186unrooted :: AnchoredDirTree a -> DirTree a
187unrooted t = (dirTree t) { name = "" }
188
189
190writeJSON :: ToJSON a => FilePath -> a -> IO ()
191writeJSON path obj =
192 createDirectoryIfMissing True (dropFileName path)
193 >> Data.Aeson.encodeFile path obj
194
195
196infixl 1 >>>>>>
197(>>>>>>) :: Monad m => m a -> (a -> m b) -> m a
198a >>>>>> f = a >>= f >>= return a
199
200
181process :: FilePath -> FilePath -> IO () 201process :: FilePath -> FilePath -> IO ()
182process inputDir outputDir = 202process inputDir outputDir =
183 readDirectoryWith return inputDir 203 readDirectoryWith return inputDir
184 >>= metadataDirTree . dirTree 204 >>= return . unrooted
185 >>= toItemTree "items" "thumbnails" 205 >>= metadataDirTree
186 >>= return . show . toEncoding 206 >>= toItemTree itemsDir thumbnailsDir
207 >>>>>> writeJSON (outputDir </> indexFile) . fst
208 >>= return . show . toEncoding . fst
187 >>= liftIO . putStrLn 209 >>= liftIO . putStrLn
210 where
211 itemsDir = "items"
212 thumbnailsDir = "thumbnails"
213 indexFile = "index.json"
188 214
189 215
190testRun :: IO () 216testRun :: IO ()