gallery/make-pages/Info.hs

494 lines
16 KiB
Haskell

{-# OPTIONS_GHC -Wno-orphans #-}
module Info
(Info (..),
tagsFor, descFor, imagesFor, linksFor, updatesFor, compareFor, sortFor,
Artist (..), Images' (..), Images, Image (..), Desc (..), DescField (..),
Link (..), Update (..),
GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
IndexInfo (..),
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
NoThumb (..), getThumb, thumbFile, pageFile, bigFile,
-- ** 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.Set (Set, (\\))
import qualified Data.Set as Set
import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe)
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)
import Data.Bifunctor (second)
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,
-- | hide from gallery view
unlisted :: !Bool,
title :: !Text,
galleryTitle :: !(Maybe Text),
artist :: !(Maybe Artist), -- nothing = me, obv
nsfwOnly :: !Bool,
tags :: ![Text],
nsfwTags :: ![Text],
desc :: !Desc,
nsfwDesc :: !Desc,
bg :: !(Maybe Text),
images :: !Images,
thumb' :: !(Maybe FilePath),
links :: ![Link],
extras :: ![FilePath]
}
deriving (Eq, Show)
data Desc =
NoDesc
| TextDesc !Text
| LongDesc ![DescField]
deriving (Eq, Show)
data DescField = DescField {name, text :: !Text}
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 Images' a =
Uncat [a] -- ^ uncategorised
| Cat [(Text, [a])] -- ^ categorised
deriving (Eq, Show, Functor, Foldable, Traversable)
type Images = Images' Image
data Link =
Link {
title :: !Text,
url :: !Text,
nsfw :: !Bool
}
deriving (Eq, Show)
data Update =
Update {
date :: !Date,
desc :: !Text,
nsfw :: !Bool,
ignoreSort :: !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 "all" (Images' a) [a] where
getField (Uncat is) = is
getField (Cat cats) = foldMap snd cats
filterImages :: (a -> Bool) -> Images' a -> Images' a
filterImages p (Uncat is) = Uncat $ filter p is
filterImages p (Cat cats) =
Cat $ filter (not . null . snd) $ map (second $ filter p) cats
instance HasField "sfwImages" Info Images where
getField = filterImages #sfw . #images
instance HasField "nsfwImages" Info Images where
getField = filterImages #nsfw . #images
instance HasField "allNsfw" Info Bool where getField = null . #all . #sfwImages
instance HasField "allSfw" Info Bool where getField = null . #all . #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 (#all 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=date}) nsfw =
maximum $ date : mapMaybe relDate (updatesFor nsfw info)
where relDate (Update {date, ignoreSort}) = date <$ guard (not ignoreSort)
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
defDescKey :: Text
defDescKey = "about"
instance Semigroup Desc where
NoDesc <> d2 = d2
d1 <> NoDesc = d1
(TextDesc t1) <> (TextDesc t2) = TextDesc $ t1 <> t2
(LongDesc m1) <> (TextDesc t2) = LongDesc $ m1 <> [DescField defDescKey t2]
(TextDesc t1) <> (LongDesc m2) = LongDesc $ [DescField defDescKey t1] <> m2
(LongDesc m1) <> (LongDesc m2) = LongDesc $ merge m1 m2
merge :: [DescField] -> [DescField] -> [DescField]
merge fs1 fs2 = go fs1 [] fs2 where
go first unused [] = first <> reverse unused
go first unused (x:xs) =
case insert first x of
Just first' -> go first' unused xs
Nothing -> go first (x:unused) xs
insert [] _ = Nothing
insert (x:xs) y =
if #name x == #name y then
Just $ x {text = #text x <> #text y} : xs
else
(x :) <$> insert xs y
instance Monoid Desc where
mempty = NoDesc
mappend = (<>)
instance HasField "exists" Desc Bool where
getField d = d /= NoDesc
descFor :: Bool -> Info -> Desc
descFor nsfw (Info {desc, nsfwDesc}) = if nsfw then desc <> nsfwDesc else desc
tagsFor :: Bool -> Info -> [Text]
tagsFor nsfw i = if nsfw then nub (#tags i <> #nsfwTags i) else #tags i
imagesFor :: Bool -> Info -> Images
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
bigFile :: FilePath -> FilePath
bigFile f
| takeExtension f == ".gif" = f
| otherwise = addSuffix "_big" f
addSuffix :: String -> FilePath -> FilePath
addSuffix suf path =
let (pre, ext) = splitExtension path in
pre ++ suf ++ ext
getKeys :: YAML.Mapping YAML.Pos -> YAML.Parser (Set Text)
getKeys = fmap Set.fromList . traverse (YAML.withStr "key" pure) . Map.keys
checkKeys :: YAML.Mapping YAML.Pos -> Set Text -> YAML.Parser ()
checkKeys mapping wanted = do
keys <- getKeys mapping
let unused = Set.toList $ keys \\ wanted
unless (null unused) do
fail $ "unused keys: " <> show unused <> "\n" <>
"expected: " <> show wanted
instance FromYAML Info where
parseYAML = YAML.withMap "info" \m -> do
checkKeys m ["date", "sort", "updates", "show-updated", "unlisted",
"gallery-title", "title", "artist", "nsfw-only", "tags",
"nsfw-tags", "desc", "nsfw-desc", "bg", "images", "thumb",
"links", "extras"]
Info <$> m .: "date"
<*> m .:? "sort" .!= ""
<*> (m .:? "updates" >>= updateList)
<*> m .:? "show-updated" .!= True
<*> m .:? "unlisted" .!= False
<*> m .: "title"
<*> m .:? "gallery-title"
<*> m .:? "artist"
<*> m .:? "nsfw-only" .!= False
<*> m .:? "tags" .!= []
<*> m .:? "nsfw-tags" .!= []
<*> m .:? "desc" .!= NoDesc
<*> m .:? "nsfw-desc" .!= NoDesc
<*> m .:? "bg"
<*> m .: "images"
<*> 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 -> do
checkKeys m ["name", "url"]
Artist <$> m .: "name" <*> m .:? "url"
instance FromYAML Desc where
parseYAML y = textDesc y <|> mapDesc y where
textDesc = YAML.withStr "text" $ pure . TextDesc
mapDesc = fmap LongDesc . parseYAML
instance FromYAML DescField where parseYAML = withPair DescField
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 = withPairM \label -> unlabelledImage' (Just label)
unlabelledImage :: YAML.Node YAML.Pos -> YAML.Parser Image
unlabelledImage = unlabelledImage' Nothing
unlabelledImage' :: Maybe Text -> YAML.Node YAML.Pos -> YAML.Parser Image
unlabelledImage' label' y = asStr y <|> asObj y
where
asStr = YAML.withStr "path" \(Text.unpack -> path) ->
let label = fromMaybe (pathToLabel path) label' in
pure $ Image {label, path, download = Nothing,
nsfw = False, warning = Nothing}
asObj = YAML.withMap "image info" \m -> do
checkKeys m ["path", "download", "nsfw", "warning"]
path <- m .: "path"
download <- m .:? "download"
nsfw <- m .:? "nsfw" .!= False
warning <- m .:? "warning"
let label = fromMaybe (pathToLabel path) label'
pure $ Image {label, path, download, nsfw, warning}
pathToLabel = Text.pack . gapToSpace . takeBaseName
gapToSpace = map \case '-' -> ' '; '_' -> ' '; c -> c
instance FromYAML Images where
parseYAML y = Uncat <$> imageList y
<|> Cat <$> YAML.withSeq "list of categories" fromPairs y
where fromPairs = traverse $ withPairM \label -> fmap (label,) . imageList
instance FromYAML Link where
parseYAML =
withPairM \title rest -> 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
checkKeys m ["url", "nsfw"]
url <- m .: "url"
nsfw <- m .:? "nsfw" .!= False
pure $ Link {title, url, nsfw}
updateList :: Maybe (YAML.Node YAML.Pos) -> YAML.Parser [Update]
updateList =
maybe (pure []) $ YAML.withMap "updates" $ traverse asEither . Map.toList
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, ignoreSort = False}
asObj date = YAML.withMap "update info" \m -> do
checkKeys m ["desc", "nsfw", "ignore-sort"]
desc <- m .: "desc"
nsfw <- m .:? "nsfw" .!= False
ignoreSort <- m .:? "ignore-sort" .!= False
pure $ Update {date, desc, nsfw, ignoreSort}
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 -> do
checkKeys m ["title", "desc", "prefix", "filters", "hidden"]
GalleryInfo <$> m .: "title"
<*> m .: "desc"
<*> m .: "prefix"
<*> m .:? "filters" .!= noFilters
<*> m .:? "hidden" .!= mempty
instance FromYAML GalleryFilters where
parseYAML = YAML.withMap "gallery filters" \m -> do
checkKeys m ["nsfw", "artist", "require", "exclude"]
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 -> do
checkKeys m ["title", "desc", "galleries", "links", "footer"]
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"
withPairM :: (FromYAML a, FromYAML b)
=> (a -> b -> YAML.Parser c)
-> (YAML.Node YAML.Pos -> YAML.Parser c)
withPairM k y = parseYAML y >>= \(Pair a b) -> k a b
withPair :: (FromYAML a, FromYAML b)
=> (a -> b -> c)
-> (YAML.Node YAML.Pos -> YAML.Parser c)
withPair f = withPairM \a b -> pure $ f a b
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