~jack/jackkelly-name

f93a1c5ca0c016c2a9f1264fc37e746947d8bc79 — Jack Kelly 2 years ago b91a370
Add wiki support
5 files changed, 164 insertions(+), 0 deletions(-)

M bin/Main.hs
M jackkelly-name.cabal
M src/Navigation.hs
A src/Wiki.hs
A src/Wiki/Slamjam.hs
M bin/Main.hs => bin/Main.hs +2 -0
@@ 6,6 6,7 @@ import Hakyll
import Navigation (navigationContext, navigation)
import Site (baseSiteContext, sectionLabel)
import Talks (talks)
import Wiki (wiki)

main :: IO ()
main = do


@@ 29,6 30,7 @@ main = do

    blog
    talks
    wiki

    -- Temp
    match "garagesale.md" $ do

M jackkelly-name.cabal => jackkelly-name.cabal +4 -0
@@ 37,11 37,15 @@ library
    Navigation
    Site
    Talks
    Wiki
    Wiki.Slamjam

  ghc-options:        -Wall
  build-depends:
    , aeson                 >=1.3.1.1 && <1.6 || >=2.0 && <2.1
    , base                  >=4.11.1  && <4.17
    , binary                ^>=0.8.8.0
    , bytestring            ^>=0.10
    , containers            >=0.5.11  && <0.7
    , data-default          ^>=0.7.1.1
    , filepath              ^>=1.4.2

M src/Navigation.hs => src/Navigation.hs +1 -0
@@ 19,6 19,7 @@ navigation :: Navigation
navigation = Navigation [] Nothing
  [ ("Blog", Url "/blog")
  , ("Talks", Url "/talks")
  , ("Wiki", Url "/wiki")
  ]

navigationContext :: Navigation -> Context a

A src/Wiki.hs => src/Wiki.hs +64 -0
@@ 0,0 1,64 @@
module Wiki where

import           Control.Applicative (empty)
import           Data.Default (def)
import           Data.Maybe (fromMaybe)
import           Data.Text (Text)
import qualified Data.Text as T
import           Hakyll
import           Navigation (navigation, navigationContext, select)
import           Site (baseSiteContext, sectionLabel)
import qualified Text.Pandoc as P
import qualified Wiki.Slamjam as Wiki

wiki :: Rules ()
wiki = do
  Wiki.slamjam

  match "wiki/*.md" $ do
    route $ setExtension "html"
    compile pageCompiler

  match "wiki/**/*.md" $ do
    route $ setExtension "html"
    compile pageCompiler

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

pageCompiler :: Compiler (Item String)
pageCompiler = do
  path <- pagePath
  let
    labeledTitle = field "title" $ \item ->
      getMetadataField (itemIdentifier item) "title"
      >>= maybe empty (pure . sectionLabel . ("Wiki":) . pure)
    context = labeledTitle <> pageContext path
  pandoc
    >>= loadAndApplyTemplate "templates/wiki/page.html" context
    >>= loadAndApplyTemplate "templates/default.html" context
    >>= relativizeUrls
  where
    pandoc = pandocCompilerWith readerOptions writerOptions
      where
        readerOptions = def
          { P.readerExtensions =
            P.disableExtension P.Ext_implicit_figures P.pandocExtensions
          }
        writerOptions = def

pagePath :: Compiler Text
pagePath = do
  path <- T.pack . toFilePath <$> getUnderlying
  ext <- T.pack <$> getUnderlyingExtension
  let Just pageNoExt = T.stripSuffix ext path
  pure $ "/" <> fromMaybe pageNoExt (T.stripSuffix "index" pageNoExt)

pageContext :: Text -> Context String
pageContext path = mconcat
  [ constField "path" $ T.unpack path
  , modificationTimeField "updated_at" "%B %e, %Y"
  , navigationContext (select "Wiki" navigation)
  , baseSiteContext
  ]

A src/Wiki/Slamjam.hs => src/Wiki/Slamjam.hs +93 -0
@@ 0,0 1,93 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TypeApplications #-}

module Wiki.Slamjam where

import           Data.Aeson (FromJSON(..), (.:), eitherDecode, withObject)
import           Data.Binary (Binary)
import           Data.Text (Text)
import qualified Data.Text as T
import           GHC.Generics (Generic)
import           Hakyll
import           Navigation (navigation, navigationContext, select)
import           Site (baseSiteContext, sectionLabel)

data TierList = TierList
  { tierS :: [Slam]
  , tierA :: [Slam]
  , tierB :: [Slam]
  , tierC :: [Slam]
  , tierD :: [Slam]
  , tierF :: [Slam]
  }
  deriving stock (Eq, Show, Generic)
  deriving anyclass Binary

instance FromJSON TierList where
  parseJSON = withObject "TierList" $ \o -> TierList
    <$> o .: "S"
    <*> o .: "A"
    <*> o .: "B"
    <*> o .: "C"
    <*> o .: "D"
    <*> o .: "F"

data Slam = Slam
  { slamName :: Text
  , slamBy :: Text
  , slamUrl :: Text
  , slamComment :: Text
  }
  deriving stock (Eq, Show, Generic)
  deriving anyclass Binary

instance FromJSON Slam where
  parseJSON = withObject "Slam" $ \o -> Slam
    <$> o .: "name"
    <*> o .: "by"
    <*> o .: "url"
    <*> o .: "comment"

slamContext :: Context Slam
slamContext = mconcat
  [ field "name" $ f slamName
  , field "by" $ f slamBy
  , field "url" $ f slamUrl
  , field "comment" $ f slamComment
  ]
  where
    f :: (Slam -> Text) -> Item Slam -> Compiler String
    f getter = pure . T.unpack . getter . itemBody

slamjam :: Rules ()
slamjam = do
  match "wiki/slamjam.json" $ do
    route $ setExtension "html"
    compile $ do
      tierList <- getResourceLBS >>=
        either fail pure . eitherDecode @TierList . itemBody

      let
        slamItems :: [Slam] -> Compiler [Item Slam]
        slamItems = fmap sequenceA . makeItem

        context = mconcat
          [ listField "tier-s" slamContext . slamItems $ tierS tierList
          , listField "tier-a" slamContext . slamItems $ tierA tierList
          , listField "tier-b" slamContext . slamItems $ tierB tierList
          , listField "tier-c" slamContext . slamItems $ tierC tierList
          , listField "tier-d" slamContext . slamItems $ tierD tierList
          , listField "tier-f" slamContext . slamItems $ tierF tierList
          , modificationTimeField "updated_at" "%B %e, %Y"
          , constField "title" $ sectionLabel ["Wiki", "Slam Jam Tier List"]
          , constField "path" "/wiki/slamjam"
          , navigationContext (select "Wiki" navigation)
          , baseSiteContext
          ]
      makeItem ""
        >>= loadAndApplyTemplate "templates/wiki/slamjam.html" context
        >>= loadAndApplyTemplate "templates/wiki/page.html" context
        >>= loadAndApplyTemplate "templates/default.html" context
        >>= relativizeUrls