site.hs

   1 --------------------------------------------------------------------------------
   2 {-# LANGUAGE OverloadedStrings #-}
   3 import           Control.Monad
   4 import qualified Data.Map.Lazy as Map
   5 import qualified Data.Text
   6 import qualified Data.Text.Lazy as T
   7 import qualified Data.Text.Lazy.Encoding as T
   8 import           Data.Monoid (mappend)
   9 import           Hakyll
  10 import qualified Text.MMark as MMark
  11 import qualified Text.MMark.Extension as MMark
  12 import qualified Text.MMark.Extension.Common as MMark
  13 import qualified Text.Megaparsec.Error as Mega
  14 import           System.Directory
  15 import           System.FilePath
  16 import           Lucid
  17 import           Eventlog.Data
  18 import           Eventlog.Args
  19 import           Eventlog.VegaTemplate
  20 import           Eventlog.HtmlTemplate
  21 import qualified Text.Blaze.Html.Renderer.Text as Blaze
  22
  23 --------------------------------------------------------------------------------
  24 main :: IO ()
  25 main = do
  26   eventLogs <- renderEventLogs
  27   hakyllWith conf $ do
  28     match "images/*" $ do
  29         route   idRoute
  30         compile copyFileCompiler
  31
  32     match "css/*" $ do
  33         route   idRoute
  34         compile compressCssCompiler
  35
  36     match (fromList ["about.rst", "contact.markdown"]) $ do
  37         route   $ setExtension "html"
  38         compile $ pandocCompiler
  39             >>= loadAndApplyTemplate "templates/default.html" defaultContext
  40             >>= relativizeUrls
  41
  42     match "posts/*" $ do
  43         route indexHtml
  44         compile $ mmarkCompiler eventLogs
  45             >>= loadAndApplyTemplate "templates/post.html"    postCtx
  46             >>= loadAndApplyTemplate "templates/default.html" postCtx
  47             >>= relativizeUrls
  48
  49     create ["archive.html"] $ do
  50         route $ setExtension "html"
  51         compile $ do
  52             posts <- recentFirst =<< loadAll "posts/*"
  53             let archiveCtx =
  54                     listField "posts" postCtx (return posts) `mappend`
  55                     constField "title" "Archives"            `mappend`
  56                     defaultContext
  57
  58             makeItem ""
  59                 >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
  60                 >>= loadAndApplyTemplate "templates/default.html" archiveCtx
  61                 >>= relativizeUrls
  62                 >>= removeIndexes
  63
  64
  65     match "index.html" $ do
  66         route idRoute
  67         compile $ do
  68             posts <- recentFirst =<< loadAll "posts/*"
  69             let indexCtx =
  70                     listField "posts" postCtx (return posts)    `mappend`
  71                     defaultContext
  72
  73             getResourceBody
  74                 >>= applyAsTemplate indexCtx
  75                 >>= loadAndApplyTemplate "templates/default.html" indexCtx
  76                 >>= relativizeUrls
  77                 >>= removeIndexes
  78
  79     match "templates/*" $ compile templateBodyCompiler
  80
  81
  82 --------------------------------------------------------------------------------
  83 postCtx :: Context String
  84 postCtx =
  85     dateField "date" "%B %e, %Y" `mappend`
  86     defaultContext
  87
  88 indexHtml :: Routes
  89 indexHtml = customRoute go
  90   where
  91     go i = let fp = toFilePath i
  92            in takeDirectory fp </> takeBaseName fp </> "index.html"
  93
  94 removeIndexes :: Item FilePath -> Compiler (Item FilePath)
  95 removeIndexes = return . fmap (withUrls removeIndex)
  96   where
  97     removeIndex fp
  98       | takeFileName fp == "index.html" = takeDirectory fp
  99       | otherwise = fp
 100
 101 conf = defaultConfiguration
 102   { deployCommand = "rsync -a _site/ luke@lukelau.me:/var/www/luke/haskell" }
 103
 104 mmarkCompiler :: Map.Map FilePath (Html ()) -> Compiler (Item String)
 105 mmarkCompiler eventlogs = do
 106   fp <- getResourceFilePath
 107   getResourceLBS >>= withItemBody (\lbs ->
 108     let text = T.toStrict $ T.decodeUtf8 lbs
 109     in case MMark.parse fp text of
 110         Left e -> error (Mega.errorBundlePretty e)
 111         Right doc ->
 112           let html = MMark.render (MMark.useExtensions extensions doc)
 113           in return $ T.unpack $ renderText html)
 114
 115   where extensions = [ MMark.ghcSyntaxHighlighter
 116                      , MMark.skylighting
 117                      , MMark.footnotes
 118                      , eventLogsExt eventlogs
 119                      ]
 120
 121 renderEventLogs :: IO (Map.Map FilePath (Html ()))
 122 renderEventLogs = foldM render mempty =<< listDirectory "eventlogs"
 123   where
 124     render acc fp = do
 125       let args = Args { sorting = Size
 126                       , reversing = False
 127                       , tracePercent = 1
 128                       , nBands = 15
 129                       , heapProfile = False
 130                       , noIncludejs = False
 131                       , json = True
 132                       , noTraces = True
 133                       , userColourScheme = ""
 134                       , files = []
 135                       }
 136       (_, dat) <- generateJson ("eventlogs" </> fp) args
 137       let conf = ChartConfig 450 500 True "accent" (AreaChart Stacked)
 138           html :: Html ()
 139           html = div_ [style_ "overflow: scroll"] $ do
 140             forM_ vegaScripts $ \url ->
 141               script_ [src_ url] ("" :: T.Text) :: Html ()
 142             toHtmlRaw $ Blaze.renderHtml $ renderChartWithJson 1 dat (vegaJsonText conf)
 143       return $ Map.insert fp html acc
 144
 145     vegaScripts = [ "https://cdn.jsdelivr.net/npm/vega@5.4.0"
 146                   , "https://cdn.jsdelivr.net/npm/vega-lite@3.3.0"
 147                   , "https://cdn.jsdelivr.net/npm/vega-embed@4.2.0"
 148                   ]
 149
 150 eventLogsExt :: Map.Map FilePath (Html ()) -> MMark.Extension
 151 eventLogsExt eventLogs = MMark.blockRender go
 152   where
 153     go :: (MMark.Block (MMark.Ois, Html ()) -> Html ()) -> MMark.Block (MMark.Ois, Html ()) -> Html ()
 154     go f (MMark.CodeBlock (Just "eventlog") url) = eventLogs Map.! (Data.Text.unpack (Data.Text.strip url))
 155     go f x = f x