aboutsummaryrefslogtreecommitdiff
path: root/compiler/src
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/src')
-rw-r--r--compiler/src/Input.hs60
-rw-r--r--compiler/src/Resource.hs8
2 files changed, 41 insertions, 27 deletions
diff --git a/compiler/src/Input.hs b/compiler/src/Input.hs
index 2480f5b..48931ec 100644
--- a/compiler/src/Input.hs
+++ b/compiler/src/Input.hs
@@ -30,11 +30,12 @@ import Data.Function ((&))
30import Data.Functor ((<&>)) 30import Data.Functor ((<&>))
31import Data.Maybe (catMaybes, fromMaybe) 31import Data.Maybe (catMaybes, fromMaybe)
32import Data.Bool (bool) 32import Data.Bool (bool)
33import Data.List (find) 33import Data.List (find, isSuffixOf)
34import Data.Time.Clock (UTCTime) 34import Data.Time.Clock (UTCTime)
35import Data.Time.LocalTime (ZonedTime) 35import Data.Time.LocalTime (ZonedTime)
36import Data.Yaml (ParseException, decodeFileEither) 36import Data.Yaml (ParseException, decodeFileEither)
37import Data.Aeson (FromJSON) 37import Data.Aeson (FromJSON)
38import qualified Data.Map.Strict as Map
38import System.FilePath (isExtensionOf, dropExtension) 39import System.FilePath (isExtensionOf, dropExtension)
39import System.Directory (doesFileExist, getModificationTime) 40import System.Directory (doesFileExist, getModificationTime)
40 41
@@ -55,12 +56,13 @@ data InputTree =
55 InputFile 56 InputFile
56 { path :: Path 57 { path :: Path
57 , modTime :: UTCTime 58 , modTime :: UTCTime
58 , sidecar :: Sidecar } 59 , sidecar :: Sidecar
60 , thumbnailPath :: Maybe Path }
59 | InputDir 61 | InputDir
60 { path :: Path 62 { path :: Path
61 , modTime :: UTCTime 63 , modTime :: UTCTime
62 , sidecar :: Sidecar 64 , sidecar :: Sidecar
63 , dirThumbnailPath :: Maybe Path 65 , thumbnailPath :: Maybe Path
64 , items :: [InputTree] } 66 , items :: [InputTree] }
65 deriving Show 67 deriving Show
66 68
@@ -81,6 +83,9 @@ emptySidecar = Sidecar
81sidecarExt :: String 83sidecarExt :: String
82sidecarExt = "yaml" 84sidecarExt = "yaml"
83 85
86thumbnailSuffix :: String
87thumbnailSuffix = "_thumbnail"
88
84dirPropFile :: String 89dirPropFile :: String
85dirPropFile = "_directory" 90dirPropFile = "_directory"
86 91
@@ -99,40 +104,49 @@ readInputTree (AnchoredFSNode _ File{}) =
99 throw $ AssertionFailed "Input directory is a file" 104 throw $ AssertionFailed "Input directory is a file"
100readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root 105readInputTree (AnchoredFSNode anchor root@Dir{}) = mkDirNode root
101 where 106 where
102 mkInputNode :: FSNode -> IO (Maybe InputTree) 107 mkInputNode :: Map.Map FileName FSNode -> FSNode -> IO (Maybe InputTree)
103 mkInputNode file@File{path} 108 mkInputNode dir file@File{path} | not (isSidecar file) && not (isThumbnail file) =
104 | not (isSidecar file) && not (isThumbnail file) = 109 do
105 do 110 sidecar <- readSidecarFile $ localPath (anchor /> path <.> sidecarExt)
106 sidecar <- readSidecarFile $ localPath (anchor /> path <.> sidecarExt) 111 modTime <- getModificationTime $ localPath (anchor /> path)
107 modTime <- getModificationTime $ localPath (anchor /> path) 112 let thumbnail = findFileThumbnail (fromMaybe "" $ fileName path) dir
108 return $ Just $ InputFile path modTime sidecar 113 return $ Just $ InputFile path modTime sidecar thumbnail
109 mkInputNode File{} = return Nothing 114 mkInputNode _ File{} = return Nothing
110 mkInputNode dir@Dir{} = Just <$> mkDirNode dir 115 mkInputNode _ dir@Dir{} = Just <$> mkDirNode dir
111 116
112 mkDirNode :: FSNode -> IO InputTree 117 mkDirNode :: FSNode -> IO InputTree
113 mkDirNode File{} = throw $ AssertionFailed "Input directory is a file" 118 mkDirNode File{} = throw $ AssertionFailed "Input directory is a file"
114 mkDirNode Dir{path, items} = 119 mkDirNode Dir{path, items} =
115 do 120 do
116 dirItems <- mapM mkInputNode items 121 dirItems <- mapM (mkInputNode $ Map.fromList (map withBaseName items)) items
117 modTime <- getModificationTime $ localPath (anchor /> path) 122 modTime <- getModificationTime $ localPath (anchor /> path)
118 sidecar <- readSidecarFile $ localPath (anchor /> path </> dirSidecar) 123 sidecar <- readSidecarFile $ localPath (anchor /> path </> dirSidecar)
119 return $ InputDir path modTime sidecar (findThumbnail items) (catMaybes dirItems) 124 return $ InputDir path modTime sidecar (findDirThumbnail items) (catMaybes dirItems)
125
126 withBaseName :: FSNode -> (FileName, FSNode)
127 withBaseName node = (fromMaybe "" $ baseName $ Files.path node, node)
128
129 findFileThumbnail :: FileName -> Map.Map FileName FSNode -> Maybe Path
130 findFileThumbnail name dict = Files.path <$> Map.lookup (name ++ thumbnailSuffix) dict
120 131
121 isSidecar :: FSNode -> Bool 132 isSidecar :: FSNode -> Bool
122 isSidecar Dir{} = False 133 isSidecar Dir{} = False
123 isSidecar File{path} = 134 isSidecar File{path} = fileName path & maybe False (isExtensionOf sidecarExt)
124 fileName path 135
125 & maybe False (isExtensionOf sidecarExt) 136 baseName :: Path -> Maybe FileName
137 baseName = fmap dropExtension . fileName
126 138
127 isThumbnail :: FSNode -> Bool 139 isThumbnail :: FSNode -> Bool
128 isThumbnail Dir{} = False 140 isThumbnail Dir{} = False
129 isThumbnail File{path} = 141 isThumbnail File{path} = baseName path & maybe False (thumbnailSuffix `isSuffixOf`)
130 fileName path 142
131 & fmap dropExtension 143 isDirThumbnail :: FSNode -> Bool
132 & maybe False (dirPropFile ==) 144 isDirThumbnail Dir{} = False
145 isDirThumbnail File{path} = baseName path & (== Just thumbnailSuffix)
146
147 findDirThumbnail :: [FSNode] -> Maybe Path
148 findDirThumbnail = fmap Files.path . find isDirThumbnail
133 149
134 findThumbnail :: [FSNode] -> Maybe Path
135 findThumbnail = fmap Files.path . find isThumbnail
136 150
137-- | Filters an InputTree. The root is always returned. 151-- | Filters an InputTree. The root is always returned.
138filterInputTree :: (InputTree -> Bool) -> InputTree -> InputTree 152filterInputTree :: (InputTree -> Bool) -> InputTree -> InputTree
diff --git a/compiler/src/Resource.hs b/compiler/src/Resource.hs
index 6b4b44c..f59eed6 100644
--- a/compiler/src/Resource.hs
+++ b/compiler/src/Resource.hs
@@ -134,11 +134,11 @@ buildGalleryTree processItem processThumbnail tagsFromDirsConfig =
134 mkGalleryItem [] 134 mkGalleryItem []
135 where 135 where
136 mkGalleryItem :: [Tag] -> InputTree -> IO GalleryItem 136 mkGalleryItem :: [Tag] -> InputTree -> IO GalleryItem
137 mkGalleryItem inheritedTags InputFile{path, modTime, sidecar} = 137 mkGalleryItem inheritedTags InputFile{path, modTime, sidecar, thumbnailPath} =
138 do 138 do
139 let itemPath = "/" /> path 139 let itemPath = "/" /> path
140 properties <- processItem itemPath path 140 properties <- processItem itemPath path
141 processedThumbnail <- processThumbnail itemPath path 141 processedThumbnail <- processThumbnail itemPath (thumbnailPath ?? path)
142 return GalleryItem 142 return GalleryItem
143 { title = Input.title sidecar ?? fileName path ?? "" 143 { title = Input.title sidecar ?? fileName path ?? ""
144 , datetime = Input.datetime sidecar ?? toZonedTime modTime 144 , datetime = Input.datetime sidecar ?? toZonedTime modTime
@@ -148,12 +148,12 @@ buildGalleryTree processItem processThumbnail tagsFromDirsConfig =
148 , thumbnail = processedThumbnail 148 , thumbnail = processedThumbnail
149 , properties = properties } 149 , properties = properties }
150 150
151 mkGalleryItem inheritedTags InputDir{path, modTime, sidecar, dirThumbnailPath, items} = 151 mkGalleryItem inheritedTags InputDir{path, modTime, sidecar, thumbnailPath, items} =
152 do 152 do
153 let itemPath = "/" /> path 153 let itemPath = "/" /> path
154 let dirTags = (Input.tags sidecar ?? []) ++ inheritedTags 154 let dirTags = (Input.tags sidecar ?? []) ++ inheritedTags
155 processedItems <- parallel $ map (mkGalleryItem dirTags) items 155 processedItems <- parallel $ map (mkGalleryItem dirTags) items
156 processedThumbnail <- maybeThumbnail itemPath dirThumbnailPath 156 processedThumbnail <- maybeThumbnail itemPath thumbnailPath
157 return GalleryItem 157 return GalleryItem
158 { title = Input.title sidecar ?? fileName path ?? "" 158 { title = Input.title sidecar ?? fileName path ?? ""
159 , datetime = Input.datetime sidecar ?? mostRecentModTime processedItems 159 , datetime = Input.datetime sidecar ?? mostRecentModTime processedItems