Massively improve the que-website

curl was throwing an exception if the file got too long, because I was
passing the entire file contents in the arguments to curl. I tried using
a tmp file but that didn't work for some reason. So I switched to req
and that seems to work well.

I also made it faster by serving all pages concurrently, and I spruced
up the CSS a ton.

1 files changed, 67 insertions, 35 deletions

diff --git a/Run/Que/Website.hs b/Run/Que/Website.hs
index 1de6bca..e6b458c 100644
--- a/Run/Que/Website.hs
+++ b/Run/Que/Website.hs
@@ -1,45 +1,77 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE LambdaCase #-}
+
 -- | spawns a few processes that serve the que.run website
 module Run.Que.Website where
 
-import           Prelude
+import qualified Control.Concurrent.Async      as Async
+import qualified Data.ByteString.Char8         as BS
+import qualified Data.Text                     as Text
+import           Network.HTTP.Req
+import           Protolude
 import           System.Environment            as Environment
 import           System.FilePath                ( (</>) )
 import qualified System.Process                as Process
+import qualified System.Exit                   as Exit
 
 main :: IO ()
 main = do
-  args <- Environment.getArgs
-  let [src, ns] = if length args == 2
-        then take 2 args
-        else if length args == 1
-          then args ++ ["/"]
-          else error "usage: que-website <srcdir> [namespace]"
-  homepage <- getHomepageHtml (src </> "style.css") (src </> "index.md")
-  client   <- readFile $ src </> "client.py"
+  (src, ns) <- Environment.getArgs >>= \case
+    [src]     -> return (src, "/")
+    [src, ns] -> return (src, ns)
+    _         -> Exit.die "usage: que-website <srcdir> [namespace]"
+
   putStrLn $ "serving " ++ src ++ " at " ++ ns
-  loop ns homepage client
-
-loop :: String -> FilePath -> FilePath -> IO ()
-loop ns homepage client =
-  serve (ns </> "index.html") homepage
-    >> serve (ns </> "_client/python") client
-    >> loop ns homepage client
-
-getHomepageHtml :: String -> String -> IO String
-getHomepageHtml style index = Process.readProcess
-  "pandoc"
-  [ "--self-contained"
-  , "--css"
-  , style
-  , "-i"
-  , index
-  , "--from"
-  , "markdown"
-  , "--to"
-  , "html"
-  ]
-  []
-
-serve :: FilePath -> FilePath -> IO ()
-serve path file =
-  Process.callProcess "curl" ["https://que.run" ++ path, "-d", file]
+  loop (Text.pack ns) $ Sources { index      = src </> "index.md"
+                                , client     = src </> "client.py"
+                                , quescripts = src </> "quescripts.md"
+                                , style      = src </> "style.css"
+                                }
+
+data Sources = Sources
+  { index :: FilePath
+  , quescripts :: FilePath
+  , client :: FilePath
+  , style :: FilePath
+  }
+
+loop :: Text -> Sources -> IO ()
+loop ns pages@Sources {..} = do
+  _ <-
+    Async.runConcurrently
+    $   (,,,)
+    <$> Async.Concurrently
+          (toHtml style index >>= serve (https "que.run" /: ns /: "index.html"))
+    <*> Async.Concurrently
+          (   BS.readFile client
+          >>= serve (https "que.run" /: ns /: "_client" /: "python")
+          )
+    <*> Async.Concurrently
+          (   toHtml style quescripts
+          >>= serve (https "que.run" /: ns /: "_page" /: "quescripts")
+          )
+  loop ns pages
+
+
+toHtml :: FilePath -> FilePath -> IO ByteString
+toHtml style md =
+  BS.pack
+    <$> Process.readProcess
+          "pandoc"
+          [ "--self-contained"
+          , "--css"
+          , style
+          , "-i"
+          , md
+          , "--from"
+          , "markdown"
+          , "--to"
+          , "html"
+          ]
+          []
+
+serve :: Url scheme -> ByteString -> IO ()
+serve path content = runReq defaultHttpConfig $ do
+  _ <- req POST path (ReqBodyBs content) ignoreResponse mempty
+  liftIO $ return ()