diff options
Diffstat (limited to 'Que')
| -rw-r--r-- | Que/Server.hs | 35 | ||||
| -rw-r--r-- | Que/Website.hs | 14 |
2 files changed, 20 insertions, 29 deletions
diff --git a/Que/Server.hs b/Que/Server.hs index 4cb0b32..9217ee8 100644 --- a/Que/Server.hs +++ b/Que/Server.hs @@ -25,13 +25,7 @@ module Que.Server ) where -import Alpha hiding - ( Text, - get, - gets, - modify, - poll, - ) +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 @@ -41,11 +35,8 @@ 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 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 @@ -105,7 +96,7 @@ instance Envy.DefConfig Config where instance Envy.FromEnv Config -routes :: Scotty.ScottyT Text App () +routes :: Scotty.ScottyT Text.Lazy.Text App () routes = do Scotty.middleware logStdout let quepath = "^\\/([[:alnum:]_-]+)\\/([[:alnum:]._/-]*)$" @@ -117,7 +108,7 @@ routes = do -- GET /_/dash Scotty.get (Scotty.literal "/_/dash") <| do authkey <- fromMaybe "" </ Scotty.header "Authorization" - adminkey <- liftIO <| lchomp </ Text.readFile "/run/keys/que-admin" + adminkey <- liftIO <| lchomp </ Text.Lazy.IO.readFile "/run/keys/que-admin" if authkey == adminkey then do d <- app <| gets ques @@ -141,7 +132,7 @@ routes = do q <- app <| que ns qp poll <- Scotty.param "poll" !: (pure . const False) if poll - then Scotty.stream $ streamQue q + then Scotty.stream <| streamQue q else do r <- liftIO <| Go.read q Scotty.html <| fromStrict <| Encoding.decodeUtf8 r @@ -150,7 +141,7 @@ routes = do -- Put a value on a que. Returns immediately. Scotty.post (Scotty.regex quepath) <| do authkey <- fromMaybe "" </ Scotty.header "Authorization" - adminkey <- liftIO <| lchomp </ Text.readFile "/run/keys/que-admin" + adminkey <- liftIO <| lchomp </ Text.Lazy.IO.readFile "/run/keys/que-admin" (ns, qp) <- extract -- Only allow my IP or localhost to publish to '_' namespace when ("_" == ns && authkey /= adminkey) @@ -167,7 +158,7 @@ routes = do -- | Given `guardNs ns whitelist`, if `ns` is not in the `whitelist` -- list, return a 405 error. -guardNs :: Text -> [Text] -> Scotty.ActionT Text App () +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 @@ -179,10 +170,10 @@ guardNs ns whitelist = when (not <| ns `elem` whitelist) <| do -- | recover from a scotty-thrown exception. (!:) :: -- | action that might throw - Scotty.ActionT Text App a -> + Scotty.ActionT Text.Lazy.Text App a -> -- | a function providing a default response instead - (Text -> Scotty.ActionT Text App a) -> - Scotty.ActionT Text App a + (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'. @@ -212,7 +203,7 @@ insertQue ns qp q as = as {ques = newQues} newQues = HashMap.insert ns newQbase (ques as) newQbase = HashMap.insert qp q <| grab ns <| ques as -extract :: Scotty.ActionT Text App (Namespace, Quepath) +extract :: Scotty.ActionT Text.Lazy.Text App (Namespace, Quepath) extract = do ns <- Scotty.param "1" path <- Scotty.param "2" @@ -232,7 +223,7 @@ modify :: (AppState -> AppState) -> App () modify f = ask >>= liftIO . atomically . flip STM.modifyTVar' f -- | housing for a set of que paths -type Namespace = Text +type Namespace = Text.Lazy.Text -- | a que is just a channel of bytes type Que = Go.Channel Message diff --git a/Que/Website.hs b/Que/Website.hs index 7eb3ae6..623173b 100644 --- a/Que/Website.hs +++ b/Que/Website.hs @@ -38,8 +38,8 @@ main = do [src, ns] -> return (src, Text.pack ns) _ -> Exit.die "usage: que-website <srcdir> [namespace]" mKey <- getKey ns - putText $ "serving " <> Text.pack src <> " at " <> ns - run mKey ns $ + putText <| "serving " <> Text.pack src <> " at " <> ns + run mKey ns <| Sources { index = src </> "index.md", client = src </> "client.py", @@ -98,7 +98,7 @@ run key ns Sources {..} = Async.runConcurrently actions |> void toHtml :: FilePath -> IO ByteString toHtml md = BS.pack - <$> Process.readProcess + </ Process.readProcess "pandoc" [ "--include-in-header", style, @@ -112,7 +112,7 @@ run key ns Sources {..} = Async.runConcurrently actions |> void [] serve :: Maybe Key -> Namespace -> Text -> ByteString -> IO () -serve Nothing "pub" path content = runReq defaultHttpConfig $ do +serve Nothing "pub" path content = runReq defaultHttpConfig <| do _ <- req POST @@ -120,9 +120,9 @@ serve Nothing "pub" path content = runReq defaultHttpConfig $ do (ReqBodyBs content) ignoreResponse mempty - liftIO $ return () + liftIO <| return () serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p -serve (Just key) ns path content = runReq defaultHttpConfig $ do +serve (Just key) ns path content = runReq defaultHttpConfig <| do let options = header "Authorization" (encodeUtf8 key) <> responseTimeout maxBound _ <- @@ -132,4 +132,4 @@ serve (Just key) ns path content = runReq defaultHttpConfig $ do (ReqBodyBs content) ignoreResponse options - liftIO $ return () + liftIO <| return () |