Re-namespacing

Moving away from the DNS-driven namespacing toward more condensed names,
mostly because I don't like typing so much.

1 files changed, 126 insertions, 0 deletions

diff --git a/Que/Website.hs b/Que/Website.hs
new file mode 100644
index 0000000..e75f2bd
--- /dev/null
+++ b/Que/Website.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | spawns a few processes that serve the que.run website
+--
+-- : exe que-website
+--
+-- : dep async
+-- : dep config-ini
+-- : dep process
+-- : dep protolude
+-- : dep req
+module Que.Website
+  ( 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 >> return ()
+ 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 ()