polysemy-webserver 0.2.0.0 → 0.2.1.0

raw patch · 2 files changed

+43/−2 lines, 2 files

Files

• polysemy-webserver.cabal +2/−2
• src/Polysemy/WebServer.hs +41/−0

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d50a6f2a69b24e2e973f6c76bb785989fb448d9269513a0aacafdc9ea071f8de+-- hash: 11ce70eb79ea2d2a2acae6692a83cd824f82db83b79a87577293b48403faa901  name:           polysemy-webserver-version:        0.2.0.0+version:        0.2.1.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

@@ -16,6 +16,7 @@ {-# LANGUAGE TypeApplications #-}  module Polysemy.WebServer (WebServer(..), PendingWebRequest, startWebServer,+  startWebServerSettings,   respondWebRequest, getBody, upgradeToWebSocketsResponse,   acceptPendingWebSocketConnection, rejectPendingWebSocketConnection,   whilePingingWebSocket, sendWebSocketDataMessages, receiveWebSocketDataMessage,@@ -44,6 +45,9 @@   StartWebServer :: Warp.Port -> (     Wai.Request -> PendingWebRequest -> m Wai.ResponseReceived) ->     WebServer m ()+  StartWebServerSettings :: Warp.Settings -> (+    Wai.Request -> PendingWebRequest -> m Wai.ResponseReceived) ->+    WebServer m ()   -- | Responds to a web request (usually called from the callback to   --   StartWebServer.   RespondWebRequest :: PendingWebRequest -> Wai.Response ->@@ -115,6 +119,42 @@       Warp.run port $ \req reply -> doRequestIO req reply       return $ s1 $> s0 +runStartWebServerSettings :: forall rInitial r f.+  ((Final IO) `Member` r, Functor f) =>+  Warp.Settings -> (+    Wai.Request -> PendingWebRequest ->+    Sem rInitial Wai.ResponseReceived) ->+  Sem (WithTactics WebServer f (Sem rInitial) r) (f ())+runStartWebServerSettings settings app = do+  s0 <- getInitialStateT+  appFnS <- bindT $ uncurry app+  ins <- getInspectorT+  let+    appFn :: (Wai.Request, PendingWebRequest) ->+             Sem r (Maybe Wai.ResponseReceived)+    appFn = runWebServerFinal . (fmap (inspect ins)) . appFnS . (s0 $>)+  withStrategicToFinal $ do+    appFnS' <- bindS (raise . appFn)+    ins' <- getInspectorS+    s1 <- getInitialStateS+    let+      appFn' :: (Wai.Request, PendingWebRequest) ->+                IO (Maybe Wai.ResponseReceived)+      appFn' = (fmap (join . inspect ins')) . appFnS' . (s1 $>)+    return $ do+      let+        doRequestIO :: Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) ->+                       IO Wai.ResponseReceived+        doRequestIO req respond = do+          maybeRR <- appFn' (req, PendingWebRequest respond)+          case maybeRR of+            Just rr -> return rr+            Nothing -> respond $+              Wai.responseLBS (HTTP.status500) [] "Internal server error"+          +      Warp.runSettings settings $ \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)@@ -210,6 +250,7 @@ runWebServerFinal =   interpretH (\v -> case v of                  StartWebServer port app -> runStartWebServer port app+                 StartWebServerSettings settings app -> runStartWebServerSettings settings app                  RespondWebRequest reqId response -> runRespondWebRequest reqId response                  GetBody maxLen req -> runGetBody maxLen req                  UpgradeToWebSocketsResponse opts app req ->