compiler: refactor transform stages

6 files changed, 461 insertions, 219 deletions

diff --git a/compiler/src/Files.hs b/compiler/src/Files.hs
new file mode 100644
index 0000000..7948842
--- /dev/null
+++ b/compiler/src/Files.hs
@@ -0,0 +1,104 @@
+{-# 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
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as
+-- published by the Free Software Foundation, either version 3 of the
+-- License, or (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+
+module Files
+  ( FileName, LocalPath, WebPath, Path
+  , (</>), (</), (/>), localPath, webPath
+  , FSNode(..), AnchoredFSNode(..)
+  , nodePath, nodeName, isHidden, flatten, filterDir, readDirectory
+  ) where
+
+
+import Control.Monad (filterM, mapM)
+import Data.Bool (bool)
+import Data.List (isPrefixOf, length, deleteBy)
+import Data.Function ((&))
+import System.Directory (doesDirectoryExist, listDirectory)
+import qualified System.FilePath
+import qualified System.FilePath.Posix
+import Utils
+
+
+type FileName = String
+type LocalPath = String
+type WebPath = String
+
+ -- | Reversed path component list
+type Path = [FileName]
+
+(</>) :: Path -> Path -> Path
+l </> r = r ++ l
+
+(</) :: Path -> FileName -> Path
+path </ file = file:path
+
+(/>) :: FileName -> Path -> Path
+file /> path = path ++ [file]
+
+localPath :: Path -> LocalPath
+localPath = System.FilePath.joinPath . reverse
+
+webPath :: Path -> WebPath
+webPath = System.FilePath.Posix.joinPath . reverse
+
+
+data FSNode = File Path | Dir Path [FSNode] deriving Show
+data AnchoredFSNode = AnchoredFSNode
+  { anchor :: LocalPath
+  , root :: FSNode } deriving Show
+
+nodePath :: FSNode -> Path
+nodePath (File path) = path
+nodePath (Dir path _) = path
+
+nodeName :: FSNode -> FileName
+nodeName = head . nodePath
+
+isHidden :: FSNode -> Bool
+isHidden node = "." `isPrefixOf` filename && length filename > 1
+  where filename = nodeName node
+
+flatten :: FSNode -> [FSNode]
+flatten file@(File _) = [file]
+flatten dir@(Dir _ childs) = dir:(concatMap flatten childs)
+
+-- | Filters a dir tree. The root is always returned.
+filterDir :: (FSNode -> Bool) -> FSNode -> FSNode
+filterDir _ file@(File _) = file
+filterDir cond (Dir path childs) =
+  filter cond childs & map (filterDir cond) & Dir path
+
+readDirectory :: LocalPath -> IO AnchoredFSNode
+readDirectory root = mkNode [""] >>= return . AnchoredFSNode root
+  where
+    mkNode :: Path -> IO FSNode
+    mkNode path =
+      (doesDirectoryExist $ localPath (root /> path))
+      >>= bool (mkFileNode path) (mkDirNode path)
+
+    mkFileNode :: Path -> IO FSNode
+    mkFileNode path = return $ File path
+
+    mkDirNode :: Path -> IO FSNode
+    mkDirNode path =
+      (listDirectory $ localPath (root /> path))
+      >>= mapM (mkNode . ((</) path))
+      >>= return . Dir path
diff --git a/compiler/src/Gallery.hs b/compiler/src/Gallery.hs
new file mode 100644
index 0000000..3be62ad
--- /dev/null
+++ b/compiler/src/Gallery.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE DuplicateRecordFields, DeriveGeneric, DeriveAnyClass #-}
+
+-- ldgallery - A static generator which turns a collection of tagged
+--             pictures into a searchable web gallery.
+--
+-- Copyright (C) 2019  Pacien TRAN-GIRARD
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as
+-- published by the Free Software Foundation, either version 3 of the
+-- License, or (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+
+module Gallery
+  ( GalleryItem(..), buildGalleryTree
+  ) where
+
+
+import GHC.Generics (Generic)
+import Data.Char (toLower)
+import Data.Function ((&))
+import Data.Maybe (fromMaybe)
+
+import Data.Aeson (ToJSON, genericToJSON, genericToEncoding)
+import qualified Data.Aeson as JSON
+
+import Utils
+import Files
+import Input
+import Resource
+
+
+encodingOptions :: JSON.Options
+encodingOptions = JSON.defaultOptions
+  { JSON.fieldLabelModifier = map toLower
+  , JSON.constructorTagModifier = map toLower
+  , JSON.sumEncoding = JSON.defaultTaggedObject
+      { JSON.tagFieldName = "type"
+      , JSON.contentsFieldName = "contents"
+      }
+  }
+
+
+type ResourcePath = String
+type Tag = String
+type FileSizeKB = Int
+
+
+data Resolution = Resolution
+  { width :: Int
+  , height :: Int
+  } deriving (Generic, Show)
+
+instance ToJSON Resolution where
+  toJSON = genericToJSON encodingOptions
+  toEncoding = genericToEncoding encodingOptions
+
+
+data GalleryItemProps =
+    Directory { items :: [GalleryItem] }
+--  | Image { resolution :: Resolution, filesize :: FileSizeKB }
+--  | Video { filesize :: FileSizeKB }
+  | Unknown
+  deriving (Generic, Show)
+
+instance ToJSON GalleryItemProps where
+  toJSON = genericToJSON encodingOptions
+  toEncoding = genericToEncoding encodingOptions
+
+
+-- TODO: fuse GalleryItem and GalleryItemProps
+data GalleryItem = GalleryItem
+  { title :: String
+  , date :: String -- TODO: checked ISO8601 date
+  , description :: String
+  , tags :: [Tag]
+  , path :: ResourcePath
+  , thumbnail :: Maybe ResourcePath
+  , properties :: GalleryItemProps
+  } deriving (Generic, Show)
+
+instance ToJSON GalleryItem where
+  toJSON = genericToJSON encodingOptions
+  toEncoding = genericToEncoding encodingOptions
+
+
+buildGalleryTree :: ResourceTree -> GalleryItem
+buildGalleryTree (ItemResource sidecar path@(filename:_) thumbnailPath) =
+  GalleryItem
+    { title = optMeta title filename
+    , date = optMeta date "" -- TODO: check and normalise dates
+    , description = optMeta description ""
+    , tags = optMeta tags []
+    , path = webPath path
+    , thumbnail = Just $ webPath thumbnailPath
+    , properties = Unknown } -- TODO
+  where
+    optMeta :: (Sidecar -> Maybe a) -> a -> a
+    optMeta get fallback = fromMaybe fallback $ get sidecar
+
+buildGalleryTree (DirResource dirItems path@(dirname:_) thumbnailPath) =
+  map buildGalleryTree dirItems
+  & \items -> GalleryItem
+    { title = dirname
+      -- TODO: consider using the most recent item's date? what if empty?
+    , date = ""
+      -- TODO: consider allowing metadata sidecars for directories too
+    , description = ""
+    , tags = aggregateChildTags items
+    , path = webPath path
+    , thumbnail = fmap webPath thumbnailPath
+    , properties = Directory items }
+  where
+    aggregateChildTags :: [GalleryItem] -> [Tag]
+    aggregateChildTags = unique . concatMap (\item -> tags (item::GalleryItem))
diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs
new file mode 100644
index 0000000..78622bf
--- /dev/null
+++ b/compiler/src/Input.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE DuplicateRecordFields, DeriveGeneric, DeriveAnyClass #-}
+
+-- ldgallery - A static generator which turns a collection of tagged
+--             pictures into a searchable web gallery.
+--
+-- Copyright (C) 2019  Pacien TRAN-GIRARD