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)
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
data 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 image0@(Image {path = path0, download = download0'}) : otherImages =
        #all images
  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 = "oops i forgot to put one, sorry!<br>\
                   \if you can let me know i'd appreciate it" :: Text
  let warning'
        | Just w <- #warning image0 = makeWarning w
        | #nsfw image0              = makeWarning defWarning
        | otherwise                 = mempty
  let warningT = makeWarning [b|.|]

  let bgStyle = ifJust bg \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'

  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=og:website>
    <meta property=og:title content="$title">
    <meta property=og:site_name content="$siteName">
    <meta property=og:description content="$desc">
    <meta property=og:image content="$url/$thumb">
    <meta property=og:url content="$url">
    <meta name=twitter:site content=@2_gecs>
    <meta name=twitter:card content=summary>

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

    $0.prefetches

    <title>$title</title>

    $nsfwDialog

    <div class=page>
      <header>
        <h1>$title</h1>
        $artistTag
        <h2 id=date class="right corner">
          $formattedDate $updateDate
        </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>

      <footer>
        <a href=$undir>back to gallery</a>
      </footer>
    </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|<h2 id=artist class="left corner">by $artistLink</h2>|]
 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
      </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 (\(img,i) -> altButton img i) imgs

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 class="buttonbar bb-links">
        $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 class="buttonbar bb-links">
        $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