diff options
Diffstat (limited to 'site.hs')
| -rw-r--r-- | site.hs | 208 |
1 files changed, 208 insertions, 0 deletions
@@ -0,0 +1,208 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad (msum) +import Data.Time (TimeLocale, formatTime, parseTimeM, defaultTimeLocale, UTCTime) +import Hakyll +import System.FilePath.Posix ((</>), (<.>), splitExtension, splitFileName, takeDirectory) + +main :: IO () +main = hakyllWith hakyllConfig $ do + match ("images/*" .||. "files/*" .||. "robots.txt") $ do + route idRoute + compile copyFileCompiler + + match "css/*" $ do + route idRoute + -- WORKAROUND: compressCssCompiler removes copyright notices + compile copyFileCompiler + + match (fromList ["about.md", "contact.md", "privacy.md"]) $ do + route $ setExtension "html" `composeRoutes` appendIndex + let context = dropIndexHtml "url" <> defaultContext + compile $ pandocCompiler + >>= loadAndApplyTemplate "templates/direct.html" context + >>= loadAndApplyTemplate "templates/default.html" context + >>= relativizeUrls + + match "posts/*" $ do + route $ setExtension "html" `composeRoutes` appendIndex + compile $ pandocCompiler + >>= loadAndApplyTemplate "templates/post.html" postContext + >>= saveSnapshot "content" + >>= loadAndApplyTemplate "templates/default.html" postContext + >>= relativizeUrls + + create ["posts.html"] $ do + route appendIndex + compile $ do + posts <- recentFirst =<< loadAll "posts/*" + let archiveContext = + listField "posts" postContext (return posts) <> + constField "title" "Blog" <> + dropIndexHtml "url" <> + defaultContext + + makeItem "" + >>= loadAndApplyTemplate "templates/posts.html" archiveContext + >>= loadAndApplyTemplate "templates/default.html" archiveContext + >>= relativizeUrls + + create ["feeds/posts.rss"] $ do + route idRoute + compileFeed renderRss rfc822DateTimeFormat + + create ["feeds/posts.atom"] $ do + route idRoute + compileFeed renderAtom rfc3339DateTimeFormat + + create ["sitemap.xml"] $ do + route idRoute + compile $ do + posts <- recentFirst =<< loadAll "posts/*" + singles <- loadAll (fromList ["about.md", "contact.md", "privacy.md", "posts.html"]) + let + pages = posts <> singles + sitemapContext = + constField "root" root <> + listField "pages" postContext (return pages) + makeItem "" + >>= loadAndApplyTemplate "templates/sitemap.xml" sitemapContext + + match "index.html" $ do + route idRoute + compile $ do + posts <- recentFirst =<< loadAll "posts/*" + let indexContext = + listField "posts" postContext (return posts) <> + defaultContext + + getResourceBody + >>= applyAsTemplate indexContext + >>= loadAndApplyTemplate "templates/default.html" indexContext + -- >>= relativizeUrls + + match "404.html" $ do + route idRoute + compile $ pandocCompiler + >>= loadAndApplyTemplate "templates/default.html" defaultContext + >>= relativizeUrls + + match "templates/*" $ compile templateBodyCompiler + +hakyllConfig :: Configuration +hakyllConfig = defaultConfiguration + { previewPort = 8080 + , deployCommand = "./deploy" + } + +postContext :: Context String +postContext = + constField "root" root <> + dateField "date" "%-e %B %Y" <> + dateField "formalDate" "%Y-%m-%d" <> + dropIndexHtml "url" <> + defaultContext + +appendIndex :: Routes +appendIndex = + customRoute $ append . splitExtension . toFilePath + where append (path, extension) = path </> "index" <.> extension + +dropIndexHtml :: String -> Context a +dropIndexHtml key = mapContext transform (urlField key) + where + transform url = case splitFileName url of + (p, "index.html") -> takeDirectory p <> "/" + _ -> url + +root :: String +root = "https://www.skreutz.com" + +feedConfiguration :: FeedConfiguration +feedConfiguration = FeedConfiguration + { feedTitle = "Stefan Kreutz' Blog" + , feedDescription = "Random bits from a passionate software engineer." + , feedAuthorName = "Stefan Kreutz" + , feedAuthorEmail = "mail@skreutz.com" + , feedRoot = root + } + +type FeedRenderer = FeedConfiguration -> Context String -> [Item String] -> Compiler (Item String) + +-- | Compile a feed of posts with a given time format. +compileFeed :: FeedRenderer -> [Char] -> Rules () +compileFeed render format = compile $ do + let feedContext = + -- Format built-in fields @published@ and @updated@. + -- TODO: Consider to vendor hakyll. + updatedField format <> + dateField "published" format <> + bodyField "description" <> + postContext + posts <- fmap (take 10) . recentFirst =<< + loadAllSnapshots "posts/*" "content" + render feedConfiguration feedContext posts + +-- | RFC 822 compliant date and time format. +-- +-- This format string differs in two ways from +-- 'Data.Time.Format.rfc822DateFormat' from package time-1.10. First, it padds +-- days with zeros instead of spaces. Second, it uses the offset of the time +-- zone instead of its name because RFC 822 does not define common time zone +-- names like UTC. See +-- https://validator.w3.org/feed/docs/warning/ProblematicalRFC822Date.html +rfc822DateTimeFormat :: String +rfc822DateTimeFormat = "%a, %d %b %Y %H:%M:%S %z" + +-- | RFC 3339 compliant date and time format. +rfc3339DateTimeFormat :: String +rfc3339DateTimeFormat = "%Y-%m-%dT%H:%M:%S%Ez" + +-- | Format field @updated@. +-- +-- Copied from Hakyll's 'dateFieldWith'. Falls back to field @published@. +updatedFieldWith + :: TimeLocale -- ^ Output time locale + -> String -- ^ Format to use on the date + -> Context a -- ^ Resulting context +updatedFieldWith locale format = field "updated" $ \i -> do + time <- getUpdatedUTC locale $ itemIdentifier i + return $ formatTime locale format time + +-- | Format field @updated@. +-- +-- Copied from Hakyll's 'dateField'. Falls back to field @published@. +updatedField + :: String -- ^ Format to use on the date + -> Context a -- ^ Resulting context +updatedField = updatedFieldWith defaultTimeLocale + +-- | Parse field @updated@. +-- +-- Copied from Hakyll's 'getItemUTC'. Falls back to field @published@. +getUpdatedUTC + :: (MonadMetadata m, MonadFail m) + => TimeLocale -- ^ Output time locale + -> Identifier -- ^ Input page + -> m UTCTime -- ^ Parsed UTCTime +getUpdatedUTC locale id' = do + metadata <- getMetadata id' + let tryField k fmt = lookupString k metadata >>= parseTime' fmt + maybe empty' return $ msum $ + [ tryField "updated" fmt | fmt <- formats ] ++ + [ tryField "published" fmt | fmt <- formats ] + where + empty' = fail $ "getUpdatedUTC: could not parse time for " ++ show id' + parseTime' = parseTimeM True locale + formats = + [ "%a, %d %b %Y %H:%M:%S %Z" + , "%a, %d %b %Y %H:%M:%S" + , "%Y-%m-%dT%H:%M:%S%Z" + , "%Y-%m-%dT%H:%M:%S" + , "%Y-%m-%d %H:%M:%S%Z" + , "%Y-%m-%d %H:%M:%S" + , "%Y-%m-%d" + , "%B %e, %Y %l:%M %p" + , "%B %e, %Y" + , "%b %d, %Y" + ] |