diff --git a/polysemy-webserver.cabal b/polysemy-webserver.cabal --- a/polysemy-webserver.cabal +++ b/polysemy-webserver.cabal @@ -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 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 diff --git a/src/Polysemy/WebServer.hs b/src/Polysemy/WebServer.hs --- a/src/Polysemy/WebServer.hs +++ b/src/Polysemy/WebServer.hs @@ -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 ) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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)