dgnum.eu/ssg/ssg.hs

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

--------------------------------------------------------------------------------

nbPostsHome :: Int
nbPostsHome = 30

patternFrom :: [String] -> [String] -> Pattern
patternFrom basenames extensions =
  foldl1 (.||.) $ map aux basenames
  where
  aux basename =
    foldl1 (.||.) $ map (fromGlob . (++) (basename ++ "/**.")) extensions

postPattern :: Pattern
postPattern = patternFrom [ "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" ]

--------------------------------------------------------------------------------

main :: IO ()
main = hakyllWith config $ do
  tags <- extractTags
  authors <- extractAuthors
  poles <- extractPoles

  tagsRules tags $ \tagStr tagsPattern -> do
    let title = "Articles appartenant à la catégorie \"" ++ 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

  tagsRules authors $ \authorStr authorsPattern -> do
    let title = "Articles (co-)écrit 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

  tagsRules poles $ \poleStr polesPattern -> do
    let title = "Articles du pôle \"" ++ poleStr ++ "\""
    route idRoute
    compile $ do
      posts <- loadAll polesPattern >>= recentFirst
      let ctx =
            constField "title" title
              <> listField "posts" postCtx (return posts)
              <> context

      makeItem ""
        >>= loadAndApplyTemplate "templates/pole.html"  ctx
        >>= loadAndApplyTemplate "templates/default.html" ctx
        >>= relativizeUrls

  create [ "tags.html" ] $ do
    route idRoute
    compile $ renderTagList tags >>= tagCompiler

  create [ "authors.html" ] $ 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

--------------------------------------------------------------------------------

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

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 ("", ["section"], []) [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" "%Y-%m-%d"
  <> 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

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

config :: Configuration
config = defaultConfiguration { destinationDirectory = "result" }