1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad (unless, when)
import Control.Monad.IO.Class
import Control.Monad.Trans.State.Lazy
import Data.Default (def)
import Data.Foldable (traverse_)
import Data.List (nub)
import Data.List.Extra (stripSuffix)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust)
import Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Text.Encoding
import qualified Data.Text.IO as TIO
import qualified Data.Yaml as Y
import Hakyll.Core.Util.File (getRecursiveContents, makeDirectories)
import Lens.Micro
import Lens.Micro.Aeson
import Lens.Micro.Mtl
import Lens.Micro.TH
import System.Environment (getArgs)
import System.FilePath ((</>), splitPath)
import qualified Text.Mustache as Mu
import Text.Pandoc.Class (runIOorExplode)
import qualified Text.Pandoc.Definition
import qualified Text.Pandoc.Extensions
import Text.Pandoc.Options (ReaderOptions(..))
import Text.Pandoc.Readers.Markdown (readMarkdown)
import Debug.Trace
io :: MonadIO m => IO a -> m a
io = liftIO
just _ (Just val) = val
just err Nothing = error ("Missing: " ++ err)
data PageInfo =
PageInfo
{ _pagePath :: FilePath
, _pageMeta :: Y.Value
, _pagePandoc :: Text.Pandoc.Definition.Pandoc
}
deriving (Show)
makeLenses ''PageInfo
data SiteState =
SiteState
{ _pages :: M.Map FilePath PageInfo
, _redirects :: M.Map FilePath FilePath -- from -> to
, _htags :: M.Map [String] [FilePath] -- tag sequence -> tagged locs
, _installs :: M.Map FilePath FilePath -- file hash -> install location
, _templates :: M.Map FilePath Mu.Template -- TODO mustache templates
, _outputDir :: FilePath
, _defaultTemplate :: FilePath
}
deriving (Show)
makeLenses ''SiteState
emptySiteState out =
SiteState
{ _pages = M.empty
, _redirects = M.empty
, _htags = M.empty
, _installs = M.empty
, _templates = M.empty
, _outputDir = out
, _defaultTemplate = "default.html"
}
type Site a = StateT SiteState IO a
hasSuffix s = isJust . stripSuffix s
sourcePages :: FilePath -> Site ()
sourcePages fp = do
links <-
io $ filter (hasSuffix ".md" . last . splitPath) <$>
getRecursiveContents (pure . const False) fp
traverse_ loadPage (map (fp </>) links)
markdownReadOpts =
def
{ readerExtensions =
Text.Pandoc.Extensions.enableExtension
Text.Pandoc.Extensions.Ext_smart
Text.Pandoc.Extensions.pandocExtensions
}
loadPage :: FilePath -> Site ()
loadPage fp = do
txt <- io $ TIO.readFile fp
(T.take 4 txt == "---\n") `unless`
error ("metadata block start missing in " ++ fp)
let (meta, markdown) = T.breakOn "\n---\n" (T.drop 4 txt)
T.null meta `when` error ("metadata block bad in " ++ fp)
yml <- Y.decodeThrow $ Data.Text.Encoding.encodeUtf8 meta
md <- io $ runIOorExplode $ readMarkdown markdownReadOpts (T.drop 5 markdown)
let mount =
T.unpack . just ("mount point of " ++ fp) $ yml ^? key "title" . _String
pages %=
M.insert mount PageInfo {_pagePath = fp, _pageMeta = yml, _pagePandoc = md}
pageTemplate :: PageInfo -> Site FilePath
pageTemplate pi = do
dt <- use defaultTemplate
pure . maybe dt T.unpack $ pi ^? pageMeta . key "template" . _String
pageTemplates :: Site [FilePath]
pageTemplates = nub <$> (gets (^.. pages . traverse) >>= traverse pageTemplate)
sourceTemplates :: FilePath -> Site ()
sourceTemplates templdir = do
ts <- pageTemplates
templs' <- fmap sequence . traverse (io . Mu.automaticCompile [templdir]) $ ts
case templs' of
Left err -> error $ "template compilation: " ++ show err
Right templs -> templates .= M.fromList (zip ts templs)
indexFilename :: FilePath -> Site FilePath
indexFilename mount = do
od <- use outputDir
pure (od </> mount </> "index.html")
installPage :: FilePath -> PageInfo -> Site ()
installPage mount pi = do
tname <- fromString <$> pageTemplate pi
templ <- use $ templates . to (M.! tname)
file <- indexFilename mount
io $ do
putStrLn $ ">>> " ++ file
makeDirectories file
TIO.writeFile file . Mu.substitute templ $ pi ^. pageMeta
installFile :: FilePath -> Site FilePath
installFile = undefined
makeRedirect :: FilePath -> FilePath -> Site ()
makeRedirect = undefined
makeRedirects :: Site ()
makeRedirects = undefined
renderTag :: [String] -> Site ()
renderTag = undefined
renderTags :: Site ()
renderTags = undefined
main = do
[targetDir] <- getArgs
flip runStateT (emptySiteState targetDir) $ do
traverse sourcePages ["external"]
sourceTemplates "templates"
use pages >>= traverse (uncurry installPage) . M.assocs
get >>= io . print
|
