dgnum.eu/ssg/ssg.hs

380 lines
12 KiB
Haskell
Raw Normal View History

2023-06-21 15:04:16 +02:00
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
2023-06-14 01:59:59 +02:00
{-# LANGUAGE OverloadedStrings #-}
2023-06-21 15:04:16 +02:00
{-# LANGUAGE RankNTypes #-}
-- Copyright 2023 Gabriel Doriath Döhler, Délégation Générale Numérique (DGNum)
2023-06-14 01:59:59 +02:00
import Control.Applicative ((<|>))
2023-06-21 15:04:16 +02:00
import Control.Monad (void, (<=<))
2023-06-14 01:59:59 +02:00
import Data.List (intersperse)
2023-06-21 16:21:35 +02:00
import Data.Map qualified as M
2023-06-21 15:04:16 +02:00
import Data.Monoid (First (..))
2023-06-14 01:59:59 +02:00
import Hakyll
2023-06-21 15:04:16 +02:00
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)
2023-06-14 01:59:59 +02:00
--------------------------------------------------------------------------------
nbPostsHome :: Int
2023-06-21 15:04:16 +02:00
nbPostsHome = 10
2023-06-14 01:59:59 +02:00
2023-06-21 16:21:35 +02:00
poleName :: M.Map String String
poleName =
M.fromList
[ ("administration-systeme", "Administration Système"),
("communication", "Communication"),
("formation", "Formation"),
("geopolitique", "Géopolitique"),
("juridique", "Juridique"),
("logiciel", "Logiciel"),
("recherche", "Recherche")
]
2023-06-14 01:59:59 +02:00
patternFrom :: [String] -> [String] -> Pattern
patternFrom basenames extensions =
foldl1 (.||.) $ map aux basenames
where
2023-06-21 15:04:16 +02:00
aux basename =
foldl1 (.||.) $ map (fromGlob . (++) "./**.") extensions
2023-06-14 01:59:59 +02:00
postPattern :: Pattern
2023-06-21 15:04:16 +02:00
postPattern = fromGlob "posts/**.md"
filePattern :: Pattern
filePattern =
patternFrom
["."]
[ "djvu",
"gif",
"ico",
"jpeg",
"jpg",
"pdf",
"png",
"ps",
"svg",
"tex",
"txt"
]
2023-06-14 01:59:59 +02:00
2023-06-21 15:04:16 +02:00
--------------------------------------------------------------------------------
2023-06-14 01:59:59 +02:00
2023-06-21 15:04:16 +02:00
main :: IO ()
main = hakyll $ do
tags <- extractMeta "tags"
authors <- extractMeta "authors"
poles <- extractMeta "poles"
2023-06-14 01:59:59 +02:00
2023-06-21 15:04:16 +02:00
-- Static files
2023-06-30 13:44:16 +02:00
match ("vendor/**" .||. "images/**" .||. "documents/**" .||. ".domains" .||. filePattern) $ do
2023-06-21 15:04:16 +02:00
route idRoute
compile copyFileCompiler
2023-06-14 01:59:59 +02:00
2023-06-21 15:04:16 +02:00
-- Minified CSS and JS
match ("js/*.min.js" .||. "css/*.min.css") $ do
route idRoute
compile copyFileCompiler
2023-06-14 01:59:59 +02:00
2023-06-21 15:04:16 +02:00
-- Regular CSS
match "css/*.css" $ do
route idRoute
compile compressCssCompiler
2023-06-14 01:59:59 +02:00
2023-06-21 15:04:16 +02:00
-- Index page
match "index.html" $ do
2023-06-14 01:59:59 +02:00
route idRoute
compile $ do
2023-06-21 15:04:16 +02:00
allPosts <- recentFirst =<< loadAll ("posts/**.md" .&&. hasNoVersion)
let posts = take nbPostsHome allPosts
2023-06-14 01:59:59 +02:00
let ctx =
2023-06-21 15:04:16 +02:00
listField "posts" postCtx (return posts)
2023-06-14 01:59:59 +02:00
<> context
2023-06-21 15:04:16 +02:00
getResourceBody
>>= applyAsTemplate ctx
2023-06-14 01:59:59 +02:00
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls
2023-06-21 15:04:16 +02:00
-- Regular pages
match "about.html" $ do
2023-06-14 01:59:59 +02:00
route idRoute
compile $ do
2023-06-21 15:04:16 +02:00
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)
2023-06-14 01:59:59 +02:00
let ctx =
2023-06-21 15:04:16 +02:00
listField "posts" postCtx (return allPosts)
2023-06-14 01:59:59 +02:00
<> context
2023-06-21 15:04:16 +02:00
getResourceBody
>>= applyAsTemplate ctx
2023-06-14 01:59:59 +02:00
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls
2023-06-21 15:04:16 +02:00
-- 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
2023-06-14 01:59:59 +02:00
route idRoute
compile $ do
posts <- loadAll polesPattern >>= recentFirst
let ctx =
2023-06-21 15:04:16 +02:00
listField "posts" postCtx (return posts)
2023-06-14 01:59:59 +02:00
<> context
2023-06-21 15:04:16 +02:00
getResourceBody
>>= applyAsTemplate ctx
>>= loadAndApplyTemplate "templates/division.html" ctx
2023-06-14 01:59:59 +02:00
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls
2023-06-21 15:04:16 +02:00
match "poles/*.html" $ do
2023-06-14 01:59:59 +02:00
route idRoute
2023-06-21 15:04:16 +02:00
compile $ do
getResourceBody
>>= applyAsTemplate context
>>= loadAndApplyTemplate "templates/division.html" context
>>= loadAndApplyTemplate "templates/default.html" context
>>= relativizeUrls
2023-06-14 01:59:59 +02:00
2023-06-21 16:21:35 +02:00
create ["poles.html"] $ do
route idRoute
compile (polePanelCompiler poles)
2023-06-21 15:04:16 +02:00
-- Authors
tagsRules authors $ \authorStr authorsPattern -> do
let title = "Articles écrits par « " ++ authorStr ++ " »"
2023-06-14 01:59:59 +02:00
route idRoute
2023-06-21 15:04:16 +02:00
compile $ do
posts <- loadAll authorsPattern >>= recentFirst
let ctx =
constField "title" title
<> listField "posts" postCtx (return posts)
<> context
2023-06-14 01:59:59 +02:00
2023-06-21 15:04:16 +02:00
makeItem ""
>>= loadAndApplyTemplate "templates/author.html" ctx
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls
2023-06-14 01:59:59 +02:00
2023-06-21 15:04:16 +02:00
create ["authors.html"] $ do
route idRoute
compile (authorPanelCompiler authors)
2023-06-14 01:59:59 +02:00
2023-06-21 15:04:16 +02:00
-- Tags
tagsRules tags $ \tagStr tagsPattern -> do
let title = "Articles relatifs à « " ++ tagStr ++ " »"
2023-06-14 01:59:59 +02:00
route idRoute
compile $ do
2023-06-21 15:04:16 +02:00
posts <- loadAll tagsPattern >>= recentFirst
let ctx =
constField "title" title
<> listField "posts" postCtx (return posts)
<> context
2023-06-14 01:59:59 +02:00
makeItem ""
2023-06-21 15:04:16 +02:00
>>= loadAndApplyTemplate "templates/tag.html" ctx
>>= loadAndApplyTemplate "templates/default.html" ctx
2023-06-14 01:59:59 +02:00
>>= relativizeUrls
2023-06-21 15:04:16 +02:00
create ["tags.html"] $ do
2023-06-14 01:59:59 +02:00
route idRoute
2023-06-21 15:04:16 +02:00
compile (tagPanelCompiler tags)
2023-06-14 01:59:59 +02:00
2023-06-21 15:04:16 +02:00
-- Partial templates to be used elsewhere
match "templates/*" $ compile templateBodyCompiler
2023-06-14 01:59:59 +02:00
2023-06-21 15:04:16 +02:00
-- Markdown version of posts
match "posts/**.md" $ version "raw" $ do
route idRoute
compile $ getResourceBody >>= relativizeUrls
2023-06-14 01:59:59 +02:00
--------------------------------------------------------------------------------
2023-06-21 15:04:16 +02:00
-- 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
2023-06-21 16:21:35 +02:00
makePolePanelLink :: String -> String -> Int -> Int -> Int -> String
makePolePanelLink pole 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 (poleName M.! pole)
polePanelCompiler :: Tags -> Compiler (Item String)
polePanelCompiler poles = do
let ctx =
field "poles" (\_ -> renderTags makePolePanelLink (mconcat . intersperse "\n") poles)
<> constField "title" "Liste des pôles"
<> context
makeItem ""
>>= loadAndApplyTemplate "templates/poles.html" ctx
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls
2023-06-21 15:04:16 +02:00
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
2023-06-21 16:21:35 +02:00
renderTagLink :: String -> Maybe FilePath -> Maybe H.Html
renderTagLink _ Nothing = Nothing
renderTagLink tag (Just filePath) =
Just
$ H.a
H.! A.title (H.stringValue $ "Pages relatives à « " ++ tag ++ " »")
H.! A.class_ "tag is-link"
H.! A.href (H.toValue $ toUrl filePath)
$ H.toHtml tag
renderPoleLink :: String -> Maybe FilePath -> Maybe H.Html
renderPoleLink _ Nothing = Nothing
renderPoleLink pole (Just filePath) =
Just
$ H.a
H.! A.title (H.stringValue $ "Page du pôle « " ++ (poleName M.! pole) ++ " »")
H.! A.class_ "tag is-light has-text-dark"
H.! A.href (H.toValue $ toUrl filePath)
$ H.toHtml (poleName M.! pole)
makeTags :: [H.Html] -> H.Html
makeTags tags = H.div H.! A.class_ "tags mt-2" $ (mconcat . intersperse "\n") tags
2023-06-21 15:04:16 +02:00
-- Utility functions
pluralize :: Int -> String -> String
pluralize count str = case count of
1 -> show count ++ " " ++ str
_ -> show count ++ " " ++ str ++ "s"
2023-06-14 01:59:59 +02:00
abstract :: Pandoc -> Maybe [Inline]
abstract (Pandoc _ blocks) =
markedUp blocks <|> fallback blocks
where
2023-06-21 15:04:16 +02:00
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
2023-06-14 01:59:59 +02:00
customPandocCompiler :: Compiler (Item String)
2023-06-21 15:04:16 +02:00
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
2023-06-14 01:59:59 +02:00
addSectionLinks :: Pandoc -> Pandoc
2023-06-21 15:04:16 +02:00
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
2023-06-14 01:59:59 +02:00
snapshotField :: String -> Snapshot -> Context String
snapshotField key snap = field key $ \item ->
loadSnapshotBody (itemIdentifier item) snap
context :: Context String
context =
mapContext escapeHtml metadataField
2023-06-21 15:04:16 +02:00
<> snapshotField "abstract" "abstract"
<> defaultContext
2023-06-14 01:59:59 +02:00
postCtx :: Context String
postCtx =
2023-06-21 15:04:16 +02:00
dateField "date" "%d/%m/%Y"
<> context
2023-06-14 01:59:59 +02:00
postCtxWith :: Tags -> Tags -> Tags -> Context String
2023-06-21 15:04:16 +02:00
postCtxWith tags authors poles =
2023-06-21 16:21:35 +02:00
tagsFieldWith (getTagsByField "poles") renderPoleLink makeTags "poles" poles
2023-06-21 15:04:16 +02:00
<> 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
2023-06-21 16:21:35 +02:00
<> tagsFieldWith getTags renderTagLink makeTags "tags" tags
2023-06-21 15:04:16 +02:00
<> postCtx
simpleRenderLink :: String -> Maybe FilePath -> Maybe H.Html
2023-06-14 01:59:59 +02:00
simpleRenderLink _ Nothing = Nothing
simpleRenderLink tag (Just filePath) =
Just $ H.a H.! A.href (H.toValue $ toUrl filePath) $ H.toHtml tag
2023-06-21 15:04:16 +02:00
licenseRenderLink :: String -> Maybe FilePath -> Maybe H.Html
2023-06-14 01:59:59 +02:00
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