374 lines
11 KiB
Haskell
374 lines
11 KiB
Haskell
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
module Info
|
|
(Info (..),
|
|
tagsFor, descFor, imagesFor, linksFor, updatesFor, compareFor, sortFor,
|
|
Artist (..), Image (..), Link (..), Update (..),
|
|
GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
|
|
IndexInfo (..),
|
|
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
|
|
NoThumb (..), getThumb, thumbFile, pageFile,
|
|
-- ** Reexports
|
|
Date (..), Day (..), Text)
|
|
where
|
|
|
|
import Date
|
|
import Records
|
|
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Control.Exception
|
|
import Data.Foldable (find)
|
|
import Data.Hashable (Hashable)
|
|
import Data.HashSet (HashSet)
|
|
import qualified Data.HashSet as HashSet
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Maybe (isJust, isNothing)
|
|
import Data.List (nub, sortBy)
|
|
import Data.Ord (comparing)
|
|
import Data.String (IsString)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text
|
|
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
|
|
import qualified Data.YAML as YAML
|
|
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
|
|
|
|
|
|
data Info =
|
|
Info {
|
|
date :: !Date,
|
|
-- | extra sort key after date
|
|
-- e.g. multiple things on the same day might have a,b,c in @sortEx@ to
|
|
-- put them in the right order in the gallery
|
|
sortEx :: !Text,
|
|
updates :: ![Update],
|
|
-- | if false, don't show updated emblem even if @updates@ is non-empty
|
|
showUpdated :: !Bool,
|
|
title :: !Text,
|
|
artist :: !(Maybe Artist), -- nothing = me, obv
|
|
nsfwOnly :: !Bool,
|
|
tags :: ![Text],
|
|
nsfwTags :: ![Text],
|
|
desc :: !(Maybe Text),
|
|
nsfwDesc :: !(Maybe Text),
|
|
bg :: !(Maybe Text),
|
|
images :: ![Image],
|
|
thumb' :: !(Maybe FilePath),
|
|
links :: ![Link],
|
|
extras :: ![FilePath]
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data Artist =
|
|
Artist {
|
|
name :: !Text,
|
|
url :: !(Maybe Text)
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data Image =
|
|
Image {
|
|
label :: !Text,
|
|
path :: !FilePath,
|
|
download :: !(Maybe FilePath),
|
|
nsfw :: !Bool,
|
|
warning :: !(Maybe Text)
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data Link =
|
|
Link {
|
|
title :: !Text,
|
|
url :: !Text,
|
|
nsfw :: !Bool
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data Update =
|
|
Update {
|
|
date :: !Date,
|
|
desc :: !Text,
|
|
nsfw :: !Bool
|
|
}
|
|
deriving (Eq, Ord, Show)
|
|
|
|
instance HasField "sfw" Image Bool where getField = not . #nsfw
|
|
instance HasField "sfw" Link Bool where getField = not . #nsfw
|
|
instance HasField "sfw" Update Bool where getField = not . #nsfw
|
|
|
|
instance HasField "sfwImages" Info [Image] where
|
|
getField = filter #sfw . #images
|
|
instance HasField "nsfwImages" Info [Image] where
|
|
getField = filter #nsfw . #images
|
|
instance HasField "allNsfw" Info Bool where getField = null . #sfwImages
|
|
instance HasField "allSfw" Info Bool where getField = null . #nsfwImages
|
|
instance HasField "anySfw" Info Bool where getField = not . #allNsfw
|
|
instance HasField "anyNsfw" Info Bool where getField = not . #allSfw
|
|
|
|
instance HasField "sfwLinks" Info [Link] where
|
|
getField = filter #sfw . #links
|
|
instance HasField "nsfwLinks" Info [Link] where
|
|
getField = filter #nsfw . #links
|
|
|
|
instance HasField "sfwUpdates" Info [Update] where
|
|
getField = filter #sfw . #updates
|
|
instance HasField "nsfwUpdates" Info [Update] where
|
|
getField = filter #nsfw . #updates
|
|
|
|
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
|
|
|
|
instance HasField "latestDate" Info (Bool -> Date) where
|
|
getField info@(Info {date}) nsfw =
|
|
maximum $ date : map #date (updatesFor nsfw info)
|
|
|
|
instance HasField "latestYear" Info (Bool -> Int) where
|
|
getField info nsfw = #year $ #latestDate info nsfw
|
|
|
|
|
|
instance HasField "updated" Info (Bool -> Bool) where
|
|
getField (Info {updates, showUpdated}) nsfw = showUpdated && updated
|
|
where updated = if nsfw then not $ null updates else any #sfw updates
|
|
|
|
descFor :: Bool -> Info -> Maybe Text
|
|
descFor nsfw (Info {desc, nsfwDesc}) = desc <> (guard nsfw *> nsfwDesc)
|
|
|
|
tagsFor :: Bool -> Info -> [Text]
|
|
tagsFor nsfw i = if nsfw then nub (#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
|
|
|
|
updatesFor :: Bool -> Info -> [Update]
|
|
updatesFor nsfw = if nsfw then #updates else #sfwUpdates
|
|
|
|
compareFor :: Bool -> Info -> Info -> Ordering
|
|
compareFor nsfw = comparing \i -> (#latestDate i nsfw, #sortEx i, #title i)
|
|
|
|
sortFor :: Bool -> [Info] -> [Info]
|
|
sortFor = sortBy . compareFor
|
|
|
|
|
|
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
|
|
|
|
|
|
instance FromYAML Info where
|
|
parseYAML = YAML.withMap "info" \m ->
|
|
Info <$> m .: "date"
|
|
<*> m .:? "sort" .!= ""
|
|
<*> (maybe [] getUL <$> m .:? "updates")
|
|
<*> m .:? "show-updated" .!= True
|
|
<*> m .: "title"
|
|
<*> m .:? "artist"
|
|
<*> m .:? "nsfw-only" .!= False
|
|
<*> m .:? "tags" .!= []
|
|
<*> m .:? "nsfw-tags" .!= []
|
|
<*> m .:? "desc"
|
|
<*> m .:? "nsfw-desc"
|
|
<*> m .:? "bg"
|
|
<*> (m .: "images" >>= imageList)
|
|
<*> m .:? "thumb"
|
|
<*> m .:? "links" .!= []
|
|
<*> m .:? "extras" .!= []
|
|
|
|
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
|
|
|
|
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) ->
|
|
pure $ Image {label = pathToLabel path, path, download = Nothing,
|
|
nsfw = False, warning = Nothing}
|
|
asObj = YAML.withMap "image info" \m -> do
|
|
path <- m .: "path"
|
|
download <- m .:? "download"
|
|
nsfw <- m .:? "nsfw" .!= False
|
|
warning <- m .:? "warning"
|
|
pure $ Image {label = pathToLabel path, path, download, nsfw, warning}
|
|
pathToLabel = Text.pack . dashToSpace . takeBaseName
|
|
dashToSpace = map \case '-' -> ' '; c -> c
|
|
|
|
instance FromYAML Link where
|
|
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}
|
|
|
|
newtype UpdateList = UL {getUL :: [Update]}
|
|
|
|
instance FromYAML UpdateList where
|
|
parseYAML y = do
|
|
pairs <- YAML.withMap "updates" (pure . Map.toList) y
|
|
UL <$> traverse asEither pairs
|
|
where
|
|
asEither (date', rest) = do
|
|
date <- parseYAML date'
|
|
asDesc date rest <|> asObj date rest
|
|
asDesc date = YAML.withStr "desc" \desc ->
|
|
pure $ Update {date, desc, nsfw = False}
|
|
asObj date = YAML.withMap "update info" \m -> do
|
|
desc <- m .: "desc"
|
|
nsfw <- m .:? "nsfw" .!= False
|
|
pure $ Update {date, desc, nsfw}
|
|
|
|
|
|
data GalleryInfo =
|
|
GalleryInfo {
|
|
title :: !Text,
|
|
desc :: !Text,
|
|
prefix :: !FilePath,
|
|
filters :: !GalleryFilters,
|
|
hidden :: !(HashSet Text) -- ^ tags to initially hide
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
instance HasField "nsfw" GalleryInfo Bool where
|
|
getField g = #nsfw (#filters g) /= NoNsfw
|
|
|
|
data GalleryFilters =
|
|
GalleryFilters {
|
|
nsfw :: !NsfwFilter,
|
|
artist :: !ArtistFilter,
|
|
require, exclude :: !(HashSet Text)
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data NsfwFilter = NoNsfw | OnlyNsfw | AllN deriving (Eq, Show)
|
|
|
|
readNsfwFilter :: (IsString str, Eq str, Alternative f) => str -> f NsfwFilter
|
|
readNsfwFilter "no" = pure NoNsfw
|
|
readNsfwFilter "only" = pure OnlyNsfw
|
|
readNsfwFilter "all" = pure AllN
|
|
readNsfwFilter _ = empty
|
|
|
|
matchNsfw :: NsfwFilter -> Info -> Bool
|
|
matchNsfw NoNsfw i = #anySfw i && not (#nsfwOnly i)
|
|
matchNsfw OnlyNsfw i = #anyNsfw i
|
|
matchNsfw AllN _ = True
|
|
|
|
instance FromYAML NsfwFilter where
|
|
parseYAML = YAML.withStr "nsfw filter" readNsfwFilter
|
|
|
|
|
|
data ArtistFilter = Me | NotMe | AllA deriving (Eq, Show)
|
|
|
|
readArtistFilter :: (IsString str, Eq str, Alternative f)
|
|
=> str -> f ArtistFilter
|
|
readArtistFilter "me" = pure Me
|
|
readArtistFilter "not-me" = pure NotMe
|
|
readArtistFilter "all" = pure AllA
|
|
readArtistFilter _ = empty
|
|
|
|
matchArtist :: ArtistFilter -> Info -> Bool
|
|
matchArtist Me = #mine
|
|
matchArtist NotMe = #notMine
|
|
matchArtist AllA = const True
|
|
|
|
noFilters :: GalleryFilters
|
|
noFilters =
|
|
GalleryFilters {nsfw = AllN, artist = AllA, require = [], exclude = []}
|
|
|
|
matchFilters :: GalleryFilters -> Info -> Bool
|
|
matchFilters (GalleryFilters {nsfw, artist, require, exclude}) i =
|
|
matchNsfw nsfw i && matchArtist artist i &&
|
|
all (\t -> HashSet.member t tags) require &&
|
|
all (\t -> not $ HashSet.member t tags) exclude
|
|
where tags = HashSet.fromList $ #tags i
|
|
|
|
|
|
instance FromYAML GalleryInfo where
|
|
parseYAML = YAML.withMap "gallery info" \m ->
|
|
GalleryInfo <$> m .: "title"
|
|
<*> m .: "desc"
|
|
<*> m .: "prefix"
|
|
<*> m .:? "filters" .!= noFilters
|
|
<*> m .:? "hidden" .!= mempty
|
|
|
|
instance FromYAML GalleryFilters where
|
|
parseYAML = YAML.withMap "gallery filters" \m ->
|
|
GalleryFilters <$> m .:? "nsfw" .!= AllN
|
|
<*> m .:? "artist" .!= AllA
|
|
<*> m .:? "require" .!= []
|
|
<*> m .:? "exclude" .!= []
|
|
|
|
instance FromYAML ArtistFilter where
|
|
parseYAML = YAML.withStr "artist filter" readArtistFilter
|
|
|
|
|
|
data IndexInfo =
|
|
IndexInfo {
|
|
title :: !Text,
|
|
desc :: !Text,
|
|
galleries :: ![GalleryInfo],
|
|
links :: ![Link],
|
|
footer :: !(Maybe Text)
|
|
}
|
|
deriving Show
|
|
|
|
instance FromYAML IndexInfo where
|
|
parseYAML = YAML.withMap "index info" \m ->
|
|
IndexInfo <$> m .: "title"
|
|
<*> m .: "desc"
|
|
<*> m .:? "galleries" .!= []
|
|
<*> m .:? "links" .!= []
|
|
<*> m .:? "footer"
|
|
|
|
|
|
data Pair a b = Pair !a !b
|
|
|
|
instance (FromYAML a, FromYAML b) => FromYAML (Pair a b) where
|
|
parseYAML = YAML.withMap "single-pair map" \m ->
|
|
case Map.toList m of
|
|
[(a, b)] -> Pair <$> parseYAML a <*> parseYAML b
|
|
_ -> fail "expected exactly one pair"
|
|
|
|
|
|
instance {-# OVERLAPPING #-} FromYAML String where
|
|
parseYAML y = Text.unpack <$> parseYAML y
|
|
|
|
instance (FromYAML a, Eq a, Hashable a) => FromYAML (HashSet a) where
|
|
parseYAML y = HashSet.fromList <$> parseYAML y
|