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.hs80
1 files changed, 49 insertions, 31 deletions
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 19bd32c..2019418 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -17,7 +17,7 @@
17-- along with this program. If not, see <https://www.gnu.org/licenses/>. 17-- along with this program. If not, see <https://www.gnu.org/licenses/>.
18 18
19module Resource 19module Resource
20 ( DirProcessor, ItemProcessor, ThumbnailProcessor 20 ( ItemProcessor, ThumbnailProcessor
21 , GalleryItem(..), GalleryItemProps(..), Resolution(..) 21 , GalleryItem(..), GalleryItemProps(..), Resolution(..)
22 , buildGalleryTree, galleryCleanupResourceDir 22 , buildGalleryTree, galleryCleanupResourceDir
23 ) where 23 ) where
@@ -27,7 +27,8 @@ import Control.Concurrent.ParallelIO.Global (parallel)
27import Data.List ((\\), sortBy) 27import Data.List ((\\), sortBy)
28import Data.Ord (comparing) 28import Data.Ord (comparing)
29import Data.Char (toLower) 29import Data.Char (toLower)
30import Data.Maybe (mapMaybe, fromMaybe) 30import Data.Maybe (mapMaybe, fromMaybe, maybeToList)
31import Data.Function ((&))
31import qualified Data.Set as Set 32import qualified Data.Set as Set
32 33
33import GHC.Generics (Generic) 34import GHC.Generics (Generic)
@@ -63,8 +64,8 @@ instance ToJSON Resolution where
63 64
64data GalleryItemProps = 65data GalleryItemProps =
65 Directory { items :: [GalleryItem] } 66 Directory { items :: [GalleryItem] }
66 | Picture 67 | Picture { resource :: Path }
67 | Other 68 | Other { resource :: Path }
68 deriving (Generic, Show) 69 deriving (Generic, Show)
69 70
70instance ToJSON GalleryItemProps where 71instance ToJSON GalleryItemProps where
@@ -87,53 +88,60 @@ instance ToJSON GalleryItem where
87 toEncoding = genericToEncoding encodingOptions 88 toEncoding = genericToEncoding encodingOptions
88 89
89 90
90type DirProcessor = Path -> IO Path 91type ItemProcessor = Path -> IO GalleryItemProps
91type ItemProcessor = Path -> IO (Path, GalleryItemProps)
92type ThumbnailProcessor = Path -> IO (Maybe Path) 92type ThumbnailProcessor = Path -> IO (Maybe Path)
93 93
94 94
95buildGalleryTree :: 95buildGalleryTree ::
96 DirProcessor -> ItemProcessor -> ThumbnailProcessor 96 ItemProcessor -> ThumbnailProcessor
97 -> Bool -> String -> InputTree -> IO GalleryItem 97 -> Bool -> String -> InputTree -> IO GalleryItem
98buildGalleryTree processDir processItem processThumbnail addDirTag galleryName inputTree = 98buildGalleryTree processItem processThumbnail addDirTag galleryName inputTree =
99 mkGalleryItem Nothing inputTree >>= return . named galleryName 99 mkGalleryItem (Path []) inputTree >>= return . named galleryName
100 where 100 where
101 named :: String -> GalleryItem -> GalleryItem 101 named :: String -> GalleryItem -> GalleryItem
102 named name item = item { title = name } 102 named name item = item { title = name }
103 103
104 mkGalleryItem :: Maybe String -> InputTree -> IO GalleryItem 104 mkGalleryItem :: Path -> InputTree -> IO GalleryItem
105 mkGalleryItem parent InputFile{path, sidecar} = 105 mkGalleryItem parents InputFile{path, sidecar} =
106 do 106 do
107 (processedItemPath, properties) <- processItem path 107 properties <- processItem path
108 processedThumbnail <- processThumbnail path 108 processedThumbnail <- processThumbnail path
109 return GalleryItem 109 return GalleryItem
110 { title = optMeta title $ fromMaybe "" $ fileName path 110 { title = itemTitle
111 , date = optMeta date "" -- TODO: check and normalise dates 111 , date = optMeta date "" -- TODO: check and normalise dates
112 , description = optMeta description "" 112 , description = optMeta description ""
113 , tags = (optMeta tags []) ++ implicitParentTag parent 113 , tags = (optMeta tags []) ++ implicitParentTag parents
114 , path = processedItemPath 114 , path = parents </ itemTitle
115 , thumbnail = processedThumbnail 115 , thumbnail = processedThumbnail
116 , properties = properties } -- TODO 116 , properties = properties } -- TODO
117 where 117 where
118 itemTitle :: String
119 itemTitle = optMeta title $ fromMaybe "" $ fileName path
120
118 optMeta :: (Sidecar -> Maybe a) -> a -> a 121 optMeta :: (Sidecar -> Maybe a) -> a -> a
119 optMeta get fallback = fromMaybe fallback $ get sidecar 122 optMeta get fallback = fromMaybe fallback $ get sidecar
120 123
121 mkGalleryItem parent InputDir{path, dirThumbnailPath, items} = 124 mkGalleryItem parents InputDir{path, dirThumbnailPath, items} =
122 do 125 do
123 processedDir <- processDir path
124 processedThumbnail <- maybeThumbnail dirThumbnailPath 126 processedThumbnail <- maybeThumbnail dirThumbnailPath
125 processedItems <- parallel $ map (mkGalleryItem $ fileName path) items 127 processedItems <- parallel $ map (mkGalleryItem itemPath) items
126 return GalleryItem 128 return GalleryItem
127 { title = fromMaybe "" $ fileName path 129 { title = itemTitle
128 -- TODO: consider using the most recent item's date? what if empty? 130 -- TODO: consider using the most recent item's date? what if empty?
129 , date = "" 131 , date = ""
130 -- TODO: consider allowing metadata sidecars for directories too 132 -- TODO: consider allowing metadata sidecars for directories too
131 , description = "" 133 , description = ""
132 , tags = (aggregateChildTags processedItems) ++ implicitParentTag parent 134 , tags = (aggregateChildTags processedItems) ++ implicitParentTag parents
133 , path = processedDir 135 , path = itemPath
134 , thumbnail = processedThumbnail 136 , thumbnail = processedThumbnail
135 , properties = Directory processedItems } 137 , properties = Directory processedItems }
136 where 138 where
139 itemTitle :: String
140 itemTitle = fromMaybe "" $ fileName path
141
142 itemPath :: Path
143 itemPath = parents </ itemTitle
144
137 maybeThumbnail :: Maybe Path -> IO (Maybe Path) 145 maybeThumbnail :: Maybe Path -> IO (Maybe Path)
138 maybeThumbnail Nothing = return Nothing 146 maybeThumbnail Nothing = return Nothing
139 maybeThumbnail (Just thumbnailPath) = processThumbnail thumbnailPath 147 maybeThumbnail (Just thumbnailPath) = processThumbnail thumbnailPath
@@ -144,9 +152,10 @@ buildGalleryTree processDir processItem processThumbnail addDirTag galleryName i
144 unique :: Ord a => [a] -> [a] 152 unique :: Ord a => [a] -> [a]
145 unique = Set.toList . Set.fromList 153 unique = Set.toList . Set.fromList
146 154
147 implicitParentTag :: Maybe String -> [Tag] 155 implicitParentTag :: Path -> [Tag]
148 implicitParentTag Nothing = [] 156 implicitParentTag parents
149 implicitParentTag (Just parent) = if addDirTag then [parent] else [] 157 | addDirTag = maybeToList $ fileName parents
158 | otherwise = []
150 159
151 160
152flattenGalleryTree :: GalleryItem -> [GalleryItem] 161flattenGalleryTree :: GalleryItem -> [GalleryItem]
@@ -157,16 +166,25 @@ flattenGalleryTree simple = [simple]
157 166
158galleryOutputDiff :: GalleryItem -> FSNode -> [Path] 167galleryOutputDiff :: GalleryItem -> FSNode -> [Path]
159galleryOutputDiff resources ref = 168galleryOutputDiff resources ref =
160 (fsPaths ref) \\ (resPaths $ flattenGalleryTree resources) 169 (filesystemPaths ref) \\ (compiledPaths $ flattenGalleryTree resources)
161 where 170 where
162 resPaths :: [GalleryItem] -> [Path] 171 filesystemPaths :: FSNode -> [Path]
163 resPaths resList = map (path::(GalleryItem->Path)) resList ++ thumbnailPaths resList 172 filesystemPaths = map Files.path . tail . flattenDir
164 173
165 thumbnailPaths :: [GalleryItem] -> [Path] 174 compiledPaths :: [GalleryItem] -> [Path]
166 thumbnailPaths = (concatMap subPaths) . (mapMaybe thumbnail) 175 compiledPaths items =
176 resourcePaths items ++ thumbnailPaths items
177 & concatMap subPaths
167 178
168 fsPaths :: FSNode -> [Path] 179 resourcePaths :: [GalleryItem] -> [Path]
169 fsPaths = map Files.path . tail . flattenDir 180 resourcePaths = mapMaybe (resourcePath . properties)
181
182 resourcePath :: GalleryItemProps -> Maybe Path
183 resourcePath Directory{} = Nothing
184 resourcePath resourceProps = Just $ resource resourceProps
185
186 thumbnailPaths :: [GalleryItem] -> [Path]
187 thumbnailPaths = mapMaybe thumbnail
170 188
171 189
172galleryCleanupResourceDir :: GalleryItem -> FileName -> IO () 190galleryCleanupResourceDir :: GalleryItem -> FileName -> IO ()