aboutsummaryrefslogtreecommitdiff
path: root/compiler/src/Lib.hs
diff options
context:
space:
mode:
authorpacien2019-12-23 05:09:25 +0100
committerpacien2019-12-23 05:09:25 +0100
commit8de4411269ae85789c1cc7d81a9ecf0facbe78ff (patch)
tree9e1e25dd238ef7560fd2573631cdb4b77b9a2adf /compiler/src/Lib.hs
parent06c4d9299bb684805051355555fa89f0d440d194 (diff)
downloadldgallery-8de4411269ae85789c1cc7d81a9ecf0facbe78ff.tar.gz
compiler: add base structures and encoding
Diffstat (limited to 'compiler/src/Lib.hs')
-rw-r--r--compiler/src/Lib.hs178
1 files changed, 174 insertions, 4 deletions
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 @@
1{-# LANGUAGE DuplicateRecordFields, DeriveGeneric #-}
2
3
4-- ldgallery - A static generator which turns a collection of tagged
5-- pictures into a searchable web gallery.
6--
7-- Copyright (C) 2019 Pacien TRAN-GIRARD
8-- 2019 Guillaume FOUET
9--
10-- This program is free software: you can redistribute it and/or modify
11-- it under the terms of the GNU Affero General Public License as
12-- published by the Free Software Foundation, either version 3 of the
13-- License, or (at your option) any later version.
14--
15-- This program is distributed in the hope that it will be useful,
16-- but WITHOUT ANY WARRANTY; without even the implied warranty of
17-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18-- GNU Affero General Public License for more details.
19--
20-- You should have received a copy of the GNU Affero General Public License
21-- along with this program. If not, see <https://www.gnu.org/licenses/>.
22
23
1module Lib 24module Lib
2 ( someFunc 25 ( testRun
3 ) where 26 ) where
27
28
29import GHC.Generics
30
31import Control.Monad.IO.Class (MonadIO, liftIO)
32import Control.Exception (Exception, throwIO)
33
34import Data.Function
35import Data.Maybe (fromMaybe)
36import Data.List (map)
37import Data.Char (toLower)
38import Data.Text (Text, empty, pack)
39import Data.Yaml (ParseException, decodeFileEither)
40import Data.Aeson
41
42import System.FilePath
43import System.Directory.Tree
44import System.Directory
45
46
47encodingOptions :: Options
48encodingOptions = defaultOptions
49 { fieldLabelModifier = map toLower
50 , constructorTagModifier = map toLower
51 , sumEncoding = defaultTaggedObject
52 { tagFieldName = "type"
53 , contentsFieldName = "contents"
54 }
55 }
56
57
58-- input structure
59
60data SidecarItemMetadata = SidecarItemMetadata
61 { title :: Maybe Text
62 , date :: Maybe Text
63 , description :: Maybe Text
64 , tags :: Maybe [Text]
65 } deriving Generic
66
67instance FromJSON SidecarItemMetadata where
68 parseJSON = genericParseJSON encodingOptions
69
70
71-- output structures
72
73type ResourcePath = Text
74type Tag = Text
75type FileSizeKB = Int
76
77
78data Resolution = Resolution
79 { width :: Int
80 , height :: Int
81 } deriving Generic
82
83instance ToJSON Resolution where
84 toJSON = genericToJSON encodingOptions
85 toEncoding = genericToEncoding encodingOptions
86
87
88data ItemProperties =
89 Directory { items :: [Item] }
90 | Image { resolution :: Resolution, filesize :: FileSizeKB }
91-- | Video { filesize :: FileSizeKB }
92 | Unknown
93 deriving Generic
94
95instance ToJSON ItemProperties where
96 toJSON = genericToJSON encodingOptions
97 toEncoding = genericToEncoding encodingOptions
98
99
100data Item = Item
101 { title :: Text
102 , date :: Text -- TODO: checked ISO8601 date
103 , description :: Text
104 , tags :: [Tag]
105 , path :: ResourcePath
106 , thumbnail :: Maybe ResourcePath
107 , properties :: ItemProperties
108 } deriving Generic
109
110instance ToJSON Item where
111 toJSON = genericToJSON encodingOptions
112 toEncoding = genericToEncoding encodingOptions
113
114
115-- mapping
116
117data LoadException = LoadException String ParseException deriving Show
118instance Exception LoadException
119
120decodeYamlFile :: (MonadIO m, FromJSON a) => FilePath -> m a
121decodeYamlFile fpath =
122 liftIO $ Data.Yaml.decodeFileEither fpath
123 >>= either (throwIO . LoadException fpath) return
124
125
126metadataDirTree :: DirTree FilePath -> IO (DirTree SidecarItemMetadata)
127metadataDirTree (Failed _ ferr) = ioError ferr
128metadataDirTree f@(File _ fpath) =
129 decodeYamlFile fpath
130 >>= \metadata -> return f { file = metadata }
131metadataDirTree d@(Dir _ dcontents) =
132 filter canContainMetadata dcontents
133 & mapM metadataDirTree
134 >>= \contents -> return d { contents = contents }
135 where
136 canContainMetadata (Dir _ _) = True
137 canContainMetadata (File fname _) = isExtensionOf ".yaml" fname
138
139
140toItemTree :: (MonadIO m) => [FileName] -> DirTree SidecarItemMetadata -> m Item
141toItemTree pathTo d@(Dir dname dcontents) =
142 mapM (toItemTree path) dcontents
143 >>= \items -> return Item
144 { title = pack dname
145 , date = empty -- TODO: would it make sense to take the date of child elements?
146 , description = empty
147 , tags = [] -- TODO: aggregate tags from childs
148 , path = pack $ joinPath $ "items":path -- FIXME: use URL path instead of system path sep
149 , thumbnail = Nothing
150 , properties = Directory { items = items }}
151 where
152 path = pathTo ++ [dname]
153toItemTree pathTo f@(File fname metadata) =
154 return Item
155 { title = optMeta title (pack fname)
156 , date = optMeta date empty -- TODO: check and normalise dates
157 , description = optMeta description empty
158 , tags = optMeta tags []
159 , path = pack $ joinPath $ "items":(pathTo ++ [fname]) -- FIXME: use URL path instead of system path sep
160 , thumbnail = Just $ pack $ joinPath $ "thumbnails":(pathTo ++ [fname]) -- FIXME: use URL path instead of system path sep
161 , properties = Unknown } -- TODO
162 where
163 optMeta get fallback = fromMaybe fallback $ get (metadata::SidecarItemMetadata)
164
165
166process :: FilePath -> FilePath -> IO ()
167process inputDir outputDir =
168 readDirectoryWith return inputDir
169 >>= metadataDirTree . dirTree
170 >>= toItemTree []
171 >>= return . show . toEncoding
172 >>= liftIO . putStrLn
173
4 174
5someFunc :: IO () 175testRun :: IO ()
6someFunc = putStrLn "someFunc" 176testRun = process "../example" "../out"