blob: 7fd5195464dce270649542af0410d585ed128c0b (
plain)
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
|
{-# LANGUAGE OverloadedStrings #-}
-- | The main deployment script.
module Main where
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 System.Environment (getArgs)
import System.FilePath ((</>), splitPath)
import qualified Text.Mustache as Mu
import qualified Text.Parsec.Error
import Text.Pandoc.Class (runIOorExplode)
import qualified Text.Pandoc.Extensions
import Text.Pandoc.Options (ReaderOptions(..))
import Text.Pandoc.Readers.Markdown (readMarkdown)
import Types
-- | A shortcut for `liftIO`.
io :: MonadIO m => IO a -> m a
io = liftIO
-- | A helper for throwing an error if something is `Nothing`
just :: String -> Maybe a -> a
just _ (Just val) = val
just err Nothing = error ("Missing: " ++ err)
-- | Test for whether something listy has a suffix
hasSuffix :: Eq a => [a] -> [a] -> Bool
hasSuffix s = isJust . stripSuffix s
-- | Load the pages from a directory and add them to `pages`.
sourcePages :: FilePath -> Site ()
sourcePages fp = do
links <-
io $ filter (hasSuffix ".md" . last . splitPath) <$>
getRecursiveContents (pure . const False) fp
traverse_ loadPage (map (fp </>) links)
-- | Default markdown reading options for Pandoc.
markdownReadOpts =
def
{ readerExtensions =
Text.Pandoc.Extensions.enableExtension
Text.Pandoc.Extensions.Ext_smart
Text.Pandoc.Extensions.pandocExtensions
}
{- | Extract `PageInfo` about a single page and save it into `pages` in
- `SiteState`. -}
loadPage :: FilePath -> Site ()
loadPage fp = do
io $ putStrLn $ "<<< " ++ fp
txt <- io $ TIO.readFile fp
{- tear out the metadata manually -}
(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)
{- parse everything -}
yml <- Y.decodeThrow $ Data.Text.Encoding.encodeUtf8 meta
md <- io $ runIOorExplode $ readMarkdown markdownReadOpts (T.drop 5 markdown)
{- find the main mount point for the page -}
let mount =
T.unpack . just ("mount point of " ++ fp) $ yml ^? key "title" . _String
{- save to the state -}
pages %=
M.insert mount PageInfo {_pagePath = fp, _pageMeta = yml, _pagePandoc = md}
-- | Find which template to use for rendering a page.
pageTemplate :: PageInfo -> Site FilePath
pageTemplate pi = do
dt <- use defaultTemplate
pure . maybe dt T.unpack $ pi ^? pageMeta . key "template" . _String
-- | Collect all templates required for rendering the currently loaded pages.
pageTemplates :: Site [FilePath]
pageTemplates = nub <$> (gets (^.. pages . traverse) >>= traverse pageTemplate)
compileTemplate :: FilePath -> FilePath -> Site (Either Text.Parsec.Error.ParseError Mu.Template)
compileTemplate templdir templ = io $ do
putStrLn $ "TTT " ++ (templdir </> templ)
Mu.automaticCompile [templdir] templ
-- | Use a template set from a given directory.
sourceTemplates :: FilePath -> Site ()
sourceTemplates templdir = do
ts <- pageTemplates
templs' <- fmap sequence . traverse (compileTemplate templdir) $ ts
case templs' of
Left err -> error $ "template compilation: " ++ show err
Right templs -> templates .= M.fromList (zip ts templs)
-- | Find the path to the "index.html" of a given mount.
indexFilename :: FilePath -> Site FilePath
indexFilename mount = do
od <- use outputDir
pure (od </> mount </> "index.html")
-- | Render a page using the current template.
installPage :: FilePath -> PageInfo -> Site ()
installPage mount pi = do
{- find the correct template and metadata -}
tname <- pageTemplate pi
templ <- use $ templates . to (M.! fromString tname)
file <- indexFilename mount
io $ do
putStrLn $ ">>> " ++ file
makeDirectories file
TIO.writeFile file . Mu.substitute templ $ pi ^. pageMeta
{- | Install a file. Files are installed into a single shared location. That
- prevents file duplication and also gives a bit of control for where the
- files reside and what are their names. -}
installFile :: FilePath -> Site FilePath
installFile = undefined
{- | Install a simple redirect handler page. -}
installRedirect :: FilePath -> FilePath -> Site ()
installRedirect = undefined
-- | Install all redirects required by pages.
installRedirects :: Site ()
installRedirects = undefined
-- | Render a site for a given tag string.
renderTag :: [String] -> Site ()
renderTag = undefined
-- | Render all tag sites.
renderTags :: Site ()
renderTags = undefined
-- | Build the whole site.
main =
flip runStateT emptySiteState $ do
traverse sourcePages ["external"]
sourceTemplates "templates"
use pages >>= traverse (uncurry installPage) . M.assocs
get >>= io . print
|
