2020-07-09 00:20:09 -04:00
|
|
|
module SinglePage (make) where
|
2020-07-07 23:28:09 -04:00
|
|
|
|
2020-08-11 14:29:54 -04:00
|
|
|
import Info
|
2020-07-15 15:31:46 -04:00
|
|
|
import BuilderQQ
|
2020-07-16 10:07:28 -04:00
|
|
|
import Records ()
|
2020-07-12 22:01:31 -04:00
|
|
|
|
2020-07-11 23:40:14 -04:00
|
|
|
import Control.Exception
|
2020-07-21 19:48:29 -04:00
|
|
|
import Data.Maybe (fromMaybe)
|
2020-07-07 23:28:09 -04:00
|
|
|
import qualified Data.Text as Strict
|
|
|
|
|
import qualified Data.Text.Lazy as Lazy
|
2020-07-31 20:27:24 -04:00
|
|
|
import qualified Data.Time.Calendar as Time
|
2020-08-08 19:22:00 -04:00
|
|
|
import System.FilePath (joinPath, splitPath, (</>))
|
|
|
|
|
import qualified System.Process as Proc
|
|
|
|
|
import Text.Read (readMaybe)
|
2020-07-11 23:40:14 -04:00
|
|
|
|
|
|
|
|
|
2020-07-12 23:02:16 -04:00
|
|
|
-- | e.g. only nsfw images are present for a non-nsfw page
|
2020-07-11 23:40:14 -04:00
|
|
|
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)"
|
2020-07-07 23:28:09 -04:00
|
|
|
|
|
|
|
|
|
2020-08-11 14:29:54 -04:00
|
|
|
make :: Text -- ^ website root
|
|
|
|
|
-> FilePath -- ^ gallery prefix
|
|
|
|
|
-> Bool -- ^ nsfw?
|
2020-08-08 19:22:00 -04:00
|
|
|
-> FilePath -- ^ data dir
|
|
|
|
|
-> FilePath -- ^ subdir of datadir containing this @info.yaml@
|
|
|
|
|
-> Info -> IO Lazy.Text
|
2020-08-11 14:29:54 -04:00
|
|
|
make root prefix nsfw dataDir dir info =
|
|
|
|
|
toLazyText <$> make' root prefix nsfw dataDir dir info
|
2020-07-07 23:28:09 -04:00
|
|
|
|
2020-08-11 14:29:54 -04:00
|
|
|
make' :: Text -> FilePath -> Bool -> FilePath -> FilePath -> Info -> IO Builder
|
|
|
|
|
make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
|
2020-08-08 19:22:00 -04:00
|
|
|
images <- withSizes (dataDir </> dir) $ imagesFor nsfw info
|
|
|
|
|
|
|
|
|
|
let undir = joinPath (replicate (length (splitPath dir)) "..")
|
|
|
|
|
|
|
|
|
|
let artistTag = ifJust artist makeArtist
|
|
|
|
|
|
|
|
|
|
let formattedDate = formatDate date
|
|
|
|
|
|
|
|
|
|
let buttonBar = makeButtonBar title images
|
|
|
|
|
let (image0@(Image {path = path0, download = download0'}),
|
|
|
|
|
Size {width = width0, height = height0})
|
|
|
|
|
= head images
|
|
|
|
|
let download0 = fromMaybe 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
|
|
|
|
|
|
2020-08-30 13:13:40 -04:00
|
|
|
let makePrefetch (Image {path}) = [b|<link rel=prefetch href=$path>|]
|
2020-08-08 19:22:00 -04:00
|
|
|
let prefetches = map (makePrefetch . #first) $ tail images
|
|
|
|
|
|
|
|
|
|
let warning' = ifJust (#warning image0) \w -> [b|@4
|
|
|
|
|
<figcaption id=cw aria-role=button tabindex=0>
|
2020-08-30 13:13:40 -04:00
|
|
|
<span id=cw-text>cw: <b>$w</b></span>
|
2020-08-08 19:22:00 -04:00
|
|
|
</figcaption>
|
2020-08-09 23:42:18 -04:00
|
|
|
|]
|
|
|
|
|
|
|
|
|
|
let bgStyle = ifJust bg \col -> [b|@0
|
2020-08-30 13:13:40 -04:00
|
|
|
<style> #mainfig { background: $col; } </style>
|
2020-08-09 23:42:18 -04:00
|
|
|
|]
|
2020-08-08 19:22:00 -04:00
|
|
|
|
2020-08-30 13:13:40 -04:00
|
|
|
let url = [b|$root/$prefix/$dir|]
|
2020-08-11 14:29:54 -04:00
|
|
|
let desc = case artist of
|
2020-08-30 13:13:40 -04:00
|
|
|
Just (Artist {name}) -> [b|by $name|]
|
2020-08-11 14:29:54 -04:00
|
|
|
Nothing -> "by niss"
|
|
|
|
|
let thumb = getThumb "" info
|
|
|
|
|
|
2020-08-08 19:22:00 -04:00
|
|
|
pure [b|@0
|
2020-07-12 22:01:31 -04:00
|
|
|
<!DOCTYPE html>
|
|
|
|
|
<html lang=en>
|
|
|
|
|
<meta charset=utf-8>
|
2020-08-04 12:59:09 -04:00
|
|
|
<meta name=viewport content="width=1200,viewport-fit=cover">
|
2020-08-04 17:12:58 -04:00
|
|
|
<link rel=stylesheet href=/style/shiny/single.css>
|
2020-08-04 18:52:56 -04:00
|
|
|
<link rel=icon href=/style/niss.svg>
|
2020-07-17 06:29:13 -04:00
|
|
|
|
2020-08-11 14:29:54 -04:00
|
|
|
<meta property=og:type content=og:website>
|
2020-08-30 13:13:40 -04:00
|
|
|
<meta property=og:title content="$title">
|
|
|
|
|
<meta property=og:site_name content="$title">
|
2020-08-11 14:29:54 -04:00
|
|
|
<meta property=og:description content="$desc">
|
2020-08-30 13:13:40 -04:00
|
|
|
<meta property=og:image content="$url/$thumb">
|
2020-08-11 14:29:54 -04:00
|
|
|
<meta property=og:url content="$url">
|
|
|
|
|
<meta name=twitter:site content=@gec_ko_>
|
|
|
|
|
<meta name=twitter:card content=summary>
|
|
|
|
|
|
2020-08-04 13:14:12 -04:00
|
|
|
<script src=/script/single.js></script>
|
2020-08-09 23:42:18 -04:00
|
|
|
$bgStyle
|
2020-08-03 13:32:40 -04:00
|
|
|
|
2020-07-25 07:59:04 -04:00
|
|
|
$0.prefetches
|
|
|
|
|
|
2020-08-30 13:13:40 -04:00
|
|
|
<title>$title</title>
|
2020-07-12 22:01:31 -04:00
|
|
|
|
|
|
|
|
<header>
|
2020-08-30 13:13:40 -04:00
|
|
|
<h1>$title</h1>
|
2020-07-14 00:51:46 -04:00
|
|
|
$artistTag
|
2020-07-19 12:03:24 -04:00
|
|
|
<h2 id=date class="right corner">$formattedDate</h2>
|
2020-07-12 22:01:31 -04:00
|
|
|
</header>
|
|
|
|
|
|
2020-08-03 13:32:40 -04:00
|
|
|
$buttonBar
|
2020-07-17 06:29:13 -04:00
|
|
|
|
2020-07-12 22:01:31 -04:00
|
|
|
<main>
|
2020-08-30 13:13:40 -04:00
|
|
|
<figure id=mainfig data-width=$width0 data-height=$height0>
|
2020-07-17 06:29:13 -04:00
|
|
|
$warning'
|
2020-08-30 13:13:40 -04:00
|
|
|
<a id=mainlink href="$download0" title="download full version">
|
|
|
|
|
<img id=mainimg src="$path0'" alt="">
|
2020-07-17 06:29:13 -04:00
|
|
|
</a>
|
|
|
|
|
</figure>
|
2020-07-12 22:01:31 -04:00
|
|
|
|
2020-08-04 12:26:36 -04:00
|
|
|
<div id=info>
|
2020-07-17 06:29:13 -04:00
|
|
|
$descSection
|
2020-07-12 22:01:31 -04:00
|
|
|
|
2020-07-17 06:29:13 -04:00
|
|
|
$tagsList
|
2020-07-12 22:01:31 -04:00
|
|
|
|
2020-07-17 06:29:13 -04:00
|
|
|
$linksList
|
2020-08-04 12:26:36 -04:00
|
|
|
</div>
|
2020-07-12 22:01:31 -04:00
|
|
|
</main>
|
|
|
|
|
|
|
|
|
|
<footer>
|
2020-08-30 13:13:40 -04:00
|
|
|
<a href=$undir>back to gallery</a>
|
2020-07-12 22:01:31 -04:00
|
|
|
</footer>
|
|
|
|
|
|]
|
2020-07-17 06:29:13 -04:00
|
|
|
|
2020-07-14 00:51:46 -04:00
|
|
|
makeArtist :: Artist -> Builder
|
|
|
|
|
makeArtist (Artist {name, url}) =
|
2020-07-19 12:03:24 -04:00
|
|
|
[b|<h2 id=artist class="left corner">by $artistLink</h2>|]
|
2020-07-14 00:51:46 -04:00
|
|
|
where
|
|
|
|
|
artistLink = case url of
|
2020-08-30 13:13:40 -04:00
|
|
|
Just u -> [b|<a href="$u">$name</a>|]
|
|
|
|
|
Nothing -> [b|$name|]
|
2020-07-14 00:51:46 -04:00
|
|
|
|
2020-08-08 19:20:34 -04:00
|
|
|
makeDesc :: Maybe Strict.Text -> Builder
|
|
|
|
|
makeDesc mdesc = ifJust mdesc \desc -> [b|@4
|
2020-08-04 12:58:40 -04:00
|
|
|
<section id=desc class=info-section>
|
2020-08-03 13:36:48 -04:00
|
|
|
<h2>about</h2>
|
|
|
|
|
<div>
|
2020-08-30 13:13:40 -04:00
|
|
|
$8.desc
|
2020-08-03 13:36:48 -04:00
|
|
|
</div>
|
|
|
|
|
</section>
|
2020-07-12 22:01:31 -04:00
|
|
|
|]
|
2020-07-07 23:28:09 -04:00
|
|
|
|
2020-08-08 19:22:00 -04:00
|
|
|
makeButtonBar :: Strict.Text -> [(Image, Size)] -> Builder
|
2020-07-25 07:58:53 -04:00
|
|
|
makeButtonBar title images =
|
2020-07-12 22:01:31 -04:00
|
|
|
case length images of
|
|
|
|
|
0 -> throw $ NoEligibleImages title
|
|
|
|
|
1 -> ""
|
2020-08-03 13:32:40 -04:00
|
|
|
_ -> [b|@0
|
2020-08-04 12:26:36 -04:00
|
|
|
<nav id=alts aria-label="alternate versions">
|
2020-08-04 12:58:40 -04:00
|
|
|
<ul class="buttonbar bb-choice">
|
2020-08-03 13:32:40 -04:00
|
|
|
$4.alts
|
2020-07-12 22:01:31 -04:00
|
|
|
</ul>
|
|
|
|
|
</nav>
|
|
|
|
|
|]
|
2020-08-08 19:22:00 -04:00
|
|
|
where alts = map (\(i, (im, sz)) -> altButton i im sz) $ zip [0..] images
|
2020-07-09 15:48:29 -04:00
|
|
|
|
2020-08-08 19:22:00 -04:00
|
|
|
altButton :: Int -> Image -> Size -> Builder
|
|
|
|
|
altButton i (Image {label, path, nsfw, warning}) (Size {width, height}) = [b|@4
|
2020-07-12 22:01:31 -04:00
|
|
|
<li$nsfwClass>
|
2020-08-30 13:13:40 -04:00
|
|
|
<input type=radio$checked name=variant id="$idLabel" value="$path'"
|
|
|
|
|
data-link="$path"$warning'
|
|
|
|
|
data-width=$width data-height=$height>
|
|
|
|
|
<label for="$idLabel"$nsfwLabelClass>$label</label>
|
2020-07-12 22:01:31 -04:00
|
|
|
|]
|
2020-07-07 23:28:09 -04:00
|
|
|
where
|
2020-08-30 13:13:40 -04:00
|
|
|
nsfwClass = if nsfw then [b| class=nsfw|] else ""
|
|
|
|
|
nsfwLabelClass = if nsfw then [b| class=nsfw-label|] else ""
|
|
|
|
|
checked = if i == 0 then [b| checked|] else ""
|
2020-08-04 12:58:40 -04:00
|
|
|
idLabel = escId label
|
|
|
|
|
path' = pageFile path
|
2020-09-13 20:33:27 -04:00
|
|
|
warning' = ifJust warning \(escAttr -> w) -> [b| data-warning="$w"|]
|
2020-07-07 23:28:09 -04:00
|
|
|
|
2020-08-04 13:05:20 -04:00
|
|
|
makeTags :: FilePath -> [Strict.Text] -> Builder
|
|
|
|
|
makeTags undir tags =
|
2020-07-17 06:29:13 -04:00
|
|
|
if null tags then "" else [b|@4
|
2020-08-04 12:26:36 -04:00
|
|
|
<nav id=tags class=info-section>
|
2020-07-12 22:01:31 -04:00
|
|
|
<h2>tags</h2>
|
2020-08-04 12:58:40 -04:00
|
|
|
<ul class="buttonbar bb-links">
|
2020-07-17 06:29:13 -04:00
|
|
|
$8.tagList
|
2020-07-12 22:01:31 -04:00
|
|
|
</ul>
|
2020-08-04 12:26:36 -04:00
|
|
|
</nav>
|
2020-07-12 22:01:31 -04:00
|
|
|
|]
|
2020-07-11 23:42:31 -04:00
|
|
|
where
|
2020-07-12 22:01:31 -04:00
|
|
|
tagList = map makeTag tags
|
2020-08-30 13:13:40 -04:00
|
|
|
makeTag tag = [b|<li><a href="$undir#require_$tag'">$tag</a>|]
|
2020-08-04 13:05:20 -04:00
|
|
|
where tag' = escId tag
|
2020-07-11 23:42:31 -04:00
|
|
|
|
2020-08-03 13:36:48 -04:00
|
|
|
extLinks :: [Link] -> Builder
|
|
|
|
|
extLinks links =
|
2020-07-17 06:29:13 -04:00
|
|
|
if null links then "" else [b|@4
|
2020-08-04 12:26:36 -04:00
|
|
|
<nav id=links class=info-section>
|
2020-07-12 22:01:31 -04:00
|
|
|
<h2>links</h2>
|
2020-08-04 12:26:36 -04:00
|
|
|
<ul class="buttonbar bb-links">
|
2020-07-17 06:29:13 -04:00
|
|
|
$8.linkList
|
2020-07-12 22:01:31 -04:00
|
|
|
</ul>
|
2020-08-04 12:26:36 -04:00
|
|
|
</nav>
|
2020-07-12 22:01:31 -04:00
|
|
|
|]
|
2020-08-03 13:36:48 -04:00
|
|
|
where linkList = map extLink links
|
2020-07-09 15:48:29 -04:00
|
|
|
|
2020-07-07 23:28:09 -04:00
|
|
|
extLink :: Link -> Builder
|
2020-08-04 12:26:36 -04:00
|
|
|
extLink (Link {title, url}) = [b|@8
|
2020-07-12 22:01:31 -04:00
|
|
|
<li>
|
2020-08-30 13:13:40 -04:00
|
|
|
<a href="$url">
|
|
|
|
|
$title
|
2020-07-12 22:01:31 -04:00
|
|
|
</a>
|
|
|
|
|
|]
|
2020-07-31 20:27:24 -04:00
|
|
|
|
|
|
|
|
formatDate :: Day -> Builder
|
2020-08-30 13:13:40 -04:00
|
|
|
formatDate date = [b|$week $day $month $year|] where
|
2020-07-31 20:27:24 -04:00
|
|
|
(year, month', day') = Time.toGregorian date
|
|
|
|
|
week' = Time.dayOfWeek date
|
|
|
|
|
day = nth day'
|
|
|
|
|
month = Strict.words "january february march april may june july \
|
|
|
|
|
\august september october november december"
|
|
|
|
|
!! (month' - 1)
|
|
|
|
|
week = Strict.words "mon tue wed thu fri sat sun" !! (fromEnum week' - 1)
|
|
|
|
|
|
|
|
|
|
nth :: Int -> Builder
|
2020-08-30 13:13:40 -04:00
|
|
|
nth n = [b|$n$suf|] where
|
|
|
|
|
suf | n >= 10, n <= 19 = [b|th|]
|
|
|
|
|
| n `mod` 10 == 1 = [b|st|]
|
|
|
|
|
| n `mod` 10 == 2 = [b|nd|]
|
|
|
|
|
| n `mod` 10 == 3 = [b|rd|]
|
|
|
|
|
| otherwise = [b|th|]
|
2020-08-08 19:22:00 -04:00
|
|
|
|
|
|
|
|
|
2020-08-12 12:05:47 -04:00
|
|
|
data Size = Size {width, height :: !Int} deriving (Eq, Show)
|
2020-08-08 19:22:00 -04:00
|
|
|
|
|
|
|
|
imageSize :: FilePath -> FilePath -> IO Size
|
|
|
|
|
imageSize dir img = do
|
|
|
|
|
-- "[0]" to get the first frame of an animation
|
|
|
|
|
-- otherwise it prints a pair for each frame
|
|
|
|
|
let filename = (dir </> img) ++ "[0]"
|
|
|
|
|
output <- Proc.readProcess "identify" ["-format", "(%W,%H)", filename] ""
|
|
|
|
|
case readMaybe output of
|
|
|
|
|
Just (width, height) -> pure $ Size {width, height}
|
|
|
|
|
Nothing -> fail $ "couldn't understand identify output:\n" ++ output
|
|
|
|
|
|
|
|
|
|
withSizes :: FilePath -> [Image] -> IO [(Image, Size)]
|
|
|
|
|
withSizes dir = traverse \img -> do
|
|
|
|
|
size <- imageSize dir $ #path img
|
|
|
|
|
pure (img, size)
|
