From 88d237aebd9fc29f28c2f3511f7eb3e30a0a1ff8 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Fri, 1 Jun 2012 15:28:45 +0200 Subject: Initial commit --- hakyll.hs | 206 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 206 insertions(+) create mode 100644 hakyll.hs (limited to 'hakyll.hs') diff --git a/hakyll.hs b/hakyll.hs new file mode 100644 index 0000000..daac1a5 --- /dev/null +++ b/hakyll.hs @@ -0,0 +1,206 @@ +{-# 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.html" $ route idRoute + create "index.html" $ constA mempty + >>> arr (setField "title" "Home") + >>> addTagCloud + >>> addArchiveLinks + >>> requireAllA allPosts (id *** arr recentFirst >>> addPosts) + >>> applyTemplateCompiler "templates/index.html" + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler + + match "posts/*" $ compile $ readPageCompiler + >>> (id &&& getIdentifier) + >>> setFieldA "path" (arr $ fromMaybe "" . runRoutes (setExtension ".html")) + >>> (id &&& arr (getField "path")) + >>> setFieldA "url" (arr ('/':)) + + -- Tags + create "tags" $ + requireAll allPosts (\_ ps -> readTags ps :: Tags String) + + -- Add a tag list compiler for every tag + match "tags/*" $ route $ setExtension ".html" + metaCompile $ require_ "tags" + >>> arr tagsMap + >>> arr (map (\(t, p) -> (tagIdentifier t, makeTagList t p))) + + -- Archive + create "archive" $ + requireAll allPosts (\_ -> 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 + >>> arr (map (\(m, p) -> (archiveIdentifier m, makeArchive m p))) + + -- 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/*" + + +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) + + +addPosts :: Compiler (Page String, [Page String]) (Page String) +addPosts = setFieldA "posts" $ + mapCompiler (addDate + >>> addTagCloud + >>> renderTagsField "prettytags" (fromCapture "tags/*") + >>> applyTemplateCompiler "templates/post_short.html") + >>> arr mconcat + >>> arr pageBody + +addDate = arr $ renderDateField "date" "%e%b/%y" "" + +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) -> "
  • " ++ prettyMonth s ++ " (" ++ show (length p) ++ ")
    • ")) + >>> 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/*" + +makeTagList :: String -> [Page String] -> Compiler () (Page String) +makeTagList tag posts = constA (mempty, posts) + >>> addPosts + >>> addTagCloud + >>> addArchiveLinks + >>> arr (setField "title" ("Posts tagged ‘" ++ tag ++ "’")) + >>> applyTemplateCompiler "templates/posts.html" + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler + +makeArchive :: String -> [Page String] -> Compiler () (Page String) +makeArchive month posts = constA (mempty, posts) + >>> addPosts + >>> addTagCloud + >>> addArchiveLinks + >>> arr (setField "title" ("Archive for " ++ prettyMonth month)) + >>> applyTemplateCompiler "templates/posts.html" + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler + +feedConfiguration :: FeedConfiguration +feedConfiguration = FeedConfiguration + { feedTitle = "Universe Factory" + , feedDescription = "Because one universe is not enough" + , feedAuthorName = "NeoRaider" + , feedRoot = "http://blog.universe-factory.net/" + } -- cgit v1.2.3