-
Notifications
You must be signed in to change notification settings - Fork 0
/
site.hs
385 lines (314 loc) · 16.1 KB
/
site.hs
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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad ( forM_ )
import Data.Functor ( (<&>) )
import Data.Maybe ( fromMaybe )
import Hakyll
import Hakyll.Images ( loadImage
, compressJpgCompiler
, ensureFitCompiler
)
-- Hakyll can trip on characters like apostrophes
-- https://github.com/jaspervdj/hakyll/issues/109
import qualified GHC.IO.Encoding as E
import Text.Pandoc.Definition
import Text.Pandoc.Extensions
import Text.Pandoc.Filter.Plot ( plotFilter )
import qualified Text.Pandoc.Filter.Plot as P
import Text.Pandoc.Highlighting ( Style, styleToCss, kate )
import Text.Pandoc.Options
import qualified Text.Pandoc.Templates as Template
import Data.Char ( isSpace )
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import System.FilePath ( (</>) )
import System.Process.Typed ( ExitCode(..), readProcess, shell )
import Text.Blaze.Html.Renderer.String ( renderHtml )
import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
import BulmaFilter ( bulmaTransform)
import Template ( mkDefaultTemplate, tocTemplate )
import Data.Time.Calendar ( showGregorian )
import Data.Time.Clock ( getCurrentTime, utctDay )
import Feed ( feedConfiguration )
import ReadingTimeFilter ( readingTimeFilter )
-- | syntax highlighting style to use throughout
syntaxHighlightingStyle :: Style
syntaxHighlightingStyle = kate
-- We match images down to two levels
-- Images/* and images/*/**
jpgImages, nonJpgImages, generatedContent :: Pattern
jpgImages = "images/*.jpg" .||. "images/*/**.jpg"
nonJpgImages = ( "images/*/**"
.||. "images/*"
) .&&. complement jpgImages
generatedContent = "generated/**"
--------------------------------------------------------------------------------
-- | Site configuration
conf :: Configuration
conf = defaultConfiguration
{ destinationDirectory = "_rendered"
, providerDirectory = "."
}
renderTemplate :: IO B.ByteString
renderTemplate = do
today <- getCurrentTime <&> (showGregorian . utctDay)
let template = mkDefaultTemplate (mconcat ["Page generated on ", today, ". "])
return (T.encodeUtf8 . T.pack . Pretty.renderHtml $ template)
main :: IO ()
main = do
-- Hakyll can trip on characters like apostrophes
-- https://github.com/jaspervdj/hakyll/issues/109
E.setLocaleEncoding E.utf8
plotConfig <- P.configuration ".pandoc-plot.yml"
-- generate the CSS required to to syntax highlighting
let css = styleToCss syntaxHighlightingStyle
writeFile ("css" </> "syntax.css") css >> putStrLn " Generated css/syntax.css"
-- We generate the default template
-- The template has a marking showing on what date was the page generated
renderTemplate
>>= B.writeFile ("templates" </> "default.html")
>> putStrLn " Generated templates/default.html"
hakyllWith conf $ do
--------------------------------------------------------------------------------
-- A lot of things can be compied directly
forM_ ["files/*", "files/*/**", "fonts/*", "js/*", nonJpgImages] $
\pattern ->
match pattern $ do
route idRoute
compile copyFileCompiler
-- JPG images are special: they can be compressed
match jpgImages $ do
route idRoute
compile $ loadImage
>>= compressJpgCompiler (50::Integer)
-- Coffee table pictures are pretty large, so
-- I resize them so they fit in 1920x1080px
>>= ensureFitCompiler 1920 1080
match generatedContent $ do
route generatedRoute
compile copyFileCompiler
match "css/*" $ do
route idRoute
compile compressCssCompiler
--------------------------------------------------------------------------------
-- These are static pages, like the "about" page
-- Note that /static/index.html is a special case and is handled below
match "static/*.md" $ do
route $ setExtension "html" `composeRoutes` staticRoute
compile $ pandocCompiler_ plotConfig
>>= loadAndApplyTemplate "templates/default.html" defaultContext
>>= relativizeUrls
--------------------------------------------------------------------------------
-- Compile projects page
-- We need to compile each project individually first
-- If this is not done, we cannot use the metadata in HTML templates
match "projects/**.md"
$ compile $ pandocCompiler_ plotConfig >>= relativizeUrls
create ["software.html"] $ do
route idRoute
compile $ do
scientific <- loadAll (fromGlob "projects/scientific/*.md")
general <- loadAll (fromGlob "projects/*.md")
let projectsCtx = mconcat [
listField "scientific" defaultContext (return scientific)
, listField "general" defaultContext (return general)
, constField "title" "Software projects"
, defaultContext
]
makeItem ""
>>= loadAndApplyTemplate "templates/projects.html" projectsCtx
>>= loadAndApplyTemplate "templates/default.html" projectsCtx
>>= relativizeUrls
--------------------------------------------------------------------------------
-- Compile blog posts
-- Explicitly do not match the drafts
match ("posts/*" .&&. complement "posts/drafts/*") $ do
route $ setExtension "html"
compile $ do
-- This weird compilation action is structured so that we can extract the reading time
-- from the document, and use it in a context
-- TODO: include Pandoc metainformation to implement reading-time filter
-- See for example here:
-- https://github.com/jaspervdj/hakyll/issues/643
(metaCtx, doc) <- pandocCompilerWithMeta plotConfig
saveSnapshot "content" doc -- Saved content for RSS feed
>>= loadAndApplyTemplate "templates/default.html" (postCtx <> metaCtx)
>>= relativizeUrls
--------------------------------------------------------------------------------
-- Create RSS feed and Atom feeds
-- See https://jaspervdj.be/hakyll/tutorials/05-snapshots-feeds.html
forM_ [ ("feed.xml", renderRss)
, ("atom.xml", renderAtom)
] $
\(name, renderFunc) -> create [name] $ do
route idRoute
compile $ do
let feedCtx = postCtx <> bodyField "description"
posts <- fmap (take 10) . recentFirst =<<
loadAllSnapshots "posts/*" "content"
renderFunc feedConfiguration feedCtx posts
--------------------------------------------------------------------------------
-- Create a page containing all posts
create ["archive.html"] $ do
route idRoute
compile $ do
posts <- recentFirst =<< loadAll "posts/*"
let archiveCtx =
listField "posts" postCtx (return posts) <>
constField "title" "All blog posts" <>
defaultContext
makeItem ""
>>= loadAndApplyTemplate "templates/archive.html" archiveCtx
>>= loadAndApplyTemplate "templates/default.html" archiveCtx
>>= relativizeUrls
--------------------------------------------------------------------------------
-- Generate the home page, including recent blog posts
match "static/index.html" $ do
route staticRoute
compile $ do
posts <- take 10 <$> (recentFirst =<< loadAll "posts/*")
let indexCtx =
listField "posts" postCtx (return posts) <>
defaultContext
getResourceBody
>>= applyAsTemplate indexCtx
>>= loadAndApplyTemplate "templates/default.html" indexCtx
>>= relativizeUrls
--------------------------------------------------------------------------------
-- Create a sitemap for easier search engine integration
-- Courtesy of Robert Pearce <https://robertwpearce.com/hakyll-pt-2-generating-a-sitemap-xml-file.html>
create ["sitemap.xml"] $ do
route idRoute
compile $ do
-- Gather all announcements
posts <- recentFirst =<< loadAll "posts/*"
-- Gather all other pages
pages <- loadAll (fromGlob "static/**")
let allPages = pages <> posts
sitemapCtx =
constField "root" "https://laurentrdc.xyz/" <>
listField "pages" postCtx (return allPages)
makeItem (""::String)
>>= loadAndApplyTemplate "templates/sitemap.xml" sitemapCtx
--------------------------------------------------------------------------------
match "templates/*" $ compile templateCompiler
postCtx :: Context String
postCtx = mconcat [ defaultContext
, constField "root" "https://laurentrdc.xyz/"
, dateField "date" "%Y-%m-%d"
, lastUpdatedField
-- Because the template language isn't powerful enough
-- to compare dates, we need to construct an updated message field
-- separately.
, updatedMessageField
]
-- | Check when a file was last updated, based on the git history
lastUpdatedViaGit :: FilePath -> IO (Maybe String)
lastUpdatedViaGit fp = do
(ec, out, _) <- readProcess (shell $ "git log --follow --date=format:\"%Y-%m-%d\" --format=\"%ad\" -- " <> fp <> " | head -1" )
case ec of
ExitFailure _ -> return Nothing
ExitSuccess -> return . Just
. TL.unpack
. TL.strip -- Very important, to remove newlines
. TL.decodeUtf8
$ out
-- | Field which provides the "last-updated" variable for items, which
-- provides the date of the most recent git commit which modifies a file.
-- Note that this context will be unavailable for generated pages
lastUpdatedField :: Context String
lastUpdatedField = field "updated" $ \(Item ident _) -> unsafeCompiler $ do
lastUpdated <- lastUpdatedViaGit (toFilePath ident)
case lastUpdated of
Nothing -> return "<unknown>"
Just dt -> return dt
-- | Field which provides the "updatedMessage" variable for items, which
-- provides the date of the most recent git commit which modifies a file.
-- Note that this context will be unavailable for generated pages
updatedMessageField :: Context String
updatedMessageField = field "updatedMessage" $ \(Item ident _) -> do
meta <- getMetadata ident
unsafeCompiler $ do
lastUpdated <- lastUpdatedViaGit (toFilePath ident)
let created = lookupString "date" meta
if lastUpdated == created
then pure mempty
else case lastUpdated of
Nothing -> pure mempty
Just dt -> return $ "Last updated on " <> filter (not . isSpace) dt <> "."
-- Pandoc compiler which also provides the Pandoc metadata as template context
-- This is necessary because it is not possible for Hakyll to be
-- aware of Pandoc document metadata at this time.
pandocCompilerWithMeta :: P.Configuration -> Compiler (Context String, Item String)
pandocCompilerWithMeta config = do
let readerOptions = defaultHakyllReaderOptions
doc <- traverse (unsafeCompiler . transforms) =<< readPandocWith readerOptions =<< getResourceBody
let Pandoc meta _ = itemBody doc
metaCtx = M.foldMapWithKey extractMeta (unMeta meta)
ident <- getUnderlying
toc <- getMetadataField ident "withtoc"
tocDepth <- getMetadataField ident "tocdepth"
template <- unsafeCompiler $ either error id <$>
Template.compileTemplate mempty (T.pack . renderHtml $ tocTemplate)
let extensions = defaultPandocExtensions
writerOptions = case toc of
Just _ -> defaultHakyllWriterOptions
{ writerExtensions = extensions
, writerHTMLMathMethod = MathML
, writerHighlightStyle = Just syntaxHighlightingStyle
, writerTableOfContents = True
, writerTOCDepth = read (fromMaybe "3" tocDepth) :: Int
, writerTemplate = Just template
}
Nothing -> defaultHakyllWriterOptions
{ writerExtensions = extensions
, writerHTMLMathMethod = MathML
, writerHighlightStyle = Just syntaxHighlightingStyle
}
return (metaCtx, writePandocWith writerOptions doc)
where
transforms doc = bulmaTransform . readingTimeFilter <$> plotFilter config (Just "HTML") doc
extractMeta :: T.Text -> MetaValue -> Context String
extractMeta name metavalue =
case metavalue of
MetaString txt -> mkField $ T.unpack txt
_ -> mempty
where
mkField = field (T.unpack name) . const . return
-- | Allow math display, code highlighting, table-of-content, and Pandoc filters
pandocCompiler_ :: P.Configuration -- ^ Pandoc-plot configuration
-> Compiler (Item String)
pandocCompiler_ = fmap snd . pandocCompilerWithMeta
-- Pandoc extensions used by the compiler
defaultPandocExtensions :: Extensions
defaultPandocExtensions =
let extensions = [
-- Pandoc Extensions: http://pandoc.org/MANUAL.html#extensions
-- Math extensions
Ext_tex_math_dollars
, Ext_tex_math_double_backslash
, Ext_latex_macros
-- Code extensions
, Ext_fenced_code_blocks
, Ext_backtick_code_blocks
, Ext_fenced_code_attributes
, Ext_inline_code_attributes -- Inline code attributes (e.g. `<$>`{.haskell})
-- Markdown extensions
, Ext_implicit_header_references -- We also allow implicit header references (instead of inserting <a> tags)
, Ext_definition_lists -- Definition lists based on PHP Markdown
, Ext_yaml_metadata_block -- Allow metadata to be speficied by YAML syntax
, Ext_superscript -- Superscripts (2^10^ is 1024)
, Ext_subscript -- Subscripts (H~2~O is water)
, Ext_footnotes -- Footnotes ([^1]: Here is a footnote)
]
defaultExtensions = writerExtensions defaultHakyllWriterOptions
in foldr enableExtension defaultExtensions extensions
-- Move content from static/ folder to base folder
staticRoute :: Routes
staticRoute = gsubRoute "static/" (const "")
-- Move generated posts from posts/generated to generated/
generatedRoute :: Routes
generatedRoute = gsubRoute "generated/" (const "posts/generated/")