diff options
-rw-r--r-- | compiler/app/Main.hs | 2 | ||||
-rw-r--r-- | compiler/package.yaml | 32 | ||||
-rw-r--r-- | compiler/src/Lib.hs | 178 | ||||
-rw-r--r-- | compiler/stack.yaml.lock | 12 |
4 files changed, 205 insertions, 19 deletions
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 | |||
3 | import Lib | 3 | import Lib |
4 | 4 | ||
5 | main :: IO () | 5 | main :: IO () |
6 | main = someFunc | 6 | 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 @@ | |||
1 | name: ldgallery-compiler | 1 | name: ldgallery-compiler |
2 | version: 0.1.0.0 | 2 | version: 0.1.0.0 |
3 | github: "githubuser/ldgallery-compiler" | 3 | github: "pacien/ldgallery" |
4 | license: BSD3 | 4 | license: AGPL-3 |
5 | author: "Author name here" | 5 | author: "Pacien TRAN-GIRARD, Guillaume FOUET" |
6 | maintainer: "example@example.com" | 6 | maintainer: "" |
7 | copyright: "2019 Author name here" | 7 | copyright: "2019 Pacien TRAN-GIRARD, Guillaume FOUET" |
8 | 8 | ||
9 | extra-source-files: | 9 | extra-source-files: |
10 | - README.md | 10 | - readme.md |
11 | - ChangeLog.md | ||
12 | 11 | ||
13 | # Metadata used when publishing your package | 12 | # Metadata used when publishing your package |
14 | # synopsis: Short description of your package | 13 | synopsis: A static generator which turns a collection of tagged pictures into a searchable web gallery |
15 | # category: Web | 14 | category: Web |
16 | 15 | description: Please see the README on GitHub at <https://github.com/pacien/ldgallery> | |
17 | # To avoid duplicated efforts in documentation and dealing with the | ||
18 | # complications of embedding Haddock markup inside cabal files, it is | ||
19 | # common to point users to the README.md file. | ||
20 | description: Please see the README on GitHub at <https://github.com/githubuser/ldgallery-compiler#readme> | ||
21 | 16 | ||
22 | dependencies: | 17 | dependencies: |
23 | - base >= 4.7 && < 5 | 18 | - base >= 4.7 && < 5 |
19 | - text | ||
20 | - optparse-applicative | ||
21 | - cmdargs | ||
22 | - filepath | ||
23 | - directory | ||
24 | - directory-tree | ||
25 | - aeson | ||
26 | - yaml | ||
27 | - JuicyPixels | ||
24 | 28 | ||
25 | library: | 29 | library: |
26 | source-dirs: src | 30 | 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 @@ | |||
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 | |||
1 | module Lib | 24 | module Lib |
2 | ( someFunc | 25 | ( testRun |
3 | ) where | 26 | ) where |
27 | |||
28 | |||
29 | import GHC.Generics | ||
30 | |||
31 | import Control.Monad.IO.Class (MonadIO, liftIO) | ||
32 | import Control.Exception (Exception, throwIO) | ||
33 | |||
34 | import Data.Function | ||
35 | import Data.Maybe (fromMaybe) | ||
36 | import Data.List (map) | ||
37 | import Data.Char (toLower) | ||
38 | import Data.Text (Text, empty, pack) | ||
39 | import Data.Yaml (ParseException, decodeFileEither) | ||
40 | import Data.Aeson | ||
41 | |||
42 | import System.FilePath | ||
43 | import System.Directory.Tree | ||
44 | import System.Directory | ||
45 | |||
46 | |||
47 | encodingOptions :: Options | ||
48 | encodingOptions = 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 | |||
60 | data SidecarItemMetadata = SidecarItemMetadata | ||
61 | { title :: Maybe Text | ||
62 | , date :: Maybe Text | ||
63 | , description :: Maybe Text | ||
64 | , tags :: Maybe [Text] | ||
65 | } deriving Generic | ||
66 | |||
67 | instance FromJSON SidecarItemMetadata where | ||
68 | parseJSON = genericParseJSON encodingOptions | ||
69 | |||
70 | |||
71 | -- output structures | ||
72 | |||
73 | type ResourcePath = Text | ||
74 | type Tag = Text | ||
75 | type FileSizeKB = Int | ||
76 | |||
77 | |||
78 | data Resolution = Resolution | ||
79 | { width :: Int | ||
80 | , height :: Int | ||
81 | } deriving Generic | ||
82 | |||
83 | instance ToJSON Resolution where | ||
84 | toJSON = genericToJSON encodingOptions | ||
85 | toEncoding = genericToEncoding encodingOptions | ||
86 | |||
87 | |||
88 | data ItemProperties = | ||
89 | Directory { items :: [Item] } | ||
90 | | Image { resolution :: Resolution, filesize :: FileSizeKB } | ||
91 | -- | Video { filesize :: FileSizeKB } | ||
92 | | Unknown | ||
93 | deriving Generic | ||
94 | |||
95 | instance ToJSON ItemProperties where | ||
96 | toJSON = genericToJSON encodingOptions | ||
97 | toEncoding = genericToEncoding encodingOptions | ||
98 | |||
99 | |||
100 | data 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 | |||
110 | instance ToJSON Item where | ||
111 | toJSON = genericToJSON encodingOptions | ||
112 | toEncoding = genericToEncoding encodingOptions | ||
113 | |||
114 | |||
115 | -- mapping | ||
116 | |||
117 | data LoadException = LoadException String ParseException deriving Show | ||
118 | instance Exception LoadException | ||
119 | |||
120 | decodeYamlFile :: (MonadIO m, FromJSON a) => FilePath -> m a | ||
121 | decodeYamlFile fpath = | ||
122 | liftIO $ Data.Yaml.decodeFileEither fpath | ||
123 | >>= either (throwIO . LoadException fpath) return | ||
124 | |||
125 | |||
126 | metadataDirTree :: DirTree FilePath -> IO (DirTree SidecarItemMetadata) | ||
127 | metadataDirTree (Failed _ ferr) = ioError ferr | ||
128 | metadataDirTree f@(File _ fpath) = | ||
129 | decodeYamlFile fpath | ||
130 | >>= \metadata -> return f { file = metadata } | ||
131 | metadataDirTree 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 | |||
140 | toItemTree :: (MonadIO m) => [FileName] -> DirTree SidecarItemMetadata -> m Item | ||
141 | toItemTree 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] | ||
153 | toItemTree 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 | |||
166 | process :: FilePath -> FilePath -> IO () | ||
167 | process inputDir outputDir = | ||
168 | readDirectoryWith return inputDir | ||
169 | >>= metadataDirTree . dirTree | ||
170 | >>= toItemTree [] | ||
171 | >>= return . show . toEncoding | ||
172 | >>= liftIO . putStrLn | ||
173 | |||
4 | 174 | ||
5 | someFunc :: IO () | 175 | testRun :: IO () |
6 | someFunc = putStrLn "someFunc" | 176 | 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 @@ | |||
1 | # This file was autogenerated by Stack. | ||
2 | # You should not edit this file by hand. | ||
3 | # For more information, please see the documentati |