This site has continuously evolved since I made the first commit while procrastinating my undergrad dissertation,
commit 632cb1f0c97c07fb99b48192444397e56ea5310f
Author: Ryan Gibb <redacted>
Date: Fri Jan 22 11:27:55 2021 +0000
Initial commit
diff --git a/index.html b/index.html
new file mode 100644
index 0000000..557db03--- /dev/null
+++ b/index.html
@@ -0,0 +1 @@
+Hello World
I started off writing plain HTML, then switching to writing in markdown and using pandoc to convert to HTML, and gradually accumulated bash scripts and makefiles to add more functionality, such as generating an Atom feed. This became unmaintainable and at the start of 2025 I overhauled it to use the Hakyll static site generator There’s a few drafts in the git repository which I don’t want to make public yet, so I include the source code used to generate this website below. It’s quite particular to my needs – Hakyll give you a big bag of tools which you can compose in your own way – but it may be useful as a reference.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Control.Applicative ((<|>))
import Control.Monad (filterM, forM, liftM, (>=>))
import Control.Monad.IO.Class (liftIO)
import Data.Aeson
import Data.Aeson.Types (Parser)
import qualified Data.ByteString.Lazy as BSL
import Data.Char (isAlphaNum)
import qualified Data.Char as C
import Data.Either (fromRight)
import qualified Data.HashMap.Strict as HM
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe, mapMaybe)
import Data.Monoid (mappend)
import Data.Text (Text, intercalate, isInfixOf, pack, unpack)
import qualified Data.Text as T
import Data.Time (UTCTime (UTCTime))
import Data.Time.Format (formatTime, parseTimeM)
import Data.Time.Locale.Compat (defaultTimeLocale)
import Graphics.HsExif
import Hakyll
import Numeric (showFFloat)
import System.Directory (doesFileExist)
import System.FilePath (takeBaseName, takeFileName)
import Text.Blaze.Html (toHtml, toValue, (!))
import qualified Text.Blaze.Html as ExifTag
import Text.Blaze.Html.Renderer.String (renderHtml)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Pandoc
import Text.Pandoc.Highlighting (pygments)
import Text.Pandoc.Lua (applyFilter)
=
indexFiles "static/home.org"
.||. "static/logs.org"
.||. "static/news.org"
.||. "static/index.org"
.||. "static/photos.org"
=
tagFiles "static/projects.org"
.||. "static/research.org"
.||. "static/technology.org"
= "static/**.md" .||. "static/**.org"
htmlFiles
= htmlFiles .&&. complement indexFiles .&&. complement tagFiles
postFiles
= "static/photos/*"
photoFiles
= fromRegex "static/[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9].*"
logFiles
= postFiles .&&. complement logFiles
articleFiles
dateFormat :: String
= "%e %b %Y"
dateFormat
feedConfiguration :: FeedConfiguration
=
feedConfiguration FeedConfiguration
= "ryan.freumh.org",
{ feedTitle = "ryan.freumh.org",
feedDescription = "Ryan Gibb",
feedAuthorName = "ryan@freumh.org",
feedAuthorEmail = "https://ryan.freumh.org"
feedRoot
}
main :: IO ()
= hakyll $ do
main <- buildTags postFiles (fromCapture "*.html")
tags
$ do
match tagFiles
route idRoute
compile tagCompiler
$ \tag pattern -> do
tagsRules tags
route idRoute$ do
compile let title = titleCase tag
let file = "static/" ++ tag ++ ".org"
<- recentFirst =<< filterM isPublished =<< loadAll pattern
posts let ctx =
"title" title
constField `mappend` listField "posts" (postContext dateFormat dateFormat tags) (return posts)
`mappend` defaultContext
<- unsafeCompiler $ doesFileExist file
exists if exists
then do
<- load $ fromFilePath file
body
makeItem (itemBody body)>>= applyAsTemplate (indexContext posts (postContext dateFormat dateFormat tags))
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls
else
""
makeItem >>= loadAndApplyTemplate "templates/tag.html" ctx
>>= loadAndApplyTemplate "templates/default.html" ctx
>>= relativizeUrls
"static/home.org" $ do
match $ staticRoute `composeRoutes` setExtension "html"
route $ do
compile <- recentFirst =<< filterM isPublished =<< loadAll articleFiles
posts
indexCompiler posts (postContext dateFormat dateFormat tags)
"static/logs.org" $ do
match $ staticRoute `composeRoutes` setExtension "html"
route $ do
compile -- so that we pick up published from the title in postContext
<- reverse <$> loadAllSnapshots logFiles "feed"
posts
indexCompiler posts (postContext dateFormat dateFormat tags)
"static/news.org" $ do
match $ staticRoute `composeRoutes` setExtension "html"
route $ do
compile <- recentFirst =<< filterM isPublished =<< loadAll postFiles
posts
indexCompiler posts (postContext dateFormat dateFormat tags)
"static/index.org" $ do
match $ staticRoute `composeRoutes` setExtension "html"
route $ do
compile <- filterM isNotDraft =<< loadAll (htmlFiles .&&. complement "static/index.org")
posts
indexCompiler posts (postContext dateFormat dateFormat tags)
"static/photos.org" $ do
match $ staticRoute `composeRoutes` setExtension "html"
route $ do
compile <- recentFirst =<< (loadAll (photoFiles .&&. hasNoVersion) :: Compiler [Item CopyFile])
photos
photosCompiler photos
$ do
matchMetadata articleFiles isNotDraftMeta $ staticRoute `composeRoutes` setExtension "html"
route $ postCompiler tags "templates/post.html"
compile
$ do
matchMetadata logFiles isNotDraftMeta $ staticRoute `composeRoutes` setExtension "html"
route $ postCompiler tags "templates/log.html"
compile
"atom.xml"] $ do
create [
route idRoute$ do
compile let feedContext = postContext dateFormat "%Y-%m-%dT%H:%M:%S%Q%Ez" tags `mappend` bodyField "content"
<- recentFirst =<< filterM isPublished =<< loadAllSnapshots postFiles "feed"
posts <- loadBody "templates/atom.xml"
atomTemplate <- loadBody "templates/atom-item.xml"
atomItemTemplate
renderAtomWithTemplates atomTemplate atomItemTemplate feedConfiguration feedContext posts
"sitemap.xml"] $ do
create [
route idRoute$ do
compile <- loadAll htmlFiles
posts let sitemapCtx =
"posts" (urlField "loc" `mappend` postContext dateFormat dateFormat tags) (return posts)
listField `mappend` constField "root" "https://ryan.freumh.org"
`mappend` defaultContext
""
makeItem >>= loadAndApplyTemplate "templates/sitemap.xml" sitemapCtx
"404.md" $ do
match $ setExtension "html"
route $ do
compile
getResourceBody>>= loadAndApplyTemplate "templates/default.html" defaultContext
"static/**" isNotDraftMeta $ do
matchMetadata
route staticRoute
compile copyFileCompiler
"static/*.css" $ do
match
route staticRoute
compile compressCssCompiler
"ieee-with-url.csl" $
match
compile cslCompiler
"references.bib" $
match
compile biblioCompiler
"templates/*" $
match
compile templateBodyCompiler
staticRoute :: Routes
= gsubRoute "static/" (const "")
staticRoute
indexCompiler :: [Item a] -> Context a -> Compiler (Item String)
= do
indexCompiler posts context
getResourceBody>>= transformRender
>>= applyAsTemplate (indexContext posts context)
>>= linkCompiler
>>= loadAndApplyTemplate "templates/default.html" defaultContext
>>= relativizeUrls
tagCompiler :: Compiler (Item String)
= do
tagCompiler
getResourceBody>>= bibRender "ieee-with-url.csl" "references.bib"
>>= linkCompiler
>>= relativizeUrls
postCompiler :: Tags -> Identifier -> Compiler (Item String)
= do
postCompiler tags template
getResourceBody>>= saveSnapshot "body"
>>= bibRenderFeed "ieee-with-url.csl" "references.bib"
>>= loadAndApplyTemplate template (postContext dateFormat dateFormat tags)
>>= linkCompiler
>>= saveSnapshot "feed"
getResourceBody>>= saveSnapshot "body"
>>= bibRender "ieee-with-url.csl" "references.bib"
>>= loadAndApplyTemplate template (postContext dateFormat dateFormat tags)
>>= linkCompiler
>>= loadAndApplyTemplate "templates/default.html" (postContext dateFormat dateFormat tags)
>>= relativizeUrls
linkCompiler :: Item String -> Compiler (Item String)
= pure . fmap (withUrls rewriteLinks)
linkCompiler
photosCompiler :: [Item a] -> Compiler (Item String)
= do
photosCompiler photos
getResourceBody>>= renderPandoc
>>= applyAsTemplate (photosContext photos)
>>= loadAndApplyTemplate "templates/default.html" defaultContext
>>= relativizeUrls
readerOptions :: ReaderOptions
=
readerOptions
def= foldr enableExtension pandocExtensions [Ext_citations, Ext_smart]
{ readerExtensions
}
writerOptions :: WriterOptions
=
writerOptions
def= enableExtension Ext_smart pandocExtensions,
{ writerExtensions = Just pygments,
writerHighlightStyle = Citeproc
writerCiteMethod
}
transformRender :: Item String -> Compiler (Item String)
=
transformRender
renderPandocWithTransformM defaultHakyllReaderOptions defaultHakyllWriterOptions pandocTransform
bibRender :: String -> String -> Item String -> Compiler (Item String)
= do
bibRender cslFileName bibFileName pandoc <- load $ fromFilePath cslFileName
csl <- load $ fromFilePath bibFileName
bib let transform =
withItemBodyPandoc (Meta meta) bs) ->
( \(pure $
Pandoc
Meta $ M.insert "link-citations" (MetaBool True) meta)
(
bs
)>=> processPandocBiblios csl [bib]
>=> withItemBody pandocTransform
renderPandocItemWithTransformM readerOptions writerOptions transform pandoc
bibRenderFeed :: String -> String -> Item String -> Compiler (Item String)
= do
bibRenderFeed cslFileName bibFileName pandoc <- load $ fromFilePath cslFileName
csl <- load $ fromFilePath bibFileName
bib let transform =
withItemBodyPandoc (Meta meta) bs) ->
( \(pure $
Pandoc
Meta $ M.insert "link-citations" (MetaBool True) meta)
(
bs
)>=> processPandocBiblios csl [bib]
>=> withItemBody pandocTransformFeed
renderPandocItemWithTransformM readerOptions writerOptions transform pandoc
pandocTransform :: Pandoc -> Compiler Pandoc
=
pandocTransform
unsafeCompiler. runIOorExplode
. ( applyFilter def [] "scripts/org-keywords.lua"
>=> applyFilter def [] "scripts/elem-ids.lua"
>=> applyFilter def [] "scripts/footnote-commas.lua"
>=> applyFilter def [] "scripts/anchor-links.lua"
)
pandocTransformFeed :: Pandoc -> Compiler Pandoc
=
pandocTransformFeed
unsafeCompiler. runIOorExplode
. ( applyFilter def [] "scripts/org-keywords.lua"
>=> applyFilter def [] "scripts/elem-ids.lua"
>=> applyFilter def [] "scripts/footnote-commas.lua"
)
indexContext :: [Item a] -> Context a -> Context String
=
indexContext posts itemContext "posts" itemContext (return posts)
listField `mappend` defaultContext
photosContext :: [Item a] -> Context String
=
photosContext photos "photos" photoContext (return photos)
listField `mappend` defaultContext
postContext :: String -> String -> Tags -> Context String
=
postContext titleDateFormat dateFormat tags "prev" (adjacentLogField (-1) dateFormat)
field `mappend` field "next" (adjacentLogField 1 dateFormat)
`mappend` dateFieldFromTitle "title" titleDateFormat
`mappend` dateField "published" dateFormat
`mappend` myDateField "updated" dateFormat
`mappend` myTagsField "tags" tags
`mappend` defaultContext
-- https://github.com/emmanueltouzery/hsexif/issues/23#issuecomment-2835135828
ExifRational num den) = f num den ""
formatNumeric f (ExifRationalList values) = go values ""
formatNumeric f (where
= id
go [] = f n d
go [(n, d)] : ns) = f n d . showString ", " . go ns
go ((n, d) = show value
formatNumeric _ value
formatAsNumber :: Int -> ExifValue -> String
= formatNumeric fmt
formatAsNumber n where
= trim0 (fltString num den) ++ s
fmt num den s = reverse . dropWhile ('.' ==) . dropWhile ('0' ==) . reverse
trim0 = showFFloat (Just n) (fromIntegral num / fromIntegral den :: Double) ""
fltString num den
ppExposureTime :: ExifValue -> String
@(ExifRational num den) =
ppExposureTime vlet seconds = fromIntegral num / (fromIntegral den :: Double)
value| seconds <= 0.25 && seconds > 0 = "1/" ++ show (round (1 / seconds) :: Int)
| otherwise = formatAsNumber 1 v
in T.unpack $ T.append (T.pack value) " sec."
= show v
ppExposureTime v
photoContext :: Context a
=
photoContext "published" dateFormat
dateField `mappend` urlField "url"
`mappend` pathField "path"
`mappend` titleField "title"
`mappend` thumbnailField "thumb"
`mappend` videoField "video"
`mappend` exifDateField "published" dateFormat
`mappend` exifLatField "lat"
`mappend` exifLongField "lon"
`mappend` exifField "make" make show
`mappend` exifField "model" model show
`mappend` exifField "focallength" focalLength (formatAsFloatingPoint 2)
`mappend` exifField "aperture" apertureValue (formatAsFloatingPoint 2)
`mappend` exifField "exposure" exposureTime ppExposureTime
`mappend` exifField "iso" isoSpeedRatings show
`mappend` locationField "loc"
exifField :: String -> ExifTag -> (ExifValue -> String) -> Context a
print =
exifField key tag $ \item -> do
field key <- exifMetadata item
metadata case M.lookup tag metadata of
Nothing -> noResult ""
Just value -> return $ print value
exifLatField :: String -> Context a
=
exifLatField key $ \item -> do
field key <- exifMetadata item
metadata case getGpsLatitudeLongitude metadata of
Nothing -> noResult ""
Just (lat, _) -> return $ show lat
exifLongField :: String -> Context a
=
exifLongField key $ \item -> do
field key <- exifMetadata item
metadata case getGpsLatitudeLongitude metadata of
Nothing -> noResult ""
Just (_, lon) -> return $ show lon
exifDateField :: String -> String -> Context a
=
exifDateField key format $ \item -> do
field key <- exifMetadata item
metadata case getDateTimeOriginal metadata of
Nothing -> noResult ""
Just date -> return $ formatTime defaultTimeLocale format date
-- TODO don't load metadata individually for each field
exifMetadata :: Item a -> Compiler (M.Map ExifTag ExifValue)
= do
exifMetadata item let identifier = itemIdentifier item
<- unsafeCompiler (parseFileExif (toFilePath identifier))
exifData return $ fromRight M.empty exifData
data PhotoLocation = PhotoLocation
displayName :: T.Text,
{ addressMap :: HM.HashMap T.Text T.Text
}deriving (Show)
instance FromJSON PhotoLocation where
= withObject "PhotoLocation" $ \v ->
parseJSON PhotoLocation
<$> v .: "display_name"
<*> v .: "address"
readCachedLocation :: FilePath -> IO (Either String PhotoLocation)
= do
readCachedLocation photoPath let cacheFile = "reverse-geocoding/" ++ takeFileName photoPath ++ ".json"
<- doesFileExist cacheFile
exists if not exists
then return $ Left "Cache file not found"
else eitherDecode <$> BSL.readFile cacheFile
formatLocation :: HM.HashMap T.Text T.Text -> T.Text
=
formatLocation m let country = HM.lookup "country" m
= HM.lookup "city" m
city
heirarchy| country == Just "United States" && city == Just "New York" =
"borough"],
[ ["state"],
["country"]
[
]| country == Just "United States" =
"city", "town", "village"],
[ ["state"],
["country"]
[
]| country == Just "United Kingdom" && city == Just "London" =
"suburb"],
[ ["city"],
["country"]
[
]| country == Just "United Kingdom" =
"city", "town", "village"],
[ ["country"]
[
]| country == Just "France" && city == Just "Paris" =
"suburb"],
[ ["city"],
["country"]
[
]| country == Just "Italy" =
"quarter"],
[ ["city", "town", "village"],
["state"],
["country"]
[
]| otherwise =
"historic"],
[ ["city", "state", "region", "town"],
["country"]
[
]= listToMaybe $ mapMaybe (`HM.lookup` m) ks
lookupFirst ks = map lookupFirst heirarchy
fields in T.intercalate ", " (catMaybes fields)
locationField :: String -> Context a
= field key $ \item -> do
locationField key let fp = toFilePath (itemIdentifier item)
<- unsafeCompiler $ readCachedLocation fp
eLoc case eLoc of
Left _ -> noResult ""
Right loc ->
let txt = formatLocation (addressMap loc)
in if T.null txt then noResult "" else return (T.unpack txt)
myDateField :: String -> String -> Context String
=
myDateField name format $ \item -> do
field name <- getMetadata (itemIdentifier item)
metadata let date :: Maybe UTCTime
= lookupString name metadata >>= parseTimeM True defaultTimeLocale "%Y-%m-%d"
date case date of
Nothing -> noResult ""
Just date -> return $ formatTime defaultTimeLocale format date
dateFieldFromTitle :: String -> String -> Context String
=
dateFieldFromTitle key format $ \item ->
field key case dateFromTitle item of
Nothing -> noResult ""
Just date ->
return $ formatTime defaultTimeLocale format date
thumbnailField :: String -> Context a
= field key $ \item -> do
thumbnailField key <- getRoute (itemIdentifier item)
mRoute case mRoute of
Nothing -> noResult ""
Just url ->
if ".mp4" `L.isSuffixOf` url
then noResult ""
else
return $
$
T.unpack "photos/" "photos/thumb/" (T.pack url)
T.replace
videoField :: String -> Context a
= field key $ \item -> do
videoField key <- getRoute (itemIdentifier item)
mRoute case mRoute of
Nothing -> noResult ""
Just url ->
if ".mp4" `L.isSuffixOf` url
then
return $
$
T.unpack "static/photos/" "photos/" (T.pack url)
T.replace else noResult ""
myTagsField :: String -> Tags -> Context String
= field key $ \item -> do
myTagsField key tags <- getTags $ itemIdentifier item
tags' if null tags'
then noResult ""
else do
<- forM tags' $ \tag -> do
links <- getRoute $ tagsMakeId tags tag
route' return $ simpleRenderLink tag route'
return $ renderHtml $ mconcat . L.intersperse ", " $ catMaybes links
renderTag :: String -> Maybe FilePath -> Maybe H.Html
Nothing = Nothing
renderTag _ Just filePath) =
renderTag tag (Just $
! A.href (toValue $ toUrl filePath) $
H.a
toHtml tag
isPublished :: Item a -> Compiler Bool
= do
isPublished item <- getMetadata (itemIdentifier item)
metadata case lookupString "published" metadata of
Just value -> return (value /= "false")
Nothing -> return (isJust (dateFromTitle item))
isNotDraft :: Item a -> Compiler Bool
= do
isNotDraft item <- getMetadata (itemIdentifier item)
metadata return $ isNotDraftMeta metadata
isNotDraftMeta :: Metadata -> Bool
= do
isNotDraftMeta metadata case lookupString "published" metadata of
Just value -> value /= "false"
Nothing -> True
dateFromTitle :: Item a -> Maybe UTCTime
=
dateFromTitle item let filePath = toFilePath (itemIdentifier item)
= takeBaseName filePath
title in parseTimeM True defaultTimeLocale "%Y-%m-%d" title
rewriteLinks :: String -> String
rewriteLinks url| "://" `T.isInfixOf` turl = url
-- workaround https://github.com/jgm/pandoc/issues/6916
| "::" `T.isInfixOf` turl =
let (basePart, rest) = T.breakOn "::" turl
= replaceExts basePart
cleanedBase = T.drop 2 rest -- Remove the "::"
headingPart = generateId headingPart
generatedId in T.unpack $ cleanedBase <> "#" <> generatedId
| otherwise =
let (base, fragment) = T.breakOn "#" turl
= replaceExts base
processedBase in T.unpack $ processedBase <> fragment
where
= T.pack url
turl = replaceExt ".md" ".html" . replaceExt ".org" ".html"
replaceExts
replaceExt :: T.Text -> T.Text -> T.Text -> T.Text
=
replaceExt oldExt newExt url let (base, fragment) = T.breakOn "#" url
= if "::" `T.isSuffixOf` base then T.dropEnd 2 base else base
cleanedBase =
processedBase if oldExt `T.isSuffixOf` cleanedBase
then T.replace oldExt newExt cleanedBase
else cleanedBase
in processedBase <> fragment
generateId :: T.Text -> T.Text
=
generateId heading let lower = T.toLower heading
= T.replace (T.pack " ") (T.pack "-") lower
spaced = T.filter (\c -> isAlphaNum c || c == '-' || c == '_' || c == '.') spaced
filtered = T.split (== '-') filtered
parts = filter (not . T.null) parts
nonEmptyParts = if null nonEmptyParts then T.pack "section" else T.intercalate (T.pack "-") nonEmptyParts
cleaned in cleaned
adjacentLogField :: Int -> String -> Item String -> Compiler String
= do
adjacentLogField offset format item <- loadAllSnapshots logFiles "body" :: Compiler [Item String]
posts let adjacent = getAdjacentLog posts item offset
case adjacent of
Nothing -> noResult ""
Just a -> do
<- getRoute (itemIdentifier a)
mroute let filePath = toFilePath (itemIdentifier item)
= takeBaseName filePath
title = fmap (formatTime defaultTimeLocale format) (dateFromTitle a)
date = fromMaybe title date
label return $ maybe "" (\r -> "<a href=\"" ++ r ++ "\">" ++ label ++ "</a>") mroute
getAdjacentLog :: [Item a] -> Item b -> Int -> Maybe (Item a)
=
getAdjacentLog posts current offset case L.elemIndex (itemIdentifier current) (map itemIdentifier posts) of
Nothing -> Nothing
Just idx ->
let newIndex = idx + offset
in if newIndex >= 0 && newIndex < length posts
then Just (posts !! newIndex)
else Nothing
titleCase :: String -> String
: xs) = C.toUpper x : map C.toLower xs titleCase (x
The directory tree looks something like,
./ieee-with-url.csl
./references.bib
./scripts/anchor-links.lua
./scripts/elem-ids.lua
./scripts/footnote-commas.lua
./static/about.org
./static/articles.org
./static/home.org
./static/index.org
./static/logs.org
./static/news.org
./static/papers.org
./static/photos.org
./static/research.org
./static/keys
./static/code.css
./static/style.css
./static/favicon.ico
./static/rss.svg
./static/2023-10-09.md
./static/2023-10-16.md
./static/2023-10-23.md
./static/...
./static/fonts/...
./static/images/...
./static/papers/...
./static/photos/...
./static/resources/...
./templates/atom-item.xml
./templates/atom.xml
./templates/default.html
./templates/log.html
./templates/post-list.html
./templates/post.html
./templates/sitemap.xml
./templates/tag.html