servant-checked-exceptions 0.4.0.0 → 0.4.1.0
raw patch · 13 files changed
+292/−36 lines, 13 filesdep ~servantPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: servant
API changes (from Hackage documentation)
+ Servant.Checked.Exceptions: data NoThrow
+ Servant.Checked.Exceptions: emptyEnvelope :: Envelope '[] a -> a
+ Servant.Checked.Exceptions.Internal.Envelope: emptyEnvelope :: Envelope '[] a -> a
+ Servant.Checked.Exceptions.Internal.Servant.API: data NoThrow
+ Servant.Checked.Exceptions.Internal.Servant.Client: instance Servant.Client.HasClient ((Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> api1) Servant.API.Alternative.:<|> (Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> api2)) => Servant.Client.HasClient (Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> (api1 Servant.API.Alternative.:<|> api2))
+ Servant.Checked.Exceptions.Internal.Servant.Client: instance forall k k1 (api :: k1) (apis :: k). Servant.Client.HasClient (api Servant.API.Sub.:> (Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> apis)) => Servant.Client.HasClient (Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> (api Servant.API.Sub.:> apis))
+ Servant.Checked.Exceptions.Internal.Servant.Client: instance forall k1 (method :: k1) (status :: GHC.Types.Nat) (ctypes :: [GHC.Types.*]) a. Servant.Client.HasClient (Servant.API.Verbs.Verb method status ctypes (Servant.Checked.Exceptions.Internal.Envelope.Envelope '[] a)) => Servant.Client.HasClient (Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> Servant.API.Verbs.Verb method status ctypes a)
+ Servant.Checked.Exceptions.Internal.Servant.Docs: instance forall k1 (method :: k1) (status :: GHC.Types.Nat) (ctypes :: [GHC.Types.*]) a. Servant.Docs.Internal.HasDocs (Servant.API.Verbs.Verb method status ctypes (Servant.Checked.Exceptions.Internal.Envelope.Envelope '[] a)) => Servant.Docs.Internal.HasDocs (Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> Servant.API.Verbs.Verb method status ctypes a)
+ Servant.Checked.Exceptions.Internal.Servant.Server: instance Servant.Server.Internal.HasServer ((Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> api1) Servant.API.Alternative.:<|> (Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> api2)) context => Servant.Server.Internal.HasServer (Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> (api1 Servant.API.Alternative.:<|> api2)) context
+ Servant.Checked.Exceptions.Internal.Servant.Server: instance forall k k1 (api :: k1) (apis :: k) (context :: [*]). Servant.Server.Internal.HasServer (api Servant.API.Sub.:> (Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> apis)) context => Servant.Server.Internal.HasServer (Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> (api Servant.API.Sub.:> apis)) context
+ Servant.Checked.Exceptions.Internal.Servant.Server: instance forall k1 (method :: k1) (status :: GHC.Types.Nat) (ctypes :: [GHC.Types.*]) a (context :: [*]). Servant.Server.Internal.HasServer (Servant.API.Verbs.Verb method status ctypes (Servant.Checked.Exceptions.Internal.Envelope.Envelope '[] a)) context => Servant.Server.Internal.HasServer (Servant.Checked.Exceptions.Internal.Servant.API.NoThrow Servant.API.Sub.:> Servant.API.Verbs.Verb method status ctypes a) context
Files
- CHANGELOG.md +5/−0
- example/Api.hs +12/−3
- example/Client.hs +32/−9
- example/Server.hs +9/−2
- servant-checked-exceptions.cabal +4/−2
- src/Servant/Checked/Exceptions.hs +3/−0
- src/Servant/Checked/Exceptions/Internal/Envelope.hs +14/−1
- src/Servant/Checked/Exceptions/Internal/Servant/API.hs +19/−0
- src/Servant/Checked/Exceptions/Internal/Servant/Client.hs +46/−1
- src/Servant/Checked/Exceptions/Internal/Servant/Docs.hs +16/−1
- src/Servant/Checked/Exceptions/Internal/Servant/Server.hs +46/−1
- stack.yaml +41/−0
- test/Spec.hs +45/−16
+ CHANGELOG.md view
@@ -0,0 +1,5 @@++## 0.4.1.0++* Add `NoThrow` type to represent handlers that don't throw any errors, but+ do return a result wrapped in an `Envelope`.
example/Api.hs view
@@ -16,7 +16,7 @@ import Text.Read (readMaybe) import Web.HttpApiData (FromHttpApiData, ToHttpApiData) -import Servant.Checked.Exceptions (Throws)+import Servant.Checked.Exceptions (NoThrow, Throws) --------- -- API --@@ -25,8 +25,9 @@ -- | This is our main 'Api' type. We will create a server, a client, and -- documentation for this api. ----- This api is composed of two routes, 'ApiStrictSearch' and 'ApiLaxSearch'.-type Api = ApiStrictSearch :<|> ApiLaxSearch+-- This api is composed of three routes, 'ApiStrictSearch', 'ApiLaxSearch', and+-- 'ApiNoErrSearch'.+type Api = ApiStrictSearch :<|> ApiLaxSearch :<|> ApiNoErrSearch -- | This is a strict search api. You pass it a @\"query\"@, and it returns a -- 'SearchResponse'. It potentially returns a 'BadSearchTermErr' if your query@@ -48,6 +49,14 @@ "lax-search" :> Capture "query" SearchQuery :> Throws BadSearchTermErr :>+ Post '[JSON] SearchResponse++-- | This is similar to 'ApiLaxSearch', but it doesn't force the query to use+-- correct terms. It does not return an error.+type ApiNoErrSearch =+ "no-err-search" :>+ Capture "query" SearchQuery :>+ NoThrow :> Post '[JSON] SearchResponse ------------------------------
example/Client.hs view
@@ -28,7 +28,7 @@ (BaseUrl(BaseUrl), ClientEnv(ClientEnv), ClientM, Scheme(Http), client, runClientM) -import Servant.Checked.Exceptions (Envelope, catchesEnvelope)+import Servant.Checked.Exceptions (Envelope, emptyEnvelope, catchesEnvelope) import Api (Api, BadSearchTermErr(BadSearchTermErr),@@ -40,7 +40,8 @@ ----------------------------------------- -- We generate the client functions just like normal. Note that when we use--- 'Throws', the client functions get generated with the 'Envelope' type.+-- 'Throws' or 'NoThrow', the client functions get generated with the+-- 'Envelope' type. strictSearch :: SearchQuery@@ -48,7 +49,10 @@ laxSearch :: SearchQuery -> ClientM (Envelope '[BadSearchTermErr] SearchResponse)-strictSearch :<|> laxSearch = client (Proxy :: Proxy Api)+noErrSearch+ :: SearchQuery+ -> ClientM (Envelope '[] SearchResponse)+strictSearch :<|> laxSearch :<|> noErrSearch = client (Proxy :: Proxy Api) -------------------------------------- -- Command-line options and parsers --@@ -57,7 +61,7 @@ -- The following are needed for using optparse-applicative to parse command -- line arguments. Most people shouldn't need to worry about how this works. -data Options = Options { query :: String, useStrict :: Bool }+data Options = Options { query :: String, useStrict :: Bool, useNoErr :: Bool } queryParser :: Parser String queryParser = argument str (metavar "QUERY")@@ -65,10 +69,17 @@ useStrictParser :: Parser Bool useStrictParser = switch $- long "strict" <> short 's' <> help "Whether to be use the strict api"+ long "strict" <> short 's' <> help "Whether or not to use the strict api" +useNoErrParser :: Parser Bool+useNoErrParser =+ switch $+ long "no-err" <>+ short 'n' <>+ help "Whether or not to use the api that does not return an error"+ commandParser :: Parser Options-commandParser = Options <$> queryParser <*> useStrictParser+commandParser = Options <$> queryParser <*> useStrictParser <*> useNoErrParser ------------------------------------------------------------------------- -- Command Runners (these use the clients generated by servant-client) --@@ -107,10 +118,22 @@ (\(SearchResponse searchResponse) -> "Success: " <> searchResponse) env --- | Run either 'runStrict' or 'runLax' depending on the command line options.+-- | This function uses the 'noErrSearch' function to send a 'SearchQuery' to+-- the server.+runNoErr :: ClientEnv -> String -> IO ()+runNoErr clientEnv query = do+ eitherRes <- runClientM (noErrSearch $ SearchQuery query) clientEnv+ case eitherRes of+ Left servantErr -> putStrLn $ "Got a ServantErr: " <> show servantErr+ Right env -> do+ let (SearchResponse res) = emptyEnvelope env+ putStrLn $ "Success: " <> res++-- | Run 'runStrict', 'runLax', or 'runNoErr' depending on the command line options. run :: ClientEnv -> Options -> IO ()-run clientEnv Options{query, useStrict = True} = runStrict clientEnv query-run clientEnv Options{query, useStrict = False} = runLax clientEnv query+run clientEnv Options{query, useStrict = True, useNoErr = _} = runStrict clientEnv query+run clientEnv Options{query, useStrict = _, useNoErr = True} = runNoErr clientEnv query+run clientEnv Options{query, useStrict = _, useNoErr = _} = runLax clientEnv query ---------- -- Main --
example/Server.hs view
@@ -33,7 +33,7 @@ -- | This is our server root for the 'ServerT' for 'Api'. We only have two -- handlers, 'postStrictSearch' and 'postLaxSearch'. serverRoot :: ServerT Api Handler-serverRoot = postStrictSearch :<|> postLaxSearch+serverRoot = postStrictSearch :<|> postLaxSearch :<|> postNoErrSearch -- | This is the handler for 'Api.ApiStrictSearch'. --@@ -59,7 +59,7 @@ -- | This is the handler for 'Api.ApiLaxSearch'. ----- This is similar to 'postStrictSearch', but it doesn't require correctly+-- This is similar to 'postStrictSearch', but it doesn't require correct -- capitalization. postLaxSearch :: SearchQuery@@ -67,6 +67,13 @@ postLaxSearch (SearchQuery query) | fmap toLower query == "hello" = pureSuccEnvelope "good" | otherwise = pureErrEnvelope BadSearchTermErr++-- | This is the handler for 'Api.ApiNoErrSearch'.+--+-- This is similar to 'postLaxSearch', but it doesn't require a correct search+-- term.+postNoErrSearch :: SearchQuery -> Handler (Envelope '[] SearchResponse)+postNoErrSearch (SearchQuery _) = pureSuccEnvelope "good" -- | Create a WAI 'Application'. app :: Application
servant-checked-exceptions.cabal view
@@ -1,5 +1,5 @@ name: servant-checked-exceptions-version: 0.4.0.0+version: 0.4.1.0 synopsis: Checked exceptions for Servant APIs. description: Please see <https://github.com/cdepillabout/servant-checked-exceptions#readme README.md>. homepage: https://github.com/cdepillabout/servant-checked-exceptions@@ -10,7 +10,9 @@ copyright: 2017 Dennis Gosnell category: Text build-type: Simple-extra-source-files: README.md+extra-source-files: CHANGELOG.md+ , README.md+ , stack.yaml cabal-version: >=1.10 flag buildexample
src/Servant/Checked/Exceptions.hs view
@@ -92,6 +92,8 @@ ( -- * 'Throws' API parameter Throws+ -- * 'NoThrow' API parameter+ , NoThrow -- * 'Envelope' response wrapper , Envelope(..) -- ** 'Envelope' helper functions@@ -102,6 +104,7 @@ , pureErrEnvelope -- *** 'Envelope' destructors , envelope+ , emptyEnvelope , fromEnvelope , fromEnvelopeOr , fromEnvelopeM
src/Servant/Checked/Exceptions/Internal/Envelope.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-}@@ -41,6 +42,7 @@ , pureErrEnvelope -- ** Envelope Destructors , envelope+ , emptyEnvelope , fromEnvelope , fromEnvelopeOr , fromEnvelopeM@@ -74,7 +76,7 @@ (Iso, Prism, Prism', iso, preview, prism) import Servant.Checked.Exceptions.Internal.Product (ToOpenProduct) import Servant.Checked.Exceptions.Internal.Union- (IsMember, OpenUnion, catchesOpenUnion, openUnionLift,+ (IsMember, OpenUnion, absurdUnion, catchesOpenUnion, openUnionLift, openUnionPrism) import Servant.Checked.Exceptions.Internal.Util (ReturnX) @@ -152,6 +154,17 @@ envelope :: (OpenUnion es -> c) -> (a -> c) -> Envelope es a -> c envelope f _ (ErrEnvelope es) = f es envelope _ f (SuccEnvelope a) = f a++-- | Unwrap an 'Envelope' that cannot contain an error.+--+-- ==== __Examples__+--+-- >>> let env = toSuccEnvelope "hello" :: Envelope '[] String+-- >>> emptyEnvelope env+-- "hello"+emptyEnvelope :: Envelope '[] a -> a+emptyEnvelope (SuccEnvelope a) = a+emptyEnvelope (ErrEnvelope es) = absurdUnion es -- | Just like 'Data.Either.fromEither' but for 'Envelope'. --
src/Servant/Checked/Exceptions/Internal/Servant/API.hs view
@@ -32,6 +32,25 @@ -- >>> type API = Throws String :> Get '[JSON] Int data Throws (e :: *) +-- | 'NoThrow' is used to indicate that an API will not throw an error, but+-- that it will still return a response wrapped in a+-- 'Servant.Checked.Exceptions.Internal.Envelope.Envelope'.+--+-- ==== __Examples__+--+-- Create an API using 'NoThrow':+--+-- >>> import Servant.API (Get, JSON, (:>))+-- >>> type API = NoThrow :> Get '[JSON] Int+--+-- A servant-server handler for this type would look like the following:+--+-- @+-- apiHandler :: 'Servant.Handler' ('Servant.Checked.Exceptions.Internal.Envelope.Envelope' \'[] Int)+-- apiHandler = 'Servant.Checked.Exceptions.Internal.Envelope.pureSuccEnvelope' 3+-- @+data NoThrow+ -- | This is used internally and should not be used by end-users. data Throwing (e :: [*])
src/Servant/Checked/Exceptions/Internal/Servant/Client.hs view
@@ -33,7 +33,7 @@ import Servant.Checked.Exceptions.Internal.Envelope (Envelope) import Servant.Checked.Exceptions.Internal.Servant.API- (Throws, Throwing, ThrowingNonterminal)+ (NoThrow, Throws, Throwing, ThrowingNonterminal) -- TODO: Make sure to also account for when headers are being used. @@ -62,6 +62,21 @@ clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy (Verb method status ctypes (Envelope es a))) +-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'+-- but returning an @'Envelope' \'[]@.+instance (HasClient (Verb method status ctypes (Envelope '[] a))) =>+ HasClient (NoThrow :> Verb method status ctypes a) where++ type Client (NoThrow :> Verb method status ctypes a) =+ Client (Verb method status ctypes (Envelope '[] a))++ clientWithRoute+ :: Proxy (NoThrow :> Verb method status ctypes a)+ -> Req+ -> Client (Verb method status ctypes (Envelope '[] a))+ clientWithRoute Proxy =+ clientWithRoute (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))+ -- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each -- branch of the API. instance HasClient ((Throwing es :> api1) :<|> (Throwing es :> api2)) =>@@ -77,6 +92,21 @@ clientWithRoute _ = clientWithRoute (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2))) +-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the+-- API.+instance HasClient ((NoThrow :> api1) :<|> (NoThrow :> api2)) =>+ HasClient (NoThrow :> (api1 :<|> api2)) where++ type Client (NoThrow :> (api1 :<|> api2)) =+ Client ((NoThrow :> api1) :<|> (NoThrow :> api2))++ clientWithRoute+ :: Proxy (NoThrow :> (api1 :<|> api2))+ -> Req+ -> Client ((NoThrow :> api1) :<|> (NoThrow :> api2))+ clientWithRoute _ =+ clientWithRoute (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))+ -- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the -- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other -- combinator, push it down so it is closer to the 'Verb'.@@ -92,3 +122,18 @@ -> Client (ThrowingNonterminal (Throwing es :> api :> apis)) clientWithRoute _ = clientWithRoute (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))++-- | When 'NoThrow' comes before any other combinator, push it down so it is+-- closer to the 'Verb'.+instance HasClient (api :> NoThrow :> apis) =>+ HasClient (NoThrow :> api :> apis) where++ type Client (NoThrow :> api :> apis) =+ Client (api :> NoThrow :> apis)++ clientWithRoute+ :: Proxy (NoThrow :> api :> apis)+ -> Req+ -> Client (api :> NoThrow :> apis)+ clientWithRoute _ =+ clientWithRoute (Proxy :: Proxy (api :> NoThrow :> apis))
src/Servant/Checked/Exceptions/Internal/Servant/Docs.hs view
@@ -45,7 +45,7 @@ (Envelope, toErrEnvelope, toSuccEnvelope) import Servant.Checked.Exceptions.Internal.Prism ((<>~)) import Servant.Checked.Exceptions.Internal.Servant.API- (Throws, Throwing)+ (NoThrow, Throws, Throwing) import Servant.Checked.Exceptions.Internal.Util (Snoc) -- TODO: Make sure to also account for when headers are being used.@@ -80,6 +80,21 @@ docOpts in api & apiEndpoints . traverse . response . respBody <>~ createRespBodiesFor (Proxy :: Proxy es) (Proxy :: Proxy ctypes)++-- | When 'NoThrow' comes before a 'Verb', generate the documentation for+-- the same 'Verb', but returning an @'Envelope' \'[]@.+instance (HasDocs (Verb method status ctypes (Envelope '[] a)))+ => HasDocs (NoThrow :> Verb method status ctypes a) where+ docsFor+ :: Proxy (NoThrow :> Verb method status ctypes a)+ -> (Endpoint, Action)+ -> DocOptions+ -> API+ docsFor Proxy (endpoint, action) docOpts =+ docsFor+ (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))+ (endpoint, action)+ docOpts -- | Create samples for a given @list@ of types, under given @ctypes@. --
src/Servant/Checked/Exceptions/Internal/Servant/Server.hs view
@@ -34,7 +34,7 @@ import Servant.Checked.Exceptions.Internal.Envelope (Envelope) import Servant.Checked.Exceptions.Internal.Servant.API- (Throws, Throwing, ThrowingNonterminal)+ (NoThrow, Throws, Throwing, ThrowingNonterminal) -- TODO: Make sure to also account for when headers are being used. @@ -67,6 +67,21 @@ -> Router env route _ = route (Proxy :: Proxy (Verb method status ctypes (Envelope es a))) +-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'+-- but returning an @'Envelope' \'[]@.+instance (HasServer (Verb method status ctypes (Envelope '[] a)) context) =>+ HasServer (NoThrow :> Verb method status ctypes a) context where++ type ServerT (NoThrow :> Verb method status ctypes a) m =+ ServerT (Verb method status ctypes (Envelope '[] a)) m++ route+ :: Proxy (NoThrow :> Verb method status ctypes a)+ -> Context context+ -> Delayed env (ServerT (Verb method status ctypes (Envelope '[] a)) Handler)+ -> Router env+ route _ = route (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))+ -- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each -- branch of the API. instance HasServer ((Throwing es :> api1) :<|> (Throwing es :> api2)) context =>@@ -82,6 +97,21 @@ -> Router env route _ = route (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2))) +-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each+-- branch of the API.+instance HasServer ((NoThrow :> api1) :<|> (NoThrow :> api2)) context =>+ HasServer (NoThrow :> (api1 :<|> api2)) context where++ type ServerT (NoThrow :> (api1 :<|> api2)) m =+ ServerT ((NoThrow :> api1) :<|> (NoThrow :> api2)) m++ route+ :: Proxy (NoThrow :> (api1 :<|> api2))+ -> Context context+ -> Delayed env (ServerT ((NoThrow :> api1) :<|> (NoThrow :> api2)) Handler)+ -> Router env+ route _ = route (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))+ -- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the -- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other -- combinator, push it down so it is closer to the 'Verb'.@@ -97,3 +127,18 @@ -> Delayed env (ServerT (ThrowingNonterminal (Throwing es :> api :> apis)) Handler) -> Router env route _ = route (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))++-- | When 'NoThrow' comes before any combinator, push it down so it is closer+-- to the 'Verb'.+instance HasServer (api :> NoThrow :> apis) context =>+ HasServer (NoThrow :> api :> apis) context where++ type ServerT (NoThrow :> api :> apis) m =+ ServerT (api :> NoThrow :> apis) m++ route+ :: Proxy (NoThrow :> api :> apis)+ -> Context context+ -> Delayed env (ServerT (api :> NoThrow :> apis) Handler)+ -> Router env+ route _ = route (Proxy :: Proxy (api :> NoThrow :> apis))
+ stack.yaml view
@@ -0,0 +1,41 @@+# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html++# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)+resolver: lts-9.2++# Local packages, usually specified by relative directory name+packages:+- '.'++# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)+extra-deps: []++# Override default flag values for local packages and extra-deps+flags: {}++# Extra package databases containing global packages+extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true++# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: >= 1.0.0++# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64++# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]++# Allow a newer minor version of GHC than the snapshot specifies+# compiler-check: newer-minor++# Enable Hackage-friendly mode, for more details see+# https://docs.haskellstack.org/en/stable/yaml_configuration/#pvp-bounds+# This has been disabled because of the following exchange:+# https://github.com/cdepillabout/pretty-simple/pull/1#issuecomment-272706215+#pvp-bounds: both
test/Spec.hs view
@@ -10,14 +10,14 @@ import Data.Type.Equality ((:~:)(Refl)) import Data.Typeable (Typeable) import Network.Wai (Application)-import Servant ((:<|>), (:>), Capture, Get, Handler, JSON, ServerT, serve)+import Servant ((:<|>)((:<|>)), (:>), Capture, Get, Handler, JSON, ServerT, serve) import Test.Hspec.Wai (get, shouldRespondWith, with) import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.Hspec (testSpec, it)+import Test.Tasty.Hspec (describe, it, testSpec) import Test.Tasty.HUnit ((@?=), assertFailure, testCase) import Servant.Checked.Exceptions- (Envelope, Throws, pureErrEnvelope, pureSuccEnvelope)+ (Envelope, NoThrow, Throws, pureErrEnvelope, pureSuccEnvelope) main :: IO () main = do@@ -69,18 +69,15 @@ type ApiThrows = Throws String :> Get '[JSON] Int -checkApiThrows- :: ServerT ApiThrows m :~: m (Envelope '[String] Int)+checkApiThrows :: ServerT ApiThrows m :~: m (Envelope '[String] Int) checkApiThrows = Refl - type ApiDoubleThrows = Throws String :> Throws Double :> Get '[JSON] Int checkApiDoubleThrows :: ServerT ApiDoubleThrows m :~: m (Envelope '[String, Double] Int) checkApiDoubleThrows = Refl - type ApiThrowsBeforeCapture = Throws String :> Capture "foobar" Double :> Get '[JSON] Int @@ -88,7 +85,6 @@ :: ServerT ApiThrowsBeforeCapture m :~: (Double -> m (Envelope '[String] Int)) checkApiThrowsBeforeCapture = Refl - type ApiThrowsBeforeMulti = Throws String :> (Get '[JSON] Int :<|> Get '[JSON] Double) @@ -97,7 +93,26 @@ (m (Envelope '[String] Int) :<|> m (Envelope '[String] Double)) checkApiThrowsBeforeMulti = Refl +type ApiNoThrow = NoThrow :> Get '[JSON] Int +checkApiNoThrows :: ServerT ApiNoThrow m :~: m (Envelope '[] Int)+checkApiNoThrows = Refl++type ApiNoThrowBeforeCapture =+ NoThrow :> Capture "foobar" Double :> Get '[JSON] Int++checkApiNoThrowBeforeCapture+ :: ServerT ApiNoThrowBeforeCapture m :~: (Double -> m (Envelope '[] Int))+checkApiNoThrowBeforeCapture = Refl++type ApiNoThrowBeforeMulti =+ NoThrow :> (Get '[JSON] Int :<|> Get '[JSON] Double)++checkApiNoThrowBeforeMulti+ :: ServerT ApiNoThrowBeforeMulti m :~:+ (m (Envelope '[] Int) :<|> m (Envelope '[] Double))+checkApiNoThrowBeforeMulti = Refl+ hasServerInstanceTests :: TestTree hasServerInstanceTests = testGroup@@ -106,23 +121,33 @@ , testCase "double Throws" $ checkApiDoubleThrows @?= Refl , testCase "Throws before Capture" $ checkApiThrowsBeforeCapture @?= Refl , testCase "Throws before (:<|>)" $ checkApiThrowsBeforeMulti @?= Refl+ , testCase "single NoThrows" $ checkApiNoThrows @?= Refl+ , testCase "NoThrow before Capture" $ checkApiNoThrowBeforeCapture @?= Refl+ , testCase "NoThrow before (:<|>)" $ checkApiNoThrowBeforeMulti @?= Refl ] ------------------ -- Server tests -- ------------------ -type TestApi = Capture "foobar" Double :> Throws Int :> Get '[JSON] String+type TestThrows = Capture "foobar" Double :> Throws Int :> Get '[JSON] String +type TestNoThrow = Capture "baz" Integer :> NoThrow :> Get '[JSON] String++type TestApi = TestThrows :<|> TestNoThrow+ server :: ServerT TestApi Handler-server = helloWorldGet+server = testThrowsGet :<|> testNoThrowsGet -helloWorldGet :: Double -> Handler (Envelope '[Int] String)-helloWorldGet double =+testThrowsGet :: Double -> Handler (Envelope '[Int] String)+testThrowsGet double = if double < 0 then pureErrEnvelope (0 :: Int) else pureSuccEnvelope "success" +testNoThrowsGet :: Integer -> Handler (Envelope '[] String)+testNoThrowsGet _ = pureSuccEnvelope "success"+ app :: Application app = serve (Proxy :: Proxy TestApi) server @@ -130,7 +155,11 @@ serverTestsIO = testSpec "server" $ with (pure app) $ do- it "handler can return error envelope" $- get "/-5" `shouldRespondWith` "{\"err\":0}"- it "handler can return success envelope" $- get "/10" `shouldRespondWith` "{\"data\":\"success\"}"+ describe "Throws" $ do+ it "handler can return error envelope" $+ get "/-5" `shouldRespondWith` "{\"err\":0}"+ it "handler can return success envelope" $+ get "/10" `shouldRespondWith` "{\"data\":\"success\"}"+ describe "NoThrow" $ do+ it "handler can return success envelope" $+ get "/10" `shouldRespondWith` "{\"data\":\"success\"}"