gallery/make-pages/Info.hs

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