dgnum.eu/ssg/ssg.hs

{-# 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.Map qualified as M
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

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")
    ]

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/**" .||. ".domains" .||. 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

  create ["poles.html"] $ do
    route idRoute
    compile (polePanelCompiler poles)

  -- 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

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

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

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

-- 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") renderPoleLink makeTags "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
    <> tagsFieldWith getTags renderTagLink makeTags "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