Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
368 lines (304 sloc) 12.9 KB
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad (forM)
import Data.Monoid (mconcat, mappend)
import Data.List (intersperse, sortBy, isInfixOf, unfoldr)
import Data.List.Split (chunksOf)
import Data.Ord (comparing)
import Data.String (IsString)
import Data.Strings (strJoin)
import Data.Time.Format (defaultTimeLocale)
import Hakyll
import System.FilePath ((</>), takeBaseName, takeDirectory,
takeFileName, splitFileName)
import Text.Blaze.Html (toHtml, toValue, (!))
import Text.Blaze.Html.Renderer.String (renderHtml)
import Text.Pandoc.Options (writerHTMLMathMethod, HTMLMathMethod(MathJax))
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
--------------------------------------------------------------------------------
-- number of posts per page (used for pagination)
--------------------------------------------------------------------------------
postsPerPage :: Int
postsPerPage = 3
postsPattern :: Pattern
postsPattern = "posts/*.md"
--------------------------------------------------------------------------------
-- rules
--------------------------------------------------------------------------------
main :: IO ()
main = hakyll $ do
paginate <- mPaginate
tags <- mTags
match ("templates/*" .&&.
complement "templates/home.html" .&&.
complement "templates/archive.html") $
compile templateCompiler
match "etc/htaccess" $ do
route $ constRoute ".htaccess"
compile copyFileCompiler
match "etc/*" $ do
route dropDirRoute
compile copyFileCompiler
match "img/*" $ do
route idRoute
compile copyFileCompiler
match "fonts/*" $ do
route idRoute
compile copyFileCompiler
match "css/*.css" $ do
route idRoute
compile copyFileCompiler
match "css/*.sass" $ do
route $ setExtension "css"
compile sass
match "js/*.js" $ do
route idRoute
compile copyFileCompiler
match "js/vendor/*.js" $ do
route idRoute
compile copyFileCompiler
match ("html/*.md" .&&. complement "html/README.md") $ do
route $ niceRoute
compile $ pandocCompilerWith defaultHakyllReaderOptions customWriterOptions
>>= loadAndApplyTemplate "templates/page.html" pageCtx
>>= relativizeUrls >>= removeIndexHtml
match "html/README.md" $ do
route dropDirRoute
compile copyFileCompiler
match "templates/home.html" $ do
route $ constRoute "index.html"
compile $ getResourceBody
>>= applyAsTemplate (homeCtx tags postsPattern)
>>= loadAndApplyTemplate "templates/page.html" (homeCtx tags postsPattern)
>>= relativizeUrls >>= removeIndexHtml
match "html/about.html" $ do
route $ rootRoute
compile $ getResourceBody
>>= applyAsTemplate pageCtx
>>= loadAndApplyTemplate "templates/page.html" pageCtx
>>= relativizeUrls >>= removeIndexHtml
match "html/projects.html" $ do
route $ rootRoute
compile $ getResourceBody
>>= applyAsTemplate pageCtx
>>= loadAndApplyTemplate "templates/page.html" pageCtx
>>= relativizeUrls >>= removeIndexHtml
match "templates/archive.html" $ do
route $ rootRoute
compile $ do
rTags <- renderTags makeTagHtml (concat . intersperse ", ") tags
getResourceBody
>>= applyAsTemplate (archiveCtx `mappend` constField "rTags" rTags)
>>= loadAndApplyTemplate "templates/page.html" archiveCtx
>>= relativizeUrls >>= removeIndexHtml
match "errors/*.html" $ do
route $ idRoute
compile $ getResourceBody
>>= applyAsTemplate pageCtx
>>= loadAndApplyTemplate "templates/page.html" pageCtx
>>= relativizeUrls
match postsPattern $ do
route $ niceRoute
compile $ pandocCompiler
>>= saveSnapshot "blogContent"
>>= loadAndApplyTemplate "templates/post.html" (postCtx tags)
>>= saveSnapshot "feedContent"
>>= loadAndApplyTemplate "templates/disqus.html" (postCtx tags)
>>= loadAndApplyTemplate "templates/page.html" (postCtx tags)
>>= relativizeUrls >>= removeIndexHtml
match "drafts/*.md" $ do
route $ niceRoute
compile $ pandocCompiler
>>= loadAndApplyTemplate "templates/post.html" (postCtx tags)
>>= loadAndApplyTemplate "templates/page.html" (postCtx tags)
>>= relativizeUrls >>= removeIndexHtml
create ["feed.xml"] $ do
route idRoute
compile $ do
posts <- fmap (take 10) . recentFirst =<<
loadAllSnapshots postsPattern "feedContent"
renderAtom feedConfiguration (feedCtx tags) posts
paginateRules paginate (pageRules tags)
tagsRules tags tagRules
--------------------------------------------------------------------------------
-- contexts
--------------------------------------------------------------------------------
descCtx :: Context String
descCtx = field "description" $ \item -> do
desc <- getMetadataField' (itemIdentifier item) "description"
return $ desc
dropIndexHtml :: String -> Context a
dropIndexHtml key = mapContext removeIndexStr (urlField key)
pageCtx :: Context String
pageCtx = descCtx `mappend` dropIndexHtml "url" `mappend` defaultContext
homeCtx :: Tags -> Pattern -> Context String
homeCtx tags pattern = mconcat
[field "posts" (\_ ->
fullPostList tags pattern (fmap (take postsPerPage) . recentFirst)), pageCtx]
archiveCtx :: Context String
archiveCtx = mconcat
[field "posts" (\_ -> postLinkList postsPattern recentFirst), pageCtx]
postCtx :: Tags -> Context String
postCtx tags = mconcat
[dateField "date" "%B %e, %Y",
tagsFieldWith getUnderscoreTags renderTagLink concatTags "tags" tags,
pageCtx]
postLinkCtx :: Context String
postLinkCtx = mconcat
[dateField "date" "%m/%d/%Y", pageCtx]
blogDescField :: Context String
blogDescField = constField "description" ("Haitham Gad's blog - a place where"
++ " you can read about programming, mathematics"
++ " and computer science!")
blogCtx :: MonadMetadata m =>
Tags -> Int -> Pattern -> Paginate -> m (Context String)
blogCtx tags n pattern paginate = return $ mconcat
[field "posts" (\_ -> fullPostList tags pattern recentFirst),
constField "title" (prependWebsite "Blog"), blogDescField,
paginateContext paginate n, pageCtx]
tagDescField :: String -> Context String
tagDescField tag = constField "description"
("Haitham Gad's blog posts tagged " ++ makeReadable tag)
tagCtx :: MonadMetadata m => String -> Pattern -> m (Context String)
tagCtx tag pattern = return $ mconcat
[field "posts" (\_ -> postLinkList pattern recentFirst),
constField "title" (prependWebsite "Tag: " ++ readableTag),
constField "tag" readableTag, tagDescField tag, pageCtx]
where readableTag = makeReadable tag
feedCtx = postCtx
--------------------------------------------------------------------------------
-- custom routes
--------------------------------------------------------------------------------
dropDirRoute :: Routes
dropDirRoute = customRoute (takeFileName . toFilePath)
-- route templates/about.html to about/index.html
rootRoute :: Routes
rootRoute = customRoute createIndexRoute
where createIndexRoute ident =
takeBaseName (toFilePath ident) </> "index.html"
-- route */name.md to */name/index.html
niceRoute :: Routes
niceRoute = customRoute createIndexRoute
where createIndexRoute ident =
takeDirectory path </> takeBaseName path </> "index.html"
where path = toFilePath ident
pageRoute :: Int -> Routes
pageRoute n = customRoute (\_ -> "blog" </> show n </> "index.html")
tagRoute :: String -> Routes
tagRoute tag = customRoute (\_ -> "tags" </> tag </> "index.html")
--------------------------------------------------------------------------------
-- custom compilers
--------------------------------------------------------------------------------
sass :: Compiler (Item String)
sass = getResourceString
>>= withItemBody (unixFilter "sassc" ["-a", "-s"])
>>= return . fmap compressCss
--------------------------------------------------------------------------------
-- configurations
--------------------------------------------------------------------------------
feedConfiguration :: FeedConfiguration
feedConfiguration = FeedConfiguration
{ feedTitle = "Haitham Gad's Blog",
feedDescription = "Blog posts by Haitham Gad",
feedAuthorName = "Haitham Gad",
feedAuthorEmail = "hgad@hgad.net",
feedRoot = "https://hgad.net"
}
--------------------------------------------------------------------------------
-- helper functions
--------------------------------------------------------------------------------
-- replace url of the form foo/bar/index.html by foo/bar/
removeIndexStr :: String -> String
removeIndexStr url = case splitFileName url of
(dir, "index.html") | isLocal dir -> dir
| otherwise -> url
_ -> url
where isLocal uri = not (isInfixOf "://" uri)
removeIndexHtml :: Item String -> Compiler (Item String)
removeIndexHtml item = return $ fmap (withUrls removeIndexStr) item
createdFirst :: MonadMetadata m => [Identifier] -> m [Identifier]
createdFirst idens = do
idensWithTime <- forM idens $ \iden -> do
utc <- getItemUTC defaultTimeLocale $ iden
return (utc, iden)
return $ map snd $ reverse $ sortBy (comparing fst) idensWithTime
postList :: Identifier -> Context String -> Pattern
-> ([Item String] -> Compiler [Item String])
-> Compiler String
postList template ctx pattern sortFilter = do
posts <- sortFilter =<< snapshots
itemTpl <- loadBody template
list <- applyTemplateList itemTpl ctx posts
return list
where snapshots = loadAllSnapshots pattern "blogContent"
fullPostList :: Tags -> Pattern -> ([Item String] -> Compiler [Item String])
-> Compiler String
fullPostList tags = postList "templates/post.html" $
constField "linkTitle" "True" `mappend` postCtx tags
postLinkList :: Pattern -> ([Item String] -> Compiler [Item String])
-> Compiler String
postLinkList = postList "templates/post-link.html" postLinkCtx
prependWebsite :: String -> String
prependWebsite s = "Haitham Gad's Website &raquo; " ++ s
--------------------------------------------------------------------------------
-- pagination functions
--------------------------------------------------------------------------------
mPaginate :: MonadMetadata m => m Paginate
mPaginate = buildPaginateWith grouper postsPattern makeId
where grouper ids = return $ chunksOf postsPerPage ids
makeId = \i -> fromFilePath $ "blog/" ++ show (i :: Int) ++ "/index.html"
-- n is the page number and pattern contains only the posts in that page
pageRules :: Tags -> PageNumber -> Pattern -> Rules ()
pageRules tags n pattern = do
route $ pageRoute n
compile $ do
ctx <- blogCtx tags n pattern =<< mPaginate
makeItem ""
>>= loadAndApplyTemplate "templates/blog.html" ctx
>>= loadAndApplyTemplate "templates/page.html" ctx
>>= relativizeUrls >>= removeIndexHtml
--------------------------------------------------------------------------------
-- tags functions
--------------------------------------------------------------------------------
mTags :: MonadMetadata m => m Tags
mTags = buildUnderscoreTags "posts/*" (fromCapture "tags/*")
buildUnderscoreTags :: MonadMetadata m =>
Pattern -> (String -> Identifier) -> m Tags
buildUnderscoreTags = buildTagsWith getUnderscoreTags
getUnderscoreTags :: MonadMetadata m => Identifier -> m [String]
getUnderscoreTags identifier = do
metadata <- getMetadata identifier
return $ maybe [] (map makeFileName . splitAll ",") $ lookupString "tags" metadata
where makeFileName = strJoin "_" . splitAll " "
-- tag is the tag name and pattern contains only the posts in that tag
tagRules :: String -> Pattern -> Rules ()
tagRules tag pattern = do
route $ tagRoute tag
compile $ do
ctx <- tagCtx tag pattern
makeItem ""
>>= loadAndApplyTemplate "templates/tag.html" ctx
>>= loadAndApplyTemplate "templates/page.html" ctx
>>= relativizeUrls >>= removeIndexHtml
makeReadable :: String -> String
makeReadable = strJoin " " . splitAll "_"
renderTagLink :: String -> (Maybe FilePath) -> Maybe H.Html
renderTagLink _ Nothing = Nothing
renderTagLink tag (Just filePath) =
Just $ H.a ! A.href (toValue $ toUrl filePath) $ toHtml $ makeReadable tag
makeTagHtml ::String -> String -> Int -> Int -> Int -> String
makeTagHtml tag url count _ _ = renderHtml $
H.a ! A.href (toValue url) $
toHtml (makeReadable tag ++ " (" ++ show count ++ ")")
concatTags :: [H.Html] -> H.Html
concatTags = (mconcat . intersperse ", ")
--------------------------------------------------------------------------------
-- pandoc functions
--------------------------------------------------------------------------------
customWriterOptions = defaultHakyllWriterOptions
{
writerHTMLMathMethod = MathJax ""
}