161 lines
4.6 KiB
Haskell
161 lines
4.6 KiB
Haskell
{-# 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
|