Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

387 lines (321 sloc) 14.007 kb
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad (forM)
import Data.Monoid (mconcat, mappend)
import Data.List (intersperse, sortBy, isInfixOf, unfoldr)
import Data.Ord (comparing)
import Data.String (IsString)
import Data.Strings (strJoin)
import Hakyll
import System.FilePath ((</>), takeBaseName, takeDirectory,
takeFileName, splitFileName)
import System.Locale (defaultTimeLocale)
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
pageCtx :: Context String
pageCtx = descCtx `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]
paginateCtx :: Paginate -> Int -> (Context String)
paginateCtx paginate n
| nPages == 1 = constField "noPages" "True"
| n == 1 = constField "prevPage" (show $ n + 1)
| n == nPages = constField "nextPage" (show $ n - 1)
| otherwise = constField "prevPage" (show $ n + 1) `mappend`
constField "nextPage" (show $ n - 1)
where nPages = M.size (paginatePages paginate)
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,
paginateCtx 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 "sass" ["-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 = "http://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 = (buildPaginator postsPerPage postsPattern)
buildPaginator :: MonadMetadata m => Int -> Pattern -> m Paginate
buildPaginator n pattern = do
idents <- createdFirst =<< getMatches pattern
let identSet = S.fromList idents
pages = flip unfoldr idents $ \xs ->
if null xs then Nothing else Just (splitAt n xs)
nPages = length pages
paginatePages' = zip [1..] pages
makeId = \i -> fromFilePath $ "blog/" ++ show i ++ "/index.html"
pagPlaces' =
[(ident, idx) | (idx,ids) <- paginatePages', ident <- ids]
return $ Paginate (M.fromList paginatePages') (M.fromList pagPlaces') makeId
(PatternDependency pattern identSet)
-- 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 ",")
$ M.lookup "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 ""
}
Jump to Line
Something went wrong with that request. Please try again.