gallery/make-pages/Info.hs

341 lines
10 KiB
Haskell

{-# OPTIONS_GHC -Wno-orphans #-}
module Info
(Info (..), tagsFor, descFor, imagesFor, linksFor,
Artist (..), Image (..), Link (..),
GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
IndexInfo (..),
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
NoThumb (..), getThumb, thumbFile, pageFile,
-- ** Reexports
Day (..), Text)
where
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 Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, isNothing)
import Data.List (nub)
import Data.Ord (comparing)
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time.Calendar (Day (..), toGregorian)
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
import Text.Read (readMaybe)
data Info =
Info {
date :: !Day,
-- 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 :: !(Map Day Text),
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)
instance HasField "sfw" Image Bool where getField = not . #nsfw
instance HasField "sfw" Link 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 "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 "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
instance HasField "latestDate" Info Day where
getField (Info {date, updates}) = maximum (date : Map.keys updates)
instance HasField "latestYear" Info Integer where
getField = #first . toGregorian . #latestDate
instance HasField "updated" Info Bool where getField = not . Map.null . #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
instance Ord Info where
compare = comparing \i -> (#latestDate i, #sortEx i, #title i)
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" .!= []
<*> 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}
data GalleryInfo =
GalleryInfo {
title :: !Text,
desc :: !Text,
prefix :: !FilePath,
filters :: !GalleryFilters,
hidden :: !(HashSet Text) -- ^ tags to initially hide
}
deriving (Eq, Show)
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 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
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