packages feed

polysemy-webserver 0.1.0.0 → 0.2.0.0

raw patch · 3 files changed

+200/−17 lines, 3 filesdep +textdep +wai-websocketsdep +websockets

Dependencies added: text, wai-websockets, websockets

Files

polysemy-webserver.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 1125f9e81101158130a70f12db4783c3043caf583c7f7d28e039506c7aed885b+-- hash: d50a6f2a69b24e2e973f6c76bb785989fb448d9269513a0aacafdc9ea071f8de  name:           polysemy-webserver-version:        0.1.0.0+version:        0.2.0.0 synopsis:       Start web servers from within a Polysemy effect stack description:    Please see the README on GitLab at <https://gitlab.com/A1kmm/polysemy-webserver/-/blob/master/README.md> category:       Web@@ -40,7 +40,9 @@     , polysemy     , polysemy-plugin     , wai+    , wai-websockets     , warp+    , websockets   default-language: Haskell2010  test-suite polysemy-webserver-test@@ -50,7 +52,7 @@       Paths_polysemy_webserver   hs-source-dirs:       test-  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -threaded -rtsopts -with-rtsopts=-N1   build-depends:       base >=4.7 && <5     , bytestring@@ -60,6 +62,9 @@     , polysemy     , polysemy-plugin     , polysemy-webserver+    , text     , wai+    , wai-websockets     , warp+    , websockets   default-language: Haskell2010
src/Polysemy/WebServer.hs view
@@ -15,15 +15,23 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} -module Polysemy.WebServer (WebServer, PendingWebRequest, startWebServer,-  respondWebRequest, getBody, runWebServerFinal) where+module Polysemy.WebServer (WebServer(..), PendingWebRequest, startWebServer,+  respondWebRequest, getBody, upgradeToWebSocketsResponse,+  acceptPendingWebSocketConnection, rejectPendingWebSocketConnection,+  whilePingingWebSocket, sendWebSocketDataMessages, receiveWebSocketDataMessage,+  sendWebSocketCloseCode, runWebServerFinal) where import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Handler.WebSockets as WaiWs import qualified Network.HTTP.Types.Status as HTTP+import qualified Network.WebSockets.Connection as WS+import qualified Network.WebSockets as WS import Polysemy import Polysemy.Final import Data.Functor import Control.Monad+import Control.Exception (catch)+import Data.Word (Word16) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS @@ -31,12 +39,44 @@   PendingWebRequest (Wai.Response -> IO Wai.ResponseReceived)  data WebServer m a where+  -- |Starts a new web-server listening on a port, sending all requests to the provided+  --  function.   StartWebServer :: Warp.Port -> (     Wai.Request -> PendingWebRequest -> m Wai.ResponseReceived) ->     WebServer m ()+  -- | Responds to a web request (usually called from the callback to+  --   StartWebServer.   RespondWebRequest :: PendingWebRequest -> Wai.Response ->                        WebServer m Wai.ResponseReceived+  -- | Reads the entire body of a request into memory. Takes a maximum length+  --   to read - if the body length exceeds this length, returns Nothing.   GetBody :: Int -> Wai.Request -> WebServer m (Maybe BS.ByteString)+  -- | Builds a response to upgrade a connection to a web socket.+  --   Returns Nothing if the request is not appropriate to upgrade.+  UpgradeToWebSocketsResponse :: WS.ConnectionOptions ->+    (WS.PendingConnection -> m ()) -> Wai.Request -> WebServer m (Maybe Wai.Response)+  -- | Accepts a pending WebSockets connection.+  AcceptPendingWebSocketConnection :: WS.PendingConnection -> WS.AcceptRequest ->+    WebServer m (Either (Either WS.HandshakeException WS.ConnectionException) WS.Connection)+  -- | Rejects a pending WebSockets connection.+  RejectPendingWebSocketConnection :: WS.PendingConnection -> WS.RejectRequest ->+    WebServer m ()+  -- | Runs an app, and sends a ping message over the WebSockets connection+  --   every n seconds while the app is executing. When the app completes,+  --   the pings will also stop.+  WhilePingingWebSocket :: WS.Connection -> Int -> m a -> WebServer m (Maybe a)+  -- | Sends some data messages over the WebSockets connection.+  SendWebSocketDataMessages :: WS.Connection -> [WS.DataMessage] -> WebServer m ()+  -- | Receives a data message from the WebSockets connection. Returns a+  --   Left @WS.CloseRequest if the connection is closed cleanly. Returns a+  --   Left @WS.ConnectionClosed if the+  --   connection is closed uncleanly.+  ReceiveWebSocketDataMessage :: WS.Connection -> WebServer m (Either WS.ConnectionException WS.DataMessage)+  -- | Sends a friendly close message and close code on a WebSocket.+  --   See http://tools.ietf.org/html/rfc6455#section-7.4 for a list of close+  --   codes.+  SendWebSocketCloseCode :: WS.WebSocketsData a => WS.Connection -> Word16 -> a -> WebServer m ()+ makeSem ''WebServer  runStartWebServer :: forall rInitial r f.@@ -75,17 +115,17 @@       Warp.run port $ \req reply -> doRequestIO req reply       return $ s1 $> s0 +ioToWebServerTactics ::+  forall a rInitial r f. (Functor f, Final IO `Member` r) =>+  IO a -> Sem (WithTactics WebServer f (Sem rInitial) r) (f a)+ioToWebServerTactics action = pureT =<< embedFinal action+ runRespondWebRequest :: forall rInitial r f.   ((Final IO) `Member` r, Functor f) =>   PendingWebRequest -> Wai.Response ->   Sem (WithTactics WebServer f (Sem rInitial) r) (f Wai.ResponseReceived)-runRespondWebRequest (PendingWebRequest respond) resp = do-  s0 <- getInitialStateT-  withStrategicToFinal $ do-    s1 <- getInitialStateS-    return $ do-      rr <- respond (resp)-      return $ s1 $> (s0 $> rr)+runRespondWebRequest (PendingWebRequest respond) resp =+  ioToWebServerTactics (respond resp)  runGetBody :: forall rInitial r f.   ((Final IO) `Member` r, Functor f) =>@@ -98,6 +138,73 @@     then pureT Nothing     else pureT (Just strictBody) +runUpgradeToWebSocketsResponse :: forall rInitial r f. (Final IO `Member` r, Functor f) =>+  WS.ConnectionOptions ->+  (WS.PendingConnection -> Sem rInitial ()) ->+  Wai.Request ->+  Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe Wai.Response))+runUpgradeToWebSocketsResponse opts app req = do+  stT <- getInitialStateT+  boundTApp' <- bindT app+  let boundTApp :: WS.PendingConnection -> Sem r ()+      boundTApp = runWebServerFinal . ($> ()) . boundTApp' . (stT $>)+  withStrategicToFinal $ do+    stS <- getInitialStateS+    boundTSApp' <- bindS (raise . boundTApp)+    let boundTSApp :: WS.PendingConnection -> IO ()+        boundTSApp = ($> ()) . boundTSApp' . (stS $>)+        finalResp :: Maybe Wai.Response+        finalResp = WaiWs.websocketsApp opts boundTSApp req+    return . return $ stS $> (stT $> finalResp)++runAcceptPendingWebSocketConnection ::+  (Final IO `Member` r, Functor f) =>+  WS.PendingConnection ->+  WS.AcceptRequest ->+  Sem (WithTactics WebServer f (Sem rInitial) r) (+    f (Either (Either WS.HandshakeException WS.ConnectionException)+       WS.Connection))+runAcceptPendingWebSocketConnection conn opts =+  ioToWebServerTactics inIO+  where+    inIO :: IO (Either+                (Either WS.HandshakeException WS.ConnectionException)+                WS.Connection)+    inIO = catch (catch (Right <$> WS.acceptRequestWith conn opts)+                   (return . Left . Right))+                 (return . Left . Left)++runWhilePingingWebSocket :: forall rInitial a r f.+  (Final IO `Member` r, Functor f) =>+  WS.Connection -> Int -> Sem rInitial a ->+  Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe a))+runWhilePingingWebSocket conn n app = do+  stT <- getInitialStateT+  appT' <- runT app+  insT <- getInspectorT+  let+    appT :: Sem r (Maybe a)+    appT = (inspect insT) <$> runWebServerFinal appT'+  withStrategicToFinal $ do+    appTS' <- runS (raise appT)+    stS <- getInitialStateS+    insS <- getInspectorS+    let appTS :: IO (Maybe a)+        appTS = (join . inspect insS) <$> appTS'+    return $ ((stS $>) . (stT $>)) <$> WS.withPingThread conn n (return ()) appTS++runReceiveWebSocketDataMessage :: forall rInitial r f.+  (Final IO `Member` r, Functor f) =>+  WS.Connection ->+  Sem (WithTactics WebServer f (Sem rInitial) r) (+  f (Either WS.ConnectionException WS.DataMessage))+runReceiveWebSocketDataMessage conn =+  ioToWebServerTactics inIO+  where+    inIO :: IO (Either WS.ConnectionException WS.DataMessage)+    inIO = catch (Right <$> WS.receiveDataMessage conn)+                 (return . Left)+ runWebServerFinal :: ((Final IO) `Member` r) =>                      Sem (WebServer ': r) a -> Sem r a runWebServerFinal =@@ -105,4 +212,18 @@                  StartWebServer port app -> runStartWebServer port app                  RespondWebRequest reqId response -> runRespondWebRequest reqId response                  GetBody maxLen req -> runGetBody maxLen req+                 UpgradeToWebSocketsResponse opts app req ->+                   runUpgradeToWebSocketsResponse opts app req+                 AcceptPendingWebSocketConnection conn opts ->+                   runAcceptPendingWebSocketConnection conn opts+                 RejectPendingWebSocketConnection conn opts ->+                   ioToWebServerTactics (WS.rejectRequestWith conn opts)+                 WhilePingingWebSocket conn n app ->+                   runWhilePingingWebSocket conn n app+                 SendWebSocketDataMessages conn msgs ->+                   ioToWebServerTactics $ WS.sendDataMessages conn msgs+                 ReceiveWebSocketDataMessage conn ->+                   runReceiveWebSocketDataMessage conn+                 SendWebSocketCloseCode conn code msg ->+                   ioToWebServerTactics $ WS.sendCloseCode conn code msg              )
test/Spec.hs view
@@ -3,10 +3,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Main where  import Polysemy import Polysemy.Final+import Polysemy.Error import Polysemy.WebServer import qualified Data.ByteString.Lazy as LBS import qualified Network.Wai as Wai@@ -15,22 +19,75 @@ import Network.HTTP.Simple import Polysemy.Async import Test.Hspec+import qualified Network.WebSockets as WS+import qualified Network.WebSockets.Connection as WS+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Encoding as TE+import Network.WebSockets.Client as WSC+import Control.Monad+import Text.Read (readMaybe)+import Data.ByteString.Lazy.Char8 as LBS8+import Control.Concurrent +eitherRedistrib :: Either (Either a b) c -> Either a (Either b c)+eitherRedistrib (Left (Left a)) = Left a+eitherRedistrib (Left (Right b)) = Right (Left b)+eitherRedistrib (Right c) = Right (Right c)+ testServerApp :: WebServer `Member` r =>   Wai.Request -> PendingWebRequest -> Sem r Wai.ResponseReceived-testServerApp _req pendingReq = respondWebRequest pendingReq (-  Wai.responseLBS (HTTP.status200) [] "Success")-+testServerApp req pendingReq+  | Wai.pathInfo req == [] = respondWebRequest pendingReq (+  Wai.responseLBS HTTP.status200 [] "Success")+  | Wai.pathInfo req == ["ws"] = do+      maybeResp <- upgradeToWebSocketsResponse WS.defaultConnectionOptions+        testWSApp req+      let resp = maybe (Wai.responseLBS HTTP.status400 [] "Bad request")+            id maybeResp+      respondWebRequest pendingReq resp+  | otherwise = respondWebRequest pendingReq (+      Wai.responseLBS HTTP.status404 [] "Not Found")+testWSApp :: forall r. WebServer `Member` r =>+  WS.PendingConnection -> Sem r ()+testWSApp pendConn =+  void $ runError @WS.ConnectionException $+    runError @WS.HandshakeException $ do+      conn <- fromEither =<< fromEither . eitherRedistrib =<<+                acceptPendingWebSocketConnection pendConn WS.defaultAcceptRequest+      whilePingingWebSocket conn 30 (go conn)+  where+    go :: (WebServer `Member` r2,+           Error WS.ConnectionException `Member` r2) =>+          WS.Connection -> Sem r2 ()+    go conn = do+      msg <- fromEither =<< receiveWebSocketDataMessage conn+      let nextResp = case msg of+                       WS.Text bs _+                         | Just n <- readMaybe . LBS8.unpack $ bs ->+                             T.pack $ show (n + 1)+                       _ -> "Invalid message: " <> (T.pack . show $ msg)+      sendWebSocketDataMessages conn [WS.Text (LBS.fromStrict $ TE.encodeUtf8 nextResp) Nothing]+      go conn main :: IO () main = runFinal . runWebServerFinal . asyncToIOFinal $ do   -- With the WebServer effect, start a new server...   async $ startWebServer 8123 testServerApp +  -- To do: Ideally provide a better way to know when it's ready...+  embedFinal $ threadDelay 5000000   embedFinal . hspec $ do     describe "Web Server" $ do-      it "should respond to requests" $ do+      it "should respond to normal requests" $ do         -- Use a client library to test...-        req <- parseRequest "http://localhost:8123/"+        req <- parseRequest "http://127.0.0.1:8123/"         resp <- httpLBS req         getResponseStatusCode resp `shouldBe` 200         getResponseBody resp `shouldBe` "Success"+      it "should support upgrading to WebSockets" $ do+        result <- WSC.runClient "127.0.0.1" 8123 "/ws" $ \conn -> do+          WS.sendTextData conn ("42" :: T.Text)+          r1 <- WS.receiveData conn+          WS.sendTextData conn (r1 :: LBS.ByteString)+          WS.receiveData conn+        result `shouldBe` ("44" :: T.Text)