1 files changed, 137 insertions, 0 deletions
diff --git a/Biz/Que/Site.hs b/Biz/Que/Site.hs
new file mode 100644
index 0000000..99486a4
--- /dev/null
+++ b/Biz/Que/Site.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | spawns a few processes that serve the que.run website
+--
+-- : out que-website
+--
+-- : dep async
+-- : dep config-ini
+-- : dep process
+-- : dep protolude
+-- : dep req
+module Biz.Que.Site
+  ( main,
+  )
+where
+
+import Alpha
+import qualified Control.Concurrent.Async as Async
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Ini.Config as Config
+import qualified Data.Text as Text
+import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text.IO as Text
+import Network.HTTP.Req
+import qualified System.Directory as Directory
+import System.Environment as Environment
+import qualified System.Exit as Exit
+import System.FilePath ((</>))
+import qualified System.Process as Process
+
+main :: IO ()
+main = do
+  (src, ns) <-
+    Environment.getArgs >>= \case
+      [src] -> return (src, "_") -- default to _ ns which is special
+      [src, ns] -> return (src, Text.pack ns)
+      _ -> Exit.die "usage: que-website <srcdir> [namespace]"
+  mKey <- getKey ns
+  putText <| "serving " <> Text.pack src <> " at " <> ns
+  run mKey ns
+    <| Sources
+      { index = src </> "Index.md",
+        client = src </> "Client.py",
+        quescripts = src </> "Quescripts.md",
+        style = src </> "Style.css",
+        apidocs = src </> "Apidocs.md",
+        tutorial = src </> "Tutorial.md"
+      }
+
+getKey :: Namespace -> IO (Maybe Key)
+getKey ns = do
+  home <- Directory.getHomeDirectory
+  let file = home </> ".config" </> "que.conf"
+  exists <- Directory.doesFileExist file
+  unless exists <| panic <| "not found: " <> Text.pack file
+  conf <- Text.readFile file
+  print (home </> ".config" </> "que.conf")
+  auth ns
+    |> Config.parseIniFile conf
+    |> either errorParsingConf identity
+    |> return
+
+errorParsingConf :: error
+errorParsingConf = panic "could not parse ~/.config/que.conf"
+
+data Sources = Sources
+  { index :: FilePath,
+    quescripts :: FilePath,
+    client :: FilePath,
+    style :: FilePath,
+    tutorial :: FilePath,
+    apidocs :: FilePath
+  }
+
+type Namespace = Text
+
+type Key = Text
+
+auth :: Namespace -> Config.IniParser (Maybe Key)
+auth "pub" = pure Nothing
+auth ns = Config.sectionMb ns <| Config.field "key"
+
+run :: Maybe Key -> Text -> Sources -> IO ()
+run key ns Sources {..} = Async.runConcurrently actions |> void
+  where
+    actions =
+      traverse
+        Async.Concurrently
+        [ forever <| toHtml index >>= serve key ns "index",
+          forever <| toHtml quescripts >>= serve key ns "quescripts",
+          forever <| BS.readFile client >>= serve key ns "client",
+          forever <| toHtml tutorial >>= serve key ns "tutorial",
+          forever <| toHtml apidocs >>= serve key ns "apidocs"
+        ]
+    toHtml :: FilePath -> IO ByteString
+    toHtml md =
+      BS.pack
+        </ Process.readProcess
+          "pandoc"
+          [ "--include-in-header",
+            style,
+            "-i",
+            md,
+            "--from",
+            "markdown",
+            "--to",
+            "html"
+          ]
+          []
+
+serve :: Maybe Key -> Namespace -> Text -> ByteString -> IO ()
+serve Nothing "pub" path content =
+  runReq defaultHttpConfig <| do
+    _ <-
+      req
+        POST
+        (http "que.run" /: "pub" /: path)
+        (ReqBodyBs content)
+        ignoreResponse
+        mempty
+    liftIO <| return ()
+serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p
+serve (Just key) ns path content =
+  runReq defaultHttpConfig <| do
+    let options =
+          header "Authorization" (encodeUtf8 key) <> responseTimeout maxBound
+    _ <-
+      req
+        POST
+        (http "que.run" /: ns /: path)
+        (ReqBodyBs content)
+        ignoreResponse
+        options
+    liftIO <| return ()