{-# LANGUAGE PatternSynonyms #-}
module SinglePage (make) where
import Date
import Info
import BuilderQQ
import NsfwWarning qualified
import TagTransforms
import Control.Exception
import Control.Monad
import Data.Char (isSpace)
import Data.Foldable
import Data.HashSet qualified as HashSet
import Data.List (sort, intersperse)
import Data.Maybe (fromMaybe, isJust)
import Data.Semigroup
import Data.Text qualified as Strict
import Data.Text.Lazy qualified as Lazy
import Data.Traversable
import System.FilePath (joinPath, splitPath)
-- | 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
-> IndexInfo
-> FilePath -- ^ gallery prefix
-> Bool -- ^ nsfw?
-> FilePath -- ^ data dir
-> FilePath -- ^ subdir of datadir containing this @info.yaml@
-> Info -> IO Lazy.Text
make root iinfo prefix nsfw dataDir dir info =
fmap toLazyText $
make' root iinfo prefix nsfw dataDir dir $
transformInfoTags iinfo.tags info
make' :: Text -> IndexInfo -> FilePath -> Bool -> FilePath -> FilePath -> Info
-> IO Builder
make' root iinfo 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 siteName = iinfo.title
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 tags = tagsFor nsfw info
let tagsList = makeTags undir tags
let linksList = extLinks $ linksFor nsfw info
let updates = sort $ updatesFor nsfw info
let updatesList = makeUpdates updates
let makePrefetch img = [b||]
where path' = bigFile img
let prefetches = map makePrefetch otherImages
let makeWarning w = [b|
$w
|]
let warning' = ifJust image0.warning makeWarning
let warningT = makeWarning [b|.|]
let bgStyle = case bg of
Default -> ""
NoBorder -> [b|
|]
Other col -> [b|
|]
let url = [b|$root/$prefix/$dir|]
let desc = case artist of
Just (Artist {name}) -> [b|by $name|]
Nothing -> "by niss"
let alt = escAttr image0.desc
let updateDate = ifJust (last' updates) \(d, _) ->
let updated = formatLong d in
[b| updated $updated|]
let nsfw' = NsfwWarning.Single <$ guard nsfw
let nsfwScript = NsfwWarning.script nsfw'
let nsfwDialog = NsfwWarning.dialog nsfw'
let imageMeta = case previewImage info of
Just (PFull (pageFile -> path)) -> [b|
|]
Just (PThumb (thumbFile -> path)) -> [b|
|]
Nothing -> throw $ NoThumb dir
let escTitle = escAttr title
pure [b|
$imageMeta
$nsfwScript
$bgStyle
$prefetches
$escTitle
$nsfwDialog
|]
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 HashSet.empty where
makeId used img = (HashSet.insert newId used, (img, newId)) where
newId = headI $ filterI (\i -> not $ i `HashSet.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|
|]
makeCat lbl imgs = [b|