module SinglePage (make) where import Date import Info import BuilderQQ import Records () import qualified NsfwWarning import Control.Exception import Data.List (sort) import Data.Maybe (fromMaybe) import qualified Data.Text as Strict import qualified Data.Text.Lazy as Lazy import System.FilePath (joinPath, splitPath, ()) import qualified System.Process as Proc import Text.Read (readMaybe) -- | 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 -> FilePath -- ^ gallery prefix -> Bool -- ^ nsfw? -> FilePath -- ^ data dir -> FilePath -- ^ subdir of datadir containing this @info.yaml@ -> Info -> IO Lazy.Text make root prefix nsfw dataDir dir info = toLazyText <$> make' root prefix nsfw dataDir dir info make' :: Text -> FilePath -> Bool -> FilePath -> FilePath -> Info -> IO Builder make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do images <- withSizes (dataDir dir) $ imagesFor nsfw info let undir = joinPath (replicate (length (splitPath dir)) "..") let artistTag = ifJust artist makeArtist let formattedDate = formatLong 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 tinyCls = if any (tiny . #second) images then [b| class=tiny|] else "" 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||] let prefetches = map (makePrefetch . #first) $ tail images let makeWarning w = [b|@0
$w
|] let defWarning = "oops i forgot to put one, sorry!
\ \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 |] 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) \(Update {date = d}) -> let updated = formatLong d in [b|
updated $updated|] let nsfwScript = NsfwWarning.script nsfw let nsfwDialog = NsfwWarning.dialog nsfw pure [b|@0 $nsfwScript $bgStyle $0.prefetches $title $nsfwDialog

$title

$artistTag

$formattedDate $updateDate

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

|] 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
|] makeButtonBar :: Strict.Text -> [(Image, Size)] -> Builder makeButtonBar title images = case images of [] -> throw $ NoEligibleImages title [_] -> "" _ -> [b|@0 |] where alts = map (\(i, (im, sz)) -> altButton i im sz) $ zip [0..] images altButton :: Int -> Image -> Size -> Builder altButton i img size = [b|@0 |] where Image {label, path, nsfw, warning, download} = img Size {width, height} = size 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 "" idLabel = escId label path' = pageFile path link = fromMaybe 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 |] 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 :: [Update] -> Builder makeUpdates ups = if null ups then "" else [b|@4

    updates

    $8.updateList
    |] where updateList = map makeUpdate ups makeUpdate :: Update -> Builder makeUpdate (Update {date, desc}) = [b|@8
    $date'
    $desc |] where date' = formatSlash date data Size = Size {width, height :: !Int} deriving (Eq, Show) tiny :: Size -> Bool tiny (Size {width, height}) = width < 250 || height < 250 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)