Rhiannon Morris
a8e5adb50d
unlisted posts will still be put in the normal place but not added to the gallery or rss feed
462 lines
14 KiB
Haskell
462 lines
14 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,
|
|
-- ** 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, 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,
|
|
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
|
|
|
|
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" .!= ""
|
|
<*> (m .:? "updates" >>= updateList)
|
|
<*> m .:? "show-updated" .!= True
|
|
<*> m .:? "unlisted" .!= False
|
|
<*> m .: "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 ->
|
|
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
|
|
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
|
|
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
|
|
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 ->
|
|
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"
|
|
|
|
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
|