gallery/make-pages/Info.hs

324 lines
9.7 KiB
Haskell
Raw Normal View History

2020-07-07 20:52:01 -04:00
{-# OPTIONS_GHC -Wno-orphans #-}
module Info
2020-08-03 13:36:48 -04:00
(Info (..), tagsFor, descFor, imagesFor, linksFor,
Artist (..), Image (..), Link (..),
2020-07-24 19:10:52 -04:00
GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
2020-07-18 05:45:32 -04:00
IndexInfo (..),
2020-07-24 19:10:52 -04:00
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
2020-08-11 14:29:54 -04:00
NoThumb (..), getThumb, thumbFile, pageFile,
2020-07-07 20:52:01 -04:00
-- ** Reexports
Day (..), Text)
2020-07-07 20:52:01 -04:00
where
2020-07-13 02:33:27 -04:00
import Records
2020-07-15 14:07:51 -04:00
import Control.Applicative
2020-08-08 19:20:34 -04:00
import Control.Monad
2020-08-11 14:29:54 -04:00
import Control.Exception
2020-07-15 14:07:51 -04:00
import Data.Foldable (find)
2020-08-03 20:27:19 -04:00
import Data.Hashable (Hashable)
import Data.HashSet (HashSet)
2020-07-24 19:10:52 -04:00
import qualified Data.HashSet as HashSet
2020-07-15 14:07:51 -04:00
import qualified Data.Map.Strict as Map
2020-08-08 19:20:34 -04:00
import Data.Maybe (isJust, isNothing)
2020-07-19 11:55:54 -04:00
import Data.Ord (comparing)
2020-07-16 05:48:09 -04:00
import Data.String (IsString)
2020-07-07 20:52:01 -04:00
import Data.Text (Text)
import qualified Data.Text as Text
2020-07-18 05:26:59 -04:00
import Data.Time.Calendar (Day (..), toGregorian)
2020-07-15 14:07:51 -04:00
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML
2020-08-11 14:29:54 -04:00
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
2020-07-07 20:52:01 -04:00
import Text.Read (readMaybe)
data Info =
Info {
2020-07-24 19:17:47 -04:00
date :: !Day,
title :: !Text,
artist :: !(Maybe Artist), -- nothing = me, obv
nsfwOnly :: !Bool,
2020-07-24 19:17:47 -04:00
tags :: ![Text],
nsfwTags :: ![Text],
desc :: !(Maybe Text),
nsfwDesc :: !(Maybe Text),
bg :: !(Maybe Text),
2020-07-24 19:17:47 -04:00
images :: ![Image],
thumb' :: !(Maybe FilePath),
2020-08-04 18:52:39 -04:00
links :: ![Link],
extras :: ![FilePath]
2020-07-07 20:52:01 -04:00
}
deriving (Eq, Show)
2020-07-12 22:38:37 -04:00
data Artist =
Artist {
name :: !Text,
url :: !(Maybe Text)
}
deriving (Eq, Show)
2020-07-07 20:52:01 -04:00
data Image =
Image {
2020-07-21 19:48:29 -04:00
label :: !Text,
path :: !FilePath,
download :: !(Maybe FilePath),
nsfw :: !Bool,
warning :: !(Maybe Text)
2020-07-07 20:52:01 -04:00
}
deriving (Eq, Show)
data Link =
Link {
2020-07-07 23:27:38 -04:00
title :: !Text,
2020-07-09 15:45:57 -04:00
url :: !Text,
nsfw :: !Bool
2020-07-07 20:52:01 -04:00
}
deriving (Eq, Show)
2020-07-13 02:33:27 -04:00
instance HasField "sfw" Image Bool where getField = not . #nsfw
instance HasField "sfw" Link Bool where getField = not . #nsfw
2020-07-16 05:47:02 -04:00
instance HasField "sfwImages" Info [Image] where
getField = filter #sfw . #images
2020-07-18 05:27:27 -04:00
instance HasField "nsfwImages" Info [Image] where
getField = filter #nsfw . #images
2020-07-16 05:47:02 -04:00
instance HasField "allNsfw" Info Bool where getField = null . #sfwImages
2020-07-18 05:27:27 -04:00
instance HasField "allSfw" Info Bool where getField = null . #nsfwImages
2020-07-16 05:47:02 -04:00
instance HasField "anySfw" Info Bool where getField = not . #allNsfw
2020-07-18 05:27:27 -04:00
instance HasField "anyNsfw" Info Bool where getField = not . #allSfw
2020-07-16 05:47:02 -04:00
2020-08-03 13:36:48 -04:00
instance HasField "sfwLinks" Info [Link] where
getField = filter #sfw . #links
instance HasField "nsfwLinks" Info [Link] where
getField = filter #nsfw . #links
2020-07-15 14:07:51 -04:00
instance HasField "thumb" Info (Maybe FilePath) where
getField (Info {thumb', images}) = thumb' <|> #path <$> find #sfw images
instance HasField "mine" Info Bool where getField = isNothing . #artist
instance HasField "notMine" Info Bool where getField = isJust . #artist
2020-07-18 05:26:59 -04:00
instance HasField "dmy" Info (Integer, Int, Int) where
getField = toGregorian . #date
instance HasField "year" Info Integer where getField = #first . #dmy
instance HasField "month" Info Int where getField = #second . #dmy
instance HasField "day" Info Int where getField = #third . #dmy
2020-08-08 19:20:34 -04:00
descFor :: Bool -> Info -> Maybe Text
descFor nsfw (Info {desc, nsfwDesc}) = desc <> (guard nsfw *> nsfwDesc)
2020-08-03 13:36:48 -04:00
tagsFor :: Bool -> Info -> [Text]
tagsFor nsfw i = if nsfw then #tags i <> #nsfwTags i else #tags i
imagesFor :: Bool -> Info -> [Image]
imagesFor nsfw = if nsfw then #images else #sfwImages
linksFor :: Bool -> Info -> [Link]
linksFor nsfw = if nsfw then #links else #sfwLinks
2020-07-19 11:55:54 -04:00
instance Ord Info where
compare = comparing \Info {date, title} -> (date, title)
2020-07-07 20:52:01 -04:00
2020-08-11 14:29:54 -04:00
newtype NoThumb = NoThumb FilePath
deriving stock Eq deriving anyclass Exception
instance Show NoThumb where show (NoThumb dir) = "no thumbnail for " ++ dir
getThumb :: FilePath -> Info -> FilePath
getThumb dir =
maybe (throw $ NoThumb dir) (\t -> dir </> thumbFile t) . #thumb
thumbFile :: FilePath -> FilePath
thumbFile = addSuffix "_small"
pageFile :: FilePath -> FilePath
pageFile f
| takeExtension f == ".gif" = f
| otherwise = addSuffix "_med" f
addSuffix :: String -> FilePath -> FilePath
addSuffix suf path =
let (pre, ext) = splitExtension path in
pre ++ suf ++ ext
2020-07-07 20:52:01 -04:00
instance FromYAML Info where
parseYAML = YAML.withMap "info" \m ->
2020-08-04 18:52:39 -04:00
Info <$> m .: "date"
<*> m .: "title"
<*> m .:? "artist"
<*> m .:? "nsfw-only" .!= False
2020-08-04 18:52:39 -04:00
<*> m .:? "tags" .!= []
<*> m .:? "nsfw-tags" .!= []
<*> m .:? "desc"
<*> m .:? "nsfw-desc"
<*> m .:? "bg"
<*> (m .: "images" >>= imageList)
2020-08-04 18:52:39 -04:00
<*> m .:? "thumb"
<*> m .:? "links" .!= []
<*> m .:? "extras" .!= []
2020-07-07 20:52:01 -04:00
2020-07-12 22:38:37 -04:00
instance FromYAML Artist where
parseYAML y = justName y <|> withUrl y where
justName = YAML.withStr "name" \name -> pure $ Artist {name, url = Nothing}
withUrl = YAML.withMap "full info" \m ->
Artist <$> m .: "name" <*> m .:? "url"
imageList :: YAML.Node YAML.Pos -> YAML.Parser [Image]
imageList y = pure <$> unlabelledImage y <|> parseYAML y
2020-07-07 20:52:01 -04:00
instance FromYAML Image where
parseYAML y = unlabelledImage y <|> labelled y where
labelled y' = do
Pair label rest <- parseYAML y'
i <- unlabelledImage rest
pure $ i {label}
unlabelledImage :: YAML.Node YAML.Pos -> YAML.Parser Image
unlabelledImage y = asStr y <|> asObj y
where
asStr = YAML.withStr "path" \(Text.unpack -> path) ->
2020-07-31 21:02:49 -04:00
pure $ Image {label = pathToLabel path, path, download = Nothing,
2020-07-21 19:48:29 -04:00
nsfw = False, warning = Nothing}
asObj = YAML.withMap "image info" \m -> do
2020-07-21 19:48:29 -04:00
path <- m .: "path"
download <- m .:? "download"
nsfw <- m .:? "nsfw" .!= False
warning <- m .:? "warning"
2020-07-31 21:02:49 -04:00
pure $ Image {label = pathToLabel path, path, download, nsfw, warning}
pathToLabel = Text.pack . dashToSpace . takeBaseName
dashToSpace = map \case '-' -> ' '; c -> c
2020-07-07 20:52:01 -04:00
instance FromYAML Link where
2020-07-17 06:29:13 -04:00
parseYAML y = do
Pair title rest <- parseYAML y
asStr title rest <|> asObj title rest
where
asStr title = YAML.withStr "url" \url ->
pure $ Link {title, url, nsfw = False}
asObj title = YAML.withMap "link info" \m -> do
url <- m .: "url"
nsfw <- m .:? "nsfw" .!= False
pure $ Link {title, url, nsfw}
2020-07-07 20:52:01 -04:00
2020-07-16 05:48:09 -04:00
data GalleryInfo =
GalleryInfo {
2020-07-24 19:17:47 -04:00
title :: !Text,
desc :: !Text,
prefix :: !FilePath,
2020-08-03 20:27:19 -04:00
filters :: !GalleryFilters,
hidden :: !(HashSet Text) -- ^ tags to initially hide
2020-07-16 05:48:09 -04:00
}
deriving (Eq, Show)
data GalleryFilters =
GalleryFilters {
2020-07-24 19:17:47 -04:00
nsfw :: !NsfwFilter,
2020-07-24 19:10:52 -04:00
artist :: !ArtistFilter,
2020-08-03 20:27:19 -04:00
require, exclude :: !(HashSet Text)
2020-07-16 05:48:09 -04:00
}
deriving (Eq, Show)
2020-07-24 19:10:52 -04:00
data NsfwFilter = NoNsfw | OnlyNsfw | AllN deriving (Eq, Show)
2020-07-16 05:48:09 -04:00
2020-07-24 19:10:52 -04:00
readNsfwFilter :: (IsString str, Eq str, Alternative f) => str -> f NsfwFilter
readNsfwFilter "no" = pure NoNsfw
readNsfwFilter "only" = pure OnlyNsfw
readNsfwFilter "all" = pure AllN
readNsfwFilter _ = empty
2020-07-16 05:48:09 -04:00
2020-07-24 19:10:52 -04:00
matchNsfw :: NsfwFilter -> Info -> Bool
matchNsfw NoNsfw i = #anySfw i && not (#nsfwOnly i)
2020-07-25 07:58:33 -04:00
matchNsfw OnlyNsfw i = #anyNsfw i
2020-07-24 19:10:52 -04:00
matchNsfw AllN _ = True
2020-07-16 05:48:09 -04:00
2020-07-24 19:10:52 -04:00
instance FromYAML NsfwFilter where
parseYAML = YAML.withStr "nsfw filter" readNsfwFilter
2020-07-16 05:48:09 -04:00
2020-07-24 19:10:52 -04:00
2020-07-31 21:02:26 -04:00
data ArtistFilter = Me | NotMe | AllA deriving (Eq, Show)
2020-07-24 19:10:52 -04:00
readArtistFilter :: (IsString str, Eq str, Alternative f)
=> str -> f ArtistFilter
readArtistFilter "me" = pure Me
readArtistFilter "not-me" = pure NotMe
2020-07-31 21:02:26 -04:00
readArtistFilter "all" = pure AllA
2020-07-24 19:10:52 -04:00
readArtistFilter _ = empty
matchArtist :: ArtistFilter -> Info -> Bool
matchArtist Me = #mine
matchArtist NotMe = #notMine
2020-07-31 21:02:26 -04:00
matchArtist AllA = const True
2020-07-16 05:48:09 -04:00
noFilters :: GalleryFilters
2020-07-24 19:10:52 -04:00
noFilters =
2020-07-31 21:02:26 -04:00
GalleryFilters {nsfw = AllN, artist = AllA, require = [], exclude = []}
2020-07-16 05:48:09 -04:00
matchFilters :: GalleryFilters -> Info -> Bool
2020-07-24 19:10:52 -04:00
matchFilters (GalleryFilters {nsfw, artist, require, exclude}) i =
matchNsfw nsfw i && matchArtist artist i &&
2020-08-03 20:27:19 -04:00
all (\t -> HashSet.member t tags) require &&
all (\t -> not $ HashSet.member t tags) exclude
where tags = HashSet.fromList $ #tags i
2020-07-16 05:48:09 -04:00
instance FromYAML GalleryInfo where
parseYAML = YAML.withMap "gallery info" \m ->
2020-07-16 10:07:28 -04:00
GalleryInfo <$> m .: "title"
2020-07-24 19:17:47 -04:00
<*> m .: "desc"
2020-07-16 10:07:28 -04:00
<*> m .: "prefix"
<*> m .:? "filters" .!= noFilters
2020-08-03 20:27:19 -04:00
<*> m .:? "hidden" .!= mempty
2020-07-16 05:48:09 -04:00
instance FromYAML GalleryFilters where
parseYAML = YAML.withMap "gallery filters" \m ->
2020-07-24 19:10:52 -04:00
GalleryFilters <$> m .:? "nsfw" .!= AllN
2020-07-31 21:02:26 -04:00
<*> m .:? "artist" .!= AllA
2020-07-24 19:10:52 -04:00
<*> m .:? "require" .!= []
<*> m .:? "exclude" .!= []
2020-07-16 05:48:09 -04:00
2020-07-24 19:10:52 -04:00
instance FromYAML ArtistFilter where
parseYAML = YAML.withStr "artist filter" readArtistFilter
2020-07-16 05:48:09 -04:00
2020-07-18 05:45:32 -04:00
data IndexInfo =
IndexInfo {
2020-07-19 06:10:27 -04:00
title :: !Text,
2020-08-11 14:29:54 -04:00
desc :: !Text,
2020-07-18 05:45:32 -04:00
galleries :: ![GalleryInfo],
2020-07-19 06:22:02 -04:00
links :: ![Link],
footer :: !(Maybe Text)
2020-07-18 05:45:32 -04:00
}
deriving Show
instance FromYAML IndexInfo where
parseYAML = YAML.withMap "index info" \m ->
2020-07-19 06:10:27 -04:00
IndexInfo <$> m .: "title"
2020-08-11 14:29:54 -04:00
<*> m .: "desc"
2020-07-19 06:10:27 -04:00
<*> m .:? "galleries" .!= []
2020-07-19 06:22:02 -04:00
<*> m .:? "links" .!= []
<*> m .:? "footer"
2020-07-18 05:45:32 -04:00
2020-07-07 20:52:01 -04:00
data Pair a b = Pair !a !b
instance (FromYAML a, FromYAML b) => FromYAML (Pair a b) where
2020-07-31 21:02:26 -04:00
parseYAML = YAML.withMap "single-pair map" \m ->
case Map.toList m of
[(a, b)] -> Pair <$> parseYAML a <*> parseYAML b
_ -> fail "expected exactly one pair"
2020-07-07 20:52:01 -04:00
2020-07-09 15:45:57 -04:00
2020-07-07 20:52:01 -04:00
instance FromYAML Day where
parseYAML = YAML.withStr "date" \str ->
case readMaybe $ Text.unpack str of
Just d -> pure d
Nothing -> fail $ "couldn't parse date " ++ show str
2020-07-15 05:35:32 -04:00
instance {-# OVERLAPPING #-} FromYAML String where
parseYAML y = Text.unpack <$> parseYAML y
2020-08-03 20:27:19 -04:00
instance (FromYAML a, Eq a, Hashable a) => FromYAML (HashSet a) where
parseYAML y = HashSet.fromList <$> parseYAML y