gallery/make-pages/Info.hs

{-# OPTIONS_GHC -fdefer-typed-holes #-}

{-# OPTIONS_GHC -Wno-orphans #-}
module Info
  (Info (..),
   anySfw, anyNsfw, allSfw, allNsfw,
   allImages, sfwImages, nsfwImages,
   thumb, latestDateFor, latestYearFor,
   sfwLinks, nsfwLinks, sfwUpdates, nsfwUpdates,
   updatesFor, hasUpdatesFor, lastUpdateFor,
   tagsFor, descFor, imagesFor, linksFor,

   CompareKey (..), compareKeyFor, compareFor, sortFor,

   Artist (..), Images' (..), Images, Image (..), Desc (..), DescField (..),

   Link (..), Update (..), Bg (..),

   GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
   readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,

   IndexInfo (..),

   NoThumb (..), getThumb, thumbFile, pageFile, bigFile,
   -- ** Reexports
   Date (..), Day (..), Text, NonEmpty (..))
where

import Date
import GHC.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, catMaybes)
import Data.List (nub, sortBy)
import Data.List.NonEmpty (NonEmpty (..), toList, nonEmpty)
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.Semigroup


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      :: ![(Date, NonEmpty 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           :: !Bg,
    images       :: !Images,
    thumb'       :: !(Maybe FilePath),
    links        :: ![Link],
    extras       :: ![FilePath]
  }
  deriving (Eq, Show)

data Bg = Default | NoBorder | Other !Text
  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),
    resize   :: !Bool
  }
  deriving (Eq, Show)

data Images' a =
    Uncat (NonEmpty a)         -- ^ uncategorised
  | Cat (NonEmpty (Text, NonEmpty 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 {
    desc       :: !Text,
    nsfw       :: !Bool,
    ignoreSort :: !Bool
  }
  deriving (Eq, Ord, Show)

instance HasField "sfw" Image  Bool where getField i = not i.nsfw
instance HasField "sfw" Link   Bool where getField i = not i.nsfw
instance HasField "sfw" Update Bool where getField i = not i.nsfw

allImages :: Images' a -> NonEmpty a
allImages (Uncat is) = is
allImages (Cat cats) = sconcat $ fmap snd cats

filterNE :: (a -> Bool) -> NonEmpty a -> Maybe (NonEmpty a)
filterNE p = nonEmpty . filter p . toList

catMaybesNE :: NonEmpty (Maybe a) -> Maybe (NonEmpty a)
catMaybesNE = nonEmpty . catMaybes . toList

filterImages :: (a -> Bool) -> Images' a -> Maybe (Images' a)
filterImages p (Uncat is) = Uncat <$> filterNE p is
filterImages p (Cat cats) =
  fmap Cat $ catMaybesNE $ fmap (traverse $ filterNE p) cats

sfwImages, nsfwImages :: Info -> Maybe Images
sfwImages  i = filterImages (.sfw)  i.images
nsfwImages i = filterImages (.nsfw) i.images

anySfw, anyNsfw, allSfw, allNsfw :: Info -> Bool
anySfw  = isJust . sfwImages
anyNsfw = isJust . nsfwImages
allSfw  = not . anyNsfw
allNsfw = not . anySfw

sfwLinks, nsfwLinks :: Info -> [Link]
sfwLinks  i = filter (.sfw)  i.links
nsfwLinks i = filter (.nsfw) i.links

updatesWith :: (Update -> Bool) -> Info -> [(Date, NonEmpty Update)]
updatesWith p i = mapMaybe (traverse $ filterNE p) i.updates

updatesFor :: Bool -> Info -> [(Date, NonEmpty Update)]
updatesFor nsfw = updatesWith \u -> nsfw || u.sfw

sfwUpdates, nsfwUpdates :: Info -> [(Date, NonEmpty Update)]
sfwUpdates  = updatesWith (.sfw)
nsfwUpdates = updatesWith (.nsfw)

lastUpdateFor :: Bool -> Info -> Maybe Date
lastUpdateFor nsfw info = case updatesFor nsfw info of
  [] -> Nothing
  us -> Just $ fst $ last us


thumb :: Info -> Maybe FilePath
thumb (Info {thumb', images}) =
  thumb' <|> (.path) <$> find (.sfw) (allImages images)

latestDateFor :: Bool -> Info -> Date
latestDateFor nsfw i = maximum $ i.date : mapMaybe relDate (updatesFor nsfw i)
 where
  relDate (date, us) = date <$ guard (not $ null us || any (.ignoreSort) us)

latestYearFor :: Bool -> Info -> Int
latestYearFor nsfw info = (latestDateFor nsfw info).year


hasUpdatesFor :: Bool -> Info -> Bool
hasUpdatesFor i nsfw = not $ null $ updatesFor i nsfw

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 x.name == y.name then
      Just $ x {text = x.text <> y.text} : 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 $ i.tags <> i.nsfwTags else i.tags

imagesFor :: Bool -> Info -> Maybe Images
imagesFor nsfw i = if nsfw then Just i.images else sfwImages i

linksFor :: Bool -> Info -> [Link]
linksFor nsfw i = if nsfw then i.links else sfwLinks i

data CompareKey = MkCompareKey !Date !Text !Text
  deriving (Eq, Ord)

compareKeyFor :: Bool -> Info -> CompareKey
compareKeyFor nsfw i = MkCompareKey (latestDateFor nsfw i) i.sortEx i.title

compareFor :: Bool -> Info -> Info -> Ordering
compareFor nsfw = comparing $ compareKeyFor nsfw

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"

canResize :: Image -> Bool
canResize i = i.resize && takeExtension i.path /= ".gif"

pageFile :: Image -> FilePath
pageFile img =
  if canResize img then addSuffix "_med" img.path else img.path

bigFile :: Image -> FilePath
bigFile img =
  if canResize img then addSuffix "_big" img.path else img.path

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"        .!= Default
         <*>  m .:  "images"
         <*>  m .:? "thumb"
         <*>  m .:? "links"  .!= []
         <*>  m .:? "extras" .!= []

instance FromYAML Bg where
  parseYAML y =
        YAML.withNull "default value" (pure Default) y
    <|> YAML.withStr "css <image> or \"noborder\""
          (\str -> pure if str == "noborder" then NoBorder else Other str) y

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

parseYAMLNE :: FromYAML a => YAML.Node YAML.Pos -> YAML.Parser (NonEmpty a)
parseYAMLNE = YAML.withSeq "non-empty sequence" \ys ->
  case nonEmpty ys of
    Just ys' -> traverse YAML.parseYAML ys'
    Nothing  -> fail "expected non-empty sequence"

imageList :: YAML.Node YAML.Pos -> YAML.Parser (NonEmpty Image)
imageList y = pure <$> unlabelledImage y <|> parseYAMLNE 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, resize = True}
  asObj = YAML.withMap "image info" \m -> do
    checkKeys m ["path", "download", "nsfw", "warning", "resize"]
    path     <- m .:  "path"
    download <- m .:? "download"
    nsfw     <- m .:? "nsfw" .!= False
    warning  <- m .:? "warning"
    resize   <- m .:? "resize" .!= True
    let label = fromMaybe (pathToLabel path) label'
    pure $ Image {label, path, download, nsfw, warning, resize}
  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 (nonEmpty -> Just xs) =
      traverse (withPairM \label -> fmap (label,) . imageList) xs
    fromPairs _ = YAML.typeMismatch "non-empty list" y

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 [(Date, NonEmpty Update)]
updateList =
  maybe (pure []) $ YAML.withMap "updates" $
    nonEmptys <=< traverse bodies . Map.toList
 where
  bodies (date', rest) = (,) <$> parseYAML date' <*> body rest
  body b =
        return <$> body1 b
    <|> YAML.withSeq "update list" (traverse body1) b
  body1 b = asDesc b <|> asObj b
  asDesc = YAML.withStr "desc" \desc ->
    pure $ Update {desc, nsfw = False, ignoreSort = False}
  asObj = 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 {desc, nsfw, ignoreSort}
  nonEmptys = traverse $ traverse $
    maybe (fail "expected non-empty list") pure . nonEmpty


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 = g.filters.nsfw /= 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 i.nsfwOnly
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    i = isNothing i.artist
matchArtist NotMe i = isJust    i.artist
matchArtist AllA  _ = 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 i.tags


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