forked from DGNum/dgnum.eu
321 lines
9.9 KiB
Haskell
321 lines
9.9 KiB
Haskell
{-# LANGUAGE ImportQualifiedPost #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
-- Copyright 2023 Gabriel Doriath Döhler, Délégation Générale Numérique (DGNum)
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad (void, (<=<))
|
|
import Data.List (intersperse)
|
|
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 = 10
|
|
|
|
patternFrom :: [String] -> [String] -> Pattern
|
|
patternFrom basenames extensions =
|
|
foldl1 (.||.) $ map aux basenames
|
|
where
|
|
aux basename =
|
|
foldl1 (.||.) $ map (fromGlob . (++) "./**.") extensions
|
|
|
|
postPattern :: Pattern
|
|
postPattern = fromGlob "posts/**.md"
|
|
|
|
filePattern :: Pattern
|
|
filePattern =
|
|
patternFrom
|
|
["."]
|
|
[ "djvu",
|
|
"gif",
|
|
"ico",
|
|
"jpeg",
|
|
"jpg",
|
|
"pdf",
|
|
"png",
|
|
"ps",
|
|
"svg",
|
|
"tex",
|
|
"txt"
|
|
]
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
main :: IO ()
|
|
main = hakyll $ do
|
|
tags <- extractMeta "tags"
|
|
authors <- extractMeta "authors"
|
|
poles <- extractMeta "poles"
|
|
|
|
-- 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
|
|
allPosts <- recentFirst =<< loadAll ("posts/**.md" .&&. hasNoVersion)
|
|
let posts = take nbPostsHome allPosts
|
|
let ctx =
|
|
listField "posts" postCtx (return posts)
|
|
<> context
|
|
|
|
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 écrits par « " ++ authorStr ++ " »"
|
|
route idRoute
|
|
compile $ do
|
|
posts <- loadAll authorsPattern >>= recentFirst
|
|
let ctx =
|
|
constField "title" title
|
|
<> listField "posts" postCtx (return posts)
|
|
<> context
|
|
|
|
makeItem ""
|
|
>>= loadAndApplyTemplate "templates/author.html" ctx
|
|
>>= loadAndApplyTemplate "templates/default.html" ctx
|
|
>>= relativizeUrls
|
|
|
|
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 tagsPattern >>= recentFirst
|
|
let ctx =
|
|
constField "title" title
|
|
<> listField "posts" postCtx (return posts)
|
|
<> context
|
|
|
|
makeItem ""
|
|
>>= loadAndApplyTemplate "templates/tag.html" ctx
|
|
>>= loadAndApplyTemplate "templates/default.html" ctx
|
|
>>= relativizeUrls
|
|
|
|
create ["tags.html"] $ do
|
|
route idRoute
|
|
compile (tagPanelCompiler tags)
|
|
|
|
-- Partial templates to be used elsewhere
|
|
match "templates/*" $ compile templateBodyCompiler
|
|
|
|
-- Markdown version of posts
|
|
match "posts/**.md" $ version "raw" $ do
|
|
route idRoute
|
|
compile $ getResourceBody >>= relativizeUrls
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- 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 $ \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
|
|
|
|
addSectionLinks :: Pandoc -> Pandoc
|
|
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 ->
|
|
loadSnapshotBody (itemIdentifier item) snap
|
|
|
|
context :: Context String
|
|
context =
|
|
mapContext escapeHtml metadataField
|
|
<> snapshotField "abstract" "abstract"
|
|
<> defaultContext
|
|
|
|
postCtx :: Context String
|
|
postCtx =
|
|
dateField "date" "%d/%m/%Y"
|
|
<> context
|
|
|
|
postCtxWith :: Tags -> Tags -> Tags -> Context String
|
|
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
|
|
|
|
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 _ 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
|