summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Site.hs123
1 files changed, 119 insertions, 4 deletions
diff --git a/src/Site.hs b/src/Site.hs
index d1afbce..dde7047 100644
--- a/src/Site.hs
+++ b/src/Site.hs
@@ -1,16 +1,131 @@
1{-# LANGUAGE OverloadedStrings #-} 1{-# LANGUAGE OverloadedStrings, RankNTypes, StandaloneDeriving, FlexibleInstances #-}
2 2
3import Hakyll 3import Hakyll
4 4
5import Data.Monoid (Monoid(..), mconcat, (<>))
6import Control.Monad (liftM)
7import Data.Char (toLower, isSpace, isAlphaNum)
8import Data.Maybe (mapMaybe, fromMaybe)
9import Data.Map (Map)
10import qualified Data.Map as Map
11import Data.List (take, reverse)
12import Data.Default
13import Text.Pandoc.Options (WriterOptions(..), ObfuscationMethod(..))
14import Control.Applicative (Alternative(..), Applicative(..))
15
16import System.FilePath (replaceExtension)
17
5main :: IO () 18main :: IO ()
6main = hakyllWith config $ do 19main = hakyllWith config $ do
7 match "/posts/*" $ do 20 match "templates/*" $ compile templateCompiler
21
22 match "css/*" $ do
23 route idRoute
24 compile copyFileCompiler
25
26 match "posts/*" $ do
8 route $ setExtension ".html" 27 route $ setExtension ".html"
9 compile $ do 28 compile $ do
29 getResourceBody >>= saveSnapshot "content"
10 pandocCompiler 30 pandocCompiler
11 >>= saveSnapshot "content"
12 >>= loadAndApplyTemplate "templates/default.html" defaultContext 31 >>= loadAndApplyTemplate "templates/default.html" defaultContext
13 >>= relativizeUrls 32 >>= relativizeUrls
14 33
34 tags <- buildTags "posts/*" tagTranslation' >>= addTag "All Posts" "posts/*"
35
36 tagsRules tags $ \tag pattern -> do
37 route idRoute
38 compile $ do
39 let ctx = mconcat [ constField "title" tag
40 , listField "posts" defaultContext $ chronological =<< loadAll pattern
41 , defaultContext
42 ]
43 makeItem ""
44 >>= loadAndApplyTemplate "templates/post-list.html" ctx
45 >>= loadAndApplyTemplate "templates/default.html" ctx
46 >>= relativizeUrls
47
48 let
49 tags' = tags { tagsMakeId = fromFilePath . (`replaceExtension` "rss") . toFilePath . tagsMakeId tags}
50
51 tagsRules tags' $ \tag pattern -> do
52 route idRoute
53 compile $ do
54 let
55 feedCtx = mconcat [ bodyField "description"
56 , defaultContext
57 ]
58 renderRss (feedConfig tag) feedCtx =<< loadAllSnapshots pattern "content"
59
60 match "index.md" $ do
61 route $ setExtension ".html"
62 compile $ do
63 let ctx = mconcat [ listField "tags" defaultContext $ mapM (\(k, _) -> renderTag k tags) $ tagsMap tags
64 , constField "title" "Index"
65 , defaultContext
66 ]
67 item <- getResourceBody
68 pandocCompilerWith def (def { writerEmailObfuscation = NoObfuscation })
69 >>= loadAndApplyTemplate "templates/index.html" ctx
70 >>= loadAndApplyTemplate "templates/default.html" ctx
71 >>= relativizeUrls
72
73deriving instance Eq (Item String)
74
75feedConfig :: String -> FeedConfiguration
76feedConfig tagName = FeedConfiguration { feedTitle = "dirty-haskell.org: " ++ tagName
77 , feedDescription = "dirty-haskell.org — A Blog."
78 , feedAuthorName = "G. Kleen"
79 , feedAuthorEmail = "blog@dirty-haskell.org"
80 , feedRoot = "https://dirty-haskell.org"
81 }
82
83renderTag :: String -- ^ Tag name
84 -> Tags
85 -> Compiler (Item String)
86renderTag tag tags = do
87 ellipsisItem <- makeItem ""
88 let
89 ids = fromMaybe [] $ lookup tag $ tagsMap tags
90 postCtx = mconcat [ listField "posts" (ellipsisContext ellipsisItem) $ liftM (withEllipsis ellipsisItem) $ chronological =<< mapM load ids
91 , constField "title" tag
92 , constField "rss" ("tags/" ++ tagTranslation tag ++ ".rss")
93 , constField "url" ("tags/" ++ tagTranslation tag ++ ".html")
94 , defaultContext
95 ]
96 makeItem ""
97 >>= loadAndApplyTemplate "templates/post-list.html" postCtx
98 >>= loadAndApplyTemplate "templates/tag.html" postCtx
99 where
100 ellipsisContext item = mconcat [ boolField "ellipsis" (== item)
101 , defaultContext
102 ]
103 boolField name f = field name (\i -> if f i
104 then pure (error $ unwords ["no string value for bool field:",name])
105 else empty)
106 withEllipsis ellipsisItem xs
107 | length xs > max = [ellipsisItem] ++ takeEnd (max - 1) xs
108 | otherwise = xs
109 takeEnd i = reverse . take i . reverse
110 max = 4
111
112tagTranslation' :: String -> Identifier
113tagTranslation' = fromCapture "tags/*.html" . tagTranslation
114
115tagTranslation :: String -> String
116tagTranslation = mapMaybe charTrans
117 where
118 charTrans c
119 | isSpace c = Just $ '-'
120 | isAlphaNum c = Just $ toLower c
121 | otherwise = Nothing
122
123addTag :: MonadMetadata m => String -> Pattern -> Tags -> m Tags
124addTag name pattern tags = do
125 ids <- getMatches pattern
126 return $ tags { tagsMap = tagsMap tags ++ [(name, ids)] }
127
15config :: Configuration 128config :: Configuration
16config = defaultConfiguration 129config = defaultConfiguration { providerDirectory = "provider"
130 , deployCommand = "rsync -av --progress -c --delete-delay -m _site/ gkleen@surtr.yggdrasil.li:/var/www/dirty-haskell.org/"
131 }