244 lines
9.1 KiB
Haskell
244 lines
9.1 KiB
Haskell
{-# LANGUAGE GHC2021 #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
-- | Music catalog: featured works + grouped-by-category listing.
|
|
-- Renders HTML directly (same pattern as Backlinks.hs) to avoid the
|
|
-- complexity of nested listFieldWith.
|
|
module Catalog
|
|
( musicCatalogCtx
|
|
) where
|
|
|
|
import Data.Char (isSpace, toLower)
|
|
import Data.List (groupBy, isPrefixOf, sortBy)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Ord (comparing)
|
|
import Data.Aeson (Value (..))
|
|
import qualified Data.Aeson.KeyMap as KM
|
|
import qualified Data.Vector as V
|
|
import qualified Data.Text as T
|
|
import Hakyll
|
|
import Contexts (siteCtx)
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Entry type
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
data CatalogEntry = CatalogEntry
|
|
{ ceTitle :: String
|
|
, ceUrl :: String
|
|
, ceYear :: Maybe String
|
|
, ceDuration :: Maybe String
|
|
, ceInstrumentation :: Maybe String
|
|
, ceCategory :: String -- defaults to "other"
|
|
, ceFeatured :: Bool
|
|
, ceHasScore :: Bool
|
|
, ceHasRecording :: Bool
|
|
}
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Category helpers
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
categoryOrder :: [String]
|
|
categoryOrder = ["orchestral","chamber","solo","vocal","choral","electronic","other"]
|
|
|
|
categoryLabel :: String -> String
|
|
categoryLabel "orchestral" = "Orchestral"
|
|
categoryLabel "chamber" = "Chamber"
|
|
categoryLabel "solo" = "Solo"
|
|
categoryLabel "vocal" = "Vocal"
|
|
categoryLabel "choral" = "Choral"
|
|
categoryLabel "electronic" = "Electronic"
|
|
categoryLabel _ = "Other"
|
|
|
|
categoryRank :: String -> Int
|
|
categoryRank c = fromMaybe (length categoryOrder)
|
|
(lookup c (zip categoryOrder [0..]))
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Parsing helpers
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | @featured: true@ in YAML becomes Bool True in Aeson; also accept the
|
|
-- string "true" in case the author quotes it.
|
|
isFeatured :: Metadata -> Bool
|
|
isFeatured meta =
|
|
case KM.lookup "featured" meta of
|
|
Just (Bool True) -> True
|
|
Just (String "true") -> True
|
|
_ -> False
|
|
|
|
-- | True if a @recording@ key is present, or any movement has an @audio@ key.
|
|
hasRecordingMeta :: Metadata -> Bool
|
|
hasRecordingMeta meta =
|
|
KM.member "recording" meta || anyMovHasAudio meta
|
|
where
|
|
anyMovHasAudio m =
|
|
case KM.lookup "movements" m of
|
|
Just (Array v) -> any movHasAudio (V.toList v)
|
|
_ -> False
|
|
movHasAudio (Object o) = KM.member "audio" o
|
|
movHasAudio _ = False
|
|
|
|
-- | Parse a year: accepts Number (e.g. @year: 2019@) or String.
|
|
parseYear :: Metadata -> Maybe String
|
|
parseYear meta =
|
|
case KM.lookup "year" meta of
|
|
Just (Number n) -> Just $ show (floor (fromRational (toRational n) :: Double) :: Int)
|
|
Just (String t) -> Just (T.unpack t)
|
|
_ -> Nothing
|
|
|
|
parseCatalogEntry :: Item String -> Compiler (Maybe CatalogEntry)
|
|
parseCatalogEntry item = do
|
|
meta <- getMetadata (itemIdentifier item)
|
|
mRoute <- getRoute (itemIdentifier item)
|
|
case mRoute of
|
|
Nothing -> return Nothing
|
|
Just r -> do
|
|
let title = fromMaybe "(untitled)" (lookupString "title" meta)
|
|
url = "/" ++ r
|
|
year = parseYear meta
|
|
dur = lookupString "duration" meta
|
|
instr = lookupString "instrumentation" meta
|
|
cat = fromMaybe "other" (lookupString "category" meta)
|
|
return $ Just CatalogEntry
|
|
{ ceTitle = title
|
|
, ceUrl = url
|
|
, ceYear = year
|
|
, ceDuration = dur
|
|
, ceInstrumentation = instr
|
|
, ceCategory = cat
|
|
, ceFeatured = isFeatured meta
|
|
, ceHasScore = not (null (fromMaybe [] (lookupStringList "score-pages" meta)))
|
|
, ceHasRecording = hasRecordingMeta meta
|
|
}
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- HTML rendering
|
|
-- ---------------------------------------------------------------------------
|
|
--
|
|
-- Trust model: per the site convention (see also Stats.hs:pageLink),
|
|
-- frontmatter @title@ values are author-controlled trusted HTML and may
|
|
-- contain inline markup such as @<em>...</em>@. They are emitted
|
|
-- pre-escaped — but we still escape every other interpolated frontmatter
|
|
-- value (year, duration, instrumentation) and sanitize hrefs through
|
|
-- 'safeHref', so a stray @<@ in those fields cannot break the markup.
|
|
|
|
-- | Defense-in-depth href sanitiser. Mirrors 'Stats.isSafeUrl'.
|
|
safeHref :: String -> String
|
|
safeHref u =
|
|
let norm = map toLower (dropWhile isSpace u)
|
|
in if not ("//" `isPrefixOf` norm)
|
|
&& any (`isPrefixOf` norm) ["/", "https://", "mailto:", "#"]
|
|
then escAttr u
|
|
else "#"
|
|
|
|
escAttr :: String -> String
|
|
escAttr = concatMap esc
|
|
where
|
|
esc '&' = "&"
|
|
esc '<' = "<"
|
|
esc '>' = ">"
|
|
esc '"' = """
|
|
esc '\'' = "'"
|
|
esc c = [c]
|
|
|
|
escText :: String -> String
|
|
escText = concatMap esc
|
|
where
|
|
esc '&' = "&"
|
|
esc '<' = "<"
|
|
esc '>' = ">"
|
|
esc c = [c]
|
|
|
|
renderIndicators :: CatalogEntry -> String
|
|
renderIndicators e = concatMap render
|
|
[ (ceHasScore e, "<span class=\"catalog-ind\" title=\"Score available\">◼</span>")
|
|
, (ceHasRecording e, "<span class=\"catalog-ind\" title=\"Recording available\">♪</span>")
|
|
]
|
|
where
|
|
render (True, s) = s
|
|
render (False, _) = ""
|
|
|
|
renderEntry :: CatalogEntry -> String
|
|
renderEntry e = concat
|
|
[ "<li class=\"catalog-entry\">"
|
|
, "<div class=\"catalog-entry-main\">"
|
|
, "<a class=\"catalog-title\" href=\"", safeHref (ceUrl e), "\">"
|
|
, ceTitle e
|
|
, "</a>"
|
|
, renderIndicators e
|
|
, maybe "" (\y -> "<span class=\"catalog-year\">" ++ escText y ++ "</span>") (ceYear e)
|
|
, maybe "" (\d -> "<span class=\"catalog-duration\">" ++ escText d ++ "</span>") (ceDuration e)
|
|
, "</div>"
|
|
, maybe "" (\i -> "<div class=\"catalog-instrumentation\">" ++ escText i ++ "</div>") (ceInstrumentation e)
|
|
, "</li>"
|
|
]
|
|
|
|
renderCategorySection :: String -> [CatalogEntry] -> String
|
|
renderCategorySection cat entries = concat
|
|
[ "<section class=\"catalog-section\">"
|
|
, "<h2 class=\"catalog-section-title\">", escText (categoryLabel cat), "</h2>"
|
|
, "<ul class=\"catalog-list\">"
|
|
, concatMap renderEntry entries
|
|
, "</ul>"
|
|
, "</section>"
|
|
]
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Load all compositions (excluding the catalog index itself)
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
loadEntries :: Compiler [CatalogEntry]
|
|
loadEntries = do
|
|
items <- loadAll ("content/music/*/index.md" .&&. hasNoVersion)
|
|
mItems <- mapM parseCatalogEntry items
|
|
return [e | Just e <- mItems]
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Context fields
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- | @$featured-works$@: HTML list of featured entries; noResult when none.
|
|
featuredWorksField :: Context String
|
|
featuredWorksField = field "featured-works" $ \_ -> do
|
|
entries <- loadEntries
|
|
let featured = filter ceFeatured entries
|
|
if null featured
|
|
then fail "no featured works"
|
|
else return $
|
|
"<ul class=\"catalog-list catalog-featured-list\">"
|
|
++ concatMap renderEntry featured
|
|
++ "</ul>"
|
|
|
|
-- | @$has-featured$@: present when at least one composition is featured.
|
|
hasFeaturedField :: Context String
|
|
hasFeaturedField = field "has-featured" $ \_ -> do
|
|
entries <- loadEntries
|
|
if any ceFeatured entries then return "true" else fail "no featured works"
|
|
|
|
-- | @$catalog-by-category$@: HTML for all category sections.
|
|
-- Sorted by canonical category order; if no compositions exist yet,
|
|
-- returns a placeholder paragraph.
|
|
catalogByCategoryField :: Context String
|
|
catalogByCategoryField = field "catalog-by-category" $ \_ -> do
|
|
entries <- loadEntries
|
|
if null entries
|
|
then return "<p class=\"catalog-empty\">Works forthcoming.</p>"
|
|
else do
|
|
let sorted = sortBy (comparing (categoryRank . ceCategory)) entries
|
|
grouped = groupBy (\a b -> ceCategory a == ceCategory b) sorted
|
|
return $ concatMap renderGroup grouped
|
|
where
|
|
-- groupBy on a non-empty list yields non-empty sublists, but pattern
|
|
-- matching is total whereas 'head' is not.
|
|
renderGroup [] = ""
|
|
renderGroup g@(e : _) = renderCategorySection (ceCategory e) g
|
|
|
|
musicCatalogCtx :: Context String
|
|
musicCatalogCtx =
|
|
constField "catalog" "true"
|
|
<> hasFeaturedField
|
|
<> featuredWorksField
|
|
<> catalogByCategoryField
|
|
<> siteCtx
|