Loop que-website threads independently

3 files changed, 62 insertions, 22 deletions

diff --git a/Com/Simatime/Alpha.hs b/Com/Simatime/Alpha.hs
index cc3d23c..7003cc5 100644
--- a/Com/Simatime/Alpha.hs
+++ b/Com/Simatime/Alpha.hs
@@ -14,6 +14,7 @@ module Com.Simatime.Alpha
   -- * Text
   , chomp
   , lchomp
+  , joinWith
   -- * Debugging tools
   , say
   -- * TODO: remove this
@@ -76,3 +77,7 @@ chomp = Text.filter (/= '\n')
 -- | Removes newlines from lazy text.
 lchomp :: LazyText.Text -> LazyText.Text
 lchomp = LazyText.filter (/= '\n')
+
+-- | Join a list of things with a separator.
+joinWith :: [a] -> [[a]] -> [a]
+joinWith = intercalate
diff --git a/Run/Que/Website.hs b/Run/Que/Website.hs
index 757f5e6..25610dd 100644
--- a/Run/Que/Website.hs
+++ b/Run/Que/Website.hs
@@ -6,21 +6,31 @@
 -- | 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 Run.Que.Website where
+module Run.Que.Website
+  ( main
+  )
+where
 
 import qualified Control.Concurrent.Async      as Async
+import           Com.Simatime.Alpha
 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           Protolude
+import           Prelude                        ( error )
+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
-import qualified System.Exit                   as Exit
 
 main :: IO ()
 main = do
@@ -28,15 +38,24 @@ main = do
     [src]     -> return (src, "_") -- default to _ ns which is special
     [src, ns] -> return (src, ns)
     _         -> Exit.die "usage: que-website <srcdir> [namespace]"
-
+  home <- Directory.getHomeDirectory
+  conf <- Text.readFile <| home </> ".config" </> "que.conf"
+  let (Auth _ key) =
+        either needConf identity
+          <| Config.parseIniFile conf
+          <| auth
+          <| Text.pack ns
   putStrLn $ "serving " ++ src ++ " at " ++ ns
-  loop (Text.pack 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"
-                                }
+  run key (Text.pack 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"
+                                   }
+
+needConf :: error
+needConf = error "you need a ~/.config/que.conf"
 
 data Sources = Sources
   { index :: FilePath
@@ -47,18 +66,27 @@ data Sources = Sources
   , apidocs :: FilePath
   }
 
-loop :: Text -> Sources -> IO ()
-loop ns pages@Sources {..} = Async.runConcurrently actions >> loop ns pages
+type Namespace = Text
+type Key = Text
+
+data Auth = Auth Namespace Key
+
+auth :: Text -> Config.IniParser Auth
+auth ns = Config.section ns $ do
+  key <- Config.field "key"
+  return <| Auth ns key
+
+run :: Key -> Text -> Sources -> IO ()
+run key ns Sources {..} = Async.runConcurrently actions >> return ()
  where
   actions = traverse
     Async.Concurrently
-    [ toHtml index >>= srv "index"
-    , toHtml quescripts >>= srv "quescripts"
-    , BS.readFile client >>= srv "client"
-    , toHtml tutorial >>= srv "tutorial"
-    , toHtml apidocs >>= srv "apidocs"
+    [ 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"
     ]
-  srv p = serve $ https "que.run" /: ns /: p
   toHtml :: FilePath -> IO ByteString
   toHtml md =
     BS.pack
@@ -77,7 +105,13 @@ loop ns pages@Sources {..} = Async.runConcurrently actions >> loop ns pages
             []
 
 -- TODO: recover from 502 errors
-serve :: Url scheme -> ByteString -> IO ()
-serve path content = runReq defaultHttpConfig $ do
-  _ <- req POST path (ReqBodyBs content) ignoreResponse mempty
+serve :: Key -> Namespace -> Text -> ByteString -> IO ()
+serve 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 ()
diff --git a/deps.nix b/deps.nix
index f2db479..0fac1bd 100644
--- a/deps.nix
+++ b/deps.nix
@@ -5,6 +5,7 @@
   "async"
   "bytestring"
   "clay"
+  "config-ini"
   "containers"
   "dhall"
   "ekg"