gallery/make-pages/Info.hs

{-# OPTIONS_GHC -Wno-orphans #-}
module Info
  (Info (..), Artist (..), Image (..), Link (..),
   GalleryInfo (..), GalleryFilters, Who (..),
   readWho, matchWho, matchNsfw, matchFilters,
   -- ** Reexports
   Day (..), Text)
where

import Records

import Control.Applicative
import Data.Foldable (find)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, isNothing)
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time.Calendar (Day (..))
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML
import Text.Read (readMaybe)


data Info =
  Info {
    date        :: !Day,
    title       :: !(Maybe Text),
    artist      :: !(Maybe Artist), -- nothing = me, obv
    warning     :: !(Maybe Text),
    tags        :: ![Text],
    nsfwTags    :: ![Text],
    description :: !(Maybe Text),
    images      :: ![Image],
    thumb'      :: !(Maybe FilePath),
    links       :: ![Link]
  }
  deriving (Eq, Show)

data Artist =
  Artist {
    name :: !Text,
    url  :: !(Maybe Text)
  }
  deriving (Eq, Show)

data Image =
  Image {
    label :: !Text,
    path  :: !FilePath,
    nsfw  :: !Bool
  }
  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 "allNsfw" Info Bool where getField = null . #sfwImages
instance HasField "anySfw" Info Bool where getField = not . #allNsfw

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 FromYAML Info where
  parseYAML = YAML.withMap "info" \m ->
    Info <$> m .:  "date"
         <*> m .:? "title"
         <*> m .:? "artist"
         <*> m .:? "warning"
         <*> m .:? "tags" .!= []
         <*> m .:? "nsfw-tags" .!= []
         <*> m .:? "description"
         <*> m .:  "images"
         <*> m .:? "thumb"
         <*> m .:? "links" .!= []

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 Image where
  parseYAML = labelledOptNsfw Image "path" "path"

instance FromYAML Link where
  parseYAML = labelledOptNsfw Link "url" "url"


data GalleryInfo =
  GalleryInfo {
    prefix   :: !FilePath,
    name     :: !Text,
    filters  :: !GalleryFilters,
    ordering :: !Int -- sorted by @ordering@ on gallery list page
  }
  deriving (Eq, Show)

data GalleryFilters =
  GalleryFilters {
    nsfw :: Maybe Bool,
    who  :: Who
  }
  deriving (Eq, Show)

data Who = Mine | NotMine | All deriving (Eq, Show)


matchNsfw :: Maybe Bool -> Info -> Bool
matchNsfw Nothing     _ = True
matchNsfw (Just nsfw) i = #allNsfw i == nsfw

readWho :: (IsString str, Eq str, Alternative f) => str -> f Who
readWho "mine"     = pure Mine
readWho "not-mine" = pure NotMine
readWho "all"      = pure All
readWho _          = empty

matchWho :: Who -> Info -> Bool
matchWho Mine    = #mine
matchWho NotMine = #notMine
matchWho All     = const True

noFilters :: GalleryFilters
noFilters = GalleryFilters {nsfw = Nothing, who = All}

matchFilters :: GalleryFilters -> Info -> Bool
matchFilters (GalleryFilters {nsfw, who}) i =
  matchNsfw nsfw i && matchWho who i


instance FromYAML GalleryInfo where
  parseYAML = YAML.withMap "gallery info" \m ->
    GalleryInfo <$> m .:  "prefix"
                <*> m .:  "name"
                <*> m .:? "filters"  .!= noFilters
                <*> m .:? "ordering" .!= 0

instance FromYAML GalleryFilters where
  parseYAML = YAML.withMap "gallery filters" \m ->
    GalleryFilters <$> m .:? "nsfw"
                   <*> m .:? "who" .!= All

instance FromYAML Who where parseYAML = YAML.withStr "who" readWho


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"


data OptNsfw a = NoNsfw !a | WithNsfw !a !Bool

appOptNsfw :: (a -> Bool -> b) -> OptNsfw a -> b
appOptNsfw f (NoNsfw   x)   = f x False
appOptNsfw f (WithNsfw x n) = f x n

labelledOptNsfw :: FromYAML a
                => (Text -> a -> Bool -> b)
                -> String -- ^ name in \"expected\" message
                -> Text   -- ^ field name
                -> YAML.Node YAML.Pos -> YAML.Parser b
labelledOptNsfw f name field y = do
  Pair l n' <- parseYAML y
  n <- parseOptNsfw name field n'
  pure $ appOptNsfw (f l) n

parseOptNsfw :: FromYAML a
             => String -- ^ name in \"expected\" message
             -> Text   -- ^ field name
             -> YAML.Node YAML.Pos -> YAML.Parser (OptNsfw a)
parseOptNsfw name field y = yes y <|> no y where
  yes = YAML.withMap (name <> " & nsfw") \m ->
    WithNsfw <$> m .: field
             <*> m .:? "nsfw" .!= False
  no = fmap NoNsfw . parseYAML


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