gallery/make-pages/SinglePage.hs

{-# LANGUAGE PatternSynonyms #-}
module SinglePage (make) where

import Date
import Info
import BuilderQQ
import qualified NsfwWarning

import Control.Exception
import Control.Monad
import Data.List (sort, intersperse)
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as Strict
import qualified Data.Text.Lazy as Lazy
import System.FilePath (joinPath, splitPath)
import qualified Data.HashSet as Set
import Data.Traversable
import Data.Semigroup
import Data.List.NonEmpty (toList)


-- | e.g. only nsfw images are present for a non-nsfw page
newtype NoEligibleImages = NoEligibleImages {title :: Strict.Text}
  deriving stock Eq deriving anyclass Exception

instance Show NoEligibleImages where
  show (NoEligibleImages {title}) =
    Strict.unpack title <> ": no images selected\n" <>
    "  (probably a nsfw-only work without --nsfw set)"


make :: Text     -- ^ website root
     -> Text     -- ^ website name
     -> FilePath -- ^ gallery prefix
     -> Bool     -- ^ nsfw?
     -> FilePath -- ^ data dir
     -> FilePath -- ^ subdir of datadir containing this @info.yaml@
     -> Info -> IO Lazy.Text
make root siteName prefix nsfw dataDir dir info =
  toLazyText <$> make' root siteName prefix nsfw dataDir dir info

make' :: Text -> Text -> FilePath -> Bool -> FilePath -> FilePath -> Info
      -> IO Builder
make' root siteName prefix nsfw _dataDir dir
      info@(Info {date, title, artist, bg}) = do
  images <- maybe (throw $ NoEligibleImages title) pure $ imagesFor nsfw info

  let undir = joinPath (replicate (length (splitPath dir)) "..")

  let formattedDate = formatLong date

  let buttonBar = makeButtonBar title $ addIds images

  let image0 :| otherImages = allImages images
  let download0 = fromMaybe (bigFile image0) image0.download
  let path0'    = pageFile image0

  let artistSection = makeArtist artist
  let descSection   = makeDesc $ descFor nsfw info
  let tagsList      = makeTags undir $ tagsFor nsfw info
  let linksList     = extLinks $ linksFor nsfw info
  let updates       = sort $ updatesFor nsfw info
  let updatesList   = makeUpdates updates

  let makePrefetch img = [b|<link rel=prefetch as=image href=$path'>|]
        where path' = bigFile img
  let prefetches = map makePrefetch otherImages

  let makeWarning w = [b|
        <figcaption id=cw aria-role=button tabindex=0>
          <span id=cw-text>$w</span>
        </figcaption>
      |]

  let warning' = ifJust image0.warning makeWarning
  let warningT = makeWarning [b|.|]

  let bgStyle = case bg of
        Default  -> ""
        NoBorder -> [b|
          <style>
            #mainfig {
              background: transparent;
              border: none;
              box-shadow: none;
            }
          </style>
        |]
        Other col -> [b|
          <style> #mainfig { background: $col; } </style>
        |]

  let url = [b|$root/$prefix/$dir|]
  let desc = case artist of
        Just (Artist {name}) -> [b|by $name|]
        Nothing -> "by niss"

  let updateDate = ifJust (last' updates) \(d, _) ->
        let updated = formatLong d in
        [b|<br> <span class=updated>updated $updated</span>|]

  let nsfw'      = NsfwWarning.Single <$ guard nsfw
  let nsfwScript = NsfwWarning.script nsfw'
  let nsfwDialog = NsfwWarning.dialog nsfw'

  let imageMeta = case previewImage info of
        Just (PFull (Image {path})) -> [b|
            <meta property=og:image  content="$url/$path">
            <meta name=twitter:card  content=summary_large_image>
            <meta name=twitter:image content="$url/$path">
          |]
        Just (PThumb path) -> [b|
            <meta property=og:image content="$url/$path">
            <meta name=twitter:card content=summary>
          |]
        Nothing -> throw $ NoThumb dir

  pure [b|
    <!DOCTYPE html>
    <html lang=en>
    <meta charset=utf-8>
    <meta name=viewport content="width=1200,viewport-fit=cover">
    <link rel=stylesheet href=/style/shiny/single.css>
    <link rel=icon href=/style/niss.svg>

    <meta property=og:type content=article>
    <meta property=og:title content="$title">
    <meta property=og:site_name content="$siteName">
    <meta property=og:description content="$desc">
    <meta property=og:url content="$url">
    $imageMeta

    <meta name=robots content='noai,noimageai'>

    <script src=/script/single.js type=module></script>
    $nsfwScript
    $bgStyle

    $prefetches

    <title>$title</title>

    $nsfwDialog

    <div class=page>
      <header>
        <h1>$title</h1>
        <h2 id=date class="right corner">
          $formattedDate $updateDate
        </h2>
        <h2 class="left corner">
          <a href=$undir>back to gallery</a>
        </h2>
      </header>

      $buttonBar

      <main>
        <figure id=mainfig>
          $warning'
          <a id=mainlink href="$download0" title="download full version">
            <img id=mainimg src="$path0'" alt="">
          </a>
        </figure>

        <div id=info>
          $artistSection

          $descSection

          $updatesList

          $linksList

          $tagsList
        </div>
      </main>
    </div>

    <template id=cw-template>
      $warningT
    </template>
  |]

last' :: [a] -> Maybe a
last' xs = if null xs then Nothing else Just $ last xs

makeArtist :: Maybe Artist -> Builder
makeArtist Nothing = ""
makeArtist (Just (Artist {name, url})) = [b|
    <section id=desc class=info-section>
      <h2>by</h2>
      <div>$artistLink</div>
    </section>
  |]
 where
   artistLink = case url of
    Just u  -> [b|<a href="$u">$name</a>|]
    Nothing -> [b|$name|]

makeDesc :: Desc -> Builder
makeDesc NoDesc = ""
makeDesc (TextDesc desc) = [b|
    <section id=desc class=info-section>
      <h2>about</h2>
      <div>
        $desc
      </div>
    </section>
  |]
makeDesc (LongDesc fs) = [b|
    <section id=desc class=info-section>
      $fields
    </section>
  |]
 where
  fields = map makeField fs
  makeField (DescField {name, text}) = [b|
      <h2>$name</h2>
      <div>
        $text
      </div>
    |]


data Inf a = a :> Inf a deriving Functor

headI :: Inf a -> a
headI (x :> _) = x

suffixes :: Inf String
suffixes = "" :> go 0 where
  go :: Int -> Inf String
  go i = show i :> go (i + 1)

filterI :: (a -> Bool) -> Inf a -> Inf a
filterI p (x :> xs) = if p x then x :> filterI p xs else filterI p xs

addIds :: Traversable t => t Image -> t (Image, Text)
addIds = snd . mapAccumL makeId Set.empty where
  makeId used img = (Set.insert newId used, (img, newId)) where
    newId = headI $ filterI (\i -> not $ i `Set.member` used) ids
    ids   = fmap (\i -> toStrictText [b|$label$i|]) suffixes
    label = escId $ img.label


pattern One :: a -> NonEmpty a
pattern One x = x :| []

makeButtonBar :: Strict.Text -> Images' (Image, Text) -> Builder
makeButtonBar title images =
  case images of
    Uncat (One _)          -> ""
    Cat   (One (_, One _)) -> ""
    Uncat imgs             -> makeNav "uncat" $ makeAlts imgs
    Cat   cats
      | all ((== 1) . length . snd) cats ->
          makeButtonBar title $ Uncat $ flatten cats
      | [(_, imgs)] <- cats ->
          makeButtonBar title (Uncat imgs)
      | otherwise ->
          makeNav "cat" $ fmap (uncurry makeCat) cats
 where
  makeNav :: CanBuild b => Text -> b -> Builder
  makeNav cls inner = [b|
     <nav id=alts class=$cls aria-label="alternate versions">
       $inner
       $skipAll
     </nav> |]
  makeCat lbl imgs = [b|
      <section>
        <h3 class=alt-cat>$lbl</h3>
        $alts
      </section> |]
    where alts = makeAlts imgs
  makeAlts imgs = [b|
       <ul class="buttonbar bb-choice">
         $elems
       </ul> |]
    where elems = fmap (uncurry altButton) imgs
  skipAll =
    if any (isJust . (.warning) . fst) images then
      [b|
        <div class=buttonbar id=skipAllDiv>
          <input type=checkbox name=skipAll id=skipAll>
          <label for=skipAll>skip warnings</label>
        </div>
      |]
    else ""

flatten :: NonEmpty (Text, NonEmpty (Image, a)) -> NonEmpty (Image, Text)
flatten =
  addIds . sconcat .
  fmap (\(t, is) -> fmap (\(i, _) -> i {label = t}) is)

altButton :: Image -> Text -> Builder
altButton img i = [b|
  <li$nsfwClass>
    <input type=radio name=variant id="$i" value="$path'"
           data-link="$link"$warning'>
    <label for="$i"$nsfwLabelClass>$label</label>
  |]
 where
  Image {label, nsfw, warning, download} = img
  nsfwClass      = if nsfw then [b| class=nsfw|]       else ""
  nsfwLabelClass = if nsfw then [b| class=nsfw-label|] else ""
  path'          = pageFile img
  link           = fromMaybe (bigFile img) download
  warning'       = ifJust warning \(escAttr -> w) -> [b| data-warning="$w"|]

makeTags :: FilePath -> [Strict.Text] -> Builder
makeTags undir tags =
  if null tags then "" else [b|
    <nav id=tags class=info-section>
      <h2>tags</h2>
      <ul>
        $tagList
      </ul>
    </nav>
  |]
 where
  tagList = map makeTag tags
  makeTag tag = [b|<li><a href="$undir#require_$tag'">$tag</a>|]
    where tag' = escId tag

extLinks :: [Link] -> Builder
extLinks links =
  if null links then "" else [b|
    <nav id=links class=info-section>
      <h2>links</h2>
      <ul>
        $linkList
      </ul>
    </nav>
  |]
  where linkList = map extLink links

extLink :: Link -> Builder
extLink (Link {title, url}) = [b|
    <li>
      <a href="$url">
        $title
      </a>
  |]

makeUpdates :: [(Date, NonEmpty Update)] -> Builder
makeUpdates ups =
  if all (null . snd) ups then "" else [b|
    <section id=updates class=info-section>
      <h2>updates</h2>
      <dl>
        $updateList
      </dl>
    </section>
  |]
 where updateList = fmap (uncurry makeUpdate) ups

makeUpdate :: Date -> NonEmpty Update -> Builder
makeUpdate date ups = [b|
    <dt>$date'
    <dd>$desc
  |] where
  date' = formatSlash date
  desc  = mconcat $ map fromText $ intersperse "; " $ toList $ fmap (.desc) ups