ssg: Update and add comments

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

View file

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

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)
{-# 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
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
@ -78,100 +170,103 @@ main = hakyllWith config $ do
>>= 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
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"
--------------------------------------------------------------------------------
-- 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/archive.html" archiveCtx
>>= loadAndApplyTemplate "templates/default.html" archiveCtx
>>= loadAndApplyTemplate "templates/authors.html" ctx
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= 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"
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
getResourceBody
>>= applyAsTemplate indexCtx
>>= loadAndApplyTemplate "templates/default.html" indexCtx
makeItem ""
>>= loadAndApplyTemplate "templates/tags.html" ctx
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls
match "templates/*.html" $ compile templateBodyCompiler
--------------------------------------------------------------------------------
-- 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
markedUp = fmap getFirst . query $ \case
Span (_, cls, _) inls | "abstract" `elem` cls -> First (Just inls)
_ -> mempty
fallback (Para inlines : Header _ _ _ : _) = Just inlines
fallback (Para inlines : Header {} : _) = Just inlines
fallback (_ : t) = fallback t
fallback [] = Nothing
customPandocCompiler :: Compiler (Item String)
customPandocCompiler = pandocCompilerWithTransformM
customPandocCompiler =
pandocCompilerWithTransformM
defaultHakyllReaderOptions
defaultHakyllWriterOptions {writerHTMLMathMethod = MathML}
( \pandoc -> do
@ -181,12 +276,14 @@ customPandocCompiler = pandocCompilerWithTransformM
(void . (saveSnapshot "abstract" <=< render))
(abstract pandoc)
pure $ addSectionLinks pandoc
) >>= relativizeUrls
)
>>= relativizeUrls
addSectionLinks :: Pandoc -> Pandoc
addSectionLinks = walk f where
addSectionLinks = walk f
where
f (Header n attr@(idAttr, _, _) inlines) =
let link = Link ("", ["section"], []) [Str "§"] ("#" <> idAttr, "")
let link = Link ("", [""], []) [Str "§"] ("#" <> idAttr, "")
in Header n attr ([link, Space] <> inlines)
f x = x
@ -202,71 +299,23 @@ context =
postCtx :: Context String
postCtx =
dateField "date" "%Y-%m-%d"
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
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 "</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 :: String -> Maybe FilePath -> Maybe H.Html
simpleRenderLink _ Nothing = Nothing
simpleRenderLink tag (Just filePath) =
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 tag (Just filePath) =
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" }