servant-checked-exceptions 0.4.1.0 → 1.0.0.0

raw patch · 10 files changed

+324/−33 lines, 10 filesdep +http-typesdep ~servantdep ~servant-clientdep ~servant-docsPVP ok

version bump matches the API change (PVP)

Dependencies added: http-types

Dependency ranges changed: servant, servant-client, servant-docs, servant-server

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +1/−1
• example/Api.hs +10/−0
• example/Server.hs +8/−5
• servant-checked-exceptions.cabal +13/−7
• src/Servant/Checked/Exceptions.hs +45/−2
• src/Servant/Checked/Exceptions/Internal/Servant/API.hs +56/−0
• src/Servant/Checked/Exceptions/Internal/Servant/Server.hs +152/−13
• stack.yaml +1/−1
• test/Spec.hs +32/−4

@@ -1,4 +1,10 @@ +## 1.0.0.0++*   Add a `ErrStatus` class that can be used to set the HTTP Status Code. Given+    an endpoint that returns a `Envelope '[e1, e2] a`, you must declare an+    instance of `ErrStatus` for `e1` and `e2`.  This is a breaking change.+ ## 0.4.1.0  *   Add `NoThrow` type to represent handlers that don't throw any errors, but

@@ -131,7 +131,7 @@ $ curl \     --request POST \     --header 'Accept: application/json' \-    'http://localhost:8201/lax-search/hello'+    'http://localhost:8201/lax-search/goodbye' {"err":"BadSearchTermErr"} ``` 

@@ -12,11 +12,13 @@ import Data.Aeson.Types (Parser) import Data.String (IsString) import Data.Text (unpack)+import Network.HTTP.Types (Status, status400, status404) import Servant.API (Capture, JSON, Post, (:>), (:<|>)) import Text.Read (readMaybe) import Web.HttpApiData (FromHttpApiData, ToHttpApiData)  import Servant.Checked.Exceptions (NoThrow, Throws)+import Servant.Checked.Exceptions.Internal.Servant.API (ErrStatus(toErrStatus))  --------- -- API --@@ -107,6 +109,10 @@   parseJSON = withText "BadSearchTermErr" $     maybe (fail "could not parse as BadSearchTermErr") pure . readMaybe . unpack +instance ErrStatus BadSearchTermErr where+  toErrStatus :: BadSearchTermErr -> Status+  toErrStatus _ = status404+ -- | This error is returned when the search query is @\"hello\"@, but it is not -- capitalized correctly.  For example, the search query @\"hello\"@ will -- return an 'IncorrectCapitialization' error.  However, the search query@@ -121,6 +127,10 @@   parseJSON :: Value -> Parser IncorrectCapitalization   parseJSON = withText "IncorrectCapitalization" $     maybe (fail "could not parse as IncorrectCapitalization") pure . readMaybe . unpack++instance ErrStatus IncorrectCapitalization where+  toErrStatus :: IncorrectCapitalization -> Status+  toErrStatus _ = status400  ---------- -- Port --

@@ -22,13 +22,16 @@ import Network.Wai.Handler.Warp (run) import Servant (Handler, (:<|>)((:<|>)), ServerT, serve) -import Servant.Checked.Exceptions-       (Envelope, pureErrEnvelope, pureSuccEnvelope)+import Servant.Checked.Exceptions (Envelope, pureErrEnvelope, pureSuccEnvelope)  import Api-       (Api, BadSearchTermErr(BadSearchTermErr),-        IncorrectCapitalization(IncorrectCapitalization),-        SearchQuery(SearchQuery), SearchResponse, port)+  ( Api+  , BadSearchTermErr(BadSearchTermErr)+  , IncorrectCapitalization(IncorrectCapitalization)+  , SearchQuery(SearchQuery)+  , SearchResponse+  , port+  )  -- | This is our server root for the 'ServerT' for 'Api'.  We only have two -- handlers, 'postStrictSearch' and 'postLaxSearch'.

@@ -1,5 +1,5 @@ name:                servant-checked-exceptions-version:             0.4.1.0+version:             1.0.0.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@@ -7,7 +7,7 @@ license-file:        LICENSE author:              Dennis Gosnell maintainer:          cdep.illabout@gmail.com-copyright:           2017 Dennis Gosnell+copyright:           2017-2018 Dennis Gosnell category:            Text build-type:          Simple extra-source-files:  CHANGELOG.md@@ -33,18 +33,20 @@                      , Servant.Checked.Exceptions.Internal.Servant.Server                      , Servant.Checked.Exceptions.Internal.Union                      , Servant.Checked.Exceptions.Internal.Util-  build-depends:       base >= 4.8 && < 5+  build-depends:       base >= 4.9 && < 5                      , aeson                      , bytestring                      , deepseq                      , http-media+                     , http-types                      , profunctors                      , tagged-                     , servant >= 0.9-                     , servant-client >= 0.9-                     , servant-docs >= 0.9-                     , servant-server >= 0.9+                     , servant >= 0.9 && < 0.12+                     , servant-client >= 0.9 && < 0.12+                     , servant-docs >= 0.9 && < 0.12+                     , servant-server >= 0.9 && < 0.12                      , text+                     , wai   default-language:    Haskell2010   ghc-options:         -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction   other-extensions:    QuasiQuotes@@ -58,6 +60,7 @@                      , aeson                      , http-api-data                      , http-client+                     , http-types                      , optparse-applicative                      , servant                      , servant-checked-exceptions@@ -78,6 +81,7 @@   build-depends:       base                      , aeson                      , http-api-data+                     , http-types                      , servant                      , servant-checked-exceptions                      , servant-docs@@ -97,6 +101,7 @@   build-depends:       base                      , aeson                      , http-api-data+                     , http-types                      , natural-transformation                      , servant                      , servant-checked-exceptions@@ -130,6 +135,7 @@   build-depends:       base                      , bytestring                      , hspec-wai+                     , http-types                      , tasty                      , tasty-hspec                      , tasty-hunit

@@ -90,10 +90,51 @@  module Servant.Checked.Exceptions   (-  -- * 'Throws' API parameter+  -- * Servant Types+  -- ** 'Throws' API parameter     Throws-  -- * 'NoThrow' API parameter+  -- ** 'NoThrow' API parameter   , NoThrow+  -- ** HTTP Error Status Code+  , ErrStatus(toErrStatus)+  , Status+  -- ** Verbs+  , VerbWithErr+  -- *** Specialized Verbs+  -- **** HTTP 200+  , GetWithErr+  , PostWithErr+  , PutWithErr+  , DeleteWithErr+  , PatchWithErr+  -- **** HTTP 201+  , PostCreatedWithErr+  -- **** HTTP 202+  , GetAcceptedWithErr+  , PostAcceptedWithErr+  , DeleteAcceptedWithErr+  , PatchAcceptedWithErr+  , PutAcceptedWithErr+  -- **** HTTP 203+  , GetNonAuthoritativeWithErr+  , PostNonAuthoritativeWithErr+  , DeleteNonAuthoritativeWithErr+  , PatchNonAuthoritativeWithErr+  , PutNonAuthoritativeWithErr+  -- **** HTTP 204+  , GetNoContentWithErr+  , PostNoContentWithErr+  , DeleteNoContentWithErr+  , PatchNoContentWithErr+  , PutNoContentWithErr+  -- **** HTTP 205+  , GetResetContentWithErr+  , PostResetContentWithErr+  , DeleteResetContentWithErr+  , PatchResetContentWithErr+  , PutResetContentWithErr+  -- **** HTTP 206+  , GetPartialContentWithErr   -- * 'Envelope' response wrapper   , Envelope(..)   -- ** 'Envelope' helper functions@@ -160,5 +201,7 @@   , tupleToProduct   , ReturnX   ) where++import Network.HTTP.Types (Status)  import Servant.Checked.Exceptions.Internal

@@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}@@ -18,6 +20,11 @@  module Servant.Checked.Exceptions.Internal.Servant.API where +import Data.Typeable (Typeable)+import GHC.Exts (Constraint)+import GHC.Generics (Generic)+import GHC.TypeLits (Nat)+import Network.HTTP.Types (Status, StdMethod(DELETE, GET, PATCH, POST, PUT)) import Servant.API ((:>))  import Servant.Checked.Exceptions.Internal.Util (Snoc)@@ -62,3 +69,52 @@     Throwing (Snoc es e) :> api   ThrowingNonterminal (Throwing es :> c :> api) =     c :> Throwing es :> api++data VerbWithErr+    (method :: k1)+    (successStatusCode :: Nat)+    (contentTypes :: [*])+    (es :: [*])+    a+  deriving (Generic, Typeable)++type GetWithErr    = VerbWithErr 'GET    200+type PostWithErr   = VerbWithErr 'POST   200+type PutWithErr    = VerbWithErr 'PUT    200+type DeleteWithErr = VerbWithErr 'DELETE 200+type PatchWithErr  = VerbWithErr 'PATCH  200++type PostCreatedWithErr = VerbWithErr 'POST 201++type GetAcceptedWithErr    = VerbWithErr 'GET 202+type PostAcceptedWithErr   = VerbWithErr 'POST 202+type DeleteAcceptedWithErr = VerbWithErr 'DELETE 202+type PatchAcceptedWithErr  = VerbWithErr 'PATCH 202+type PutAcceptedWithErr    = VerbWithErr 'PUT 202++type GetNonAuthoritativeWithErr    = VerbWithErr 'GET 203+type PostNonAuthoritativeWithErr   = VerbWithErr 'POST 203+type DeleteNonAuthoritativeWithErr = VerbWithErr 'DELETE 203+type PatchNonAuthoritativeWithErr  = VerbWithErr 'PATCH 203+type PutNonAuthoritativeWithErr    = VerbWithErr 'PUT 203++type GetNoContentWithErr    = VerbWithErr 'GET 204+type PostNoContentWithErr   = VerbWithErr 'POST 204+type DeleteNoContentWithErr = VerbWithErr 'DELETE 204+type PatchNoContentWithErr  = VerbWithErr 'PATCH 204+type PutNoContentWithErr    = VerbWithErr 'PUT 204++type GetResetContentWithErr    = VerbWithErr 'GET 205+type PostResetContentWithErr   = VerbWithErr 'POST 205+type DeleteResetContentWithErr = VerbWithErr 'DELETE 205+type PatchResetContentWithErr  = VerbWithErr 'PATCH 205+type PutResetContentWithErr    = VerbWithErr 'PUT 205++type GetPartialContentWithErr = VerbWithErr 'GET 206++class ErrStatus e where+  toErrStatus :: e -> Status++type family AllErrStatus (es :: [k]) :: Constraint where+  AllErrStatus '[] = ()+  AllErrStatus (a ': as) = (ErrStatus a, AllErrStatus as)

@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -26,17 +27,47 @@  module Servant.Checked.Exceptions.Internal.Servant.Server where +import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import Data.Functor.Identity+import Data.Maybe import Data.Proxy (Proxy(Proxy))-import Servant.Server.Internal.Router (Router)-import Servant.Server.Internal.RoutingApplication (Delayed)+import GHC.TypeLits (KnownNat, natVal)+import Network.HTTP.Types+import Network.Wai+import Servant.API.ContentTypes -- (AcceptHeader(AcceptHeader), AllCTRender, handleAcceptH)+import Servant.Server.Internal (ct_wildcard)+import Servant.Server.Internal.Router (Router, Router', leafRouter)+import Servant.Server.Internal.RoutingApplication -- (Delayed, DelayedIO, RouteResult(FailFatal, Route), addAcceptCheck, addMethodCheck, runAction) import Servant-       (Context, Handler, HasServer(..), ServerT, Verb, (:>), (:<|>))+  ( (:<|>)+  , (:>)+  , Context+  , Handler+  , HasServer(..)+  , ReflectMethod+  , ServerT+  , Verb+  , err405+  , err406+  , reflectMethod+  ) -import Servant.Checked.Exceptions.Internal.Envelope (Envelope)+import Servant.Checked.Exceptions.Internal.Envelope (Envelope, envelope)+import Servant.Checked.Exceptions.Internal.Union (OpenUnion, Union(That, This)) import Servant.Checked.Exceptions.Internal.Servant.API-       (NoThrow, Throws, Throwing, ThrowingNonterminal)+  ( AllErrStatus+  , ErrStatus(toErrStatus)+  , NoThrow+  , Throwing+  , ThrowingNonterminal+  , Throws+  , VerbWithErr+  )  -- TODO: Make sure to also account for when headers are being used.+-- This might be hard to do:+-- https://github.com/cdepillabout/servant-checked-exceptions/issues/4  -- | Change a 'Throws' into 'Throwing'. instance (HasServer (Throwing '[e] :> api) context) =>@@ -54,33 +85,38 @@  -- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb' -- but returning an @'Envelope' es@.-instance (HasServer (Verb method status ctypes (Envelope es a)) context) =>+instance (HasServer (VerbWithErr method status ctypes es a) context) =>     HasServer (Throwing es :> Verb method status ctypes a) context where    type ServerT (Throwing es :> Verb method status ctypes a) m =-    ServerT (Verb method status ctypes (Envelope es a)) m+    ServerT (VerbWithErr method status ctypes es a) m    route     :: Proxy (Throwing es :> Verb method status ctypes a)     -> Context context-    -> Delayed env (ServerT (Verb method status ctypes (Envelope es a)) Handler)+    -> Delayed env+         (ServerT (VerbWithErr method status ctypes es a) Handler)     -> Router env-  route _ = route (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))+  route _ =+    route+      (Proxy :: Proxy (VerbWithErr method status ctypes 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) =>+instance+    ( HasServer (VerbWithErr method status ctypes '[] 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+    ServerT (VerbWithErr method status ctypes '[] a) m    route     :: Proxy (NoThrow :> Verb method status ctypes a)     -> Context context-    -> Delayed env (ServerT (Verb method status ctypes (Envelope '[] a)) Handler)+    -> Delayed env (ServerT (VerbWithErr method status ctypes '[] a) Handler)     -> Router env-  route _ = route (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))+  route _ = route (Proxy :: Proxy (VerbWithErr method status ctypes '[] a))  -- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each -- branch of the API.@@ -142,3 +178,106 @@     -> Delayed env (ServerT (api :> NoThrow :> apis) Handler)     -> Router env   route _ = route (Proxy :: Proxy (api :> NoThrow :> apis))++---------------------+-- Verb With Error --+---------------------++instance+    {-# OVERLAPPABLE #-}+    ( AllCTRender ctypes (Envelope es a)+    , AllErrStatus es+    , KnownNat successStatus+    , ReflectMethod method+    ) =>+    HasServer (VerbWithErr method successStatus ctypes es a) context where++  type ServerT (VerbWithErr method successStatus ctypes es a) m =+    m (Envelope es a)++  route+    :: Proxy (VerbWithErr method successStatus ctypes es a)+    -> Context context+    -> Delayed env (Handler (Envelope es a))+    -> Router' env+         ( Request ->+           (RouteResult Response -> IO ResponseReceived) ->+           IO ResponseReceived+         )+  route Proxy _ = methodRouter method successStatus (Proxy :: Proxy ctypes)+    where+      method :: Method+      method = reflectMethod (Proxy :: Proxy method)++      successStatus :: Status+      successStatus =+        toEnum . fromInteger $ natVal (Proxy :: Proxy successStatus)++methodRouter ::+     forall ctypes a es env.+     (AllCTRender ctypes (Envelope es a), AllErrStatus es)+  => Method+  -> Status+  -> Proxy ctypes+  -> Delayed env (Handler (Envelope es a))+  -> Router' env+       ( Request ->+         (RouteResult Response -> IO ResponseReceived)->+         IO ResponseReceived+       )+methodRouter method successStatus proxy action = leafRouter route'+  where+    route'+      :: env+      -> Request+      -> (RouteResult Response -> IO ResponseReceived)+      -> IO ResponseReceived+    route' env request respond = do+      let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request+      let theAction =+            action+              `addMethodCheck` methodCheck method request+              `addAcceptCheck` acceptCheck proxy accH+      runAction theAction env request respond $ go request accH++    go :: Request -> ByteString -> Envelope es a -> RouteResult Response+    go request accH envel = do+      let status = envelope getErrStatus (const successStatus) envel+      let handleA = handleAcceptH proxy (AcceptHeader accH) envel+      processMethodRouter handleA status method Nothing request++allowedMethod :: Method -> Request -> Bool+allowedMethod method request =+  allowedMethodHead method request || requestMethod request == method++allowedMethodHead :: Method -> Request -> Bool+allowedMethodHead method request =+  method == methodGet && requestMethod request == methodHead++methodCheck :: Method -> Request -> DelayedIO ()+methodCheck method request+  | allowedMethod method request = return ()+  | otherwise                    = delayedFail err405++acceptCheck :: (AllMime list) => Proxy list -> ByteString -> DelayedIO ()+acceptCheck proxy accH+  | canHandleAcceptH proxy (AcceptHeader accH) = return ()+  | otherwise                                  = delayedFail err406++getErrStatus :: AllErrStatus es => OpenUnion es -> Status+getErrStatus (This (Identity e)) = toErrStatus e+getErrStatus (That es) = getErrStatus es++processMethodRouter+  :: Maybe (LBS.ByteString, LBS.ByteString)+  -> Status+  -> Method+  -> Maybe [(HeaderName, ByteString)]+  -> Request -> RouteResult Response+processMethodRouter handleA status method headers request = case handleA of+  Nothing -> FailFatal err406 -- this should not happen (checked before),+                              -- so we make it fatal if it does+  Just (contentT, body) -> Route $ responseLBS status hdrs bdy+    where+      bdy = if allowedMethodHead method request then "" else body+      hdrs = (hContentType, LBS.toStrict contentT) : (fromMaybe [] headers)

@@ -1,7 +1,7 @@ # 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+resolver: lts-10.5  # Local packages, usually specified by relative directory name packages:

@@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Main where @@ -9,15 +11,37 @@ import Data.Proxy (Proxy(Proxy)) import Data.Type.Equality ((:~:)(Refl)) import Data.Typeable (Typeable)+import Network.HTTP.Types (status404) import Network.Wai (Application)-import Servant ((:<|>)((:<|>)), (:>), Capture, Get, Handler, JSON, ServerT, serve)-import Test.Hspec.Wai (get, shouldRespondWith, with)+import Servant+  ( (:<|>)((:<|>))+  , (:>)+  , Capture+  , Get+  , Handler+  , JSON+  , ServerT+  , serve+  )+import Test.Hspec.Wai+  ( ResponseMatcher(matchStatus)+  , get+  , shouldRespondWith+  , with+  ) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.Hspec (describe, it, testSpec) import Test.Tasty.HUnit ((@?=), assertFailure, testCase)  import Servant.Checked.Exceptions-       (Envelope, NoThrow, Throws, pureErrEnvelope, pureSuccEnvelope)+  ( Envelope+  , ErrStatus(toErrStatus)+  , NoThrow+  , Status+  , Throws+  , pureErrEnvelope+  , pureSuccEnvelope+  )  main :: IO () main = do@@ -130,6 +154,10 @@ -- Server tests -- ------------------ +instance ErrStatus Int where+  toErrStatus :: Int -> Status+  toErrStatus _ = status404+ type TestThrows = Capture "foobar" Double :> Throws Int :> Get '[JSON] String  type TestNoThrow = Capture "baz" Integer :> NoThrow :> Get '[JSON] String@@ -157,7 +185,7 @@     with (pure app) $ do       describe "Throws" $ do         it "handler can return error envelope" $-          get "/-5" `shouldRespondWith` "{\"err\":0}"+          get "/-5" `shouldRespondWith` "{\"err\":0}" { matchStatus = 404 }         it "handler can return success envelope" $           get "/10" `shouldRespondWith` "{\"data\":\"success\"}"       describe "NoThrow" $ do