site.hs

   1 --------------------------------------------------------------------------------
   2 {-# LANGUAGE OverloadedStrings #-}
   3 import           Control.Applicative ((<$>))
   4 import           Data.Monoid         (mappend)
   5 import           Hakyll
   6 import           Data.Map as M
   7 import qualified Data.Set as S
   8 import           Data.Maybe          (fromMaybe)
   9 import           Text.Pandoc.Options
  10
  11 config :: Configuration
  12 config = defaultConfiguration
  13   { deployCommand =
  14       "rsync -Havz _site/ rekado@elephly.net:/srv/disk1/rekado/elephly.net" }
  15
  16 myFeedConfiguration :: FeedConfiguration
  17 myFeedConfiguration = FeedConfiguration
  18   { feedTitle       = "Rekado's website"
  19   , feedDescription = "Music, words, and hacking"
  20   , feedAuthorName  = "Rekado"
  21   , feedAuthorEmail = "rekado+feed@elephly.net"
  22   , feedRoot        = "http://elephly.net"
  23   }
  24
  25 --------------------------------------------------------------------------------
  26 main :: IO ()
  27 main = hakyllWith config $ do
  28     match "css/*" $ do
  29         route   idRoute
  30         compile compressCssCompiler
  31
  32     match (    "js/libs/*"
  33           .||. "js/hyphenator/*"
  34           .||. "js/hyphenator/patterns/*"
  35           .||. "js/*"
  36           .||. "downies/*"
  37           .||. "downies/music/*"
  38           .||. "images/*"
  39           .||. "images/posts/*"
  40           .||. "images/posts/*/*"
  41           .||. "favicon.ico"
  42           ) $ do
  43       route   idRoute
  44       compile copyFileCompiler
  45
  46     match ( "static/*.markdown" .||. "static/*/*.markdown" ) $ do
  47       route   $ setExtension "html" `composeRoutes` gsubRoute "static/" (const "")
  48       compile $ pandocCompiler
  49         >>= loadAndApplyTemplate "templates/default.html" defaultContext
  50         >>= relativizeUrls
  51
  52     match "static/*.html" $ do
  53       route   $ gsubRoute "static/" (const "")
  54       compile $ do
  55         getResourceBody
  56           >>= loadAndApplyTemplate "templates/default.html" defaultContext
  57           >>= relativizeUrls
  58
  59     match "posts/*.markdown" $ do
  60       route   $ setExtension "html"
  61       compile defaultCompiler
  62         --itemTpl <- loadBody "templates/photo.html"
  63         --metadata <- getMetadata
  64         --let m = M.lookup "photo" metadata
  65
  66     -- direct links
  67     match "posts/2010-03-28-elephly.markdown" $ version "direct" $  do
  68       route   $ constRoute "elephly.html"
  69       compile defaultCompiler
  70
  71     match "posts/2010-03-23-fur-man.markdown" $ version "direct" $  do
  72       route   $ constRoute "fur-man.html"
  73       compile defaultCompiler
  74
  75     -- blog post archive
  76     create ["posts/index.html"] $ do
  77       route   idRoute
  78       compile $ do
  79         let archiveCtx =
  80               field "posts" (\_ -> postList recentFirst) `mappend`
  81               defaultContext
  82
  83         makeItem ""
  84           >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
  85           >>= loadAndApplyTemplate "templates/default.html" archiveCtx
  86           >>= relativizeUrls
  87
  88     create ["rss.xml"] $ postFeed renderRss
  89     create ["atom.xml"] $ postFeed renderAtom
  90
  91     -- always show the most recent blog post
  92     create ["index.html"] $ do
  93       route idRoute
  94       compile $ do
  95         mostRecent <- fmap head . recentFirst =<< loadAllSnapshots "posts/*.markdown" "non-relative"
  96         makeItem (itemBody mostRecent) >>= relativizeUrls
  97
  98     match "templates/*" $ compile templateCompiler
  99
 100
 101 --------------------------------------------------------------------------------
 102 postCtx :: Context String
 103 postCtx =
 104     dateField "date" "%B %e, %Y" `mappend`
 105     photoSnippet `mappend`
 106     flattrSnippet `mappend`
 107     licenseSnippet `mappend`
 108     defaultContext
 109
 110 -- If a post declares a certain key in the metadata header,
 111 -- load the given template, otherwise ignore.
 112 snippet :: String -> String -> Identifier -> Context String
 113 snippet name key templatePath = field name $ \item -> do
 114     metadata <- getMetadata (itemIdentifier item)
 115     case M.lookup key metadata of
 116       Just file -> itemBody <$> loadAndApplyTemplate templatePath postCtx item
 117       _         -> return ""
 118
 119 photoSnippet   = snippet "photo-snippet" "photo" "templates/photo.html"
 120 flattrSnippet  = snippet "flattr-snippet" "flattr" "templates/flattr.html"
 121 licenseSnippet = snippet "license-snippet" "license" "templates/license.html"
 122
 123 postFeed renderer = do
 124   route idRoute
 125   compile $ do
 126     let feedCtx = postCtx `mappend` bodyField "description"
 127     posts <- fmap (take 10) . recentFirst =<<
 128       loadAllSnapshots "posts/*.markdown" "content"
 129     renderer myFeedConfiguration feedCtx posts
 130
 131 --------------------------------------------------------------------------------
 132 postList :: ([Item String] -> Compiler [Item String]) -> Compiler String
 133 postList sortFilter = do
 134   posts   <- sortFilter =<< loadAll ("posts/*.markdown" .&&. hasNoVersion)
 135   itemTpl <- loadBody "templates/post-item.html"
 136   list    <- applyTemplateList itemTpl postCtx posts
 137   return list
 138
 139 customPandocCompiler :: Compiler (Item String)
 140 customPandocCompiler =
 141     pandocCompilerWith
 142       (addRExt Ext_pipe_tables defaultHakyllReaderOptions)
 143       (addWExt Ext_pipe_tables defaultHakyllWriterOptions)
 144   where
 145     addRExt e opts = opts { readerExtensions = S.insert e (readerExtensions opts) }
 146     addWExt e opts = opts { writerExtensions = S.insert e (writerExtensions opts) }
 147
 148 defaultCompiler = customPandocCompiler
 149   >>= loadAndApplyTemplate "templates/post.html"    postCtx
 150   >>= saveSnapshot "content"
 151   >>= loadAndApplyTemplate "templates/default.html" postCtx
 152   >>= saveSnapshot "non-relative"
 153   >>= relativizeUrls