1 files changed, 32 insertions, 219 deletions

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 ()
+    let resourceTree = buildResourceTree inputTree