From e069bc069f998e3158c826e20f7d94575907ae46 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Fri, 23 Oct 2020 16:16:50 -0400 Subject: Rename Que.{Server,Website} -> Que.{Host,Site} --- Que/Host.hs | 254 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Que/Host.nix | 46 ++++++++++ Que/Server.hs | 251 ------------------------------------------------------- Que/Server.nix | 46 ---------- Que/Site.hs | 135 ++++++++++++++++++++++++++++++ Que/Site.nix | 59 +++++++++++++ Que/Website.hs | 135 ------------------------------ Que/Website.nix | 59 ------------- default.nix | 12 +-- 9 files changed, 500 insertions(+), 497 deletions(-) create mode 100644 Que/Host.hs create mode 100644 Que/Host.nix delete mode 100644 Que/Server.hs delete mode 100644 Que/Server.nix create mode 100644 Que/Site.hs create mode 100644 Que/Site.nix delete mode 100644 Que/Website.hs delete mode 100644 Que/Website.nix diff --git a/Que/Host.hs b/Que/Host.hs new file mode 100644 index 0000000..5b51dba --- /dev/null +++ b/Que/Host.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Interprocess communication +-- +-- Prior art: +-- - +-- - +-- - +-- - sorta: and +-- +-- : exe que-server +-- +-- : dep async +-- : dep envy +-- : dep protolude +-- : dep scotty +-- : dep stm +-- : dep unagi-chan +-- : dep unordered-containers +module Que.Host + ( main, + ) +where + +import Alpha hiding (gets, modify, poll) +import qualified Control.Concurrent.Go as Go +import qualified Control.Concurrent.STM as STM +import qualified Control.Exception as Exception +import Control.Monad.Reader (MonadTrans) +import qualified Data.ByteString.Builder.Extra as Builder +import qualified Data.ByteString.Lazy as BSL +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Text.Encoding as Encoding +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.IO as Text.Lazy.IO +import qualified Network.HTTP.Types.Status as Http +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import Network.Wai.Middleware.RequestLogger + ( logStdout, + ) +import qualified System.Envy as Envy +import qualified Web.Scotty.Trans as Scotty +import qualified Prelude + +{-# ANN module ("HLint: ignore Reduce duplication" :: Prelude.String) #-} + +main :: IO () +main = Exception.bracket startup shutdown <| uncurry Warp.run + where + startup = Envy.decodeWithDefaults Envy.defConfig >>= \c -> do + sync <- STM.newTVarIO initialAppState + let runActionToIO m = runReaderT (runApp m) sync + waiapp <- Scotty.scottyAppT runActionToIO <| routes c + putText "*" + putText "Que.Host" + putText <| "port: " <> (show <| quePort c) + putText <| "skey: " <> (show <| queSkey c) + return (port c, waiapp) + shutdown :: a -> IO a + shutdown = pure . identity + +newtype App a + = App + { runApp :: ReaderT (STM.TVar AppState) IO a + } + deriving + ( Applicative, + Functor, + Monad, + MonadIO, + MonadReader + (STM.TVar AppState) + ) + +newtype AppState + = AppState + { ques :: HashMap Namespace Quebase + } + +initialAppState :: AppState +initialAppState = AppState {ques = mempty} + +data Config + = Config + { -- | QUE_PORT + quePort :: Warp.Port, + -- | QUE_SKEY + queSkey :: FilePath + } + deriving (Generic, Show) + +instance Envy.DefConfig Config where + defConfig = Config 3000 "/run/skey/que-admin" + +instance Envy.FromEnv Config + +routes :: Config -> Scotty.ScottyT Text.Lazy.Text App () +routes cfg = do + Scotty.middleware logStdout + let quepath = "^\\/([[:alnum:]_-]+)\\/([[:alnum:]._/-]*)$" + let namespace = "^\\/([[:alnum:]_-]+)\\/?$" -- matches '/ns' and '/ns/' but not '/ns/path' + + -- GET /index.html + Scotty.get (Scotty.literal "/index.html") <| Scotty.redirect "/_/index" + Scotty.get (Scotty.literal "/") <| Scotty.redirect "/_/index" + -- GET /_/dash + Scotty.get (Scotty.literal "/_/dash") <| do + authkey <- fromMaybe "" > Scotty.text "not allowed: _ is a reserved namespace" + >> Scotty.finish + guardNs ns ["pub", "_"] + -- passed all auth checks + app . modify <| upsertNamespace ns + q <- app <| que ns qp + qdata <- Scotty.body + _ <- liftIO <| Go.write q <| BSL.toStrict qdata + return () + +-- | Given `guardNs ns whitelist`, if `ns` is not in the `whitelist` +-- list, return a 405 error. +guardNs :: Text.Lazy.Text -> [Text.Lazy.Text] -> Scotty.ActionT Text.Lazy.Text App () +guardNs ns whitelist = when (not <| ns `elem` whitelist) <| do + Scotty.status Http.methodNotAllowed405 + Scotty.text + <| "not allowed: use 'pub' namespace or signup to protect '" + <> ns + <> "' at https://que.run" + Scotty.finish + +-- | recover from a scotty-thrown exception. +(!:) :: + -- | action that might throw + Scotty.ActionT Text.Lazy.Text App a -> + -- | a function providing a default response instead + (Text.Lazy.Text -> Scotty.ActionT Text.Lazy.Text App a) -> + Scotty.ActionT Text.Lazy.Text App a +(!:) = Scotty.rescue + +-- | Forever write the data from 'Que' to 'Wai.StreamingBody'. +streamQue :: Que -> Wai.StreamingBody +streamQue q write _ = loop q + where + loop c = + Go.read c + >>= (write . Builder.byteStringInsert) + >> loop c + +-- | Gets the thing from the Hashmap. Call's 'error' if key doesn't exist. +grab :: (Eq k, Hashable k) => k -> HashMap k v -> v +grab = flip (HashMap.!) + +-- | Inserts the namespace in 'AppState' if it doesn't exist. +upsertNamespace :: Namespace -> AppState -> AppState +upsertNamespace ns as = + if HashMap.member ns (ques as) + then as + else as {ques = HashMap.insert ns mempty (ques as)} + +-- | Inserts the que at the proper 'Namespace' and 'Quepath'. +insertQue :: Namespace -> Quepath -> Que -> AppState -> AppState +insertQue ns qp q as = as {ques = newQues} + where + newQues = HashMap.insert ns newQbase (ques as) + newQbase = HashMap.insert qp q <| grab ns <| ques as + +extract :: Scotty.ActionT Text.Lazy.Text App (Namespace, Quepath) +extract = do + ns <- Scotty.param "1" + path <- Scotty.param "2" + return (ns, path) + +-- | A synonym for 'lift' in order to be explicit about when we are +-- operating at the 'App' layer. +app :: MonadTrans t => App a -> t App a +app = lift + +-- | Get something from the app state +gets :: (AppState -> b) -> App b +gets f = ask >>= liftIO . STM.readTVarIO >>= return AppState) -> App () +modify f = ask >>= liftIO . atomically . flip STM.modifyTVar' f + +-- | housing for a set of que paths +type Namespace = Text.Lazy.Text + +-- | a que is just a channel of bytes +type Que = Go.Channel Message + +-- | any path can serve as an identifier for a que +type Quepath = Text + +-- | any opaque data +type Message = ByteString + +-- | a collection of ques +type Quebase = HashMap Quepath Que + +-- | Lookup or create a que +que :: Namespace -> Quepath -> App Que +que ns qp = do + _ques <- gets ques + let qbase = grab ns _ques + queExists = HashMap.member qp qbase + if queExists + then return <| grab qp qbase + else do + c <- liftIO <| Go.chan 1 + modify (insertQue ns qp c) + gets ques /> grab ns /> grab qp diff --git a/Que/Host.nix b/Que/Host.nix new file mode 100644 index 0000000..e326483 --- /dev/null +++ b/Que/Host.nix @@ -0,0 +1,46 @@ +{ options +, lib +, config +, pkgs +, modulesPath +}: + +let + cfg = config.services.que-server; +in +{ + options.services.que-server = { + enable = lib.mkEnableOption "Enable the que-server service"; + port = lib.mkOption { + type = lib.types.int; + default = 3000; + description = '' + The port on which que-server will listen for + incoming HTTP traffic. + ''; + }; + package = lib.mkOption { + type = lib.types.package; + description = "que-server package to use"; + }; + }; + config = lib.mkIf cfg.enable { + systemd.services.que-server = { + path = [ cfg.package ]; + wantedBy = [ "multi-user.target" ]; + script = '' + ${cfg.package}/bin/que-server + ''; + description = '' + Que server + ''; + serviceConfig = { + Environment = ["QUE_PORT=${toString cfg.port}"]; + KillSignal = "INT"; + Type = "simple"; + Restart = "on-abort"; + RestartSec = "1"; + }; + }; + }; +} diff --git a/Que/Server.hs b/Que/Server.hs deleted file mode 100644 index 9217ee8..0000000 --- a/Que/Server.hs +++ /dev/null @@ -1,251 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Interprocess communication --- --- Prior art: --- - --- - --- - --- - sorta: and --- --- : exe que-server --- --- : dep async --- : dep envy --- : dep protolude --- : dep scotty --- : dep stm --- : dep unagi-chan --- : dep unordered-containers -module Que.Server - ( main, - ) -where - -import Alpha hiding (gets, modify, poll) -import qualified Control.Concurrent.Go as Go -import qualified Control.Concurrent.STM as STM -import qualified Control.Exception as Exception -import Control.Monad.Reader (MonadTrans) -import qualified Data.ByteString.Builder.Extra as Builder -import qualified Data.ByteString.Lazy as BSL -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.Text.Encoding as Encoding -import qualified Data.Text.Lazy as Text.Lazy -import qualified Data.Text.Lazy.IO as Text.Lazy.IO -import qualified Network.HTTP.Types.Status as Http -import qualified Network.Wai as Wai -import qualified Network.Wai.Handler.Warp as Warp -import Network.Wai.Middleware.RequestLogger - ( logStdout, - ) -import qualified System.Envy as Envy -import qualified Web.Scotty.Trans as Scotty -import qualified Prelude - -{-# ANN module ("HLint: ignore Reduce duplication" :: Prelude.String) #-} - -main :: IO () -main = Exception.bracket startup shutdown <| uncurry Warp.run - where - startup = Envy.decodeWithDefaults Envy.defConfig >>= \c -> do - sync <- STM.newTVarIO initialAppState - let runActionToIO m = runReaderT (runApp m) sync - waiapp <- Scotty.scottyAppT runActionToIO routes - putText "*" - putText "que-server" - putText <| "port: " <> (show <| quePort c) - return (quePort c, waiapp) - shutdown :: a -> IO a - shutdown = pure . identity - -newtype App a - = App - { runApp :: ReaderT (STM.TVar AppState) IO a - } - deriving - ( Applicative, - Functor, - Monad, - MonadIO, - MonadReader - (STM.TVar AppState) - ) - -newtype AppState - = AppState - { ques :: HashMap Namespace Quebase - } - -initialAppState :: AppState -initialAppState = AppState {ques = mempty} - -newtype Config - = Config - { -- | QUE_PORT - quePort :: Warp.Port - } - deriving (Generic, Show) - -instance Envy.DefConfig Config where - defConfig = Config 3000 - -instance Envy.FromEnv Config - -routes :: Scotty.ScottyT Text.Lazy.Text App () -routes = do - Scotty.middleware logStdout - let quepath = "^\\/([[:alnum:]_-]+)\\/([[:alnum:]._/-]*)$" - let namespace = "^\\/([[:alnum:]_-]+)\\/?$" -- matches '/ns' and '/ns/' but not '/ns/path' - - -- GET /index.html - Scotty.get (Scotty.literal "/index.html") <| Scotty.redirect "/_/index" - Scotty.get (Scotty.literal "/") <| Scotty.redirect "/_/index" - -- GET /_/dash - Scotty.get (Scotty.literal "/_/dash") <| do - authkey <- fromMaybe "" > Scotty.text "not allowed: _ is a reserved namespace" - >> Scotty.finish - guardNs ns ["pub", "_"] - -- passed all auth checks - app . modify <| upsertNamespace ns - q <- app <| que ns qp - qdata <- Scotty.body - _ <- liftIO <| Go.write q <| BSL.toStrict qdata - return () - --- | Given `guardNs ns whitelist`, if `ns` is not in the `whitelist` --- list, return a 405 error. -guardNs :: Text.Lazy.Text -> [Text.Lazy.Text] -> Scotty.ActionT Text.Lazy.Text App () -guardNs ns whitelist = when (not <| ns `elem` whitelist) <| do - Scotty.status Http.methodNotAllowed405 - Scotty.text - <| "not allowed: use 'pub' namespace or signup to protect '" - <> ns - <> "' at https://que.run" - Scotty.finish - --- | recover from a scotty-thrown exception. -(!:) :: - -- | action that might throw - Scotty.ActionT Text.Lazy.Text App a -> - -- | a function providing a default response instead - (Text.Lazy.Text -> Scotty.ActionT Text.Lazy.Text App a) -> - Scotty.ActionT Text.Lazy.Text App a -(!:) = Scotty.rescue - --- | Forever write the data from 'Que' to 'Wai.StreamingBody'. -streamQue :: Que -> Wai.StreamingBody -streamQue q write _ = loop q - where - loop c = - Go.read c - >>= (write . Builder.byteStringInsert) - >> loop c - --- | Gets the thing from the Hashmap. Call's 'error' if key doesn't exist. -grab :: (Eq k, Hashable k) => k -> HashMap k v -> v -grab = flip (HashMap.!) - --- | Inserts the namespace in 'AppState' if it doesn't exist. -upsertNamespace :: Namespace -> AppState -> AppState -upsertNamespace ns as = - if HashMap.member ns (ques as) - then as - else as {ques = HashMap.insert ns mempty (ques as)} - --- | Inserts the que at the proper 'Namespace' and 'Quepath'. -insertQue :: Namespace -> Quepath -> Que -> AppState -> AppState -insertQue ns qp q as = as {ques = newQues} - where - newQues = HashMap.insert ns newQbase (ques as) - newQbase = HashMap.insert qp q <| grab ns <| ques as - -extract :: Scotty.ActionT Text.Lazy.Text App (Namespace, Quepath) -extract = do - ns <- Scotty.param "1" - path <- Scotty.param "2" - return (ns, path) - --- | A synonym for 'lift' in order to be explicit about when we are --- operating at the 'App' layer. -app :: MonadTrans t => App a -> t App a -app = lift - --- | Get something from the app state -gets :: (AppState -> b) -> App b -gets f = ask >>= liftIO . STM.readTVarIO >>= return AppState) -> App () -modify f = ask >>= liftIO . atomically . flip STM.modifyTVar' f - --- | housing for a set of que paths -type Namespace = Text.Lazy.Text - --- | a que is just a channel of bytes -type Que = Go.Channel Message - --- | any path can serve as an identifier for a que -type Quepath = Text - --- | any opaque data -type Message = ByteString - --- | a collection of ques -type Quebase = HashMap Quepath Que - --- | Lookup or create a que -que :: Namespace -> Quepath -> App Que -que ns qp = do - _ques <- gets ques - let qbase = grab ns _ques - queExists = HashMap.member qp qbase - if queExists - then return <| grab qp qbase - else do - c <- liftIO <| Go.chan 1 - modify (insertQue ns qp c) - gets ques /> grab ns /> grab qp diff --git a/Que/Server.nix b/Que/Server.nix deleted file mode 100644 index e326483..0000000 --- a/Que/Server.nix +++ /dev/null @@ -1,46 +0,0 @@ -{ options -, lib -, config -, pkgs -, modulesPath -}: - -let - cfg = config.services.que-server; -in -{ - options.services.que-server = { - enable = lib.mkEnableOption "Enable the que-server service"; - port = lib.mkOption { - type = lib.types.int; - default = 3000; - description = '' - The port on which que-server will listen for - incoming HTTP traffic. - ''; - }; - package = lib.mkOption { - type = lib.types.package; - description = "que-server package to use"; - }; - }; - config = lib.mkIf cfg.enable { - systemd.services.que-server = { - path = [ cfg.package ]; - wantedBy = [ "multi-user.target" ]; - script = '' - ${cfg.package}/bin/que-server - ''; - description = '' - Que server - ''; - serviceConfig = { - Environment = ["QUE_PORT=${toString cfg.port}"]; - KillSignal = "INT"; - Type = "simple"; - Restart = "on-abort"; - RestartSec = "1"; - }; - }; - }; -} diff --git a/Que/Site.hs b/Que/Site.hs new file mode 100644 index 0000000..2b35956 --- /dev/null +++ b/Que/Site.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | 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.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 [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 + 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 () diff --git a/Que/Site.nix b/Que/Site.nix new file mode 100644 index 0000000..6a24d9d --- /dev/null +++ b/Que/Site.nix @@ -0,0 +1,59 @@ +{ options +, lib +, config +, pkgs +, modulesPath +}: + +let + cfg = config.services.que-website; + static = pkgs.stdenv.mkDerivation { + src = ./.; + name = "que-website-static"; + installPhase = '' + mkdir -p $out + cp ${./apidocs.md} $out/apidocs.md + cp ${./index.md} $out/index.md + cp ${./quescripts.md} $out/quescripts.md + cp ${./style.css} $out/style.css + cp ${./tutorial.md} $out/tutorial.md + cp ${./client.py} $out/client.py + ''; + }; +in +{ + options.services.que-website = { + enable = lib.mkEnableOption "Enable the que-website service"; + namespace = lib.mkOption { + type = lib.types.str; + default = "_"; + description = '' + The que namespace on which que-website will broadcast. + ''; + }; + package = lib.mkOption { + type = lib.types.package; + description = "que-website package to use"; + }; + }; + config = lib.mkIf cfg.enable { + systemd.services.que-website = { + path = [ cfg.package pkgs.pandoc ]; + wantedBy = [ "multi-user.target" ]; + script = '' + ${cfg.package}/bin/que-website ${static} ${cfg.namespace} + ''; + description = '' + Que website server + ''; + serviceConfig = { + User = "root"; + Environment = "HOME=/root"; + KillSignal = "INT"; + Type = "simple"; + Restart = "on-abort"; + RestartSec = "1"; + }; + }; + }; +} diff --git a/Que/Website.hs b/Que/Website.hs deleted file mode 100644 index 623173b..0000000 --- a/Que/Website.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | 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 [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 - 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 () diff --git a/Que/Website.nix b/Que/Website.nix deleted file mode 100644 index 6a24d9d..0000000 --- a/Que/Website.nix +++ /dev/null @@ -1,59 +0,0 @@ -{ options -, lib -, config -, pkgs -, modulesPath -}: - -let - cfg = config.services.que-website; - static = pkgs.stdenv.mkDerivation { - src = ./.; - name = "que-website-static"; - installPhase = '' - mkdir -p $out - cp ${./apidocs.md} $out/apidocs.md - cp ${./index.md} $out/index.md - cp ${./quescripts.md} $out/quescripts.md - cp ${./style.css} $out/style.css - cp ${./tutorial.md} $out/tutorial.md - cp ${./client.py} $out/client.py - ''; - }; -in -{ - options.services.que-website = { - enable = lib.mkEnableOption "Enable the que-website service"; - namespace = lib.mkOption { - type = lib.types.str; - default = "_"; - description = '' - The que namespace on which que-website will broadcast. - ''; - }; - package = lib.mkOption { - type = lib.types.package; - description = "que-website package to use"; - }; - }; - config = lib.mkIf cfg.enable { - systemd.services.que-website = { - path = [ cfg.package pkgs.pandoc ]; - wantedBy = [ "multi-user.target" ]; - script = '' - ${cfg.package}/bin/que-website ${static} ${cfg.namespace} - ''; - description = '' - Que website server - ''; - serviceConfig = { - User = "root"; - Environment = "HOME=/root"; - KillSignal = "INT"; - Type = "simple"; - Restart = "on-abort"; - RestartSec = "1"; - }; - }; - }; -} diff --git a/default.nix b/default.nix index 29ed1a3..2915990 100644 --- a/default.nix +++ b/default.nix @@ -43,8 +43,8 @@ in rec { imports = [ ./Biz/packages.nix ./Biz/users.nix - ./Que/Server.nix - ./Que/Website.nix + ./Que/Host.nix + ./Que/Site.nix ./Que/Prod.nix ]; networking.hostName = "prod-que"; @@ -52,12 +52,12 @@ in rec { services.que-server = { enable = true; port = 80; - package = Que.Server; + package = Que.Host; }; services.que-website = { enable = true; namespace = "_"; - package = Que.Website; + package = Que.Site; }; }; # Production server for herocomics.app @@ -84,8 +84,8 @@ in rec { Biz.Ibb.Client = build.ghcjs Biz/Ibb/Client.hs; Hero.Host = build.ghc Hero/Host.hs; Hero.Node = build.ghcjs Hero/Node.hs; - Que.Server = build.ghc ./Que/Server.hs; - Que.Website = build.ghc ./Que/Website.hs; + Que.Host = build.ghc ./Que/Host.hs; + Que.Site = build.ghc ./Que/Site.hs; # Development environment env = build.env; # Fall through to any of our overlay packages -- cgit v1.2.3