599 lines
27 KiB
Haskell
599 lines
27 KiB
Haskell
{-# LANGUAGE GHC2021 #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
-- | Photography section — routing and per-page compilation.
|
|
--
|
|
-- Phase 1 (current): single-photo entries in flat and directory form,
|
|
-- plus the @/photography/@ landing page that lists every entry.
|
|
--
|
|
-- Phase 5 will extend this module with:
|
|
-- * collection-photo files (@content/photography/<series>/<photo>.md@)
|
|
-- * series landing pages
|
|
-- * @/photography/by-year/@ chronological indexes
|
|
-- * @/photography/contact-sheet/@ alternate view
|
|
-- * @/photography/feed.xml@ Atom feed
|
|
-- * @/photography/map/@ Leaflet map (Phase 4)
|
|
--
|
|
-- See @PHOTOGRAPHY.md@ at the repo root for the full design and
|
|
-- phased implementation plan.
|
|
module Photography
|
|
( photographyRules
|
|
) where
|
|
|
|
import Control.Monad (forM, forM_)
|
|
import Data.List (sortBy)
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Map.Strict (Map)
|
|
import Data.Maybe (mapMaybe, fromMaybe, catMaybes)
|
|
import qualified Data.Set as Set
|
|
import Data.Set (Set)
|
|
import Data.Ord (Down (..), comparing)
|
|
import System.FilePath (takeDirectory, takeFileName, replaceExtension)
|
|
import qualified Data.Aeson as Aeson
|
|
import Data.Aeson (Value (..), (.=))
|
|
import qualified Data.Aeson.KeyMap as KM
|
|
import qualified Data.Text.Lazy as TL
|
|
import qualified Data.Text.Lazy.Encoding as TLE
|
|
import qualified Data.Vector as V
|
|
import qualified Data.Scientific as Sci
|
|
import Hakyll
|
|
import Compilers (pageCompiler, photographyCompiler)
|
|
import Contexts (photographyCtx, pageCtx, siteCtx,
|
|
recentFirstByDisplay)
|
|
import qualified Patterns as P
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Rules
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | All photography rules. Called from 'Site.rules' once.
|
|
--
|
|
-- Order is intentional:
|
|
--
|
|
-- 1. Co-located assets first (so the photo file is in @_site/@
|
|
-- before any page that references it is compiled — Hakyll's
|
|
-- dependency tracker handles this anyway, but the surface
|
|
-- ordering reads top-down by data flow).
|
|
-- 2. Single-photo entries (flat + directory form).
|
|
-- 3. Section landing at @/photography/@ — loaded after the
|
|
-- photo entries so its @loadAll photographyPattern@ resolves
|
|
-- each photo's frontmatter through 'photographyCtx'.
|
|
photographyRules :: Rules ()
|
|
photographyRules = do
|
|
-- A directory is a "series" iff it has @.md@ siblings alongside
|
|
-- its @index.md@. Collected once at rule-gen time so the entry
|
|
-- rule can branch on series-landing template selection without
|
|
-- re-globbing per item.
|
|
siblingIds <- getMatches
|
|
( "content/photography/*/*.md"
|
|
.&&. complement "content/photography/*/index.md"
|
|
)
|
|
let seriesSlugs :: Set String
|
|
seriesSlugs = Set.fromList
|
|
[ takeFileName (takeDirectory (toFilePath ident))
|
|
| ident <- siblingIds
|
|
]
|
|
|
|
photographyAssetRules
|
|
photographyEntryRules seriesSlugs
|
|
photographySeriesPhotoRules
|
|
photographyLandingRules
|
|
photographyMapDataRule
|
|
photographyMapPageRule
|
|
photographyFeedRule
|
|
photographyByYearRules
|
|
photographyContactSheetRule
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Assets
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | Co-located assets — the photo file itself, and (Phase 3) the
|
|
-- generated @{photo}.exif.yaml@ + @{photo}.palette.yaml@ sidecars.
|
|
-- Two patterns are matched in sequence:
|
|
--
|
|
-- * @content/photography/<asset>@ — flat-single co-located assets
|
|
-- * @content/photography/<slug>/<asset>@ — directory-form co-located assets
|
|
--
|
|
-- Markdown files are excluded from both rules; they're compiled by
|
|
-- 'photographyEntryRules' and 'photographyLandingRules'.
|
|
--
|
|
-- The @.exif.yaml@ / @.palette.yaml@ sidecars produced by Phase 3
|
|
-- tooling will be added to the @.gitignore@ defense-in-depth list,
|
|
-- but copying them through the asset rule is harmless if a stray
|
|
-- one slips into the repo. The build is not load-bearing on
|
|
-- sidecar absence.
|
|
photographyAssetRules :: Rules ()
|
|
photographyAssetRules = do
|
|
-- Top-level non-Markdown files (flat-single co-located assets, plus
|
|
-- any future top-level photography assets like a landing-page hero).
|
|
--
|
|
-- Sidecars produced by the Phase 3 Python tooling
|
|
-- (@{photo}.exif.yaml@, @{photo}.palette.yaml@) are excluded —
|
|
-- they're consumed by Hakyll at build time and have no role in
|
|
-- the deployed site.
|
|
match ("content/photography/*"
|
|
.&&. complement "content/photography/*.md"
|
|
.&&. complement "content/photography/*.exif.yaml"
|
|
.&&. complement "content/photography/*.palette.yaml"
|
|
.&&. complement "content/photography/*.dims.yaml") $ do
|
|
route $ gsubRoute "content/" (const "")
|
|
compile copyFileCompiler
|
|
|
|
-- Directory-form entries' co-located assets. Excludes the entry's
|
|
-- @index.md@, any other Markdown sibling files (collection photos
|
|
-- in Phase 5), and every build-time YAML sidecar (EXIF, palette,
|
|
-- dimensions).
|
|
match ("content/photography/*/*"
|
|
.&&. complement "content/photography/*/index.md"
|
|
.&&. complement "content/photography/*/*.md"
|
|
.&&. complement "content/photography/*/*.exif.yaml"
|
|
.&&. complement "content/photography/*/*.palette.yaml"
|
|
.&&. complement "content/photography/*/*.dims.yaml") $ do
|
|
route $ gsubRoute "content/" (const "")
|
|
compile copyFileCompiler
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Single-photo entries
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | Compile each single-photo entry. Routing follows the essay
|
|
-- convention so the URL shape is predictable:
|
|
--
|
|
-- * @content/photography/<slug>.md@ → @photography/<slug>.html@
|
|
-- * @content/photography/<slug>/index.md@ → @photography/<slug>/index.html@
|
|
--
|
|
-- The @"content"@ snapshot is saved so a future @/photography/feed.xml@
|
|
-- (Phase 5) can render the rendered body as feed entry content.
|
|
photographyEntryRules :: Set String -> Rules ()
|
|
photographyEntryRules seriesSlugs =
|
|
match P.photographyPattern $ do
|
|
route photoEntryRoute
|
|
compile $ do
|
|
ident <- getUnderlying
|
|
let fp = toFilePath ident
|
|
isIndex = takeFileName fp == "index.md"
|
|
slug = takeFileName (takeDirectory fp)
|
|
isSeriesLanding = isIndex && slug `Set.member` seriesSlugs
|
|
template
|
|
| isSeriesLanding = "templates/photography-series.html"
|
|
| otherwise = "templates/photography.html"
|
|
ctx
|
|
| isSeriesLanding = seriesCtx
|
|
| otherwise = photographyCtx
|
|
photographyCompiler
|
|
>>= saveSnapshot "content"
|
|
>>= loadAndApplyTemplate template ctx
|
|
>>= loadAndApplyTemplate "templates/default.html" ctx
|
|
>>= relativizeUrls
|
|
|
|
-- | Sibling photos inside a series directory:
|
|
-- @content/photography/<series>/<photo>.md@. Compiled with the
|
|
-- single-photo template; routed to @<series>/<photo>/index.html@
|
|
-- so the URL is the canonical directory form (matches the rest of
|
|
-- the photography section's URL shape).
|
|
--
|
|
-- Series landings (@<series>/index.md@) are handled by
|
|
-- 'photographyEntryRules' with the @photographyPattern@ match;
|
|
-- they're explicitly excluded here so the two rules don't double-route.
|
|
photographySeriesPhotoRules :: Rules ()
|
|
photographySeriesPhotoRules =
|
|
match ("content/photography/*/*.md"
|
|
.&&. complement "content/photography/*/index.md") $ do
|
|
route $ customRoute $ \ident ->
|
|
-- Drop @"content/"@ prefix and @".md"@ suffix, then append
|
|
-- @"/index.html"@ to get directory-style URLs.
|
|
let fp = toFilePath ident
|
|
rel = drop (length contentPrefix) fp
|
|
stripped = take (length rel - 3) rel
|
|
in stripped ++ "/index.html"
|
|
compile $ photographyCompiler
|
|
>>= saveSnapshot "content"
|
|
>>= loadAndApplyTemplate "templates/photography.html" photographyCtx
|
|
>>= loadAndApplyTemplate "templates/default.html" photographyCtx
|
|
>>= relativizeUrls
|
|
where
|
|
contentPrefix = "content/" :: String
|
|
|
|
-- | Context for series-landing pages. Extends 'photographyCtx' with a
|
|
-- @series-photos@ list field that loads the directory's sibling
|
|
-- photos (the @<series>/<photo>.md@ files), most-recent-first.
|
|
--
|
|
-- The @is-series@ const flag lets the consuming template branch on
|
|
-- whether to render single-photo chrome (figure + EXIF dl + body)
|
|
-- or series chrome (intro + photo grid + body).
|
|
seriesCtx :: Context String
|
|
seriesCtx =
|
|
constField "is-series" "true"
|
|
<> listFieldWith "series-photos" photographyCtx loadSeriesChildren
|
|
<> photographyCtx
|
|
where
|
|
loadSeriesChildren parent = do
|
|
let ident = itemIdentifier parent
|
|
slug = takeFileName (takeDirectory (toFilePath ident))
|
|
pat = fromGlob ("content/photography/" ++ slug ++ "/*.md")
|
|
.&&. complement
|
|
(fromGlob ("content/photography/" ++ slug ++ "/index.md"))
|
|
.&&. hasNoVersion
|
|
recentFirstByDisplay =<< loadAll pat
|
|
|
|
-- | Route a photography entry to its public URL. The pattern check on
|
|
-- @takeFileName@ distinguishes flat (@content/photography/<slug>.md@)
|
|
-- from directory-form (@content/photography/<slug>/index.md@) without
|
|
-- re-globbing, since Hakyll has already pre-filtered to entries
|
|
-- matching 'P.photographyPattern'.
|
|
--
|
|
-- Mirrors the essay rule's customRoute (@Site.rules@) but stripped of
|
|
-- the dev-mode draft branch — drafts are an essay-only concept right
|
|
-- now.
|
|
photoEntryRoute :: Routes
|
|
photoEntryRoute = customRoute $ \ident ->
|
|
let fp = toFilePath ident
|
|
fname = takeFileName fp
|
|
isIndex = fname == "index.md"
|
|
in if isIndex
|
|
-- content/photography/<slug>/index.md
|
|
-- → photography/<slug>/index.html
|
|
then replaceExtension (drop (length contentPrefix) fp) "html"
|
|
-- content/photography/<slug>.md → photography/<slug>.html
|
|
else "photography/" ++ replaceExtension fname "html"
|
|
where
|
|
contentPrefix :: String
|
|
contentPrefix = "content/"
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Landing page
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | Section landing at @/photography/@. Loads all photo entries
|
|
-- resolved against 'photographyCtx' so each card has access to
|
|
-- slug / photo-url / captured-display / palette swatches.
|
|
--
|
|
-- Sorts by display date (creation date, or most-recent revision
|
|
-- when the entry has a @revised:@ entry — same ordering authority
|
|
-- that essay listings use). Phase 2 will replace this listing with
|
|
-- the masonry/grid/chronological mode toggle, but the underlying
|
|
-- data feed stays the same — the toggle is a JS layer over the
|
|
-- already-rendered grid markup.
|
|
photographyLandingRules :: Rules ()
|
|
photographyLandingRules =
|
|
match "content/photography/index.md" $ do
|
|
route $ constRoute "photography/index.html"
|
|
compile $ do
|
|
photos <- recentFirstByDisplay
|
|
=<< loadAll (P.photographyPattern .&&. hasNoVersion)
|
|
let ctx =
|
|
listField "photos" photographyCtx (return photos)
|
|
<> constField "photography" "true"
|
|
<> constField "list-page" "true"
|
|
<> pageCtx
|
|
pageCompiler
|
|
>>= loadAndApplyTemplate "templates/photography-index.html" ctx
|
|
>>= loadAndApplyTemplate "templates/default.html" ctx
|
|
>>= relativizeUrls
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Map data (Phase 4)
|
|
-- ---------------------------------------------------------------------------
|
|
--
|
|
-- Two artifacts together:
|
|
--
|
|
-- * @/photography/map.json@ — JSON array of pin objects, fetched
|
|
-- by @static/js/photography-map.js@ at view time. Built directly
|
|
-- from frontmatter; no Python dependency.
|
|
-- * @/photography/map/@ — the page that renders the Leaflet
|
|
-- viewport. Lightweight HTML; the heavy lifting lives in the JS.
|
|
--
|
|
-- Privacy: every coordinate is rounded to the precision the author
|
|
-- declares in @geo-precision:@ (default @"city"@) BEFORE it leaves
|
|
-- this build step. Full-precision coords never reach @map.json@.
|
|
-- @geo-precision: hidden@ omits the entry entirely.
|
|
|
|
-- | Strip a trailing @"index.html"@ component so a Hakyll route
|
|
-- like @"photography/foo/index.html"@ becomes @"photography/foo/"@.
|
|
-- Used for map.json click-through URLs.
|
|
stripIndexHtml :: String -> String
|
|
stripIndexHtml r
|
|
| suffixMatches = take (length r - 10) r -- 10 = length "index.html"
|
|
| otherwise = r
|
|
where
|
|
suffix = "/index.html" :: String
|
|
suffixMatches = suffix == drop (length r - length suffix) r
|
|
|
|
-- | Round a decimal coordinate to the precision that matches the
|
|
-- author's @geo-precision:@ declaration.
|
|
--
|
|
-- * @exact@: 4 decimal places (~10 m)
|
|
-- * @km@ : 2 decimal places (~1 km)
|
|
-- * @city@ : 1 decimal place (~10 km) — default
|
|
-- * other : treated as @city@
|
|
--
|
|
-- @hidden@ is handled at the call site by skipping the pin entirely;
|
|
-- this function is not consulted in that case.
|
|
roundCoord :: String -> Double -> Double
|
|
roundCoord prec x =
|
|
let n = case prec of
|
|
"exact" -> 4
|
|
"km" -> 2
|
|
"city" -> 1
|
|
_ -> 1
|
|
scale = 10 ^^ (n :: Int) :: Double
|
|
in fromIntegral (round (x * scale) :: Integer) / scale
|
|
|
|
-- | Extract @[lat, lon]@ from a frontmatter @geo:@ list. Accepts only
|
|
-- exactly two numeric entries — anything else returns 'Nothing' so
|
|
-- the entry is silently skipped on the map.
|
|
parseGeo :: Aeson.Object -> Maybe (Double, Double)
|
|
parseGeo meta = case KM.lookup "geo" meta of
|
|
Just (Array vec) | V.length vec == 2 ->
|
|
case (asDouble (vec V.! 0), asDouble (vec V.! 1)) of
|
|
(Just lat, Just lon) -> Just (lat, lon)
|
|
_ -> Nothing
|
|
_ -> Nothing
|
|
where
|
|
asDouble (Number n) = Just (Sci.toRealFloat n)
|
|
asDouble _ = Nothing
|
|
|
|
-- | Build a single pin object from a photo entry. Returns 'Nothing'
|
|
-- when:
|
|
-- * the entry has no @geo:@ frontmatter, or
|
|
-- * it has @geo-precision: hidden@, or
|
|
-- * the entry has no resolvable route (shouldn't happen for
|
|
-- photographyPattern items, but be defensive).
|
|
buildPin :: Item String -> Compiler (Maybe Value)
|
|
buildPin item = do
|
|
let ident = itemIdentifier item
|
|
meta <- getMetadata ident
|
|
mRoute <- getRoute ident
|
|
case (parseGeo meta, lookupString "geo-precision" meta, mRoute) of
|
|
(_, Just "hidden", _) -> return Nothing
|
|
(Just (lat, lon), prec, Just r) ->
|
|
let prec' = fromMaybe "city" prec
|
|
rLat = roundCoord prec' lat
|
|
rLon = roundCoord prec' lon
|
|
fp = toFilePath ident
|
|
slug = takeFileName (takeDirectory fp)
|
|
title = fromMaybe slug (lookupString "title" meta)
|
|
photo = lookupString "photo" meta
|
|
-- Trim trailing "index.html" so the click-through URL
|
|
-- is the canonical directory form (no implicit redirect).
|
|
url = "/" ++ stripIndexHtml r
|
|
thumb = case photo of
|
|
Just p | not (null p) ->
|
|
"/photography/" ++ slug ++ "/" ++ p
|
|
_ -> ""
|
|
captured = lookupString "captured" meta
|
|
in return $ Just $ Aeson.object $
|
|
[ "slug" .= slug
|
|
, "title" .= title
|
|
, "url" .= url
|
|
, "lat" .= rLat
|
|
, "lon" .= rLon
|
|
] ++ (if null thumb then [] else ["thumb" .= thumb])
|
|
++ maybe [] (\c -> ["captured" .= c]) captured
|
|
_ -> return Nothing
|
|
|
|
-- | @/photography/map.json@ — JSON array of geo-tagged photo pins
|
|
-- for the Leaflet client. Excludes entries with @geo-precision:
|
|
-- hidden@ and entries with no @geo:@ frontmatter. Walks
|
|
-- 'allPhotoEntries' so series children with their own GPS land
|
|
-- on the map alongside top-level photos.
|
|
photographyMapDataRule :: Rules ()
|
|
photographyMapDataRule =
|
|
create ["photography/map.json"] $ do
|
|
route idRoute
|
|
compile $ do
|
|
photos <- loadAll (P.allPhotoEntries .&&. hasNoVersion)
|
|
:: Compiler [Item String]
|
|
pins <- mapMaybe id <$> mapM buildPin photos
|
|
-- LBS.unpack truncates each UTF-8 byte to a Char (Latin-1
|
|
-- mode), and Hakyll then re-encodes the String to UTF-8 on
|
|
-- write — producing double-encoded mojibake for any non-
|
|
-- ASCII title (em-dashes, accents, etc.). Decoding through
|
|
-- Text gives Hakyll a String of Unicode code points it can
|
|
-- re-encode cleanly.
|
|
makeItem $ TL.unpack $ TLE.decodeUtf8 $ Aeson.encode pins
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Map page (Phase 4)
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | @/photography/map/@ — the Leaflet-driven map view. Synthesised
|
|
-- page; no Markdown source. The @photography-map@ context flag
|
|
-- gates Leaflet CSS / JS loading in @head.html@ and @default.html@,
|
|
-- so other photography pages stay lightweight.
|
|
photographyMapPageRule :: Rules ()
|
|
photographyMapPageRule =
|
|
create ["photography/map/index.html"] $ do
|
|
route idRoute
|
|
compile $ do
|
|
let ctx = constField "title" "Map · Photography"
|
|
<> constField "photography" "true"
|
|
<> constField "photography-map" "true"
|
|
<> siteCtx
|
|
makeItem ""
|
|
>>= loadAndApplyTemplate "templates/photography-map.html" ctx
|
|
>>= loadAndApplyTemplate "templates/default.html" ctx
|
|
>>= relativizeUrls
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Atom feed (Phase 5)
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | Configuration for the photography-only Atom feed at
|
|
-- @/photography/feed.xml@. Distinct from the main @/feed.xml@ so
|
|
-- text-primary subscribers don't unexpectedly get image-heavy
|
|
-- entries in their reader.
|
|
photographyFeedConfig :: FeedConfiguration
|
|
photographyFeedConfig = FeedConfiguration
|
|
{ feedTitle = "Levi Neuwirth — Photography"
|
|
, feedDescription = "New photographs by Levi Neuwirth"
|
|
, feedAuthorName = "Levi Neuwirth"
|
|
, feedAuthorEmail = "levi@levineuwirth.org"
|
|
, feedRoot = "https://levineuwirth.org"
|
|
}
|
|
|
|
-- | Description field for Atom feed entries: prepends an absolute-URL
|
|
-- @<img>@ tag (so the photograph displays inline in the reader) to
|
|
-- the rendered prose body. Composed ABOVE 'bodyField' so it wins
|
|
-- when @$description$@ is consumed by the Atom template.
|
|
photographyFeedDescription :: Context String
|
|
photographyFeedDescription = field "description" $ \item -> do
|
|
let ident = itemIdentifier item
|
|
body <- itemBody <$> (loadSnapshot ident "content" :: Compiler (Item String))
|
|
meta <- getMetadata ident
|
|
let fp = toFilePath ident
|
|
isDir = takeFileName fp == "index.md"
|
|
slug = takeFileName (takeDirectory fp)
|
|
photo = lookupString "photo" meta
|
|
imgTag = case (isDir, photo) of
|
|
(True, Just p) | not (null p) ->
|
|
"<p><img src=\"https://levineuwirth.org/photography/"
|
|
++ slug ++ "/" ++ p ++ "\" alt=\"\"></p>\n"
|
|
_ -> ""
|
|
return (imgTag ++ body)
|
|
|
|
-- | @/photography/feed.xml@ — Atom feed of the most recent 30 photo
|
|
-- entries, with each photograph embedded inline at the top of its
|
|
-- entry description.
|
|
photographyFeedRule :: Rules ()
|
|
photographyFeedRule =
|
|
create ["photography/feed.xml"] $ do
|
|
route idRoute
|
|
compile $ do
|
|
photos <- fmap (take 30) . recentFirst
|
|
=<< loadAllSnapshots
|
|
(P.allPhotoEntries .&&. hasNoVersion)
|
|
"content"
|
|
let feedCtx =
|
|
dateField "updated" "%Y-%m-%dT%H:%M:%SZ"
|
|
<> dateField "published" "%Y-%m-%dT%H:%M:%SZ"
|
|
<> photographyFeedDescription
|
|
<> bodyField "description"
|
|
<> defaultContext
|
|
renderAtom photographyFeedConfig feedCtx photos
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- By-year pages (Phase 5)
|
|
-- ---------------------------------------------------------------------------
|
|
--
|
|
-- @/photography/by-year/@ is the index of years that have photos;
|
|
-- @/photography/by-year/<year>/@ lists each year's photos
|
|
-- chronologically. Year is taken from @captured:@ frontmatter
|
|
-- (when present), falling back to @date:@. Photos with neither
|
|
-- field — or with a malformed date — are silently dropped from this
|
|
-- surface; they remain visible on the main grid and any tag pages
|
|
-- their frontmatter produces.
|
|
|
|
-- | Extract a four-digit year from a frontmatter @captured:@ or
|
|
-- @date:@ field. Returns 'Nothing' when neither is set or both are
|
|
-- shorter than four characters.
|
|
yearOfPhoto :: Metadata -> Maybe String
|
|
yearOfPhoto meta =
|
|
let firstFour s = if length s >= 4 then Just (take 4 s) else Nothing
|
|
in case lookupString "captured" meta >>= firstFour of
|
|
Just yr -> Just yr
|
|
Nothing -> lookupString "date" meta >>= firstFour
|
|
|
|
-- | All by-year rules: collect (year, identifier) pairs once, then
|
|
-- build the index page and one page per year.
|
|
photographyByYearRules :: Rules ()
|
|
photographyByYearRules = do
|
|
photoIds <- getMatches (P.allPhotoEntries .&&. hasNoVersion)
|
|
pairs <- forM photoIds $ \ident -> do
|
|
meta <- getMetadata ident
|
|
return $ fmap (\yr -> (yr, ident)) (yearOfPhoto meta)
|
|
let yearMap :: Map String [Identifier]
|
|
yearMap = Map.fromListWith (++) [(yr, [i]) | (yr, i) <- catMaybes pairs]
|
|
-- Years sorted descending so the most recent appear first.
|
|
years = map fst $ sortBy (comparing (Down . fst)) (Map.toList yearMap)
|
|
|
|
photographyByYearIndexRule yearMap years
|
|
forM_ years $ \yr -> photographyByYearPageRule yr (yearMap Map.! yr)
|
|
|
|
-- | @/photography/by-year/@ — top-level index. Lists each year that
|
|
-- has photos with the count, linking to the per-year page.
|
|
photographyByYearIndexRule :: Map String [Identifier] -> [String] -> Rules ()
|
|
photographyByYearIndexRule yearMap years =
|
|
create ["photography/by-year/index.html"] $ do
|
|
route idRoute
|
|
compile $ do
|
|
let yearItems =
|
|
[ Item (fromFilePath ("year-" ++ yr))
|
|
(yr, length (Map.findWithDefault [] yr yearMap))
|
|
| yr <- years
|
|
]
|
|
yrCtx =
|
|
field "year" (return . fst . itemBody)
|
|
<> field "year-url" (\i -> return $ "/photography/by-year/"
|
|
++ fst (itemBody i) ++ "/")
|
|
<> field "year-count"
|
|
(return . show . snd . itemBody)
|
|
ctx =
|
|
listField "years" yrCtx (return yearItems)
|
|
<> constField "title" "Photography by year"
|
|
<> constField "photography" "true"
|
|
<> siteCtx
|
|
makeItem ""
|
|
>>= loadAndApplyTemplate
|
|
"templates/photography-by-year-index.html" ctx
|
|
>>= loadAndApplyTemplate "templates/default.html" ctx
|
|
>>= relativizeUrls
|
|
|
|
-- | @/photography/by-year/<year>/@ — list of photos captured that year.
|
|
photographyByYearPageRule :: String -> [Identifier] -> Rules ()
|
|
photographyByYearPageRule yr idents =
|
|
create [fromFilePath ("photography/by-year/" ++ yr ++ "/index.html")] $ do
|
|
route idRoute
|
|
compile $ do
|
|
photos <- recentFirstByDisplay
|
|
=<< mapM (\i -> load i :: Compiler (Item String)) idents
|
|
let ctx =
|
|
listField "photos" photographyCtx (return photos)
|
|
<> constField "title" ("Photography · " ++ yr)
|
|
<> constField "year" yr
|
|
<> constField "photography" "true"
|
|
<> constField "list-page" "true"
|
|
<> siteCtx
|
|
makeItem ""
|
|
>>= loadAndApplyTemplate
|
|
"templates/photography-by-year.html" ctx
|
|
>>= loadAndApplyTemplate "templates/default.html" ctx
|
|
>>= relativizeUrls
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Contact sheet (Phase 5)
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | @/photography/contact-sheet/@ — alternate view of every photo in
|
|
-- a film-strip aesthetic: thin white-bordered frames, frame numbers
|
|
-- in the corner, slightly grainy backdrop. Distinct from the main
|
|
-- grid views; deep cut rather than primary surface.
|
|
--
|
|
-- Sort order: chronological by display date (asc). The contact-sheet
|
|
-- convention reads top-to-bottom in capture order — a roll of film,
|
|
-- not a recency feed. Each frame's index doubles as its frame
|
|
-- number. The CSS handles the frame numbering via a CSS counter so
|
|
-- we don't have to thread the index through the template.
|
|
photographyContactSheetRule :: Rules ()
|
|
photographyContactSheetRule =
|
|
create ["photography/contact-sheet/index.html"] $ do
|
|
route idRoute
|
|
compile $ do
|
|
-- Reverse the recent-first sort to get oldest-first
|
|
-- (capture chronology), matching the contact-sheet
|
|
-- convention.
|
|
photos <- reverse <$> (recentFirstByDisplay
|
|
=<< loadAll (P.allPhotoEntries .&&. hasNoVersion)
|
|
:: Compiler [Item String])
|
|
let ctx =
|
|
listField "photos" photographyCtx (return photos)
|
|
<> constField "title" "Contact sheet · Photography"
|
|
<> constField "photography" "true"
|
|
<> siteCtx
|
|
makeItem ""
|
|
>>= loadAndApplyTemplate
|
|
"templates/photography-contact-sheet.html" ctx
|
|
>>= loadAndApplyTemplate "templates/default.html" ctx
|
|
>>= relativizeUrls
|
|
|