module SinglePage (make) where import Info import BuilderQQ import Records () import Control.Exception import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import qualified Data.Text as Strict import qualified Data.Text.Lazy as Lazy import qualified Data.Time as Time 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, updates}) = do 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 let updatesList = makeUpdates $ Map.toList updates let makePrefetch (Image {path}) = [b||] let prefetches = map (makePrefetch . #first) $ tail images let makeWarning w = [b|@4
$w
|] let warning' = ifJust (#warning image0) makeWarning 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 (Map.lookupMax updates) \(formatDate -> u, _) -> [b|
updated $u|] pure [b|@0 $bgStyle $0.prefetches $title

$title

$artistTag

$formattedDate $updateDate

$buttonBar
$warning'
$descSection $tagsList $linksList $updatesList
|] makeArtist :: Artist -> Builder makeArtist (Artist {name, url}) = [b|

by $artistLink

|] where artistLink = case url of Just u -> [b|$name|] Nothing -> [b|$name|] makeDesc :: Maybe Strict.Text -> Builder makeDesc mdesc = ifJust mdesc \desc -> [b|@4

about

$8.desc
|] makeButtonBar :: Strict.Text -> [(Image, Size)] -> Builder makeButtonBar title images = case length images of 0 -> throw $ NoEligibleImages title 1 -> "" _ -> [b|@0 |] where alts = map (\(i, (im, sz)) -> altButton i im sz) $ zip [0..] images altButton :: Int -> Image -> Size -> Builder altButton i (Image {label, path, nsfw, warning}) (Size {width, height}) = [b|@4 |] where 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 warning' = ifJust warning \(escAttr -> w) -> [b| data-warning="$w"|] makeTags :: FilePath -> [Strict.Text] -> Builder makeTags undir tags = if null tags then "" else [b|@4 |] where tagList = map makeTag tags makeTag tag = [b|
  • $tag|] where tag' = escId tag extLinks :: [Link] -> Builder extLinks links = if null links then "" else [b|@4 |] where linkList = map extLink links extLink :: Link -> Builder extLink (Link {title, url}) = [b|@8
  • $title |] makeUpdates :: [(Day, Text)] -> Builder makeUpdates ups = if null ups then "" else [b|@4

    updates

    $8.updateList
    |] where updateList = map (uncurry makeUpdate) ups makeUpdate :: Day -> Text -> Builder makeUpdate date txt = [b|@8
    $date'
    $txt |] where date' = Time.formatTime Time.defaultTimeLocale "%-d/%-m/%Y" date formatDate :: Day -> Builder formatDate date = [b|$week $day $month $year|] where (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 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|] data Size = Size {width, height :: !Int} deriving (Eq, Show) 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)