packages feed

sydtest-servant 0.2.0.0 → 0.2.0.1

raw patch · 5 files changed

+165/−2 lines, 5 files

Files

+ CHANGELOG.md view
@@ -0,0 +1,13 @@+# Changelog++## [0.2.0.1] - 2022-04-02++### Added++* `servantSpecWithContext`, `servantSpecWithSetupFuncWithContext`, and `clientEnvSetupFuncWithContext`++## [0.2.0.0] - 2021-06-17++### Added++* Added `IsTest` instances for `ClientM ()`.
src/Test/Syd/Servant.hs view
@@ -4,12 +4,16 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Test.Syd.Servant   ( servantSpec,     servantSpecWithSetupFunc,     clientEnvSetupFunc,+    servantSpecWithContext,+    servantSpecWithSetupFuncWithContext,+    clientEnvSetupFuncWithContext,     testClient,     testClientOrError,   )@@ -37,6 +41,59 @@ clientEnvSetupFunc :: forall api. HasServer api '[] => Servant.Proxy api -> HTTP.Manager -> ServerT api Handler -> SetupFunc ClientEnv clientEnvSetupFunc py man server = do   let application = serve py server+  p <- applicationSetupFunc application+  pure $+    mkClientEnv+      man+      ( BaseUrl+          Http+          "127.0.0.1"+          (fromIntegral p) -- Safe because it is PortNumber -> Int+          ""+      )++-- | Like 'servantSpec', but allows setting a context. Useful for example when your server uses basic auth.+servantSpecWithContext ::+  forall api (ctx :: [*]).+  (HasServer api ctx, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters) =>+  Servant.Proxy api ->+  Context ctx ->+  ServerT api Handler ->+  ServantSpec ->+  Spec+servantSpecWithContext py ctx server = servantSpecWithSetupFuncWithContext py ctx (pure server)++-- | Like 'servantSpecWithSetupFunc', but allows setting a context. Useful for example when your server uses basic auth.+servantSpecWithSetupFuncWithContext ::+  forall api (ctx :: [*]).+  (HasServer api ctx, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters) =>+  Servant.Proxy api ->+  Context ctx ->+  SetupFunc (ServerT api Handler) ->+  ServantSpec ->+  Spec+servantSpecWithSetupFuncWithContext py ctx setupFunc = servantSpecWithSetupFuncWithContext' py ctx $ \() -> setupFunc++servantSpecWithSetupFuncWithContext' ::+  forall api (ctx :: [*]) inner.+  (HasServer api ctx, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters) =>+  Servant.Proxy api ->+  Context ctx ->+  (inner -> SetupFunc (ServerT api Handler)) ->+  ServantSpec ->+  SpecWith inner+servantSpecWithSetupFuncWithContext' py ctx serverSetupFunc = managerSpec . setupAroundWith' (\man inner -> serverSetupFunc inner >>= clientEnvSetupFuncWithContext py ctx man)++clientEnvSetupFuncWithContext ::+  forall api (ctx :: [*]).+  (HasServer api ctx, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters) =>+  Servant.Proxy api ->+  Context ctx ->+  HTTP.Manager ->+  ServerT api Handler ->+  SetupFunc ClientEnv+clientEnvSetupFuncWithContext py x man server = do+  let application = serveWithContext py x server   p <- applicationSetupFunc application   pure $     mkClientEnv
sydtest-servant.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack  name:           sydtest-servant-version:        0.2.0.0+version:        0.2.0.1 synopsis:       A servant companion library for sydtest category:       Testing homepage:       https://github.com/NorfairKing/sydtest#readme@@ -16,6 +16,9 @@ license:        OtherLicense license-file:   LICENSE.md build-type:     Simple+extra-source-files:+    LICENSE.md+    CHANGELOG.md  source-repository head   type: git@@ -43,7 +46,9 @@   main-is: Spec.hs   other-modules:       Test.Syd.Servant.Example+      Test.Syd.Servant.ExampleWithContext       Test.Syd.ServantSpec+      Test.Syd.ServantWithContextSpec       Paths_sydtest_servant   hs-source-dirs:       test@@ -58,4 +63,5 @@     , stm     , sydtest     , sydtest-servant+    , sydtest-wai   default-language: Haskell2010
+ test/Test/Syd/Servant/ExampleWithContext.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Test.Syd.Servant.ExampleWithContext where++import Control.Concurrent.STM+import Control.Monad.IO.Class+import Servant+import Servant.Client++exampleAPI :: Proxy ExampleAPI+exampleAPI = Proxy++newtype User = User String++type ExampleAPI =+  BasicAuth "test" User+    :> ( "get" :> Get '[JSON] Int+           :<|> "add" :> ReqBody '[JSON] Int :> Post '[JSON] NoContent+       )++exampleServer :: TVar Int -> Server ExampleAPI+exampleServer var = const $ serveGet :<|> serveAdd+  where+    serveGet :: Handler Int+    serveGet = liftIO $ readTVarIO var+    serveAdd :: Int -> Handler NoContent+    serveAdd i = do+      liftIO $ atomically $ modifyTVar var (+ i)+      pure NoContent++exampleApplication :: TVar Int -> Application+exampleApplication var = serveWithContext exampleAPI exampleContext (exampleServer var)++exampleContext :: Context '[BasicAuthCheck User]+exampleContext = checkBasicAuth :. EmptyContext++checkBasicAuth :: BasicAuthCheck User+checkBasicAuth = BasicAuthCheck $ \basicAuthData ->+  let username = basicAuthUsername basicAuthData+      password = basicAuthPassword basicAuthData+   in pure $ if username == "foo" && password == "bar" then Authorized (User "foo") else Unauthorized++clientGetCorrectCredentials :: ClientM Int+clientAddCorrectCredentials :: Int -> ClientM NoContent+(clientGetCorrectCredentials :<|> clientAddCorrectCredentials) = client exampleAPI BasicAuthData {basicAuthUsername = "foo", basicAuthPassword = "bar"}++clientGetWrongCredentials :: ClientM Int+clientAddWrongCredentials :: Int -> ClientM NoContent+(clientGetWrongCredentials :<|> clientAddWrongCredentials) = client exampleAPI BasicAuthData {basicAuthUsername = "wrong", basicAuthPassword = "wrong"}
+ test/Test/Syd/ServantWithContextSpec.hs view
@@ -0,0 +1,36 @@+module Test.Syd.ServantWithContextSpec (spec) where++import Control.Concurrent.STM+import Servant+import Servant.Client+import Test.Syd+import Test.Syd.Servant+import Test.Syd.Servant.ExampleWithContext+import Test.Syd.Wai++exampleSetupFunc :: SetupFunc (Server ExampleAPI)+exampleSetupFunc = SetupFunc $ \func -> do+  var <- newTVarIO 0+  func $ exampleServer var++spec :: Spec+spec = servantSpecWithSetupFuncWithContext exampleAPI exampleContext exampleSetupFunc $ do+  describe "requests with correct credentials" $ do+    it "gets zero at the start" $ do+      r <- clientGetCorrectCredentials+      liftIO $ r `shouldBe` 0+    it "can add 1 to get 1" $ do+      NoContent <- clientAddCorrectCredentials 1+      r <- clientGetCorrectCredentials+      liftIO $ r `shouldBe` 1+  describe "requests with incorrect credentials" $ do+    it "doesn't allow GET requests without correct credentials" $ \clientEnv -> do+      errOrResult <- testClientOrError clientEnv clientGetWrongCredentials+      case errOrResult of+        Left (FailureResponse _ res) -> responseStatusCode res `shouldBe` forbidden403+        res -> expectationFailure $ "Expected a failed request with status 403, but got " <> show res+    it "doesn't allow POST requests without correct credentials" $ \clientEnv -> do+      errOrResult <- testClientOrError clientEnv $ clientAddWrongCredentials 1+      case errOrResult of+        Left (FailureResponse _ res) -> responseStatusCode res `shouldBe` forbidden403+        res -> expectationFailure $ "Expected a failed request with status 403, but got " <> show res