diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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"} ``` diff --git a/example/Api.hs b/example/Api.hs --- a/example/Api.hs +++ b/example/Api.hs @@ -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 -- diff --git a/example/Server.hs b/example/Server.hs --- a/example/Server.hs +++ b/example/Server.hs @@ -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'. diff --git a/servant-checked-exceptions.cabal b/servant-checked-exceptions.cabal --- a/servant-checked-exceptions.cabal +++ b/servant-checked-exceptions.cabal @@ -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 . 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 diff --git a/src/Servant/Checked/Exceptions.hs b/src/Servant/Checked/Exceptions.hs --- a/src/Servant/Checked/Exceptions.hs +++ b/src/Servant/Checked/Exceptions.hs @@ -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 diff --git a/src/Servant/Checked/Exceptions/Internal/Servant/API.hs b/src/Servant/Checked/Exceptions/Internal/Servant/API.hs --- a/src/Servant/Checked/Exceptions/Internal/Servant/API.hs +++ b/src/Servant/Checked/Exceptions/Internal/Servant/API.hs @@ -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) diff --git a/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs b/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs --- a/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs +++ b/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs @@ -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) diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -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: diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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