From 3d34bd4a406296de9d711ef421f4f80a0b9b0efa Mon Sep 17 00:00:00 2001
From: Mirek Kratochvil <exa.exa@gmail.com>
Date: Mon, 22 May 2023 23:23:25 +0200
Subject: [PATCH] even more

---
 site.hs | 121 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 121 insertions(+)
 create mode 100644 site.hs

diff --git a/site.hs b/site.hs
new file mode 100644
index 0000000..826534e
--- /dev/null
+++ b/site.hs
@@ -0,0 +1,121 @@
+{-# 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.Extra (stripSuffix)
+import qualified Data.Map as M
+import Data.Maybe (isJust)
+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 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 SiteState =
+  SiteState
+    { _pages :: M.Map FilePath ( FilePath
+                               , Y.Value
+                               , Text.Pandoc.Definition.Pandoc -- loc -> (source, meta, markdown)
+                                )
+    , _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
+    , _outputDir :: 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
+    }
+
+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 (fp, yml, md)
+
+sourceTemplates :: FilePath -> Site ()
+sourceTemplates _ = pure ()
+
+installPage :: FilePath -> Site ()
+installPage = undefined
+
+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 sourceTemplates ["templates"]
+    traverse sourcePages ["external"]
+    get >>= io . print