diff options
| -rw-r--r-- | Com/Simatime/Alpha.hs | 13 | ||||
| -rw-r--r-- | Com/Simatime/Go.hs | 5 | ||||
| -rw-r--r-- | Run/Que/Server.hs | 28 |
3 files changed, 37 insertions, 9 deletions
diff --git a/Com/Simatime/Alpha.hs b/Com/Simatime/Alpha.hs index 8f5a506..cc3d23c 100644 --- a/Com/Simatime/Alpha.hs +++ b/Com/Simatime/Alpha.hs @@ -11,6 +11,9 @@ module Com.Simatime.Alpha , (/>) , (</) , (<//) + -- * Text + , chomp + , lchomp -- * Debugging tools , say -- * TODO: remove this @@ -22,6 +25,8 @@ import Data.Function ( (&) ) import Data.Functor ( (<&>) ) import Data.String import Data.Text ( Text ) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText import qualified Prelude import Protolude as X @@ -63,3 +68,11 @@ infixr 0 <| -- functor. Could also be defined as `f >>= return . g` (/>) :: Functor f => f a -> (a -> b) -> f b (/>) = (<&>) + +-- | Removes newlines from text. +chomp :: Text -> Text +chomp = Text.filter (/= '\n') + +-- | Removes newlines from lazy text. +lchomp :: LazyText.Text -> LazyText.Text +lchomp = LazyText.filter (/= '\n') diff --git a/Com/Simatime/Go.hs b/Com/Simatime/Go.hs index bd9296a..e622539 100644 --- a/Com/Simatime/Go.hs +++ b/Com/Simatime/Go.hs @@ -7,6 +7,7 @@ Golang and Clojure's core.async. $example -} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Com.Simatime.Go ( -- * Running and forking @@ -25,6 +26,7 @@ import Com.Simatime.Alpha hiding ( read ) import qualified Control.Concurrent as Concurrent import qualified Control.Concurrent.Chan.Unagi.Bounded as Chan +import qualified Data.Aeson as Aeson -- | A standard channel. data Channel a = Channel @@ -33,6 +35,9 @@ data Channel a = Channel , _size :: Int } +instance Aeson.ToJSON (Channel a) where + toJSON _ = Aeson.String ("#<channel>" :: Text) + -- | Starts a background process. fork :: IO () -> IO Concurrent.ThreadId fork = Concurrent.forkIO diff --git a/Run/Que/Server.hs b/Run/Que/Server.hs index 4974498..146a16a 100644 --- a/Run/Que/Server.hs +++ b/Run/Que/Server.hs @@ -35,6 +35,7 @@ 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 @@ -84,6 +85,19 @@ routes = do 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.header "Authorization" + adminkey <- liftIO <| lchomp </ Text.readFile "/run/keys/que-admin" + if authkey == adminkey + then do + d <- app <| gets ques + Scotty.json d + else do + Scotty.status Http.methodNotAllowed405 + Scotty.text "not allowed" + + -- | Namespace management Scotty.matchAny (Scotty.regex namespace) <| do Scotty.status Http.notImplemented501 @@ -110,17 +124,13 @@ routes = do -- -- Put a value on a que. Returns immediately. Scotty.post (Scotty.regex quepath) <| do - xFwdHost <- Scotty.header "X-Forwarded-Host" - xRealIP <- Scotty.header "X-Real-IP" - host <- Scotty.header "Host" + 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 - when ("_" == ns) <| case (xFwdHost, xRealIP, host) of - (Just "73.222.221.62", _, _) -> Scotty.status Http.ok200 - (_, Just "73.222.221.62", _) -> Scotty.status Http.ok200 - (_, _, Just ("localhost:3000")) -> Scotty.status Http.ok200 - _ -> Scotty.status Http.methodNotAllowed405 - >> Scotty.text "not allowed: _ is a reserved namespace" + when ("_" == ns && authkey /= adminkey) + <| Scotty.status Http.methodNotAllowed405 + >> Scotty.text "not allowed: _ is a reserved namespace" guardNs ns ["pub", "_"] -- passed all auth checks app . modify <| upsertNamespace ns |