How This Site Is Build

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

{-# LANGUAGE OverloadedStrings #-}

import Control.Monad (filterM, forM, liftM, (>=>))
import Control.Monad.IO.Class (liftIO)
import Data.Char (isAlphaNum)
import qualified Data.Char as C
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.Monoid (mappend)
import qualified Data.Text as T
import Data.Time (UTCTime (UTCTime))
import Data.Time.Format (formatTime, parseTimeM)
import Data.Time.Locale.Compat (defaultTimeLocale)
import Hakyll
import System.Directory (doesFileExist)
import System.FilePath (takeBaseName)
import Text.Blaze.Html (toHtml, toValue, (!))
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"

htmlFiles = "static/**.md" .||. "static/**.org"

postFiles = htmlFiles .&&. complement indexFiles .&&. complement tagFiles

photoFiles = "static/photos/*"

logFiles = fromRegex "static/[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9].*"

articleFiles = postFiles .&&. complement logFiles

dateFormat :: String
dateFormat = "%e %b %Y"

feedConfiguration :: FeedConfiguration
feedConfiguration =
  FeedConfiguration
    { feedTitle = "ryan.freumh.org",
      feedDescription = "ryan.freumh.org",
      feedAuthorName = "Ryan Gibb",
      feedAuthorEmail = "ryan@freumh.org",
      feedRoot = "https://ryan.freumh.org"
    }

main :: IO ()
main = hakyll $ do
  tags <- buildTags postFiles (fromCapture "*.html")

  match tagFiles $ do
    route idRoute
    compile tagCompiler

  tagsRules tags $ \tag pattern -> do
    route idRoute
    compile $ do
      let title = titleCase tag
      let file = "static/" ++ tag ++ ".org"
      posts <- recentFirst =<< filterM isPublished =<< loadAll pattern
      let ctx =
            constField "title" title
              `mappend` listField "posts" (postContext dateFormat dateFormat tags) (return posts)
              `mappend` defaultContext
      exists <- unsafeCompiler $ doesFileExist file
      if exists
        then do
          body <- load $ fromFilePath file
          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

  match "static/home.org" $ do
    route $ staticRoute `composeRoutes` setExtension "html"
    compile $ do
      posts <- recentFirst =<< filterM isPublished =<< loadAll articleFiles
      indexCompiler posts (postContext dateFormat dateFormat tags)

  match "static/logs.org" $ do
    route $ staticRoute `composeRoutes` setExtension "html"
    compile $ do
      -- so that we pick up published from the title in postContext
      posts <- reverse <$> loadAllSnapshots logFiles "feed"
      indexCompiler posts (postContext dateFormat dateFormat tags)

  match "static/news.org" $ do
    route $ staticRoute `composeRoutes` setExtension "html"
    compile $ do
      posts <- recentFirst =<< filterM isPublished =<< loadAll postFiles
      indexCompiler posts (postContext dateFormat dateFormat tags)

  match "static/index.org" $ do
    route $ staticRoute `composeRoutes` setExtension "html"
    compile $ do
      posts <- filterM isNotDraft =<< loadAll (htmlFiles .&&. complement "static/index.org")
      indexCompiler posts (postContext dateFormat dateFormat tags)

  match "static/photos.org" $ do
    route $ staticRoute `composeRoutes` setExtension "html"
    compile $ do
      photos <- recentFirst =<< (loadAll (photoFiles .&&. hasNoVersion) :: Compiler [Item CopyFile])
      indexCompiler photos photoContext

  matchMetadata articleFiles isNotDraftMeta $ do
    route $ staticRoute `composeRoutes` setExtension "html"
    compile $ postCompiler tags "templates/post.html"

  matchMetadata logFiles isNotDraftMeta $ do
    route $ staticRoute `composeRoutes` setExtension "html"
    compile $ postCompiler tags "templates/log.html"

  create ["atom.xml"] $ do
    route idRoute
    compile $ do
      let feedContext = postContext dateFormat "%Y-%m-%dT%H:%M:%S%Q%Ez" tags `mappend` bodyField "content"
      posts <- recentFirst =<< filterM isPublished =<< loadAllSnapshots postFiles "feed"
      atomTemplate <- loadBody "templates/atom.xml"
      atomItemTemplate <- loadBody "templates/atom-item.xml"
      renderAtomWithTemplates atomTemplate atomItemTemplate feedConfiguration feedContext posts

  create ["sitemap.xml"] $ do
    route idRoute
    compile $ do
      posts <- loadAll htmlFiles
      let sitemapCtx =
            listField "posts" (urlField "loc" `mappend` (postContext dateFormat dateFormat tags)) (return posts)
              `mappend` constField "root" "https://ryan.freumh.org"
              `mappend` defaultContext
      makeItem ""
        >>= loadAndApplyTemplate "templates/sitemap.xml" sitemapCtx

  match "404.md" $ do
    route $ setExtension "html"
    compile $ do
      getResourceBody
        >>= loadAndApplyTemplate "templates/default.html" defaultContext

  matchMetadata "static/**" isNotDraftMeta $ do
    route staticRoute
    compile copyFileCompiler

  match "static/*.css" $ do
    route staticRoute
    compile compressCssCompiler

  match "ieee-with-url.csl" $
    compile cslCompiler

  match "references.bib" $
    compile biblioCompiler

  match "templates/*" $
    compile templateBodyCompiler

staticRoute :: Routes
staticRoute = gsubRoute "static/" (const "")

indexCompiler :: [Item a] -> Context a -> Compiler (Item String)
indexCompiler posts context = do
  getResourceBody
    >>= transformRender
    >>= applyAsTemplate (indexContext posts context)
    >>= linkCompiler
    >>= loadAndApplyTemplate "templates/default.html" defaultContext
    >>= relativizeUrls

tagCompiler :: Compiler (Item String)
tagCompiler = do
  getResourceBody
    >>= bibRender "ieee-with-url.csl" "references.bib"
    >>= linkCompiler
    >>= relativizeUrls

postCompiler :: Tags -> Identifier -> Compiler (Item String)
postCompiler tags template = do
  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)
linkCompiler = pure . fmap (withUrls rewriteLinks)

readerOptions :: ReaderOptions
readerOptions =
  def
    { readerExtensions = foldr enableExtension pandocExtensions [Ext_citations, Ext_smart]
    }

writerOptions :: WriterOptions
writerOptions =
  def
    { writerExtensions = enableExtension Ext_smart pandocExtensions,
      writerHighlightStyle = Just pygments,
      writerCiteMethod = Citeproc
    }

transformRender :: Item String -> Compiler (Item String)
transformRender =
  renderPandocWithTransformM defaultHakyllReaderOptions defaultHakyllWriterOptions pandocTransform

bibRender :: String -> String -> Item String -> Compiler (Item String)
bibRender cslFileName bibFileName pandoc = do
  csl <- load $ fromFilePath cslFileName
  bib <- load $ fromFilePath bibFileName
  let transform =
        withItemBody
          ( \(Pandoc (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)
bibRenderFeed cslFileName bibFileName pandoc = do
  csl <- load $ fromFilePath cslFileName
  bib <- load $ fromFilePath bibFileName
  let transform =
        withItemBody
          ( \(Pandoc (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"
      )

postContext :: String -> String -> Tags -> Context String
postContext titleDateFormat dateFormat tags =
  field "prev" (adjacentLogField (-1) dateFormat)
    `mappend` field "next" (adjacentLogField 1 dateFormat)
    `mappend` dateFieldFromTitle "title" titleDateFormat
    `mappend` dateField "published" dateFormat
    `mappend` myDateField "updated" dateFormat
    `mappend` myTagsField "tags" tags
    `mappend` defaultContext

photoContext :: Context a
photoContext =
  dateField "title" dateFormat
    `mappend` dateField "published" dateFormat
    `mappend` urlField "url"
    `mappend` pathField "path"
    `mappend` titleField "title"
    `mappend` thumbnailField "thumb"
    `mappend` videoField "video"

indexContext :: [Item a] -> Context a -> Context String
indexContext posts itemContext =
  listField "posts" itemContext (return posts)
    `mappend` defaultContext

myDateField :: String -> String -> Context String
myDateField name format =
  field name $ \item -> do
    metadata <- getMetadata (itemIdentifier item)
    let date :: Maybe UTCTime
        date = lookupString name metadata >>= parseTimeM True defaultTimeLocale "%Y-%m-%d"
    case date of
      Nothing -> noResult ""
      Just date -> return $ formatTime defaultTimeLocale format date

dateFieldFromTitle :: String -> String -> Context String
dateFieldFromTitle key format =
  field key $ \item ->
    case dateFromTitle item of
      Nothing -> noResult ""
      Just date ->
        return $ formatTime defaultTimeLocale format date

thumbnailField :: String -> Context a
thumbnailField key = field key $ \item -> do
  mRoute <- getRoute (itemIdentifier item)
  case mRoute of
    Nothing -> noResult ""
    Just url ->
      if ".mp4" `L.isSuffixOf` url
        then noResult ""
        else
          return $
            T.unpack $
              T.replace "photos/" "photos/thumb/" (T.pack url)

videoField :: String -> Context a
videoField key = field key $ \item -> do
  mRoute <- getRoute (itemIdentifier item)
  case mRoute of
    Nothing -> noResult ""
    Just url ->
      if ".mp4" `L.isSuffixOf` url
        then
          return $
            T.unpack $
              T.replace "static/photos/" "photos/" (T.pack url)
        else noResult ""

myTagsField :: String -> Tags -> Context String
myTagsField key tags = field key $ \item -> do
  tags' <- getTags $ itemIdentifier item
  if null tags'
    then noResult ""
    else do
      links <- forM tags' $ \tag -> do
        route' <- getRoute $ tagsMakeId tags tag
        return $ simpleRenderLink tag route'
      return $ renderHtml $ mconcat . L.intersperse ", " $ catMaybes links

renderTag :: String -> Maybe FilePath -> Maybe H.Html
renderTag _ Nothing = Nothing
renderTag tag (Just filePath) =
  Just $
    H.a ! A.href (toValue $ toUrl filePath) $
      toHtml tag

isPublished :: Item a -> Compiler Bool
isPublished item = do
  metadata <- getMetadata (itemIdentifier item)
  case lookupString "published" metadata of
    Just value -> return (value /= "false")
    Nothing -> return (isJust (dateFromTitle item))

isNotDraft :: Item a -> Compiler Bool
isNotDraft item = do
  metadata <- getMetadata (itemIdentifier item)
  return $ isNotDraftMeta metadata

isNotDraftMeta :: Metadata -> Bool
isNotDraftMeta metadata = do
  case lookupString "published" metadata of
    Just value -> value /= "false"
    Nothing -> True

dateFromTitle :: Item a -> Maybe UTCTime
dateFromTitle item =
  let filePath = toFilePath (itemIdentifier item)
      title = takeBaseName filePath
   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
          cleanedBase = replaceExts basePart
          headingPart = T.drop 2 rest -- Remove the "::"
          generatedId = generateId headingPart
       in T.unpack $ cleanedBase <> "#" <> generatedId
  | otherwise =
      let (base, fragment) = T.breakOn "#" turl
          processedBase = replaceExts base
       in T.unpack $ processedBase <> fragment
  where
    turl = T.pack url
    replaceExts = replaceExt ".md" ".html" . replaceExt ".org" ".html"

replaceExt :: T.Text -> T.Text -> T.Text -> T.Text
replaceExt oldExt newExt url =
  let (base, fragment) = T.breakOn "#" url
      cleanedBase = if "::" `T.isSuffixOf` base then T.dropEnd 2 base else base
      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
      spaced = T.replace (T.pack " ") (T.pack "-") lower
      filtered = T.filter (\c -> isAlphaNum c || c == '-' || c == '_' || c == '.') spaced
      parts = T.split (== '-') filtered
      nonEmptyParts = filter (not . T.null) parts
      cleaned = if null nonEmptyParts then T.pack "section" else T.intercalate (T.pack "-") nonEmptyParts
   in cleaned

adjacentLogField :: Int -> String -> Item String -> Compiler String
adjacentLogField offset format item = do
  posts <- loadAllSnapshots logFiles "body" :: Compiler [Item String]
  let adjacent = getAdjacentLog posts item offset
  case adjacent of
    Nothing -> noResult ""
    Just a -> do
      mroute <- getRoute (itemIdentifier a)
      let filePath = toFilePath (itemIdentifier item)
          title = takeBaseName filePath
          date = fmap (formatTime defaultTimeLocale format) (dateFromTitle a)
          label = fromMaybe title date
      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
titleCase (x : xs) = C.toUpper x : map C.toLower xs