gallery/make-pages/SinglePage.hs

module SinglePage (make) where

import Date
import Info
import BuilderQQ
import Records ()
import qualified NsfwWarning

import Control.Exception
import Control.Monad
import Data.List (sort, intersperse)
import Data.Maybe (fromMaybe, isNothing, 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


-- | 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
  let images = imagesFor nsfw info

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

  let artistTag = ifJust artist makeArtist

  let formattedDate = formatLong date

  let buttonBar = makeButtonBar title $ addIds images

  let allImages = #all images
  let image0@(Image {path = path0, download = download0'}) = head allImages
  let otherImages = tail allImages

  let download0 = fromMaybe (bigFile path0) download0'
  let path0'    = pageFile path0

  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 (Image {path}) = [b|<link rel=prefetch href=$path'>|]
        where path' = bigFile path
  let prefetches = map makePrefetch otherImages

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

  let defWarning = [b|
          i forgot to add a cw, sorry! <br>
          if you can let me know i'd appreciate it
        |]
  let warning'
        | Just w <- #warning image0 = makeWarning w
        | #nsfw image0              = makeWarning defWarning
        | otherwise                 = mempty
  let warningT = makeWarning [b|.|]

  let bgStyle = case bg of
        Default  -> ""
        NoBorder -> [b|@0
          <style>
            #mainfig {
              background: transparent;
              border: none;
              box-shadow: none;
            }
          </style>
        |]
        Other col -> [b|@0
          <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 thumb = getThumb "" info

  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 =
        if #sfw image0 && isNothing (#warning image0) then [b|@0
          <meta property=og:image  content="$url/$path0'">
          <meta name=twitter:card  content=summary_large_image>
          <meta name=twitter:image content="$url/$path0'">
        |] else [b|@0
          <meta property=og:image content="$url/$thumb">
          <meta name=twitter:card content=summary>
        |]

  pure [b|@0
    <!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">
    <meta name=twitter:site content=@2_gecs>
    $imageMeta

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

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

    $0.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">
          $artistTag
          <a href=$undir>back to gallery</a>
        </h2>
      </header>

      $2.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>
          $6.descSection

          $6.updatesList

          $6.linksList

          $6.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 :: Artist -> Builder
makeArtist (Artist {name, url}) =
  [b|by $artistLink <br>|]
 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|@0
    <section id=desc class=info-section>
      <h2>about</h2>
      <div>
        $4.desc
      </div>
    </section>
  |]
makeDesc (LongDesc fs) = [b|@0
    <section id=desc class=info-section>
      $2.fields
    </section>
  |]
 where
  fields = map makeField fs
  makeField (DescField {name, text}) = [b|@0
      <h2>$name</h2>
      <div>
        $4.text
      </div>
    |]

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 = head $ filter (\i -> not $ i `Set.member` used) ids
    ids = [toStrictText [b|$label$i|] | i <- "" : map show [0::Int ..]]
    label = escId $ #label img

makeButtonBar :: Strict.Text -> Images' (Image, Text) -> Builder
makeButtonBar title images =
  case images of
    Uncat []        -> throw $ NoEligibleImages title
    Uncat [_]       -> ""
    Cat   [(_,[_])] -> ""
    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"   $ map (uncurry makeCat) cats
 where
  makeNav (cls :: Text) inner = [b|@0
     <nav id=alts class=$cls aria-label="alternate versions">
       $2.inner
       $2.skipAll
     </nav> |]
  makeCat lbl imgs = [b|@0
      <section>
        <h3 class=alt-cat>$lbl</h3>
        $0.alts
      </section> |]
    where alts = makeAlts imgs
  makeAlts imgs = [b|@0
       <ul class="buttonbar bb-choice">
         $2.elems
       </ul> |]
    where elems = map (uncurry altButton) imgs
  skipAll =
    if any (isJust . #warning . fst) images then
      [b|@0
        <div class=buttonbar id=skipAllDiv>
          <input type=checkbox name=skipAll id=skipAll>
          <label for=skipAll>skip warnings</label>
        </div>
      |]
    else
      ""

flatten :: [(Text, [(Image, a)])] -> [(Image, Text)]
flatten cats =
  addIds [(img {label = cat}) | (cat, is) <- cats, (img, _) <- is]

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

makeTags :: FilePath -> [Strict.Text] -> Builder
makeTags undir tags =
  if null tags then "" else [b|@0
    <nav id=tags class=info-section>
      <h2>tags</h2>
      <ul>
        $4.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|@0
    <nav id=links class=info-section>
      <h2>links</h2>
      <ul>
        $4.linkList
      </ul>
    </nav>
  |]
  where linkList = map extLink links

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

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

makeUpdate :: Date -> [Update] -> Builder
makeUpdate _    []  = ""
makeUpdate date ups = [b|@8
    <dt>$date'
    <dd>$desc
  |] where
  date' = formatSlash date
  desc  = mconcat $ map fromText $ intersperse "; " $ map #desc ups