polysemy-webserver (empty) → 0.1.0.0

raw patch · 6 files changed

+247/−0 lines, 6 filesdep +basedep +bytestringdep +hspecsetup-changed

Dependencies added: base, bytestring, hspec, http-conduit, http-types, polysemy, polysemy-plugin, polysemy-webserver, wai, warp

Files

LICENSE +30/−0
README.md +6/−0
Setup.hs +2/−0
polysemy-webserver.cabal +65/−0
src/Polysemy/WebServer.hs +108/−0
test/Spec.hs +36/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Andrew Miller (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Miller nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,6 @@+# polysemy-webserver++A simple wrapper around Warp and Wai to make it easier to write web servers+using Polysemy.++See test/Spec.hs for a simple example of how to use it.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ polysemy-webserver.cabal view

@@ -0,0 +1,65 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 1125f9e81101158130a70f12db4783c3043caf583c7f7d28e039506c7aed885b++name:           polysemy-webserver+version:        0.1.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+author:         Andrew Miller+maintainer:     andrew@amxl.com+copyright:      Copyright (C) 2020 Andrew Miller+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://gitlab.com/A1kmm/polysemy-webserver++library+  exposed-modules:+      Polysemy.WebServer+  other-modules:+      Paths_polysemy_webserver+  hs-source-dirs:+      src+  default-extensions: DataKinds FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeOperators TypeFamilies+  ghc-options: -O2 -flate-specialise -fspecialise-aggressively -Wall -fno-warn-orphans -fplugin=Polysemy.Plugin+  build-depends:+      base >=4.7 && <5+    , bytestring+    , http-types+    , polysemy+    , polysemy-plugin+    , wai+    , warp+  default-language: Haskell2010++test-suite polysemy-webserver-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_polysemy_webserver+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring+    , hspec+    , http-conduit+    , http-types+    , polysemy+    , polysemy-plugin+    , polysemy-webserver+    , wai+    , warp+  default-language: Haskell2010

+ src/Polysemy/WebServer.hs view

@@ -0,0 +1,108 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}++module Polysemy.WebServer (WebServer, PendingWebRequest, startWebServer,+  respondWebRequest, getBody, runWebServerFinal) where+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.HTTP.Types.Status as HTTP+import Polysemy+import Polysemy.Final+import Data.Functor+import Control.Monad+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS++newtype PendingWebRequest =+  PendingWebRequest (Wai.Response -> IO Wai.ResponseReceived)++data WebServer m a where+  StartWebServer :: Warp.Port -> (+    Wai.Request -> PendingWebRequest -> m Wai.ResponseReceived) ->+    WebServer m ()+  RespondWebRequest :: PendingWebRequest -> Wai.Response ->+                       WebServer m Wai.ResponseReceived+  GetBody :: Int -> Wai.Request -> WebServer m (Maybe BS.ByteString)+makeSem ''WebServer++runStartWebServer :: forall rInitial r f.+  ((Final IO) `Member` r, Functor f) =>+  Warp.Port -> (+    Wai.Request -> PendingWebRequest ->+    Sem rInitial Wai.ResponseReceived) ->+  Sem (WithTactics WebServer f (Sem rInitial) r) (f ())+runStartWebServer port 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.run port $ \req reply -> doRequestIO req reply+      return $ s1 $> s0++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)++runGetBody :: forall rInitial r f.+  ((Final IO) `Member` r, Functor f) =>+  Int -> Wai.Request ->+  Sem (WithTactics WebServer f (Sem rInitial) r) (f (Maybe BS.ByteString))+runGetBody maxLen req = do+  body <- embedFinal $ Wai.lazyRequestBody req+  let strictBody = LBS.toStrict $ LBS.take (fromIntegral $ maxLen + 1) body+  if BS.length strictBody > maxLen+    then pureT Nothing+    else pureT (Just strictBody)++runWebServerFinal :: ((Final IO) `Member` r) =>+                     Sem (WebServer ': r) a -> Sem r a+runWebServerFinal =+  interpretH (\v -> case v of+                 StartWebServer port app -> runStartWebServer port app+                 RespondWebRequest reqId response -> runRespondWebRequest reqId response+                 GetBody maxLen req -> runGetBody maxLen req+             )

+ test/Spec.hs view

@@ -0,0 +1,36 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Polysemy+import Polysemy.Final+import Polysemy.WebServer+import qualified Data.ByteString.Lazy as LBS+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.HTTP.Types.Status as HTTP+import Network.HTTP.Simple+import Polysemy.Async+import Test.Hspec++testServerApp :: WebServer `Member` r =>+  Wai.Request -> PendingWebRequest -> Sem r Wai.ResponseReceived+testServerApp _req pendingReq = respondWebRequest pendingReq (+  Wai.responseLBS (HTTP.status200) [] "Success")++main :: IO ()+main = runFinal . runWebServerFinal . asyncToIOFinal $ do+  -- With the WebServer effect, start a new server...+  async $ startWebServer 8123 testServerApp++  embedFinal . hspec $ do+    describe "Web Server" $ do+      it "should respond to requests" $ do+        -- Use a client library to test...+        req <- parseRequest "http://localhost:8123/"+        resp <- httpLBS req+        getResponseStatusCode resp `shouldBe` 200+        getResponseBody resp `shouldBe` "Success"