{-# 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||] where path' = bigFile img let prefetches = map makePrefetch otherImages let makeWarning w = [b|@0
$w
|] let warning' = ifJust image0.warning makeWarning let warningT = makeWarning [b|.|] let bgStyle = case bg of Default -> "" NoBorder -> [b|@0 |] Other col -> [b|@0 |] 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|
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 (Image {path})) -> [b|@0 |] Just (PThumb path) -> [b|@0 |] Nothing -> throw $ NoThumb dir pure [b|@0 $imageMeta $nsfwScript $bgStyle $0.prefetches $title $nsfwDialog

$title

$formattedDate $updateDate

back to gallery

$2.buttonBar
$warning'
$6.artistSection $6.descSection $6.updatesList $6.linksList $6.tagsList
|] 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|@0

by

$artistLink
|] where artistLink = case url of Just u -> [b|$name|] Nothing -> [b|$name|] makeDesc :: Desc -> Builder makeDesc NoDesc = "" makeDesc (TextDesc desc) = [b|@0

about

$4.desc
|] makeDesc (LongDesc fs) = [b|@0
$2.fields
|] where fields = map makeField fs makeField (DescField {name, text}) = [b|@0

$name

$4.text
|] 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|@0 |] makeCat lbl imgs = [b|@0

$lbl

$0.alts
|] where alts = makeAlts imgs makeAlts imgs = [b|@0 |] where elems = fmap (uncurry altButton) imgs skipAll = if any (isJust . (.warning) . fst) images then [b|@0
|] 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|@0 |] 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|@0 |] where tagList = map makeTag tags makeTag tag = [b|
  • $tag|] where tag' = escId tag extLinks :: [Link] -> Builder extLinks links = if null links then "" else [b|@0 |] where linkList = map extLink links extLink :: Link -> Builder extLink (Link {title, url}) = [b|@8
  • $title |] makeUpdates :: [(Date, NonEmpty Update)] -> Builder makeUpdates ups = if all (null . snd) ups then "" else [b|@4

    updates

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