diff options
| -rw-r--r-- | Com/Simatime/Alpha.hs | 5 | ||||
| -rw-r--r-- | Run/Que/Website.hs | 78 | ||||
| -rw-r--r-- | deps.nix | 1 |
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 () @@ -5,6 +5,7 @@ "async" "bytestring" "clay" + "config-ini" "containers" "dhall" "ekg" |