From 05dd1b23ac64db2446cdeebf8b29043d052fc607 Mon Sep 17 00:00:00 2001
From: Mirek Kratochvil <exa.exa@gmail.com>
Date: Tue, 23 May 2023 23:06:18 +0200
Subject: installs

---
 site.hs | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 51 insertions(+), 12 deletions(-)

(limited to 'site.hs')

diff --git a/site.hs b/site.hs
index 826534e..bc4421c 100644
--- a/site.hs
+++ b/site.hs
@@ -6,9 +6,11 @@ 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 (isJust)
+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
@@ -20,6 +22,7 @@ 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
@@ -34,17 +37,25 @@ 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 ( FilePath
-                               , Y.Value
-                               , Text.Pandoc.Definition.Pandoc -- loc -> (source, meta, markdown)
-                                )
+    { _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 () -- TODO mustache templates
+    , _templates :: M.Map FilePath Mu.Template -- TODO mustache templates
     , _outputDir :: FilePath
+    , _defaultTemplate :: FilePath
     }
   deriving (Show)
 
@@ -58,6 +69,7 @@ emptySiteState out =
     , _installs = M.empty
     , _templates = M.empty
     , _outputDir = out
+    , _defaultTemplate = "default.html"
     }
 
 type Site a = StateT SiteState IO a
@@ -90,13 +102,39 @@ loadPage fp = do
   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 (fp, yml, md)
+  pages %=
+    M.insert mount PageInfo {_pagePath = fp, _pageMeta = yml, _pagePandoc = md}
 
-sourceTemplates :: FilePath -> Site ()
-sourceTemplates _ = pure ()
+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)
 
-installPage :: FilePath -> Site ()
-installPage = undefined
+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
@@ -116,6 +154,7 @@ renderTags = undefined
 main = do
   [targetDir] <- getArgs
   flip runStateT (emptySiteState targetDir) $ do
-    traverse sourceTemplates ["templates"]
     traverse sourcePages ["external"]
+    sourceTemplates "templates"
+    use pages >>= traverse (uncurry installPage) . M.assocs
     get >>= io . print
-- 
cgit v1.2.3