ref: 2382e5a2d5476e0e48ca9294bdd762aaf3cc347f lthms.xyz/app/Main.hs -rw-r--r-- 4.1 KiB View raw
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Main where

import           Data.Monoid ((<>))
import           GitHash
import           Hakyll
import           System.FilePath.Posix
import           Hakyll.Web.Pandoc (pandocCompilerWithTransform,
                                    defaultHakyllReaderOptions,
                                    defaultHakyllWriterOptions)
import           Text.Pandoc.Options (WriterOptions(..))
import           Text.Pandoc (Pandoc(..), Block(..))
import           Text.Pandoc.Walk (walk)
import           Text.Regex

unsafeUnwrap :: Either a b -> b
unsafeUnwrap (Right x) = x

main :: IO ()
main = do
  hash <- giHash . unsafeUnwrap <$> getGitInfo "."

  let lthmsCtx = mkLthmsCtx hash

  hakyll $ do
    match "vendor/**" $ do
      route idRoute
      compile copyFileCompiler

    match "img/**" $ do
      route idRoute
      compile copyFileCompiler

    match "css/style.css" $ do
      route idRoute
      compile copyFileCompiler

    match "templates/**"  $ compile templateCompiler

    match "index.html" $ do
      route idRoute
      compile $ do
        posts <- loadAll "blog/**" >>= recentFirst
        let ctx = listField "blog" postCtx (return posts)
                  <> lthmsCtx

        getResourceBody
          >>= applyAsTemplate ctx
          >>= loadAndApplyTemplate "templates/default.html" ctx
          >>= relativizeUrls

    match "emacs.d.org" $ do
      route $ setExtension ".html"
      compile $ pandocCompiler'
        >>= loadAndApplyTemplate "templates/page.html" lthmsCtx
        >>= loadAndApplyTemplate "templates/default.html" lthmsCtx
        >>= relativizeUrls

    match "blog/**" $ do
      route articleRoute
      compile $ pandocCompiler'
        >>= saveSnapshot "content"
        >>= loadAndApplyTemplate "templates/page.html" lthmsCtx
        >>= loadAndApplyTemplate "templates/default.html" lthmsCtx
        >>= relativizeUrls

    create ["rss"] $ do
      route idRoute
      compile $ do
        let feedCtx = defaultContext <> bodyField "description"
        posts <- loadAllSnapshots "blog/**" "content" >>= recentFirst

        renderRss lthmsFeed feedCtx posts

lthmsFeed :: FeedConfiguration
lthmsFeed = FeedConfiguration
    { feedTitle       = "~lthms"
    , feedDescription = "Functional programming, theorem proving, or whaterever."
    , feedAuthorName  = "Thomas Letan"
    , feedAuthorEmail = "contact@thomasletan.fr"
    , feedRoot        = "https://lthms.xyz"
    }

mkLthmsCtx :: String -> Context String
mkLthmsCtx hash = constField "long" hash
                  <> constField "short" (take 7 hash)
                  <> defaultContext

postCtx :: Context String
postCtx = dateField "date" "%Y-%m-%d"
          <> defaultContext

pandocCompiler' :: Compiler (Item String)
pandocCompiler' =
  pandocCompilerWithTransform defaultHakyllReaderOptions
                              defaultHakyllWriterOptions
                                   { writerTableOfContents = True
                                   , writerTemplate = Just template
                                   , writerTOCDepth = 4
                                   }
                              (shiftHeaders 1)
  where template =
          "<div id='false_toc'>\n\
          \  $if(toc)$\n\
          \  <h2>Contents</h2>\n\
          \  $toc$\n\
          \  $endif$\n\
          \</div>\n\
          \$body$"

articleRoute :: Routes
articleRoute = customRoute makeR
    where
        makeR i  = shorten (toFilePath i) </> fileName (toFilePath i) ++ ".html"

        fileName :: FilePath -> FilePath
        fileName p = case (convertArticleFile . takeBaseName) p of
                         Just np -> np
                         Nothing -> error $ "[ERROR] wrong format: " ++ p
        shorten    = joinPath . splitPath . takeDirectory

convertArticleFile :: String -> Maybe String
convertArticleFile f = fmap last $ matchRegex articleRx f

articleRx :: Regex
articleRx = mkRegex "^([0-9]{4})\\-([0-9]{2})\\-([0-9]{2})\\-(.+)$"

shiftHeaders :: Int -> Pandoc -> Pandoc
shiftHeaders i p = walk go p
  where
    go (Header l a inl) = Header (l+i) a inl
    go x = x