path: root/hakyll.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Prelude hiding (id)
import Control.Arrow
import Control.Category (id)
import Control.Monad
import Data.Function (on)
import Data.List hiding (group)
import Data.Maybe
import Data.Monoid (mempty, mconcat)

import System.FilePath (takeFileName)
import System.Locale (defaultTimeLocale, TimeLocale)
import Data.Time.Calendar
import Data.Time.Clock (UTCTime (..))
import Data.Time.Format (parseTime, formatTime)

import Text.Printf

import Hakyll

main :: IO ()
main = hakyll $ do
  -- Compress CSS
  match "css/*" $ do
    route   idRoute
    compile compressCssCompiler

  -- Images
  match "images/**" $ do
    route   idRoute
    compile copyFileCompiler

  -- Render posts
  group "posts" $ do
    match (inPostGroup "posts/*") $ do
      route   $ setExtension ".html"
      compile $ pageCompiler
        >>> addDate
        >>> addTagCloud
        >>> addArchiveLinks
        >>> renderTagsField "prettytags" (fromCapture "tags/*")
        >>> applyTemplateCompiler "templates/post.html"
        >>> applyTemplateCompiler "templates/default.html"
        >>> relativizeUrlsCompiler

  -- Index
  match "index*" $ route $ setExtension ".html"
  metaCompile $ requireAllA allPosts $ arr (recentFirst . snd)
    >>> ((constA () &&& constA "index*") &&& id)
    >>> paginatePosts (const "Home")

  match "posts/*" $ compile $ pageCompiler
    >>> (id &&& getIdentifier)
    >>> setFieldA "path" (arr $ fromMaybe "" . runRoutes (setExtension ".html"))
    >>> (id &&& arr (getField "path"))
    >>> setFieldA "url" (arr toUrl)
    
  -- Tags
  create "tags" $
    requireAll_ allPosts >>> arr readTags

  match "tags/*" $ route $ setExtension ".html"
  metaCompile $ require_ "tags"
    >>> arr tagsMap
    >>> mapCompiler (((arr id &&& arr (parseGlob . (++ "*") . identifierPath . tagIdentifier)) *** id)
                     >>> paginatePosts (\tag -> "Posts tagged ‘" ++ tag ++ "’")
                    )
    >>> arr concat

  -- Archive
  create "archive" $
    requireAll_ allPosts >>> arr (Tags . groupTuples . reverse . sortBy (compare `on` fst) . catMaybes . map (\page -> getDate page >>= (\date -> return (date, page))))
  
  match "archive/**" $ route $ setExtension ".html"
  metaCompile $ require_ "archive"
    >>> arr tagsMap
    >>> mapCompiler (((arr id &&& arr (parseGlob . (++ "*") . identifierPath . archiveIdentifier)) *** id)
                     >>> paginatePosts (\month -> "Archive for " ++ prettyMonth month)
                    )
    >>> arr concat

  -- Render RSS feed
  match "rss.xml" $ route idRoute
  create "rss.xml" $ requireAll_ allPosts
    >>> mapCompiler (arr $ copyBodyToField "description")
    >>> renderRss feedConfiguration

  -- Read templates
  match "templates/*" $ compile templateCompiler
  where
    postGroup = Just "posts"

    inPostGroup :: Pattern a -> Pattern a
    inPostGroup p = patternIntersection [inGroup postGroup, p]

    notInPostGroup :: Pattern a -> Pattern a
    notInPostGroup p = patternIntersection [complement $ inGroup postGroup, p]

    allPosts :: Pattern (Page String)
    allPosts = notInPostGroup "posts/*"

    nav prev next = navPrev prev ++ navNext next

    navPrev Nothing = "<span class=\"newer\">&nbsp;</span>"
    navPrev (Just url) = "<span class=\"newer\"><a href=\"" ++ url ++ "\" rel=\"prev\">&laquo; Newer Entries</a></span>"

    navNext Nothing = "<span class=\"older\">&nbsp;</span>"
    navNext (Just url) = "<span class=\"older\"><a href=\"" ++ url ++ "\" rel=\"next\">Older Entries &raquo;</a></span>"

    pageTitle 0 = ""
    pageTitle i = " - Page " ++ show (i+1)

    paginatePosts :: (a -> String) -> Compiler ((a, Pattern (Page String)), [Page String]) [(Identifier (Page String), Compiler () (Page String))]
    paginatePosts title = paginate 5 (setExtension ".html")
                          (arr (\(a, prev, next, i, pages) -> ((mempty, (a, prev, next, i)), pages))
                           >>> first (first (addTagCloud >>> addArchiveLinks)
                                      >>> arr (\(page, (a, prev, next, i)) -> setField "nav" (nav prev next) $ setField "title" (title a ++ pageTitle i) page)
                                     )
                           >>> addPosts
                           >>> applyTemplateCompiler "templates/index.html"
                           >>> applyTemplateCompiler "templates/default.html"
                           >>> relativizeUrlsCompiler
                          )





patternIntersection :: [Pattern a] -> Pattern a
patternIntersection patterns = predicate $ flip all patterns . flip matches


getUTCMaybe :: TimeLocale     -- ^ Output time locale
            -> Page a         -- ^ Input page
            -> Maybe UTCTime  -- ^ Parsed UTCTime
getUTCMaybe locale page = msum
    [ fromPublished "%a, %d %b %Y %H:%M:%S UT"
    , fromPublished "%Y-%m-%dT%H:%M:%SZ"
    , fromPublished "%B %e, %Y %l:%M %p"
    , fromPublished "%B %e, %Y"
    , getFieldMaybe "path" page >>= parseTime' "%Y-%m-%d" .
        intercalate "-" . take 3 . splitAll "-" . takeFileName
    ]
  where
    fromPublished f  = getFieldMaybe "published" page >>= parseTime' f
    parseTime' f str = parseTime locale f str

getDate :: Page a -> Maybe String
getDate = liftM ((\(y, m, _) -> printf "%04d/%02d" y m) . toGregorian . utctDay) . getUTCMaybe defaultTimeLocale

groupTuples :: Eq a => [(a, b)] -> [(a, [b])]
groupTuples = map (fst . head &&& map snd) . groupBy ((==) `on` fst)

paginate :: Int -> Routes -> Compiler (a, Maybe String, Maybe String, Int, [Page String]) (Page String) -> Compiler ((a, Pattern (Page String)), [Page String]) [(Identifier (Page String), Compiler () (Page String))]
paginate perPage routes c = arr $ \((a, pattern), posts) -> renderPages a pattern 0 (n posts) posts
  where
    renderPages _ _ _ _ [] = []
    renderPages a pattern i n posts = (name i, constA (a, prev i, next i n, i, cur) >>> c):(renderPages a pattern (i+1) n rest)
      where
        (cur, rest) = splitAt perPage posts

        prev 0 = Nothing
        prev i = fmap toUrl . runRoutes routes . name $ i-1

        next i n = if i == (n-1) then Nothing else fmap toUrl . runRoutes routes . name $ i+1

        name 0 = fromCapture pattern ""
        name i = fromCapture pattern $ show i

    n posts = (length posts + perPage - 1) `div` perPage


addPosts :: Compiler (Page String, [Page String]) (Page String)
addPosts = setFieldA "posts" $
              mapCompiler (addDate
                           >>> addTagCloud
                           >>> renderTagsField "prettytags" (fromCapture "tags/*")
                           >>> applyTemplateCompiler "templates/post.html")
              >>> arr mconcat
              >>> arr pageBody

addDate = arr $ renderDateField "date" "<span class=\"data\"><span class=\"j\">%e</span>%b/%y</span>" ""

addTagCloud = requireA "tags" (setFieldA "tagcloud" renderTagCloud')
  where
    renderTagCloud' :: Compiler (Tags String) String
    renderTagCloud' = renderTagCloud tagIdentifier 100 300

addArchiveLinks = requireA "archive" (setFieldA "archive" renderArchive)
  where
    renderArchive :: Compiler (Tags String) String
    renderArchive = arr tagsMap
                    >>> arr (map (\(s, p) -> "<li><a href=\"/archive/" ++ s ++ ".html\">" ++ prettyMonth s ++ "</a>&nbsp;(" ++ show (length p) ++ ")</li>"))
                    >>> arr mconcat

prettyMonth :: String -> String
prettyMonth s = month ++ " " ++ year
  where
    year = take 4 s
    month = case (drop 5 s) of
      "01" -> "January"
      "02" -> "February"
      "03" -> "March"
      "04" -> "April"
      "05" -> "May"
      "06" -> "June"
      "07" -> "July"
      "08" -> "August"
      "09" -> "September"
      "10" -> "October"
      "11" -> "November"
      "12" -> "December"
      _ -> "Unknown"


tagIdentifier :: String -> Identifier (Page String)
tagIdentifier = fromCapture "tags/*"

archiveIdentifier :: String -> Identifier (Page String)
archiveIdentifier = fromCapture "archive/*"

feedConfiguration :: FeedConfiguration
feedConfiguration = FeedConfiguration
    { feedTitle       = "Universe Factory"
    , feedDescription = "Because one universe is not enough"
    , feedAuthorName  = "NeoRaider"
    , feedRoot        = "http://blog.universe-factory.net"
    }