aboutsummaryrefslogtreecommitdiff
path: root/compiler/src/Resource.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/src/Resource.hs')
-rw-r--r--compiler/src/Resource.hs185
1 files changed, 128 insertions, 57 deletions
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index afc8203..dcf9422 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -20,15 +20,13 @@
20 DuplicateRecordFields 20 DuplicateRecordFields
21 , DeriveGeneric 21 , DeriveGeneric
22 , DeriveAnyClass 22 , DeriveAnyClass
23 , NamedFieldPuns
23#-} 24#-}
24 25
25module Resource 26module Resource
26 ( ResourceTree(..) 27 ( DirProcessor, ItemProcessor, ThumbnailProcessor
27 , DirProcessor 28 , GalleryItem, GalleryItemProps, Resolution(..)
28 , ItemProcessor 29 , buildGalleryTree, galleryCleanupResourceDir
29 , ThumbnailProcessor
30 , buildResourceTree
31 , cleanupResourceDir
32 ) where 30 ) where
33 31
34 32
@@ -36,79 +34,152 @@ import Control.Concurrent.ParallelIO.Global (parallel)
36import Data.Function ((&)) 34import Data.Function ((&))
37import Data.List ((\\), subsequences, sortBy) 35import Data.List ((\\), subsequences, sortBy)
38import Data.Ord (comparing) 36import Data.Ord (comparing)
39import Data.Maybe (mapMaybe) 37import Data.Char (toLower)
38import Data.Maybe (mapMaybe, fromMaybe)
39import qualified Data.Set as Set
40
41import GHC.Generics (Generic)
42import Data.Aeson (FromJSON, ToJSON, genericToJSON, genericToEncoding)
43import qualified Data.Aeson as JSON
44
40import Files 45import Files
41import Input (InputTree(..), Sidecar) 46import Input (InputTree(..), Sidecar(..))
47
48
49encodingOptions :: JSON.Options
50encodingOptions = JSON.defaultOptions
51 { JSON.fieldLabelModifier = map toLower
52 , JSON.constructorTagModifier = map toLower
53 , JSON.sumEncoding = JSON.defaultTaggedObject
54 { JSON.tagFieldName = "type"
55 , JSON.contentsFieldName = "contents"
56 }
57 }
58
59
60
61type Tag = String
62type FileSizeKB = Int
63
64
65data Resolution = Resolution
66 { width :: Int
67 , height :: Int
68 } deriving (Generic, Show, FromJSON)
42 69
70instance ToJSON Resolution where
71 toJSON = genericToJSON encodingOptions
72 toEncoding = genericToEncoding encodingOptions
43 73
44-- | Tree representing the compiled gallery resources. 74
45data ResourceTree = 75data GalleryItemProps =
46 ItemResource 76 Directory { items :: [GalleryItem] }
47 { sidecar :: Sidecar 77 | Picture
48 , resPath :: Path 78 | Other
49 , thumbnailPath :: Maybe Path } 79 deriving (Generic, Show)
50 | DirResource 80
51 { items :: [ResourceTree] 81instance ToJSON GalleryItemProps where
52 , resPath :: Path 82 toJSON = genericToJSON encodingOptions
53 , thumbnailPath :: Maybe Path } 83 toEncoding = genericToEncoding encodingOptions
54 deriving Show 84
85
86data GalleryItem = GalleryItem
87 { title :: String
88 , date :: String -- TODO: checked ISO8601 date
89 , description :: String
90 , tags :: [Tag]
91 , path :: Path
92 , thumbnail :: Maybe Path
93 , properties :: GalleryItemProps
94 } deriving (Generic, Show)
95
96instance ToJSON GalleryItem where
97 toJSON = genericToJSON encodingOptions
98 toEncoding = genericToEncoding encodingOptions
55 99
56 100
57type DirProcessor = Path -> IO Path 101type DirProcessor = Path -> IO Path
58type ItemProcessor = Path -> IO Path 102type ItemProcessor = Path -> IO Path
59type ThumbnailProcessor = Path -> IO (Maybe Path) 103type ThumbnailProcessor = Path -> IO (Maybe Path)
60 104
61buildResourceTree :: 105
62 DirProcessor -> ItemProcessor -> ThumbnailProcessor -> InputTree 106buildGalleryTree ::
63 -> IO ResourceTree 107 DirProcessor -> ItemProcessor -> ThumbnailProcessor
64buildResourceTree processDir processItem processThumbnail = resNode 108 -> String -> InputTree -> IO GalleryItem
109buildGalleryTree processDir processItem processThumbnail galleryName inputTree =
110 mkGalleryItem inputTree >>= return . named galleryName
65 where 111 where
66 resNode (InputFile path sidecar) = 112 named :: String -> GalleryItem -> GalleryItem
113 named name item = item { title = name }
114
115 mkGalleryItem :: InputTree -> IO GalleryItem
116 mkGalleryItem InputFile{path, sidecar} =
67 do 117 do
68 processedItem <- processItem path 118 processedItem <- processItem path
69 processedThumbnail <- processThumbnail path 119 processedThumbnail <- processThumbnail path
70 return ItemResource 120 return GalleryItem
71 { sidecar = sidecar 121 { title = optMeta title $ fileName path
72 , resPath = processedItem 122 , date = optMeta date "" -- TODO: check and normalise dates
73 , thumbnailPath = processedThumbnail } 123 , description = optMeta description ""
74 124 , tags = optMeta tags []
75 resNode (InputDir path thumbnailPath items) = 125 , path = processedItem
126 , thumbnail = processedThumbnail
127 , properties = Other } -- TODO
128 where
129 optMeta :: (Sidecar -> Maybe a) -> a -> a
130 optMeta get fallback = fromMaybe fallback $ get sidecar
131
132 mkGalleryItem InputDir{path, dirThumbnailPath, items} =
76 do 133 do
77 processedDir <- processDir path 134 processedDir <- processDir path
78 processedThumbnail <- maybeThumbnail thumbnailPath 135 processedThumbnail <- maybeThumbnail dirThumbnailPath
79 dirItems <- parallel $ map resNode items 136 processedItems <- parallel $ map mkGalleryItem items
80 return DirResource 137 return GalleryItem
81 { items = dirItems 138 { title = fileName path
82 , resPath = processedDir 139 -- TODO: consider using the most recent item's date? what if empty?
83 , thumbnailPath = processedThumbnail } 140 , date = ""
84 141 -- TODO: consider allowing metadata sidecars for directories too
85 maybeThumbnail :: Maybe Path -> IO (Maybe Path) 142 , description = ""
86 maybeThumbnail Nothing = return Nothing 143 , tags = aggregateChildTags processedItems
87 maybeThumbnail (Just path) = processThumbnail path 144 , path = processedDir
88 145 , thumbnail = processedThumbnail
89 146 , properties = Directory processedItems }
90flattenResourceTree :: ResourceTree -> [ResourceTree] 147 where
91flattenResourceTree item@ItemResource{} = [item] 148 maybeThumbnail :: Maybe Path -> IO (Maybe Path)
92flattenResourceTree dir@(DirResource items _ _) = 149 maybeThumbnail Nothing = return Nothing
93 dir:(concatMap flattenResourceTree items) 150 maybeThumbnail (Just path) = processThumbnail path
94 151
95outputDiff :: ResourceTree -> FSNode -> [Path] 152 aggregateChildTags :: [GalleryItem] -> [Tag]
96outputDiff resources ref = 153 aggregateChildTags = unique . concatMap (\item -> tags (item::GalleryItem))
97 (fsPaths ref) \\ (resPaths $ flattenResourceTree resources) 154
155 unique :: Ord a => [a] -> [a]
156 unique = Set.toList . Set.fromList
157
158
159flattenGalleryTree :: GalleryItem -> [GalleryItem]
160flattenGalleryTree dir@(GalleryItem _ _ _ _ _ _ (Directory items)) =
161 dir : concatMap flattenGalleryTree items
162flattenGalleryTree simple = [simple]
163
164
165galleryOutputDiff :: GalleryItem -> FSNode -> [Path]
166galleryOutputDiff resources ref =
167 (fsPaths ref) \\ (resPaths $ flattenGalleryTree resources)
98 where 168 where
99 resPaths :: [ResourceTree] -> [Path] 169 resPaths :: [GalleryItem] -> [Path]
100 resPaths resList = map resPath resList ++ thumbnailPaths resList 170 resPaths resList = map (path::(GalleryItem->Path)) resList ++ thumbnailPaths resList
101 171
102 thumbnailPaths :: [ResourceTree] -> [Path] 172 thumbnailPaths :: [GalleryItem] -> [Path]
103 thumbnailPaths = (concatMap subPaths) . (mapMaybe thumbnailPath) 173 thumbnailPaths = (concatMap subPaths) . (mapMaybe thumbnail)
104 174
105 fsPaths :: FSNode -> [Path] 175 fsPaths :: FSNode -> [Path]
106 fsPaths = map nodePath . tail . flattenDir 176 fsPaths = map nodePath . tail . flattenDir
107 177
108cleanupResourceDir :: ResourceTree -> FileName -> IO () 178
109cleanupResourceDir resourceTree outputDir = 179galleryCleanupResourceDir :: GalleryItem -> FileName -> IO ()
180galleryCleanupResourceDir resourceTree outputDir =
110 readDirectory outputDir 181 readDirectory outputDir
111 >>= return . outputDiff resourceTree . root 182 >>= return . galleryOutputDiff resourceTree . root
112 >>= return . sortBy (flip $ comparing pathLength) -- nested files before dirs 183 >>= return . sortBy (flip $ comparing pathLength) -- nested files before dirs
113 >>= return . map (localPath . (/>) outputDir) 184 >>= return . map (localPath . (/>) outputDir)
114 >>= mapM_ remove 185 >>= mapM_ remove