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