ssg: Update and add comments
This commit is contained in:
Tom Hubrecht
parent
5cf5768cef
commit
0047a58248
2 changed files with 232 additions and 183 deletions
|
|
@ -10,6 +10,6 @@ stdenv.mkDerivation {
|
|||
${ssg}/bin/ssg build
|
||||
'';
|
||||
installPhase = ''
|
||||
cp -av result $out
|
||||
cp -av _site $out
|
||||
'';
|
||||
}
|
||||
|
|
|
|||
413
ssg/ssg.hs
413
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 "</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" }
|
||||
|
|
|
|||
Loading…
Reference in a new issue