DGNum/dgnum.eu
11
1
Fork 0
Code Issues 4 Pull requests Actions Packages Projects Releases Wiki Activity

ssg: Update and add comments

Browse source
This commit is contained in:
Tom Hubrecht 2023-06-21 15:04:16 +02:00
parent 5cf5768cef
commit 0047a58248
2 changed files with 232 additions and 183 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
site/default.nix
View file

@ -10,6 +10,6 @@ stdenv.mkDerivation {
${ssg}/bin/ssg build ${ssg}/bin/ssg build
''; '';
installPhase = '' installPhase = ''
cp -av result $out cp -av _site $out
''; '';
} }

413
ssg/ssg.hs
View file

@ -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) -- Copyright 2023 Gabriel Doriath Döhler, Délégation Générale Numérique (DGNum)
{-# LANGUAGE OverloadedStrings #-}
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad ((<=<), void) import Control.Monad (void, (<=<))
import Data.Monoid (First(..))
import Data.List (intersperse) import Data.List (intersperse)
import Data.Monoid (First (..))
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 Hakyll 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 :: Int
nbPostsHome = 30 nbPostsHome = 10
patternFrom :: [String] -> [String] -> Pattern patternFrom :: [String] -> [String] -> Pattern
patternFrom basenames extensions = patternFrom basenames extensions =
foldl1 (.||.) $ map aux basenames foldl1 (.||.) $ map aux basenames
where where
aux basename = aux basename =
foldl1 (.||.) $ map (fromGlob . (++) (basename ++ "/**.")) extensions foldl1 (.||.) $ map (fromGlob . (++) "./**.") extensions
postPattern :: Pattern postPattern :: Pattern
postPattern = patternFrom [ "posts" ] [ "md" ] postPattern = fromGlob "posts/**.md"
imgPattern :: Pattern filePattern :: Pattern
imgPattern = patternFrom [ ".", "images" ] [ "png", "jpeg", "jpg", "gif", "svg", "ico" ] filePattern =
patternFrom
docPattern :: Pattern ["."]
docPattern = patternFrom [ ".", "docs" ] [ "pdf", "ps", "djvu", "tex", "txt" ] [ "djvu",
.||. patternFrom [ "docs" ] [ "md" ] "gif",
"ico",
miscPattern :: Pattern "jpeg",
miscPattern = foldl1 (.||.) [ "about.md", "services.md", "FAQ.md", "contact.md" ] "jpg",
"pdf",
"png",
"ps",
"svg",
"tex",
"txt"
]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
main :: IO () main :: IO ()
main = hakyllWith config $ do main = hakyll $ do
tags <- extractTags tags <- extractMeta "tags"
authors <- extractAuthors authors <- extractMeta "authors"
poles <- extractPoles poles <- extractMeta "poles"
tagsRules tags $ \tagStr tagsPattern -> do -- Static files
let title = "Articles appartenant à la catégorie \"" ++ tagStr ++ "\"" 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 route idRoute
compile $ do compile $ do
posts <- loadAll tagsPattern >>= recentFirst allPosts <- recentFirst =<< loadAll ("posts/**.md" .&&. hasNoVersion)
let posts = take nbPostsHome allPosts
let ctx = let ctx =
constField "title" title listField "posts" postCtx (return posts)
<> listField "posts" postCtx (return posts)
<> context <> context
makeItem "" getResourceBody
>>= loadAndApplyTemplate "templates/tag.html" ctx >>= applyAsTemplate ctx
>>= loadAndApplyTemplate "templates/default.html" ctx >>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls >>= 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 tagsRules authors $ \authorStr authorsPattern -> do
let title = "Articles (co-)écrit par \"" ++ authorStr ++ "\"" let title = "Articles écrits par « " ++ authorStr ++ " »"
route idRoute route idRoute
compile $ do compile $ do
posts <- loadAll authorsPattern >>= recentFirst posts <- loadAll authorsPattern >>= recentFirst
@ -74,121 +166,126 @@ main = hakyllWith config $ do
<> context <> context
makeItem "" makeItem ""
>>= loadAndApplyTemplate "templates/author.html" ctx >>= loadAndApplyTemplate "templates/author.html" ctx
>>= loadAndApplyTemplate "templates/default.html" ctx >>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls >>= relativizeUrls
tagsRules poles $ \poleStr polesPattern -> do create ["authors.html"] $ do
let title = "Articles du pôle \"" ++ poleStr ++ "\"" route idRoute
compile (authorPanelCompiler authors)
-- Tags
tagsRules tags $ \tagStr tagsPattern -> do
let title = "Articles relatifs à « " ++ tagStr ++ " »"
route idRoute route idRoute
compile $ do compile $ do
posts <- loadAll polesPattern >>= recentFirst posts <- loadAll tagsPattern >>= recentFirst
let ctx = let ctx =
constField "title" title constField "title" title
<> listField "posts" postCtx (return posts) <> listField "posts" postCtx (return posts)
<> context <> context
makeItem "" makeItem ""
>>= loadAndApplyTemplate "templates/pole.html" ctx >>= loadAndApplyTemplate "templates/tag.html" ctx
>>= loadAndApplyTemplate "templates/default.html" ctx >>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls >>= relativizeUrls
create [ "tags.html" ] $ do create ["tags.html"] $ do
route idRoute 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 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 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 -> Maybe [Inline]
abstract (Pandoc _ blocks) = abstract (Pandoc _ blocks) =
markedUp blocks <|> fallback blocks markedUp blocks <|> fallback blocks
where where
markedUp = fmap getFirst . query $ \inl -> case inl of markedUp = fmap getFirst . query $ \case
Span (_, cls, _) inls | "abstract" `elem` cls -> First (Just inls) Span (_, cls, _) inls | "abstract" `elem` cls -> First (Just inls)
_ -> mempty _ -> mempty
fallback (Para inlines : Header _ _ _ : _) = Just inlines fallback (Para inlines : Header {} : _) = Just inlines
fallback (_ : t) = fallback t fallback (_ : t) = fallback t
fallback [] = Nothing fallback [] = Nothing
customPandocCompiler :: Compiler (Item String) customPandocCompiler :: Compiler (Item String)
customPandocCompiler = pandocCompilerWithTransformM customPandocCompiler =
defaultHakyllReaderOptions pandocCompilerWithTransformM
defaultHakyllWriterOptions { writerHTMLMathMethod = MathML } defaultHakyllReaderOptions
(\pandoc -> do defaultHakyllWriterOptions {writerHTMLMathMethod = MathML}
let render = fmap writePandoc . makeItem . Pandoc mempty . pure . Plain ( \pandoc -> do
maybe let render = fmap writePandoc . makeItem . Pandoc mempty . pure . Plain
(pure ()) maybe
(void . (saveSnapshot "abstract" <=< render)) (pure ())
(abstract pandoc) (void . (saveSnapshot "abstract" <=< render))
pure $ addSectionLinks pandoc (abstract pandoc)
) >>= relativizeUrls pure $ addSectionLinks pandoc
)
>>= relativizeUrls
addSectionLinks :: Pandoc -> Pandoc addSectionLinks :: Pandoc -> Pandoc
addSectionLinks = walk f where addSectionLinks = walk f
f (Header n attr@(idAttr, _, _) inlines) = where
let link = Link ("", ["section"], []) [Str "§"] ("#" <> idAttr, "") f (Header n attr@(idAttr, _, _) inlines) =
in Header n attr ([link, Space] <> inlines) let link = Link ("", [""], []) [Str "§"] ("#" <> idAttr, "")
f x = x in Header n attr ([link, Space] <> inlines)
f x = x
snapshotField :: String -> Snapshot -> Context String snapshotField :: String -> Snapshot -> Context String
snapshotField key snap = field key $ \item -> snapshotField key snap = field key $ \item ->
@ -197,76 +294,28 @@ snapshotField key snap = field key $ \item ->
context :: Context String context :: Context String
context = context =
mapContext escapeHtml metadataField mapContext escapeHtml metadataField
<> snapshotField "abstract" "abstract" <> snapshotField "abstract" "abstract"
<> defaultContext <> defaultContext
postCtx :: Context String postCtx :: Context String
postCtx = postCtx =
dateField "date" "%Y-%m-%d" dateField "date" "%d/%m/%Y"
<> context <> context
postCtxWith :: Tags -> Tags -> Tags -> Context String postCtxWith :: Tags -> Tags -> Tags -> Context String
postCtxWith tags authors poles postCtxWith tags authors poles =
= tagsFieldWith getPoles simpleRenderLink (mconcat . intersperse ", ") "poles" poles tagsFieldWith (getTagsByField "poles") 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 (getTagsByField "authors") simpleRenderLink (mconcat . (\l -> if null l 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 <> tagsFieldWith (getTagsByField "authors") licenseRenderLink (mconcat . intersperse ", " . (\l -> if null l then [] else l ++ [H.toHtml ("and" :: String)])) "authorLicense" authors
<> tagsField "tags" tags <> tagsField "tags" tags
<> postCtx <> postCtx
tagCompiler :: String -> Compiler (Item String) simpleRenderLink :: String -> Maybe FilePath -> Maybe H.Html
tagCompiler tags =
makeItem ""
>>= loadAndApplyTemplate "templates/tags.html" ctx
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls
where
prettyTags = replaceAll ", " (const "</li><li>") tags
ctx = constField "title" "Toutes les catégories" <> constField "alltags" prettyTags <> context
authorCompiler :: String -> Compiler (Item String)
authorCompiler authors =
makeItem ""
>>= loadAndApplyTemplate "templates/authors.html" ctx
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls
where
prettyAuthors = replaceAll ", " (const "</li><li>") authors
ctx = constField "title" "Tout les (co-)auteurs" <> constField "allauthors" prettyAuthors <> context
getAuthors :: MonadMetadata m => Identifier -> m [String]
getAuthors identifier = do
metadata <- getMetadata identifier
return $ maybe [] (map trim . splitAll ",") $ lookupString "author" metadata
getPoles :: MonadMetadata m => Identifier -> m [String]
getPoles identifier = do
metadata <- getMetadata identifier
return $ maybe [] (map trim . splitAll ",") $ lookupString "poles" metadata
extractTags :: Rules Tags
extractTags = do
tags <- buildTags postPattern $ fromCapture "tags/*.html"
return $ sortTagsBy caseInsensitiveTags tags
extractAuthors :: Rules Tags
extractAuthors = do
authors <- buildTagsWith getAuthors postPattern $ fromCapture "authors/*.html"
return $ sortTagsBy caseInsensitiveTags authors
extractPoles :: Rules Tags
extractPoles = do
poles <- buildTagsWith getPoles postPattern $ fromCapture "poles/*.html"
return $ sortTagsBy caseInsensitiveTags poles
simpleRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html
simpleRenderLink _ Nothing = Nothing simpleRenderLink _ Nothing = Nothing
simpleRenderLink tag (Just filePath) = simpleRenderLink tag (Just filePath) =
Just $ H.a H.! A.href (H.toValue $ toUrl filePath) $ H.toHtml tag Just $ H.a H.! A.href (H.toValue $ toUrl filePath) $ H.toHtml tag
licenseRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html licenseRenderLink :: String -> Maybe FilePath -> Maybe H.Html
licenseRenderLink _ Nothing = Nothing licenseRenderLink _ Nothing = Nothing
licenseRenderLink tag (Just filePath) = licenseRenderLink tag (Just filePath) =
Just $ H.a H.! A.href (H.toValue $ toUrl filePath) H.! A.rel "cc:attributionURL dct:creator" $ H.toHtml tag Just $ H.a H.! A.href (H.toValue $ toUrl filePath) H.! A.rel "cc:attributionURL dct:creator" $ H.toHtml tag
config :: Configuration
config = defaultConfiguration { destinationDirectory = "result" }