Working prototype in hakyll

1 files changed, 119 insertions, 4 deletions

diff --git a/src/Site.hs b/src/Site.hs
index d1afbce..dde7047 100644
--- a/src/Site.hs
+++ b/src/Site.hs
@@ -1,16 +1,131 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, RankNTypes, StandaloneDeriving, FlexibleInstances #-}
 
 import Hakyll
 
+import Data.Monoid (Monoid(..), mconcat, (<>))
+import Control.Monad (liftM)
+import Data.Char (toLower, isSpace, isAlphaNum)
+import Data.Maybe (mapMaybe, fromMaybe)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.List (take, reverse)
+import Data.Default
+import Text.Pandoc.Options (WriterOptions(..), ObfuscationMethod(..))
+import Control.Applicative (Alternative(..), Applicative(..))
+
+import System.FilePath (replaceExtension)
+
 main :: IO ()
 main = hakyllWith config $ do
-  match "/posts/*" $ do
+  match "templates/*" $ compile templateCompiler
+
+  match "css/*" $ do
+    route idRoute
+    compile copyFileCompiler
+
+  match "posts/*" $ do
     route $ setExtension ".html"
     compile $ do
+      getResourceBody >>= saveSnapshot "content"
       pandocCompiler
-        >>= saveSnapshot "content"
         >>= loadAndApplyTemplate "templates/default.html" defaultContext
         >>= relativizeUrls
 
+  tags <- buildTags "posts/*" tagTranslation' >>= addTag "All Posts" "posts/*"
+
+  tagsRules tags $ \tag pattern -> do
+    route idRoute
+    compile $ do
+      let ctx = mconcat [ constField "title" tag
+                        , listField "posts" defaultContext $ chronological =<< loadAll pattern
+                        , defaultContext
+                        ]
+      makeItem ""
+        >>= loadAndApplyTemplate "templates/post-list.html" ctx
+        >>= loadAndApplyTemplate "templates/default.html" ctx
+        >>= relativizeUrls
+
+  let
+    tags' = tags { tagsMakeId = fromFilePath . (`replaceExtension` "rss") . toFilePath . tagsMakeId tags}
+
+  tagsRules tags' $ \tag pattern -> do
+    route idRoute
+    compile $ do
+      let
+        feedCtx = mconcat [ bodyField "description"
+                          , defaultContext
+                          ]
+      renderRss (feedConfig tag) feedCtx =<< loadAllSnapshots pattern "content"
+
+  match "index.md" $ do
+    route $ setExtension ".html"
+    compile $ do
+      let ctx = mconcat [ listField "tags" defaultContext $ mapM (\(k, _) -> renderTag k tags) $ tagsMap tags
+                        , constField "title" "Index"
+                        , defaultContext
+                        ]
+      item <- getResourceBody
+      pandocCompilerWith def (def { writerEmailObfuscation = NoObfuscation })
+        >>= loadAndApplyTemplate "templates/index.html" ctx
+        >>= loadAndApplyTemplate "templates/default.html" ctx
+        >>= relativizeUrls
+
+deriving instance Eq (Item String)
+
+feedConfig :: String -> FeedConfiguration
+feedConfig tagName = FeedConfiguration { feedTitle = "dirty-haskell.org: " ++ tagName
+                                       , feedDescription = "dirty-haskell.org — A Blog."
+                                       , feedAuthorName = "G. Kleen"
+                                       , feedAuthorEmail = "blog@dirty-haskell.org"
+                                       , feedRoot = "https://dirty-haskell.org"
+                                       }
+
+renderTag :: String -- ^ Tag name
+          -> Tags
+          -> Compiler (Item String)
+renderTag tag tags = do
+  ellipsisItem <- makeItem ""
+  let
+    ids = fromMaybe [] $ lookup tag $ tagsMap tags
+    postCtx = mconcat [ listField "posts" (ellipsisContext ellipsisItem) $ liftM (withEllipsis ellipsisItem) $ chronological =<< mapM load ids
+                      , constField "title" tag
+                      , constField "rss" ("tags/" ++ tagTranslation tag ++ ".rss")
+                      , constField "url" ("tags/" ++ tagTranslation tag ++ ".html")
+                      , defaultContext
+                      ]
+  makeItem ""
+    >>= loadAndApplyTemplate "templates/post-list.html" postCtx
+    >>= loadAndApplyTemplate "templates/tag.html" postCtx
+  where
+    ellipsisContext item = mconcat [ boolField "ellipsis" (== item)
+                                   , defaultContext
+                                   ]
+    boolField name f = field name (\i -> if f i
+                                         then pure (error $ unwords ["no string value for bool field:",name])
+                                         else empty)
+    withEllipsis ellipsisItem xs
+      | length xs > max = [ellipsisItem] ++ takeEnd (max - 1) xs
+      | otherwise = xs
+    takeEnd i = reverse . take i . reverse
+    max = 4
+
+tagTranslation' :: String -> Identifier
+tagTranslation' = fromCapture "tags/*.html" . tagTranslation
+
+tagTranslation :: String -> String
+tagTranslation = mapMaybe charTrans
+  where
+    charTrans c
+      | isSpace c = Just $ '-'
+      | isAlphaNum c = Just $ toLower c
+      | otherwise = Nothing
+
+addTag :: MonadMetadata m => String -> Pattern -> Tags -> m Tags
+addTag name pattern tags = do
+  ids <- getMatches pattern
+  return $ tags { tagsMap = tagsMap tags ++ [(name, ids)] }
+
 config :: Configuration
-config = defaultConfiguration
+config = defaultConfiguration { providerDirectory = "provider"
+                              , deployCommand = "rsync -av --progress -c --delete-delay -m  _site/ gkleen@surtr.yggdrasil.li:/var/www/dirty-haskell.org/"
+                              }