diff options
Diffstat (limited to 'Que')
| -rw-r--r-- | Que/Server.hs | 214 | ||||
| -rw-r--r-- | Que/Website.hs | 147 |
2 files changed, 195 insertions, 166 deletions
diff --git a/Que/Server.hs b/Que/Server.hs index 841cbfa..b0f3fbd 100644 --- a/Que/Server.hs +++ b/Que/Server.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} -- | Interprocess communication -- @@ -22,68 +22,82 @@ -- : dep unagi-chan -- : dep unordered-containers module Que.Server - ( main + ( main, ) where -import Alpha hiding ( Text - , get - , 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 Alpha hiding + ( Text, + get, + 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 Data.Text.Lazy ( Text - , fromStrict - ) -import qualified Data.Text.Lazy.IO as Text -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 System.Exit as Exit -import qualified Web.Scotty.Trans as Scotty +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 Data.Text.Lazy + ( Text, + fromStrict, + ) +import qualified Data.Text.Lazy.IO as Text +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 System.Exit as Exit +import qualified Web.Scotty.Trans as Scotty main :: IO () main = Exception.bracket startup shutdown <| uncurry Warp.run - where - startup = Envy.decodeEnv >>= \case - Left e -> Exit.die e - Right c -> do - sync <- STM.newTVarIO initialAppState - let runActionToIO m = runReaderT (runApp m) sync - waiapp <- Scotty.scottyAppT runActionToIO routes - 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)) - -data AppState = AppState - { ques :: HashMap Namespace Quebase - } + where + startup = Envy.decodeEnv >>= \case + Left e -> Exit.die e + Right c -> do + sync <- STM.newTVarIO initialAppState + let runActionToIO m = runReaderT (runApp m) sync + waiapp <- Scotty.scottyAppT runActionToIO routes + 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) + ) + +data AppState + = AppState + { ques :: HashMap Namespace Quebase + } initialAppState :: AppState -initialAppState = AppState { ques = mempty } +initialAppState = AppState {ques = mempty} -data Config = Config - { quePort :: Warp.Port -- ^ QUE_PORT - } deriving (Generic, Show) +data Config + = Config + { -- | QUE_PORT + quePort :: Warp.Port + } + deriving (Generic, Show) instance Envy.DefConfig Config where defConfig = Config 3000 @@ -93,17 +107,15 @@ instance Envy.FromEnv Config routes :: Scotty.ScottyT Text App () routes = do Scotty.middleware logStdout - - let quepath = "^\\/([[:alnum:]_]+)\\/([[:alnum:]._/]*)$" + let quepath = "^\\/([[:alnum:]_]+)\\/([[:alnum:]._/]*)$" let namespace = "^\\/([[:alnum:]_]+)\\/?$" -- matches '/ns' and '/ns/' but not '/ns/path' - -- | GET /index.html + -- GET /index.html Scotty.get (Scotty.literal "/index.html") <| Scotty.redirect "/_/index" Scotty.get (Scotty.literal "/") <| Scotty.redirect "/_/index" - - -- | GET /_/dash + -- GET /_/dash Scotty.get (Scotty.literal "/_/dash") <| do - authkey <- fromMaybe "" </ Scotty.header "Authorization" + authkey <- fromMaybe "" </ Scotty.header "Authorization" adminkey <- liftIO <| lchomp </ Text.readFile "/run/keys/que-admin" if authkey == adminkey then do @@ -112,14 +124,11 @@ routes = do else do Scotty.status Http.methodNotAllowed405 Scotty.text "not allowed" - - - -- | Namespace management + -- Namespace management Scotty.matchAny (Scotty.regex namespace) <| do Scotty.status Http.notImplemented501 Scotty.text "namespace management coming soon" - - -- | GET que + -- GET que -- -- Receive a value from a que. Blocks until a value is received, -- then returns. If 'poll=true', then stream data from the Que to the @@ -127,20 +136,19 @@ routes = do Scotty.get (Scotty.regex quepath) <| do (ns, qp) <- extract app . modify <| upsertNamespace ns - q <- app <| que ns qp + q <- app <| que ns qp poll <- Scotty.param "poll" !: (pure . const False) guardNs ns ["pub", "_"] case poll of True -> Scotty.stream $ streamQue q - _ -> do + _ -> do r <- liftIO <| Go.read q Scotty.html <| fromStrict <| Encoding.decodeUtf8 r - - -- | POST que + -- POST que -- -- Put a value on a que. Returns immediately. Scotty.post (Scotty.regex quepath) <| do - authkey <- fromMaybe "" </ Scotty.header "Authorization" + authkey <- fromMaybe "" </ Scotty.header "Authorization" adminkey <- liftIO <| lchomp </ Text.readFile "/run/keys/que-admin" (ns, qp) <- extract -- Only allow my IP or localhost to publish to '_' namespace @@ -151,9 +159,9 @@ routes = do guardNs ns ["pub", "_"] -- passed all auth checks app . modify <| upsertNamespace ns - q <- app <| que ns qp + q <- app <| que ns qp qdata <- Scotty.body - _ <- liftIO <| Go.write q <| BSL.toStrict qdata + _ <- liftIO <| Go.write q <| BSL.toStrict qdata return () -- | Given `guardNs ns whitelist`, if `ns` is not in the `whitelist` @@ -168,21 +176,23 @@ guardNs ns whitelist = when (not <| ns `elem` whitelist) <| do Scotty.finish -- | recover from a scotty-thrown exception. -(!:) - :: Scotty.ActionT Text App a -- ^ action that might throw - -> (Text -> Scotty.ActionT Text App a) -- ^ a function providing a default response instead - -> Scotty.ActionT Text App a +(!:) :: + -- | action that might throw + Scotty.ActionT Text App a -> + -- | a function providing a default response instead + (Text -> Scotty.ActionT Text App a) -> + Scotty.ActionT Text App a (!:) = Scotty.rescue -- | Forever write the data from 'Que' to 'Wai.StreamingBody'. streamQue :: Que -> Wai.StreamingBody streamQue q write _ = Go.mult q >>= loop - where - loop c = - Go.tap c - >>= (write . Builder.byteStringInsert) - >> (write <| Builder.byteStringInsert "\n") - >> loop c + where + loop c = + Go.tap c + >>= (write . Builder.byteStringInsert) + >> (write <| Builder.byteStringInsert "\n") + >> 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 @@ -190,20 +200,21 @@ 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) } +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 +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 App (Namespace, Quepath) extract = do - ns <- Scotty.param "1" + ns <- Scotty.param "1" path <- Scotty.param "2" return (ns, path) @@ -220,17 +231,26 @@ gets f = ask >>= liftIO . STM.readTVarIO >>= return . f modify :: (AppState -> AppState) -> App () modify f = ask >>= liftIO . atomically . flip STM.modifyTVar' f -type Namespace = Text -- ^ housing for a set of que paths -type Que = Go.Channel Message -- ^ a que is just a channel of bytes -type Quepath = Text -- ^ any path can serve as an identifier for a que -type Message = ByteString -- ^ any opaque data -type Quebase = HashMap Quepath Que -- ^ a collection of ques +-- | housing for a set of que paths +type Namespace = 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 + let qbase = grab ns _ques queExists = HashMap.member qp qbase if queExists then return <| grab qp qbase diff --git a/Que/Website.hs b/Que/Website.hs index e75f2bd..cfb860c 100644 --- a/Que/Website.hs +++ b/Que/Website.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE LambdaCase #-} -- | spawns a few processes that serve the que.run website -- @@ -13,39 +13,41 @@ -- : dep protolude -- : dep req module Que.Website - ( main + ( 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 +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] -> return (src, "_") -- default to _ ns which is special [src, ns] -> return (src, Text.pack ns) - _ -> Exit.die "usage: que-website <srcdir> [namespace]" + _ -> 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" - } + 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 @@ -63,64 +65,71 @@ getKey ns = do 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 - } +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" +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" - ] - [] + 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 + _ <- + 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 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 + _ <- + req + POST + (http "que.run" /: ns /: path) + (ReqBodyBs content) + ignoreResponse + options liftIO $ return () |