diff --git a/site/default.nix b/site/default.nix index 0304e13..5b29c49 100644 --- a/site/default.nix +++ b/site/default.nix @@ -10,6 +10,6 @@ stdenv.mkDerivation { ${ssg}/bin/ssg build ''; installPhase = '' - cp -av result $out + cp -av _site $out ''; } diff --git a/ssg/ssg.hs b/ssg/ssg.hs index dad4e25..fe9a909 100644 --- a/ssg/ssg.hs +++ b/ssg/ssg.hs @@ -1,70 +1,162 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + -- Copyright 2023 Gabriel Doriath Döhler, Délégation Générale Numérique (DGNum) -{-# LANGUAGE OverloadedStrings #-} - import Control.Applicative ((<|>)) -import Control.Monad ((<=<), void) -import Data.Monoid (First(..)) +import Control.Monad (void, (<=<)) import Data.List (intersperse) - -import qualified Text.Blaze.Html5 as H -import qualified Text.Blaze.Html5.Attributes as A -import Text.Pandoc.Walk (query, walk) -import Text.Pandoc.Definition - ( Pandoc(..), Block(Header, Para, Plain), Inline(..) ) -import Text.Pandoc.Options ( WriterOptions(..), HTMLMathMethod( MathML ) ) +import Data.Monoid (First (..)) import Hakyll +import Text.Blaze.Html.Renderer.String (renderHtml) +import Text.Blaze.Html5 qualified as H +import Text.Blaze.Html5.Attributes qualified as A +import Text.Pandoc.Definition + ( Block (Header, Para, Plain), + Inline (..), + Pandoc (..), + ) +import Text.Pandoc.Options (HTMLMathMethod (MathML), WriterOptions (..)) +import Text.Pandoc.Walk (query, walk) -------------------------------------------------------------------------------- nbPostsHome :: Int -nbPostsHome = 30 +nbPostsHome = 10 patternFrom :: [String] -> [String] -> Pattern patternFrom basenames extensions = foldl1 (.||.) $ map aux basenames where - aux basename = - foldl1 (.||.) $ map (fromGlob . (++) (basename ++ "/**.")) extensions + aux basename = + foldl1 (.||.) $ map (fromGlob . (++) "./**.") extensions postPattern :: Pattern -postPattern = patternFrom [ "posts" ] [ "md" ] +postPattern = fromGlob "posts/**.md" -imgPattern :: Pattern -imgPattern = patternFrom [ ".", "images" ] [ "png", "jpeg", "jpg", "gif", "svg", "ico" ] - -docPattern :: Pattern -docPattern = patternFrom [ ".", "docs" ] [ "pdf", "ps", "djvu", "tex", "txt" ] - .||. patternFrom [ "docs" ] [ "md" ] - -miscPattern :: Pattern -miscPattern = foldl1 (.||.) [ "about.md", "services.md", "FAQ.md", "contact.md" ] +filePattern :: Pattern +filePattern = + patternFrom + ["."] + [ "djvu", + "gif", + "ico", + "jpeg", + "jpg", + "pdf", + "png", + "ps", + "svg", + "tex", + "txt" + ] -------------------------------------------------------------------------------- main :: IO () -main = hakyllWith config $ do - tags <- extractTags - authors <- extractAuthors - poles <- extractPoles +main = hakyll $ do + tags <- extractMeta "tags" + authors <- extractMeta "authors" + poles <- extractMeta "poles" - tagsRules tags $ \tagStr tagsPattern -> do - let title = "Articles appartenant à la catégorie \"" ++ tagStr ++ "\"" + -- Static files + match ("vendor/**" .||. "images/**" .||. "documents/**" .||. filePattern) $ do + route idRoute + compile copyFileCompiler + + -- Minified CSS and JS + match ("js/*.min.js" .||. "css/*.min.css") $ do + route idRoute + compile copyFileCompiler + + -- Regular CSS + match "css/*.css" $ do + route idRoute + compile compressCssCompiler + + -- Index page + match "index.html" $ do route idRoute compile $ do - posts <- loadAll tagsPattern >>= recentFirst + allPosts <- recentFirst =<< loadAll ("posts/**.md" .&&. hasNoVersion) + let posts = take nbPostsHome allPosts let ctx = - constField "title" title - <> listField "posts" postCtx (return posts) + listField "posts" postCtx (return posts) <> context - makeItem "" - >>= loadAndApplyTemplate "templates/tag.html" ctx + getResourceBody + >>= applyAsTemplate ctx >>= loadAndApplyTemplate "templates/default.html" ctx >>= relativizeUrls + -- Regular pages + match "about.html" $ do + route idRoute + compile $ do + getResourceBody + >>= applyAsTemplate context + >>= loadAndApplyTemplate "templates/default.html" context + >>= relativizeUrls + + match ("faq.md" .||. "services.md" .||. "contact.md") $ do + route $ setExtension "html" + compile $ + customPandocCompiler + >>= loadAndApplyTemplate "templates/default.html" (postCtxWith tags authors poles) + >>= relativizeUrls + + -- Archives (i.e. list of all posts) + match "archives.html" $ do + route idRoute + compile $ do + allPosts <- recentFirst =<< loadAll ("posts/**.md" .&&. hasNoVersion) + let ctx = + listField "posts" postCtx (return allPosts) + <> context + + getResourceBody + >>= applyAsTemplate ctx + >>= loadAndApplyTemplate "templates/default.html" ctx + >>= relativizeUrls + + -- Invidual posts + match "posts/**.md" $ do + route $ setExtension "html" + compile $ + customPandocCompiler + >>= loadAndApplyTemplate "templates/post.html" (postCtxWith tags authors poles) + >>= loadAndApplyTemplate "templates/default.html" (postCtxWith tags authors poles) + >>= relativizeUrls + + -- Divisions + tagsRules poles $ \_ polesPattern -> do + route idRoute + compile $ do + posts <- loadAll polesPattern >>= recentFirst + let ctx = + listField "posts" postCtx (return posts) + <> context + + getResourceBody + >>= applyAsTemplate ctx + >>= loadAndApplyTemplate "templates/division.html" ctx + >>= loadAndApplyTemplate "templates/default.html" ctx + >>= relativizeUrls + + match "poles/*.html" $ do + route idRoute + compile $ do + getResourceBody + >>= applyAsTemplate context + >>= loadAndApplyTemplate "templates/division.html" context + >>= loadAndApplyTemplate "templates/default.html" context + >>= relativizeUrls + + -- Authors tagsRules authors $ \authorStr authorsPattern -> do - let title = "Articles (co-)écrit par \"" ++ authorStr ++ "\"" + let title = "Articles écrits par « " ++ authorStr ++ " »" route idRoute compile $ do posts <- loadAll authorsPattern >>= recentFirst @@ -74,121 +166,126 @@ main = hakyllWith config $ do <> context makeItem "" - >>= loadAndApplyTemplate "templates/author.html" ctx + >>= loadAndApplyTemplate "templates/author.html" ctx >>= loadAndApplyTemplate "templates/default.html" ctx >>= relativizeUrls - tagsRules poles $ \poleStr polesPattern -> do - let title = "Articles du pôle \"" ++ poleStr ++ "\"" + create ["authors.html"] $ do + route idRoute + compile (authorPanelCompiler authors) + + -- Tags + tagsRules tags $ \tagStr tagsPattern -> do + let title = "Articles relatifs à « " ++ tagStr ++ " »" route idRoute compile $ do - posts <- loadAll polesPattern >>= recentFirst + posts <- loadAll tagsPattern >>= recentFirst let ctx = constField "title" title <> listField "posts" postCtx (return posts) <> context makeItem "" - >>= loadAndApplyTemplate "templates/pole.html" ctx + >>= loadAndApplyTemplate "templates/tag.html" ctx >>= loadAndApplyTemplate "templates/default.html" ctx >>= relativizeUrls - create [ "tags.html" ] $ do + create ["tags.html"] $ do route idRoute - compile $ renderTagList tags >>= tagCompiler + compile (tagPanelCompiler tags) - create [ "authors.html" ] $ do + -- Partial templates to be used elsewhere + match "templates/*" $ compile templateBodyCompiler + + -- Markdown version of posts + match "posts/**.md" $ version "raw" $ do route idRoute - compile $ renderTagList authors >>= authorCompiler - - match (imgPattern .||. docPattern) $ do - route idRoute - compile copyFileCompiler - - match "css/*.css" $ do - route idRoute - compile compressCssCompiler - - match miscPattern $ do - route $ setExtension "html" - compile $ customPandocCompiler - >>= loadAndApplyTemplate "templates/default.html" context - >>= relativizeUrls - - match postPattern $ do - route $ setExtension "html" - compile $ customPandocCompiler - >>= loadAndApplyTemplate "templates/post.html" (postCtxWith tags authors poles) - >>= loadAndApplyTemplate "templates/default.html" (postCtxWith tags authors poles) - >>= relativizeUrls - - match (postPattern .||. miscPattern) $ version "raw" $ do - route $ setExtension "md" compile $ getResourceBody >>= relativizeUrls - create [ "archive.html" ] $ do - route idRoute - compile $ do - posts <- recentFirst =<< loadAll (postPattern .&&. hasNoVersion) - let archiveCtx = - listField "posts" postCtx (return posts) - <> constField "title" "Archives" - <> context - - makeItem "" - >>= loadAndApplyTemplate "templates/archive.html" archiveCtx - >>= loadAndApplyTemplate "templates/default.html" archiveCtx - >>= relativizeUrls - - match "index.html" $ do - route idRoute - compile $ do - allPosts <- recentFirst =<< loadAll (postPattern .&&. hasNoVersion) - let posts = take nbPostsHome allPosts - let indexCtx = - listField "posts" postCtx (return posts) - <> constField "title" "Accueil" - <> context - - getResourceBody - >>= applyAsTemplate indexCtx - >>= loadAndApplyTemplate "templates/default.html" indexCtx - >>= relativizeUrls - - match "templates/*.html" $ compile templateBodyCompiler - -------------------------------------------------------------------------------- +-- Metadata extraction +extractMeta :: String -> Rules Tags +extractMeta name = do + tags <- buildTagsWith (getTagsByField name) postPattern (fromCapture (fromGlob (name ++ "/*.html"))) + return (sortTagsBy caseInsensitiveTags tags) + +-- Renderers +makeAuthorPanelLink :: String -> String -> Int -> Int -> Int -> String +makeAuthorPanelLink author url count _ _ = + renderHtml $ H.a H.! A.href (H.toValue url) H.! A.class_ "panel-block" $ do + H.span H.! A.class_ "tag mr-3" $ H.toHtml (pluralize count "publication") + H.toHtml author + +authorPanelCompiler :: Tags -> Compiler (Item String) +authorPanelCompiler authors = do + let ctx = + field "authors" (\_ -> renderTags makeAuthorPanelLink (mconcat . intersperse "\n") authors) + <> constField "title" "Liste des auteur·e·s" + <> context + + makeItem "" + >>= loadAndApplyTemplate "templates/authors.html" ctx + >>= loadAndApplyTemplate "templates/default.html" ctx + >>= relativizeUrls + +makeTagPanelLink :: String -> String -> Int -> Int -> Int -> String +makeTagPanelLink tag url count _ _ = + renderHtml $ H.a H.! A.href (H.toValue url) H.! A.class_ "panel-block" $ do + H.span H.! A.class_ "tag mr-3" $ H.toHtml (pluralize count "publication") + H.toHtml tag + +tagPanelCompiler :: Tags -> Compiler (Item String) +tagPanelCompiler tags = do + let ctx = + field "tags" (\_ -> renderTags makeTagPanelLink (mconcat . intersperse "\n") tags) + <> constField "title" "Liste des catégories" + <> context + + makeItem "" + >>= loadAndApplyTemplate "templates/tags.html" ctx + >>= loadAndApplyTemplate "templates/default.html" ctx + >>= relativizeUrls + +-- Utility functions +pluralize :: Int -> String -> String +pluralize count str = case count of + 1 -> show count ++ " " ++ str + _ -> show count ++ " " ++ str ++ "s" + abstract :: Pandoc -> Maybe [Inline] abstract (Pandoc _ blocks) = markedUp blocks <|> fallback blocks where - markedUp = fmap getFirst . query $ \inl -> case inl of - Span (_, cls, _) inls | "abstract" `elem` cls -> First (Just inls) - _ -> mempty - fallback (Para inlines : Header _ _ _ : _) = Just inlines - fallback (_ : t) = fallback t - fallback [] = Nothing + markedUp = fmap getFirst . query $ \case + Span (_, cls, _) inls | "abstract" `elem` cls -> First (Just inls) + _ -> mempty + fallback (Para inlines : Header {} : _) = Just inlines + fallback (_ : t) = fallback t + fallback [] = Nothing customPandocCompiler :: Compiler (Item String) -customPandocCompiler = pandocCompilerWithTransformM - defaultHakyllReaderOptions - defaultHakyllWriterOptions { writerHTMLMathMethod = MathML } - (\pandoc -> do - let render = fmap writePandoc . makeItem . Pandoc mempty . pure . Plain - maybe - (pure ()) - (void . (saveSnapshot "abstract" <=< render)) - (abstract pandoc) - pure $ addSectionLinks pandoc - ) >>= relativizeUrls +customPandocCompiler = + pandocCompilerWithTransformM + defaultHakyllReaderOptions + defaultHakyllWriterOptions {writerHTMLMathMethod = MathML} + ( \pandoc -> do + let render = fmap writePandoc . makeItem . Pandoc mempty . pure . Plain + maybe + (pure ()) + (void . (saveSnapshot "abstract" <=< render)) + (abstract pandoc) + pure $ addSectionLinks pandoc + ) + >>= relativizeUrls addSectionLinks :: Pandoc -> Pandoc -addSectionLinks = walk f where - f (Header n attr@(idAttr, _, _) inlines) = - let link = Link ("", ["section"], []) [Str "§"] ("#" <> idAttr, "") - in Header n attr ([link, Space] <> inlines) - f x = x +addSectionLinks = walk f + where + f (Header n attr@(idAttr, _, _) inlines) = + let link = Link ("", [""], []) [Str "§"] ("#" <> idAttr, "") + in Header n attr ([link, Space] <> inlines) + f x = x snapshotField :: String -> Snapshot -> Context String snapshotField key snap = field key $ \item -> @@ -197,76 +294,28 @@ snapshotField key snap = field key $ \item -> context :: Context String context = mapContext escapeHtml metadataField - <> snapshotField "abstract" "abstract" - <> defaultContext + <> snapshotField "abstract" "abstract" + <> defaultContext postCtx :: Context String postCtx = - dateField "date" "%Y-%m-%d" - <> context + dateField "date" "%d/%m/%Y" + <> context postCtxWith :: Tags -> Tags -> Tags -> Context String -postCtxWith tags authors poles - = tagsFieldWith getPoles simpleRenderLink (mconcat . intersperse ", ") "poles" poles - <> tagsFieldWith getAuthors simpleRenderLink (mconcat . (\l -> if length l == 0 then [] else H.toHtml ("par " :: String):l) . intersperse ", ") "author" authors - <> tagsFieldWith getAuthors licenseRenderLink (mconcat . intersperse ", " . (\l -> if length l == 0 then [] else l ++ [H.toHtml ("and" :: String)])) "authorLicense" authors - <> tagsField "tags" tags - <> postCtx +postCtxWith tags authors poles = + tagsFieldWith (getTagsByField "poles") simpleRenderLink (mconcat . intersperse ", ") "poles" poles + <> tagsFieldWith (getTagsByField "authors") simpleRenderLink (mconcat . (\l -> if null l then [] else H.toHtml ("par " :: String) : l) . intersperse ", ") "author" authors + <> tagsFieldWith (getTagsByField "authors") licenseRenderLink (mconcat . intersperse ", " . (\l -> if null l then [] else l ++ [H.toHtml ("and" :: String)])) "authorLicense" authors + <> tagsField "tags" tags + <> postCtx -tagCompiler :: String -> Compiler (Item String) -tagCompiler tags = - makeItem "" - >>= loadAndApplyTemplate "templates/tags.html" ctx - >>= loadAndApplyTemplate "templates/default.html" ctx - >>= relativizeUrls - where - prettyTags = replaceAll ", " (const "