summaryrefslogtreecommitdiffstats
path: root/hakyll.hs
diff options
context:
space:
mode:
Diffstat (limited to 'hakyll.hs')
-rw-r--r--hakyll.hs206
1 files changed, 206 insertions, 0 deletions
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" "<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\" title=\"" ++ prettyMonth s ++ "\">" ++ 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/*"
+
+makeTagList :: String -> [Page String] -> Compiler () (Page String)
+makeTagList tag posts = constA (mempty, posts)
+ >>> addPosts
+ >>> addTagCloud
+ >>> addArchiveLinks
+ >>> arr (setField "title" ("Posts tagged &#8216;" ++ tag ++ "&#8217;"))
+ >>> 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/"
+ }