{-# 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