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) 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 -> 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 $ addIds images let (image0@(Image {path = path0, download = download0'}), Size {width = width0, height = height0}) : otherImages = #all 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) otherImages let makeWarning w = [b|@0

|] 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

$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

about

$4.desc

|] makeDesc (LongDesc fs) = [b|@0

$2.fields

|] where fields = map makeField fs makeField (DescField {name, text}) = [b|@0

$name

$4.text

|] addIds :: Images' (Image, a) -> Images' (Image, a, Text) addIds = snd . mapAccumL makeId Set.empty where makeId used (img, x) = (Set.insert newId used, (img, x, 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, Size, Text) -> Builder makeButtonBar title images = case images of Uncat [] -> throw $ NoEligibleImages title Uncat [_] -> "" Cat [(_,[_])] -> "" Uncat imgs -> makeNav "uncat" $ makeAlts imgs Cat cats -> makeNav "cat" $ map (uncurry makeCat) cats where makeNav (cls :: Text) inner = [b|@0 |] makeCat lbl imgs = [b|@0

$lbl

$0.alts

|] where alts = makeAlts imgs makeAlts imgs = [b|@0

$2.elems |] where elems = map (\(img,sz,i) -> altButton img sz i) imgs altButton :: Image -> Size -> Text -> Builder altButton img size i = [b|@0 $label |] 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 "" 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 :: Traversable t => FilePath -> t Image -> IO (t (Image, Size)) withSizes dir = traverse \img -> do size <- imageSize dir $ #path img pure (img, size)