From 8de4411269ae85789c1cc7d81a9ecf0facbe78ff Mon Sep 17 00:00:00 2001 From: pacien Date: Mon, 23 Dec 2019 05:09:25 +0100 Subject: compiler: add base structures and encoding --- compiler/app/Main.hs | 2 +- compiler/package.yaml | 32 +++++---- compiler/src/Lib.hs | 178 +++++++++++++++++++++++++++++++++++++++++++++-- compiler/stack.yaml.lock | 12 ++++ 4 files changed, 205 insertions(+), 19 deletions(-) create mode 100644 compiler/stack.yaml.lock diff --git a/compiler/app/Main.hs b/compiler/app/Main.hs index de1c1ab..ac9b441 100644 --- a/compiler/app/Main.hs +++ b/compiler/app/Main.hs @@ -3,4 +3,4 @@ module Main where import Lib main :: IO () -main = someFunc +main = testRun diff --git a/compiler/package.yaml b/compiler/package.yaml index 7cd0178..f2a319e 100644 --- a/compiler/package.yaml +++ b/compiler/package.yaml @@ -1,26 +1,30 @@ name: ldgallery-compiler version: 0.1.0.0 -github: "githubuser/ldgallery-compiler" -license: BSD3 -author: "Author name here" -maintainer: "example@example.com" -copyright: "2019 Author name here" +github: "pacien/ldgallery" +license: AGPL-3 +author: "Pacien TRAN-GIRARD, Guillaume FOUET" +maintainer: "" +copyright: "2019 Pacien TRAN-GIRARD, Guillaume FOUET" extra-source-files: -- README.md -- ChangeLog.md +- readme.md # Metadata used when publishing your package -# synopsis: Short description of your package -# category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at +synopsis: A static generator which turns a collection of tagged pictures into a searchable web gallery +category: Web +description: Please see the README on GitHub at dependencies: - base >= 4.7 && < 5 +- text +- optparse-applicative +- cmdargs +- filepath +- directory +- directory-tree +- aeson +- yaml +- JuicyPixels library: source-dirs: src diff --git a/compiler/src/Lib.hs b/compiler/src/Lib.hs index d36ff27..c52e095 100644 --- a/compiler/src/Lib.hs +++ b/compiler/src/Lib.hs @@ -1,6 +1,176 @@ +{-# 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 +-- 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 . + + module Lib - ( someFunc - ) where + ( testRun + ) where + + +import GHC.Generics + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Exception (Exception, throwIO) + +import Data.Function +import Data.Maybe (fromMaybe) +import Data.List (map) +import Data.Char (toLower) +import Data.Text (Text, empty, pack) +import Data.Yaml (ParseException, decodeFileEither) +import Data.Aeson + +import System.FilePath +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 + +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 + +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 + +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 + +instance ToJSON Item where + toJSON = genericToJSON encodingOptions + toEncoding = genericToEncoding encodingOptions + + +-- mapping + +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 + + +metadataDirTree :: DirTree FilePath -> IO (DirTree SidecarItemMetadata) +metadataDirTree (Failed _ ferr) = ioError ferr +metadataDirTree f@(File _ fpath) = + decodeYamlFile fpath + >>= \metadata -> return f { file = metadata } +metadataDirTree d@(Dir _ dcontents) = + filter canContainMetadata dcontents + & mapM metadataDirTree + >>= \contents -> return d { contents = contents } + where + canContainMetadata (Dir _ _) = True + canContainMetadata (File fname _) = isExtensionOf ".yaml" fname + + +toItemTree :: (MonadIO m) => [FileName] -> DirTree SidecarItemMetadata -> m Item +toItemTree pathTo d@(Dir dname dcontents) = + mapM (toItemTree path) dcontents + >>= \items -> return Item + { title = pack dname + , date = empty -- TODO: would it make sense to take the date of child elements? + , description = empty + , tags = [] -- TODO: aggregate tags from childs + , path = pack $ joinPath $ "items":path -- FIXME: use URL path instead of system path sep + , thumbnail = Nothing + , properties = Directory { items = items }} + where + path = pathTo ++ [dname] +toItemTree pathTo f@(File fname metadata) = + return Item + { title = optMeta title (pack fname) + , date = optMeta date empty -- TODO: check and normalise dates + , description = optMeta description empty + , tags = optMeta tags [] + , path = pack $ joinPath $ "items":(pathTo ++ [fname]) -- FIXME: use URL path instead of system path sep + , thumbnail = Just $ pack $ joinPath $ "thumbnails":(pathTo ++ [fname]) -- FIXME: use URL path instead of system path sep + , properties = Unknown } -- TODO + where + optMeta get fallback = fromMaybe fallback $ get (metadata::SidecarItemMetadata) + + +process :: FilePath -> FilePath -> IO () +process inputDir outputDir = + readDirectoryWith return inputDir + >>= metadataDirTree . dirTree + >>= toItemTree [] + >>= return . show . toEncoding + >>= liftIO . putStrLn + -someFunc :: IO () -someFunc = putStrLn "someFunc" +testRun :: IO () +testRun = process "../example" "../out" diff --git a/compiler/stack.yaml.lock b/compiler/stack.yaml.lock new file mode 100644 index 0000000..fc538c1 --- /dev/null +++ b/compiler/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 524799 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/17.yaml + sha256: 1d72b33c0fc048e23f4f18fd76a6ad79dd1d8a3c054644098a71a09855e40c7c + original: lts-14.17 -- cgit v1.2.3