src/Main.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Main where
   3
   4 import Control.Monad (Monad(..), filterM, void)
   5 import Data.Bool
   6 import Data.Either (Either(..))
   7 import Data.Eq (Eq(..))
   8 import Data.Function (($), (.), const)
   9 import Data.Functor ((<$>))
  10 import Data.Functor.Identity (runIdentity)
  11 import Data.Maybe (Maybe(..))
  12 import Data.Monoid (mconcat)
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.String (String)
  15 import Hakyll.Web.Sass (sassCompiler)
  16 import Prelude (error, (-))
  17 import System.IO (IO)
  18 import qualified Data.List as List
  19 import qualified Data.Text as T
  20 import qualified Hakyll as H
  21 import qualified System.Environment as Env
  22 import qualified Text.Pandoc.Options as Pandoc
  23 import qualified Text.Pandoc.Templates as Pandoc
  24
  25 main :: IO ()
  26 main = do
  27   args <- Env.getArgs
  28   Env.withArgs args $ H.hakyllWith H.defaultConfiguration $ do
  29     let postsPattern = "content/posts/*.md"
  30     tags <- H.buildTags postsPattern $
  31       H.fromCapture "tags/*/index.html"
  32     let siteCtx = mconcat
  33           [ H.defaultContext
  34           ]
  35     let tagsCtx = mconcat
  36           [ H.tagsField "tags-links" tags
  37           , H.field "tags-counts" (\_ -> H.renderTagList tags)
  38           ]
  39     let postCtx = mconcat
  40           [ H.dateField "date" "%e %B %Y"
  41           , H.dateField "datetime" "%Y-%m-%d"
  42           -- , tagLinks H.getTags "tags" tags
  43           , tagsCtx
  44           , siteCtx
  45           ]
  46     let postList sortFilter = do
  47           itemTmpl <- H.loadBody "templates/post-link.html"
  48           H.loadAll postsPattern
  49             >>= sortFilter
  50             >>= H.applyTemplateList itemTmpl postCtx
  51
  52     H.match "content/index.html" $ do
  53       let ctx = mconcat
  54             [ H.constField "title" "Index"
  55             -- , H.field "tags-cloud" $ \_ -> tagCloud 60 150 tags
  56             , tagsCtx
  57             , siteCtx
  58             ]
  59       H.route $ stripRoute "content/"
  60       H.compile $ do
  61         body <- H.itemBody <$> H.templateBodyCompiler
  62         H.loadAllSnapshots postsPattern "teaser"
  63           >>= ((List.take 10 <$>) . H.recentFirst)
  64           >>= H.applyTemplateList body (postCtx <> H.bodyField "posts")
  65           >>= H.makeItem
  66           >>= H.loadAndApplyTemplate "templates/index.html" (ctx <> H.bodyField "posts")
  67           >>= H.loadAndApplyTemplate "templates/default.html" (ctx <> H.bodyField "posts")
  68           >>= H.relativizeUrls
  69           >>= chopIndexUrls
  70
  71     H.create ["posts/index.html"] $ do
  72       H.route H.idRoute
  73       H.compile $ do
  74         let ctx = mconcat
  75               [ H.constField "title" "Blog"
  76               , H.constField "description" "Web log entries"
  77               , H.field "posts" (\_ -> postList H.recentFirst)
  78               , siteCtx
  79               ]
  80         H.makeItem ""
  81           >>= H.loadAndApplyTemplate "templates/posts-list.html" ctx
  82           >>= H.loadAndApplyTemplate "templates/default.html" ctx
  83           >>= H.relativizeUrls
  84           >>= chopIndexUrls
  85
  86     H.match postsPattern $ do
  87       H.route $
  88         --directorizeDate `H.composeRoutes`
  89         stripRoute "content/" `H.composeRoutes`
  90         H.setExtension "html"
  91       H.compile $ do
  92         ident <- H.getUnderlying
  93         toc <- H.getMetadataField ident "tableOfContents"
  94         source <- H.getResourceFilePath
  95         updated <- H.unixFilter "git" ["log", "-1", "--format=%ad", "--",  source] ""
  96         let ctx = mconcat
  97               [ H.constField "source" source
  98               , H.constField "updated" updated
  99               , postCtx
 100               ]
 101         compiledContent <- H.pandocCompilerWith H.defaultHakyllReaderOptions $ case toc of
 102           Just "true" ->
 103             H.defaultHakyllWriterOptions
 104               { Pandoc.writerNumberSections = True
 105               , Pandoc.writerTableOfContents = True
 106               , Pandoc.writerTOCDepth = 3
 107               , Pandoc.writerTemplate = Just tocTemplate
 108               }
 109             where
 110             tocTemplate =
 111               case runIdentity $ Pandoc.compileTemplate "" tmpl of
 112                 Left err -> error err
 113                 Right template -> template
 114                 where
 115                 tmpl = T.unlines
 116                   [ ""
 117                   , "<div class=\"toc\"><div class=\"header\">Table des matières</div>"
 118                   , "$toc$"
 119                   , "</div>"
 120                   , "$body$"
 121                   ]
 122           _ -> H.defaultHakyllWriterOptions
 123         compiledTeaser <- H.pandocCompilerWith
 124           H.defaultHakyllReaderOptions
 125           H.defaultHakyllWriterOptions
 126         teaser <- H.loadAndApplyTemplate "templates/post-teaser.html" ctx $
 127           List.unlines . List.takeWhile (/= "<!--more-->") . List.lines
 128           <$> compiledTeaser
 129         void $ H.saveSnapshot "teaser" teaser
 130         H.loadAndApplyTemplate "templates/post.html" ctx compiledContent
 131           >>= H.saveSnapshot "content"
 132           >>= H.loadAndApplyTemplate "templates/default.html" ctx
 133           >>= H.relativizeUrls
 134           >>= chopIndexUrls
 135
 136     H.tagsRules tags $ \tag _ -> do
 137       H.route H.idRoute
 138       H.compile $ do
 139         posts <- postList $ \ps ->
 140           H.recentFirst ps
 141           >>= filterM ((List.elem tag <$>) . H.getTags . H.itemIdentifier)
 142         let ctx = mconcat
 143               [ H.constField "tag" tag
 144               , H.constField "title" ("Posts for tag: " <> tag)
 145               , H.constField "posts" posts
 146               , H.constField "description" ("Posts for tag: " <> tag)
 147               , siteCtx
 148               ]
 149         H.makeItem ""
 150           >>= H.loadAndApplyTemplate "templates/posts-list.html" ctx
 151           >>= H.loadAndApplyTemplate "templates/default.html" ctx
 152           >>= H.relativizeUrls
 153           >>= chopIndexUrls
 154
 155     let feedConfiguration = H.FeedConfiguration
 156           { H.feedTitle       = "Sourcephile - feed"
 157           , H.feedDescription = "Logiciellerie"
 158           , H.feedAuthorName  = "Sourcephile"
 159           , H.feedAuthorEmail = "contact@sourcephile.fr"
 160           , H.feedRoot        = "https://sourcephile.fr"
 161           }
 162     let feedCtx = postCtx <> H.bodyField "description"
 163     H.create ["rss.xml"] $ do
 164       H.route H.idRoute
 165       H.compile $ do
 166         posts <- H.loadAllSnapshots postsPattern "content"
 167         sorted <- H.recentFirst posts
 168         H.renderRss feedConfiguration feedCtx sorted
 169     H.create ["atom.xml"] $ do
 170       H.route H.idRoute
 171       H.compile $ do
 172         posts <- H.loadAllSnapshots postsPattern "content"
 173         sorted <- H.recentFirst posts
 174         H.renderAtom feedConfiguration feedCtx sorted
 175
 176     {-
 177     H.create ["sitemap.xml"] $ do
 178       H.route iH.dRoute
 179       H.compile $ sitemapCompiler def
 180         { sitemapBase     = scSiteRoot siteConfig'
 181         , sitemapRewriter = ('/' :) . stripIndex
 182         }
 183     -}
 184
 185     scssDependency <- H.makePatternDependency "assets/css/**.scss"
 186     H.rulesExtraDependencies [scssDependency] .
 187       H.match "assets/css/default.scss" $ do
 188         H.route $ H.setExtension "css"
 189         H.compile ((H.compressCss <$>) <$> sassCompiler)
 190
 191     H.match "assets/images/**" $ do
 192       H.route H.idRoute
 193       H.compile H.copyFileCompiler
 194
 195     {-
 196     H.match "assets/js/*.js" $ do
 197       H.route H.idRoute
 198       H.compile H.compressJsCompiler
 199     -}
 200
 201     H.match "static/*" $ do
 202       H.route $ stripRoute "static/"
 203       H.compile H.copyFileCompiler
 204
 205     H.match "templates/*" $
 206       H.compile H.templateBodyCompiler
 207
 208     H.match "content/robots.txt" $ do
 209       H.route $ stripRoute "content/"
 210       H.compile H.copyFileCompiler
 211
 212 chopIndexUrls :: H.Item String -> H.Compiler (H.Item String)
 213 chopIndexUrls item = return $ H.withUrls stripIndex <$> item
 214
 215 -- | Strips "index.html" from given URL string.
 216 stripIndex :: String -> String
 217 stripIndex url
 218   | "index.html" `List.isSuffixOf` url =
 219     List.take (List.length url - 10) url
 220   | otherwise = url
 221
 222 stripRoute :: String -> H.Routes
 223 stripRoute r = H.gsubRoute r $ const ""