From 0b2f6fb420d213b4ee718b9ac79cc3f9fa7678d5 Mon Sep 17 00:00:00 2001 From: pacien Date: Wed, 25 Dec 2019 21:04:31 +0100 Subject: compiler: refactor transform stages --- compiler/src/Lib.hs | 251 +++++++--------------------------------------------- 1 file changed, 32 insertions(+), 219 deletions(-) (limited to 'compiler/src/Lib.hs') diff --git a/compiler/src/Lib.hs b/compiler/src/Lib.hs index 70a2cca..bab7e9c 100644 --- a/compiler/src/Lib.hs +++ b/compiler/src/Lib.hs @@ -1,11 +1,7 @@ -{-# LANGUAGE DuplicateRecordFields, DeriveGeneric #-} - - -- ldgallery - A static generator which turns a collection of tagged -- pictures into a searchable web gallery. -- -- Copyright (C) 2019 Pacien TRAN-GIRARD --- 2019 Guillaume FOUET -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as @@ -26,232 +22,49 @@ module Lib ) where -import GHC.Generics - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Exception (Exception, throwIO) - -import Data.Function -import Data.Maybe (fromMaybe, listToMaybe) -import Data.List (map) -import Data.Set (fromList, toList) -import Data.Char (toLower) -import Data.Text (Text, empty, pack) -import Data.Yaml (ParseException, decodeFileEither) -import Data.Aeson - -import System.FilePath ((), joinPath, dropFileName, dropExtension, isExtensionOf) -import qualified System.FilePath.Posix (joinPath) -import System.Directory.Tree -import System.Directory - - -encodingOptions :: Options -encodingOptions = defaultOptions - { fieldLabelModifier = map toLower - , constructorTagModifier = map toLower - , sumEncoding = defaultTaggedObject - { tagFieldName = "type" - , contentsFieldName = "contents" - } - } - - --- input structure - -data SidecarItemMetadata = SidecarItemMetadata - { title :: Maybe Text - , date :: Maybe Text - , description :: Maybe Text - , tags :: Maybe [Text] - } deriving (Generic, Show) - -instance FromJSON SidecarItemMetadata where - parseJSON = genericParseJSON encodingOptions - - --- output structures - -type ResourcePath = Text -type Tag = Text -type FileSizeKB = Int - - -data Resolution = Resolution - { width :: Int - , height :: Int - } deriving (Generic, Show) - -instance ToJSON Resolution where - toJSON = genericToJSON encodingOptions - toEncoding = genericToEncoding encodingOptions - - -data ItemProperties = - Directory { items :: [Item] } - | Image { resolution :: Resolution, filesize :: FileSizeKB } --- | Video { filesize :: FileSizeKB } - | Unknown - deriving (Generic, Show) - -instance ToJSON ItemProperties where - toJSON = genericToJSON encodingOptions - toEncoding = genericToEncoding encodingOptions - - -data Item = Item - { title :: Text - , date :: Text -- TODO: checked ISO8601 date - , description :: Text - , tags :: [Tag] - , path :: ResourcePath - , thumbnail :: Maybe ResourcePath - , properties :: ItemProperties - } deriving (Generic, Show) - -instance ToJSON Item where - toJSON = genericToJSON encodingOptions - toEncoding = genericToEncoding encodingOptions - +import GHC.Generics (Generic) +import Data.Function ((&)) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (dropFileName, ()) +import Data.Aeson (ToJSON, encodeFile) --- mapping +import Files (FileName, readDirectory) +import Input (readInputTree) +import Resource (buildResourceTree) +import Gallery (buildGalleryTree) -data LoadException = LoadException String ParseException deriving Show -instance Exception LoadException -decodeYamlFile :: (MonadIO m, FromJSON a) => FilePath -> m a -decodeYamlFile fpath = - liftIO $ Data.Yaml.decodeFileEither fpath - >>= either (throwIO . LoadException fpath) return - - -toMetaTree :: DirTree FilePath -> IO (DirTree SidecarItemMetadata) -toMetaTree tree = return (filterDir canContainMetadata tree) >>= metaNode - where - -- TODO: exclude hidden files (name starting with '.')? - canContainMetadata :: DirTree a -> Bool - canContainMetadata (File fname _) = isExtensionOf ".yaml" fname - canContainMetadata (Dir _ _) = True - - metaNode :: DirTree FilePath -> IO (DirTree SidecarItemMetadata) - metaNode (Failed _ ferr) = ioError ferr - metaNode file@(File _ fpath) = decodeYamlFile fpath - >>= \metadata -> return file { file = metadata } - metaNode dir@(Dir _ dcontents) = mapM metaNode dcontents - >>= \contents -> return dir { contents = contents } - - -unique :: Ord a => [a] -> [a] -unique = Data.Set.toList . Data.Set.fromList - -joinURLPath :: [FileName] -> Text -joinURLPath = pack . System.FilePath.Posix.joinPath - - -toItemTree :: FilePath -> FilePath -> DirTree SidecarItemMetadata -> IO Item -toItemTree itemsDir thumbnailsDir = itemNode [] - where - itemNode :: [FileName] -> DirTree SidecarItemMetadata -> IO Item - itemNode pathTo (Dir dname dcontents) = - mapM (itemNode path) dcontents - >>= \items -> return Item - { title = pack dname - , date = empty - , description = empty - , tags = aggregateChildTags items - , path = joinURLPath $ itemsDir:path - , thumbnail = Nothing - , properties = Directory items } - where - path = pathTo ++ [dname] - aggregateChildTags = unique . concatMap (\item -> tags (item::Item)) - - itemNode pathTo (File fname metadata) = - return Item - { title = optMeta title $ pack name - , date = optMeta date empty -- TODO: check and normalise dates - , description = optMeta description empty - , tags = optMeta tags [] - , path = joinURLPath $ itemsDir:path - , thumbnail = Just $ joinURLPath $ thumbnailsDir:path - , properties = Unknown } -- TODO - where - name = dropExtension fname - path = pathTo ++ [name] - optMeta get fallback = fromMaybe fallback $ get (metadata::SidecarItemMetadata) - - -data ObjectTree = ObjectTree - { pathTo :: [ObjectTree] - , meta :: (DirTree SidecarItemMetadata) - , item :: Item } deriving Show - -rootObjectTree :: DirTree SidecarItemMetadata -> Item -> ObjectTree -rootObjectTree = ObjectTree [] - -toObjectTree :: (DirTree SidecarItemMetadata -> IO Item) -> DirTree SidecarItemMetadata -> IO ObjectTree -toObjectTree itemGen meta = itemGen meta >>= return . (rootObjectTree meta) - -flatten :: ObjectTree -> [ObjectTree] -flatten object@(ObjectTree _ (File _ _) _) = [object] -flatten object@(ObjectTree pathTo (Dir _ dcontents) item) = - zip dcontents (items $ properties item) - & map (uncurry $ ObjectTree $ pathTo ++ [object]) - & concatMap flatten - & (:) object - -objFileName :: ObjectTree -> FileName -objFileName (ObjectTree _ (Dir name _) _) = name -objFileName (ObjectTree _ (File name _) _) = dropExtension name -- without ".yaml" - -objFilePath :: ObjectTree -> FilePath -objFilePath obj@(ObjectTree pathTo _ _) = - (map (name . meta) pathTo) ++ [objFileName obj] - & System.FilePath.joinPath - - -data FileTransform = FileTransform - { src :: FilePath - , dst :: FilePath } deriving Show +writeJSON :: ToJSON a => FileName -> a -> IO () +writeJSON path obj = + createDirectoryIfMissing True (dropFileName path) + >> encodeFile path obj -isUpToDate :: FilePath -> FilePath -> IO Bool -isUpToDate ref target = +process :: FilePath -> FilePath -> IO () +process inputDirPath outputDirPath = do - refTime <- getModificationTime ref - targetTime <- getModificationTime target - return (target >= ref) + inputDir <- readDirectory inputDirPath + putStrLn "\nINPUT DIR" + putStrLn (show inputDir) + outputDir <- readDirectory outputDirPath + putStrLn "\nOUTPUT DIR" + putStrLn (show outputDir) -unrooted :: AnchoredDirTree a -> DirTree a -unrooted t = (dirTree t) { name = "" } + inputTree <- readInputTree inputDir + putStrLn "\nINPUT TREE" + putStrLn (show inputTree) -writeJSON :: ToJSON a => FilePath -> a -> IO () -writeJSON path obj = - createDirectoryIfMissing True (dropFileName path) - >> Data.Aeson.encodeFile path obj + let resourceTree = buildResourceTree inputTree + putStrLn "\nRESOURCE TREE" + putStrLn (show resourceTree) -passthrough :: Monad m => (a -> m b) -> a -> m a -passthrough f a = return a >>= f >>= \_ -> return a + -- TODO: make buildResourceTree build a resource compilation strategy + -- TODO: clean up output dir by comparing its content with the resource tree + -- TODO: execute (in parallel) the resource compilation strategy list -process :: FilePath -> FilePath -> IO () -process inputDir outputDir = - readDirectoryWith return inputDir - >>= return . unrooted - >>= toMetaTree - >>= toObjectTree (toItemTree itemsDir thumbnailsDir) - >>= passthrough (writeJSON (outputDir indexFile) . item) - >>= return . flatten --- >>= mapM (return . pathTo) - >>= return . (map objFilePath) - >>= return . show --- >>= return . show . toEncoding . item - >>= liftIO . putStrLn - where - itemsDir = "items" - thumbnailsDir = "thumbnails" - indexFile = "index.json" + buildGalleryTree resourceTree & writeJSON (outputDirPath "index.json") testRun :: IO () -testRun = process "../example" "../out" +testRun = process "../../example" "../../out" -- cgit v1.2.3