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.hs151
1 files changed, 95 insertions, 56 deletions
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 56f7a3f..e134468 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -18,27 +18,30 @@
18 18
19module Resource 19module Resource
20 ( ItemProcessor, ThumbnailProcessor 20 ( ItemProcessor, ThumbnailProcessor
21 , GalleryItem(..), GalleryItemProps(..), Resolution(..) 21 , GalleryItem(..), GalleryItemProps(..), Resolution(..), Resource(..), Thumbnail(..)
22 , buildGalleryTree, galleryCleanupResourceDir 22 , buildGalleryTree, galleryCleanupResourceDir
23 ) where 23 ) where
24 24
25 25
26import Control.Concurrent.ParallelIO.Global (parallel) 26import Control.Concurrent.ParallelIO.Global (parallel)
27import Data.List ((\\), sortBy) 27import Data.List (sortOn)
28import Data.Ord (comparing) 28import Data.List.Ordered (minusBy)
29import Data.Char (toLower) 29import Data.Char (toLower)
30import Data.Maybe (mapMaybe, fromMaybe, maybeToList) 30import Data.Maybe (mapMaybe, fromMaybe)
31import Data.Function ((&)) 31import Data.Function ((&))
32import qualified Data.Set as Set 32import qualified Data.Set as Set
33import Data.Text (pack)
33import Data.Time.Clock (UTCTime) 34import Data.Time.Clock (UTCTime)
34import Data.Time.LocalTime (ZonedTime, utc, utcToZonedTime, zonedTimeToUTC) 35import Data.Time.LocalTime (ZonedTime, utc, utcToZonedTime, zonedTimeToUTC)
36import Data.Time.Format (formatTime, defaultTimeLocale)
35import Safe.Foldable (maximumByMay) 37import Safe.Foldable (maximumByMay)
36 38
37import GHC.Generics (Generic) 39import GHC.Generics (Generic)
38import Data.Aeson (FromJSON, ToJSON, genericToJSON, genericToEncoding) 40import Data.Aeson (ToJSON, genericToJSON, genericToEncoding)
39import qualified Data.Aeson as JSON 41import qualified Data.Aeson as JSON
40 42
41import Files 43import Files
44import Config (Resolution(..), TagsFromDirectoriesConfig(..))
42import Input (InputTree(..), Sidecar(..)) 45import Input (InputTree(..), Sidecar(..))
43 46
44 47
@@ -55,20 +58,24 @@ encodingOptions = JSON.defaultOptions
55 58
56type Tag = String 59type Tag = String
57 60
58data Resolution = Resolution 61data Resource = Resource
59 { width :: Int 62 { resourcePath :: Path
60 , height :: Int 63 , modTime :: UTCTime
61 } deriving (Generic, Show, FromJSON) 64 } deriving (Generic, Show)
62 65
63instance ToJSON Resolution where 66instance ToJSON Resource where
64 toJSON = genericToJSON encodingOptions 67 toJSON Resource{resourcePath, modTime} =
65 toEncoding = genericToEncoding encodingOptions 68 JSON.String $ pack (webPath resourcePath ++ "?" ++ timestamp)
69 where
70 timestamp = formatTime defaultTimeLocale "%s" modTime
66 71
67 72
68data GalleryItemProps = 73data GalleryItemProps =
69 Directory { items :: [GalleryItem] } 74 Directory { items :: [GalleryItem] }
70 | Picture { resource :: Path } 75 | Picture
71 | Other { resource :: Path } 76 { resource :: Resource
77 , resolution :: Resolution }
78 | Other { resource :: Resource }
72 deriving (Generic, Show) 79 deriving (Generic, Show)
73 80
74instance ToJSON GalleryItemProps where 81instance ToJSON GalleryItemProps where
@@ -76,13 +83,23 @@ instance ToJSON GalleryItemProps where
76 toEncoding = genericToEncoding encodingOptions 83 toEncoding = genericToEncoding encodingOptions
77 84
78 85
86data Thumbnail = Thumbnail
87 { resource :: Resource
88 , resolution :: Resolution
89 } deriving (Generic, Show)
90
91instance ToJSON Thumbnail where
92 toJSON = genericToJSON encodingOptions
93 toEncoding = genericToEncoding encodingOptions
94
95
79data GalleryItem = GalleryItem 96data GalleryItem = GalleryItem
80 { title :: String 97 { title :: String
81 , datetime :: ZonedTime 98 , datetime :: ZonedTime
82 , description :: String 99 , description :: String
83 , tags :: [Tag] 100 , tags :: [Tag]
84 , path :: Path 101 , path :: Path
85 , thumbnail :: Maybe Path 102 , thumbnail :: Maybe Thumbnail
86 , properties :: GalleryItemProps 103 , properties :: GalleryItemProps
87 } deriving (Generic, Show) 104 } deriving (Generic, Show)
88 105
@@ -92,51 +109,61 @@ instance ToJSON GalleryItem where
92 109
93 110
94type ItemProcessor = Path -> IO GalleryItemProps 111type ItemProcessor = Path -> IO GalleryItemProps
95type ThumbnailProcessor = Path -> IO (Maybe Path) 112type ThumbnailProcessor = Path -> IO (Maybe Thumbnail)
96 113
97 114
98buildGalleryTree :: 115buildGalleryTree ::
99 ItemProcessor -> ThumbnailProcessor 116 ItemProcessor -> ThumbnailProcessor -> TagsFromDirectoriesConfig
100 -> Int -> String -> InputTree -> IO GalleryItem 117 -> InputTree -> IO GalleryItem
101buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName inputTree = 118buildGalleryTree processItem processThumbnail tagsFromDirsConfig inputTree =
102 mkGalleryItem [] inputTree 119 mkGalleryItem [] inputTree
103 where 120 where
104 mkGalleryItem :: [String] -> InputTree -> IO GalleryItem 121 mkGalleryItem :: [Tag] -> InputTree -> IO GalleryItem
105 mkGalleryItem parentTitles InputFile{path, modTime, sidecar} = 122 mkGalleryItem inheritedTags InputFile{path, modTime, sidecar} =
106 do 123 do
107 properties <- processItem path 124 properties <- processItem path
108 processedThumbnail <- processThumbnail path 125 processedThumbnail <- processThumbnail path
109 return GalleryItem 126 return GalleryItem
110 { title = fromMeta title $ fromMaybe "" $ fileName path 127 { title = Input.title sidecar ?? fileName path ?? ""
111 , datetime = fromMaybe (toZonedTime modTime) (Input.datetime sidecar) 128 , datetime = Input.datetime sidecar ?? toZonedTime modTime
112 , description = fromMeta description "" 129 , description = Input.description sidecar ?? ""
113 , tags = unique ((fromMeta tags []) ++ implicitParentTags parentTitles) 130 , tags = unique ((Input.tags sidecar ?? []) ++ inheritedTags ++ parentDirTags path)
114 , path = "/" /> path 131 , path = "/" /> path
115 , thumbnail = processedThumbnail 132 , thumbnail = processedThumbnail
116 , properties = properties } 133 , properties = properties }
117 134
118 where 135 mkGalleryItem inheritedTags InputDir{path, modTime, sidecar, dirThumbnailPath, items} =
119 fromMeta :: (Sidecar -> Maybe a) -> a -> a
120 fromMeta get fallback = fromMaybe fallback $ get sidecar
121
122 mkGalleryItem parentTitles InputDir{path, modTime, dirThumbnailPath, items} =
123 do 136 do
137 let dirTags = (Input.tags sidecar ?? []) ++ inheritedTags
138 processedItems <- parallel $ map (mkGalleryItem dirTags) items
124 processedThumbnail <- maybeThumbnail dirThumbnailPath 139 processedThumbnail <- maybeThumbnail dirThumbnailPath
125 processedItems <- parallel $ map (mkGalleryItem subItemsParents) items
126 return GalleryItem 140 return GalleryItem
127 { title = fromMaybe galleryName (fileName path) 141 { title = Input.title sidecar ?? fileName path ?? ""
128 , datetime = fromMaybe (toZonedTime modTime) (mostRecentModTime processedItems) 142 , datetime = Input.datetime sidecar ?? mostRecentModTime processedItems
129 , description = "" 143 ?? toZonedTime modTime
130 , tags = unique (aggregateTags processedItems ++ implicitParentTags parentTitles) 144 , description = Input.description sidecar ?? ""
145 , tags = unique (aggregateTags processedItems ++ parentDirTags path)
131 , path = "/" /> path 146 , path = "/" /> path
132 , thumbnail = processedThumbnail 147 , thumbnail = processedThumbnail
133 , properties = Directory processedItems } 148 , properties = Directory processedItems }
134 149
135 where 150 infixr ??
136 subItemsParents :: [String] 151 (??) :: Maybe a -> a -> a
137 subItemsParents = (maybeToList $ fileName path) ++ parentTitles 152 (??) = flip fromMaybe
153
154 unique :: Ord a => [a] -> [a]
155 unique = Set.toList . Set.fromList
156
157 parentDirTags :: Path -> [Tag]
158 parentDirTags (Path elements) =
159 drop 1 elements
160 & take (fromParents tagsFromDirsConfig)
161 & map (prefix tagsFromDirsConfig ++)
138 162
139 maybeThumbnail :: Maybe Path -> IO (Maybe Path) 163 aggregateTags :: [GalleryItem] -> [Tag]
164 aggregateTags = concatMap (\item -> tags (item::GalleryItem))
165
166 maybeThumbnail :: Maybe Path -> IO (Maybe Thumbnail)
140 maybeThumbnail Nothing = return Nothing 167 maybeThumbnail Nothing = return Nothing
141 maybeThumbnail (Just thumbnailPath) = processThumbnail thumbnailPath 168 maybeThumbnail (Just thumbnailPath) = processThumbnail thumbnailPath
142 169
@@ -147,15 +174,6 @@ buildGalleryTree processItem processThumbnail tagsFromDirectories galleryName in
147 comparingTime :: ZonedTime -> ZonedTime -> Ordering 174 comparingTime :: ZonedTime -> ZonedTime -> Ordering
148 comparingTime l r = compare (zonedTimeToUTC l) (zonedTimeToUTC r) 175 comparingTime l r = compare (zonedTimeToUTC l) (zonedTimeToUTC r)
149 176
150 aggregateTags :: [GalleryItem] -> [Tag]
151 aggregateTags = concatMap (\item -> tags (item::GalleryItem))
152
153 unique :: Ord a => [a] -> [a]
154 unique = Set.toList . Set.fromList
155
156 implicitParentTags :: [String] -> [Tag]
157 implicitParentTags = take tagsFromDirectories
158
159 toZonedTime :: UTCTime -> ZonedTime 177 toZonedTime :: UTCTime -> ZonedTime
160 toZonedTime = utcToZonedTime utc 178 toZonedTime = utcToZonedTime utc
161 179
@@ -175,24 +193,45 @@ galleryOutputDiff resources ref =
175 193
176 compiledPaths :: [GalleryItem] -> [Path] 194 compiledPaths :: [GalleryItem] -> [Path]
177 compiledPaths items = 195 compiledPaths items =
178 resourcePaths items ++ thumbnailPaths items 196 resPaths items ++ thumbnailPaths items
179 & concatMap subPaths 197 & concatMap subPaths
180 198
181 resourcePaths :: [GalleryItem] -> [Path] 199 resPaths :: [GalleryItem] -> [Path]