diff --git a/cabal.project b/cabal.project index 938098646..21145d96b 100644 --- a/cabal.project +++ b/cabal.project @@ -25,15 +25,16 @@ packages: doc/cookbook/custom-errors doc/cookbook/basic-streaming doc/cookbook/db-postgres-pool --- doc/cookbook/db-sqlite-simple + -- doc/cookbook/db-sqlite-simple doc/cookbook/file-upload doc/cookbook/generic -- doc/cookbook/hoist-server-with-context --- doc/cookbook/https + -- doc/cookbook/https -- doc/cookbook/jwt-and-basic-auth/ doc/cookbook/pagination -- doc/cookbook/sentry doc/cookbook/testing + doc/cookbook/uverb doc/cookbook/structuring-apis doc/cookbook/using-custom-monad doc/cookbook/using-free-client diff --git a/doc/cookbook/uverb/UVerb.lhs b/doc/cookbook/uverb/UVerb.lhs new file mode 100644 index 000000000..e5e9bc072 --- /dev/null +++ b/doc/cookbook/uverb/UVerb.lhs @@ -0,0 +1,217 @@ +# Listing alternative responses and exceptions in your API types + +Servant allows you to talk about the exceptions you throw in your API +types. This is not limited to actual exceptions, you can write +handlers that respond with arbitrary open unions of types. + +## Preliminaries + +```haskell +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -Wno-orphans #-} + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (async) +import Control.Monad (when) +import Control.Monad.Except (ExceptT (..), MonadError (..), MonadTrans (..), runExceptT) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.String.Conversions (cs) +import Data.Swagger (ToSchema) +import Data.Typeable (Proxy (Proxy)) +import qualified GHC.Generics as GHC +import qualified Network.HTTP.Client as Client +import qualified Network.Wai.Handler.Warp as Warp +import Servant.API +import Servant.Client +import Servant.Server +import Servant.Swagger +``` + +## The API + +This looks like a `Verb`-based routing table, except that `UVerb` has +no status, and carries a list of response types rather than a single +one. Each entry in the list carries its own response code. + +```haskell +type API = + "fisx" :> Capture "bool" Bool + :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String] + :<|> "arian" + :> UVerb 'GET '[JSON] '[WithStatus 201 ArianUser] +``` + +Here are the details: + +```haskell +data FisxUser = FisxUser {name :: String} + deriving (Eq, Show, GHC.Generic) + +instance ToJSON FisxUser +instance FromJSON FisxUser +instance ToSchema FisxUser + +-- | 'HasStatus' allows us to can get around 'WithStatus' if we want +-- to, and associate the status code with our resource types directly. +-- +-- (To avoid orphan instances and make it more explicit what's in the +-- API and what isn't, we could even introduce a newtype 'Resource' +-- that wraps all the types we're using in our routing table, and then +-- define lots of 'HasStatus' instances for @Resource This@ and +-- @Resource That@.) +instance HasStatus FisxUser where + type StatusOf FisxUser = 203 + +data ArianUser = ArianUser + deriving (Eq, Show, GHC.Generic) + +instance ToJSON ArianUser +instance FromJSON ArianUser +instance ToSchema ArianUser +``` + +## Server, Client, Swagger + +You can just respond with any of the elements of the union in handlers. + +```haskell +fisx :: Bool -> Handler (Union '[FisxUser, WithStatus 303 String]) +fisx True = respond (FisxUser "fisx") +fisx False = respond (WithStatus @303 ("still fisx" :: String)) + +arian :: Handler (Union '[WithStatus 201 ArianUser]) +arian = respond (WithStatus @201 ArianUser) +``` + +You can create client functions like you're used to: + +``` +fisxClient :: Bool -> ClientM (Union '[FisxUser, WithStatus 303 String]) +arianClient :: ClientM (Union '[WithStatus 201 ArianUser]) +(fisxClient :<|> arianClient) = client (Proxy @API) +``` + +... and that's basically it! Here are a few sample commands that +show you how the swagger docs look like and how you can handle the +result unions in clients: + +``` +main :: IO () +main = do + putStrLn . cs . encodePretty $ toSwagger (Proxy @API) + _ <- async . Warp.run 8080 $ serve (Proxy @API) (fisx :<|> arian) + threadDelay 50000 + mgr <- Client.newManager Client.defaultManagerSettings + let cenv = mkClientEnv mgr (BaseUrl Http "localhost" 8080 "") + result <- runClientM (fisxClient True) cenv + print $ foldMapUnion (Proxy @Show) show <$> result + print $ matchUnion @FisxUser <$> result + print $ matchUnion @(WithStatus 303 String) <$> result + pure () +``` + +## Idiomatic exceptions + +Since `UVerb` (probably) will mostly be used for error-like responses, it may be desirable to be able to early abort handler, like with current servant one would use `throwError` with `ServerError`. + +```haskell +newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a } + deriving newtype (Functor, Applicative, Monad, MonadTrans) + +-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use +-- underlying monad's instance. +instance MonadError e m => MonadError e (UVerbT xs m) where + throwError = lift . throwError + catchError (UVerbT act) h = UVerbT $ ExceptT $ + runExceptT act `catchError` (runExceptT . unUVerbT . h) + +-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler +-- may use the usual 'return'. +runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs) +runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond) + +-- | Short-circuit 'UVerbT' computation returning one of the response types. +throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a +throwUVerb = UVerbT . ExceptT . fmap Left . respond +``` + +Example usage: + +```haskell +data Foo = Foo Int Int Int + deriving (Show, Eq, GHC.Generic, ToJSON) + deriving HasStatus via WithStatus 200 Foo + +data Bar = Bar + deriving (Show, Eq, GHC.Generic, ToJSON) + +h :: Handler (Union '[Foo, WithStatus 400 Bar]) +h = runUVerbT $ do + when ({- something bad -} True) $ + throwUVerb $ WithStatus @400 Bar + + when ({- really bad -} False) $ + throwError $ err500 + + -- a lot of code here... + + return $ Foo 1 2 3 +``` + +## Related Work + +There is the [issue from +2017](https://github.com/haskell-servant/servant/issues/841) that was +resolved by the introduction of `UVerb`, with a long discussion on +alternative designs. + +[servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions) +is a good solution to the problem, but it restricts the user to JSON +and a very specific envelop encoding for the union type, which is +often not acceptable. (One good reason for this design choice is that +it makes writing clients easier, where you need to get to the union +type from one representative, and you don't want to run several +parsers in the hope that the ones that should will always error out so +you can try until the right one returns a value.) + +[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is +another shot at at the problem. It is inspired by +servant-checked-exceptions, so it may be worth taking a closer look. +The README claims that +[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has +some code for generalized error handling. + +In an earier version of the `UVerb` implementation, we have used some +code from +[world-peace](https://hackage.haskell.org/package/world-peace), but +that package itself wasn't flexible enough, and we had to use +[sop-core](https://hackage.haskell.org/package/sop-core) to implement +the `HasServer` instance. + +Here is a blog post we found on the subject: +https://lukwagoallan.com/posts/unifying-servant-server-error-responses + +(If you have anything else, please add it here or let us know.) + +```haskell +main :: IO () +main = return () +``` diff --git a/doc/cookbook/uverb/uverb.cabal b/doc/cookbook/uverb/uverb.cabal new file mode 100644 index 000000000..0388365df --- /dev/null +++ b/doc/cookbook/uverb/uverb.cabal @@ -0,0 +1,33 @@ +name: cookbook-uverb +version: 0.0.1 +synopsis: How to use the 'UVerb' type. +description: Listing alternative responses and exceptions in your API types. +homepage: http://docs.servant.dev/ +license: BSD3 +license-file: ../../../servant/LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +category: Servant +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2 + +executable cookbook-uverb + main-is: UVerb.lhs + build-depends: base == 4.* + , aeson >= 1.2 + , aeson-pretty >= 0.8.8 + , async + , http-client + , mtl + , servant + , servant-client + , servant-server + , servant-swagger + , string-conversions + , swagger2 + , wai + , warp + default-language: Haskell2010 + ghc-options: -Wall -pgmL markdown-unlit + build-tool-depends: markdown-unlit:markdown-unlit diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 591069f37..7c3927cb3 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -78,6 +78,7 @@ library , http-types >= 0.12.2 && < 0.13 , network-uri >= 2.6.1.0 && < 2.7 , safe >= 0.3.17 && < 0.4 + , sop-core >= 0.4.0.0 && < 0.6 hs-source-dirs: src default-language: Haskell2010 diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index f18d327f2..cfebbb5ff 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -18,6 +18,8 @@ module Servant.Client.Core -- * Client generation clientIn , HasClient(..) + , foldMapUnion + , matchUnion -- * Request , Request diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index 783072443..d515d1209 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,6 +8,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -15,31 +17,48 @@ module Servant.Client.Core.HasClient ( clientIn, HasClient (..), EmptyClient (..), + foldMapUnion, + matchUnion, ) where import Prelude () import Prelude.Compat +import Control.Arrow + (left, (+++)) import Control.Monad (unless) import qualified Data.ByteString.Lazy as BL +import Data.Either + (partitionEithers) import Data.Foldable (toList) import Data.List (foldl') -import Data.Proxy - (Proxy (Proxy)) import Data.Sequence (fromList) import qualified Data.Text as T import Network.HTTP.Media (MediaType, matches, parseAccept, (//)) +import qualified Data.Sequence as Seq +import Data.SOP.BasicFunctors + (I (I), (:.:) (Comp)) +import Data.SOP.Constraint + (All) +import Data.SOP.NP + (NP (..), cpure_NP) +import Data.SOP.NS + (NS (S)) import Data.String (fromString) import Data.Text (Text, pack) +import Data.Proxy + (Proxy (Proxy)) import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.HTTP.Types + (Status) import qualified Network.HTTP.Types as H import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, @@ -54,9 +73,11 @@ import Servant.API contentType, getHeadersHList, getResponse, toQueryParam, toUrlPiece) import Servant.API.ContentTypes - (contentTypes) + (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender)) import Servant.API.Modifiers (FoldRequired, RequiredArgument, foldRequiredArgument) +import Servant.API.UVerb + (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion) import Servant.Client.Core.Auth import Servant.Client.Core.BasicAuth @@ -288,6 +309,71 @@ instance {-# OVERLAPPING #-} hoistClientMonad _ _ f ma = f ma +data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus + deriving (Eq, Show) + +instance {-# OVERLAPPING #-} + ( RunClient m, + contentTypes ~ (contentType ': otherContentTypes), + -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem + -- allow this in instance types as of 8.8.3.) + as ~ (a ': as'), + AllMime contentTypes, + ReflectMethod method, + All (AllMimeUnrender contentTypes) as, + All HasStatus as, HasStatuses as', + Unique (Statuses as) + ) => + HasClient m (UVerb method contentTypes as) + where + type Client m (UVerb method contentTypes as) = m (Union as) + + clientWithRoute _ _ request = do + let accept = Seq.fromList . allMime $ Proxy @contentTypes + -- offering to accept all mime types listed in the api gives best compatibility. eg., + -- we might not own the server implementation, and the server may choose to support + -- only part of the api. + + method = reflectMethod $ Proxy @method + acceptStatus = statuses (Proxy @as) + response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept} + responseContentType <- checkContentTypeHeader response + unless (any (matches responseContentType) accept) $ do + throwClientError $ UnsupportedContentType responseContentType response + + let status = responseStatusCode response + body = responseBody response + res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) body + case res of + Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response + Right x -> return x + where + -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the + -- failures it encountered along the way + -- TODO; better name, rewrite haddocs. + tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs) + tryParsers _ Nil = Left [ClientNoMatchingStatus] + tryParsers status (Comp x :* xs) + | status == statusOf (Comp x) = + case partitionEithers x of + (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs + (_, (res : _)) -> Right . inject . I $ res + | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for + (ClientStatusMismatch :) +++ S $ tryParsers status xs + + -- | Given a list of types, parses the given response body as each type + mimeUnrenders :: + forall cts xs. + All (AllMimeUnrender cts) xs => + Proxy cts -> + BL.ByteString -> + NP ([] :.: Either (MediaType, String)) xs + mimeUnrenders ctp body = cpure_NP + (Proxy @(AllMimeUnrender cts)) + (Comp . map (\(mediaType, parser) -> left ((,) mediaType) (parser body)) . allMimeUnrender $ ctp) + + hoistClientMonad _ _ nt s = nt s + instance {-# OVERLAPPABLE #-} ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method, FramingUnrender framing, FromSourceIO chunk a @@ -710,4 +796,4 @@ decodedAs response ct = do Left err -> throwClientError $ DecodeFailure (T.pack err) response Right val -> return val where - accept = toList $ contentTypes ct + accept = toList $ contentTypes ct diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs index 81e5d4326..7d2aa9805 100644 --- a/servant-client-core/src/Servant/Client/Core/Reexport.hs +++ b/servant-client-core/src/Servant/Client/Core/Reexport.hs @@ -5,6 +5,8 @@ module Servant.Client.Core.Reexport ( -- * HasClient HasClient(..) + , foldMapUnion + , matchUnion -- * Response (for @Raw@) , Response diff --git a/servant-client-core/src/Servant/Client/Core/RunClient.hs b/servant-client-core/src/Servant/Client/Core/RunClient.hs index fb5eb957b..4487f05c3 100644 --- a/servant-client-core/src/Servant/Client/Core/RunClient.hs +++ b/servant-client-core/src/Servant/Client/Core/RunClient.hs @@ -7,6 +7,7 @@ -- | Types for possible backends to run client-side `Request` queries module Servant.Client.Core.RunClient ( RunClient (..), + runRequest, RunStreamingClient (..), ClientF (..), ) where @@ -14,6 +15,8 @@ module Servant.Client.Core.RunClient ( import Prelude () import Prelude.Compat +import Network.HTTP.Types.Status + (Status) import Control.Monad.Free (Free (..), liftF) @@ -22,10 +25,15 @@ import Servant.Client.Core.Request import Servant.Client.Core.Response class Monad m => RunClient m where - -- | How to make a request. - runRequest :: Request -> m Response + -- | How to make a request, with an optional list of status codes to not throw exceptions + -- for (default: [200..299]). + runRequestAcceptStatus :: Maybe [Status] -> Request -> m Response throwClientError :: ClientError -> m a +-- | How to make a request. +runRequest :: RunClient m => Request -> m Response +runRequest = runRequestAcceptStatus Nothing + class RunClient m => RunStreamingClient m where withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a @@ -41,6 +49,7 @@ data ClientF a | Throw ClientError deriving (Functor) +-- TODO: honour the accept-status argument. instance ClientF ~ f => RunClient (Free f) where - runRequest req = liftF (RunRequest req id) + runRequestAcceptStatus _ req = liftF (RunRequest req id) throwClientError = liftF . Throw diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index d3ae978d3..ec571a92c 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -108,6 +108,7 @@ test-suite spec , kan-extensions , servant-client , servant-client-core + , sop-core , stm , text , transformers diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index c25c8a934..29c209f8d 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -65,7 +65,7 @@ import GHC.Generics import Network.HTTP.Media (renderHeader) import Network.HTTP.Types - (hContentType, renderQuery, statusCode) + (hContentType, renderQuery, statusCode, Status) import Servant.Client.Core import qualified Network.HTTP.Client as Client @@ -155,14 +155,14 @@ instance Alt ClientM where a b = a `catchError` \_ -> b instance RunClient ClientM where - runRequest = performRequest + runRequestAcceptStatus = performRequest throwClientError = throwError runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm -performRequest :: Request -> ClientM Response -performRequest req = do +performRequest :: Maybe [Status] -> Request -> ClientM Response +performRequest acceptStatus req = do ClientEnv m burl cookieJar' createClientRequest <- ask let clientRequest = createClientRequest burl req request <- case cookieJar' of @@ -183,8 +183,11 @@ performRequest req = do let status = Client.responseStatus response status_code = statusCode status ourResponse = clientResponseToResponse id response - unless (status_code >= 200 && status_code < 300) $ - throwError $ mkFailureResponse burl req ourResponse + goodStatus = case acceptStatus of + Nothing -> status_code >= 200 && status_code < 300 + Just good -> status `elem` good + unless goodStatus $ do + throwError $ mkFailureResponse burl req ourResponse return ourResponse where requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString) diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs index 216586384..6a1b235d0 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -47,7 +47,7 @@ import Data.Time.Clock (getCurrentTime) import GHC.Generics import Network.HTTP.Types - (statusCode) + (Status, statusCode) import qualified Network.HTTP.Client as Client @@ -112,7 +112,7 @@ instance Alt ClientM where a b = a `catchError` \_ -> b instance RunClient ClientM where - runRequest = performRequest + runRequestAcceptStatus = performRequest throwClientError = throwError instance RunStreamingClient ClientM where @@ -136,8 +136,8 @@ withClientM cm env k = runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = withClientM cm env (evaluate . force) -performRequest :: Request -> ClientM Response -performRequest req = do +performRequest :: Maybe [Status] -> Request -> ClientM Response +performRequest acceptStatus req = do -- TODO: should use Client.withResponse here too ClientEnv m burl cookieJar' createClientRequest <- ask let clientRequest = createClientRequest burl req @@ -165,10 +165,14 @@ performRequest req = do let status = Client.responseStatus response status_code = statusCode status ourResponse = clientResponseToResponse id response - unless (status_code >= 200 && status_code < 300) $ + goodStatus = case acceptStatus of + Nothing -> status_code >= 200 && status_code < 300 + Just good -> status `elem` good + unless goodStatus $ do throwError $ mkFailureResponse burl req ourResponse return ourResponse +-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above). performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a performWithStreamingRequest req k = do m <- asks manager diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 6f3850107..0864896d0 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -9,6 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -26,10 +27,14 @@ import Control.Concurrent import Control.Monad.Error.Class (throwError) import Data.Aeson +import qualified Data.ByteString.Lazy as LazyByteString import Data.Char (chr, isPrint) import Data.Monoid () import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8, decodeUtf8) import GHC.Generics (Generic) import qualified Network.HTTP.Client as C @@ -47,8 +52,11 @@ import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData (..), Capture, CaptureAll, DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header, - Headers, JSON, NoContent (NoContent), Post, QueryFlag, - QueryParam, QueryParams, Raw, ReqBody, addHeader) + Headers, JSON, MimeRender(mimeRender), + MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText, + Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody, + StdMethod(GET), Union, UVerb, WithStatus(WithStatus), + addHeader) import Servant.Client import qualified Servant.Client.Core.Auth as Auth import Servant.Server @@ -63,7 +71,7 @@ _ = client comprehensiveAPIWithoutStreaming data Person = Person { _name :: String , _age :: Integer - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Read, Generic) instance ToJSON Person instance FromJSON Person @@ -74,6 +82,15 @@ instance FromForm Person instance Arbitrary Person where arbitrary = Person <$> arbitrary <*> arbitrary +instance MimeRender PlainText Person where + mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show + +instance MimeUnrender PlainText Person where + mimeUnrender _ = + -- This does not handle any errors, but it should be fine for tests + Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict + + alice :: Person alice = Person "Alice" 42 @@ -105,6 +122,12 @@ type Api = :<|> "deleteContentType" :> DeleteNoContent :<|> "redirectWithCookie" :> Raw :<|> "empty" :> EmptyAPI + :<|> "uverb-success-or-redirect" :> + Capture "bool" Bool :> + UVerb 'GET '[PlainText] '[WithStatus 200 Person, + WithStatus 301 Text] + :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] + api :: Proxy Api api = Proxy @@ -126,6 +149,10 @@ getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] getRespHeaders :: ClientM (Headers TestHeaders Bool) getDeleteContentType :: ClientM NoContent getRedirectWithCookie :: HTTP.Method -> ClientM Response +uverbGetSuccessOrRedirect :: Bool + -> ClientM (Union '[WithStatus 200 Person, + WithStatus 301 Text]) +uverbGetCreated :: ClientM (Union '[WithStatus 201 Person]) getRoot :<|> getGet @@ -143,7 +170,9 @@ getRoot :<|> getRespHeaders :<|> getDeleteContentType :<|> getRedirectWithCookie - :<|> EmptyClient = client api + :<|> EmptyClient + :<|> uverbGetSuccessOrRedirect + :<|> uverbGetCreated = client api server :: Application server = serve api ( @@ -166,7 +195,12 @@ server = serve api ( :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") - :<|> emptyServer) + :<|> emptyServer + :<|> (\shouldRedirect -> if shouldRedirect + then respond (WithStatus @301 ("redirecting" :: Text)) + else respond (WithStatus @200 alice )) + :<|> respond (WithStatus @201 carol) + ) type FailApi = "get" :> Raw diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs index 272b607c5..9e12f0345 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -31,6 +32,8 @@ import Data.Foldable import Data.Maybe (listToMaybe) import Data.Monoid () +import Data.Text + (Text) import qualified Network.HTTP.Client as C import qualified Network.HTTP.Types as HTTP import Test.Hspec @@ -39,7 +42,7 @@ import Test.HUnit import Test.QuickCheck import Servant.API - (NoContent (NoContent), getHeaders) + (NoContent (NoContent), WithStatus(WithStatus), getHeaders) import Servant.Client import qualified Servant.Client.Core.Request as Req import Servant.Client.Internal.HttpClient (defaultMakeClientRequest) @@ -151,3 +154,23 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do result <- left show <$> runClient (getMultiple cap num flag body) baseUrl return $ result === Right (cap, num, flag, body) + + context "With a route that can either return success or redirect" $ do + it "Redirects when appropriate" $ \(_, baseUrl) -> do + eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @301 @Text "redirecting") + + it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do + eitherResponse <- runClient (uverbGetSuccessOrRedirect False) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @200 alice) + + context "with a route that uses uverb but only has a single response" $ + it "returns the expected response" $ \(_, baseUrl) -> do + eitherResponse <- runClient (uverbGetCreated) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol) diff --git a/servant-http-streams/src/Servant/HttpStreams/Internal.hs b/servant-http-streams/src/Servant/HttpStreams/Internal.hs index 54c920bc0..4d2bae2e0 100644 --- a/servant-http-streams/src/Servant/HttpStreams/Internal.hs +++ b/servant-http-streams/src/Servant/HttpStreams/Internal.hs @@ -141,7 +141,7 @@ instance Alt ClientM where a b = a `catchError` \_ -> b instance RunClient ClientM where - runRequest = performRequest + runRequestAcceptStatus = performRequest throwClientError = throwError instance RunStreamingClient ClientM where @@ -155,8 +155,8 @@ withClientM cm env k = let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm in f k -performRequest :: Request -> ClientM Response -performRequest req = do +performRequest :: Maybe [Status] -> Request -> ClientM Response +performRequest acceptStatus req = do ClientEnv burl conn <- ask let (req', body) = requestToClientRequest burl req x <- ClientM $ lift $ lift $ Codensity $ \k -> do @@ -165,7 +165,10 @@ performRequest req = do let sc = Client.getStatusCode res' lbs <- BSL.fromChunks <$> Streams.toList body' let res'' = clientResponseToResponse res' lbs - if sc >= 200 && sc < 300 + goodStatus = case acceptStatus of + Nothing -> sc >= 200 && sc < 300 + Just good -> sc `elem` (statusCode <$> good) + if goodStatus then k (Right res'') else k (Left (mkFailureResponse burl req res'')) diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 8772cdc50..e417a6eb0 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -51,6 +51,7 @@ library Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServerError Servant.Server.StaticFiles + Servant.Server.UVerb -- deprecated exposed-modules: @@ -84,6 +85,7 @@ library , network-uri >= 2.6.1.0 && < 2.8 , monad-control >= 1.0.2.3 && < 1.1 , network >= 2.8 && < 3.2 + , sop-core >= 0.4.0.0 && < 0.6 , string-conversions >= 0.4.0.1 && < 0.5 , resourcet >= 1.2.2 && < 1.3 , tagged >= 0.8.6 && < 0.9 @@ -94,6 +96,7 @@ library hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall -Wno-redundant-constraints executable greet diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 99c0b1e59..5d40eb6f6 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -110,6 +110,7 @@ module Servant.Server -- * Re-exports , Application , Tagged (..) + , module Servant.Server.UVerb ) where @@ -122,6 +123,7 @@ import Data.Text import Network.Wai (Application) import Servant.Server.Internal +import Servant.Server.UVerb -- * Implementing Servers diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a234f145f..ba42c8e98 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -65,7 +65,7 @@ import Network.Socket (SockAddr) import Network.Wai (Application, Request, httpVersion, isSecure, lazyRequestBody, - queryString, remoteHost, requestBody, requestHeaders, + queryString, remoteHost, getRequestBodyChunk, requestHeaders, requestMethod, responseLBS, responseStream, vault) import Prelude () import Prelude.Compat @@ -681,7 +681,7 @@ instance bodyCheck fromRS = withRequest $ \req -> do let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk - let body = requestBody req + let body = getRequestBodyChunk req let rs = S.fromAction B.null body let rs' = fromRS $ framingUnrender' rs return rs' diff --git a/servant-server/src/Servant/Server/UVerb.hs b/servant-server/src/Servant/Server/UVerb.hs new file mode 100644 index 000000000..bbddba348 --- /dev/null +++ b/servant-server/src/Servant/Server/UVerb.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Servant.Server.UVerb + ( respond, + IsServerResource, + ) +where + +import Data.Proxy (Proxy (Proxy)) +import Data.SOP (I (I)) +import Data.SOP.Constraint (All, And) +import Data.String.Conversions (LBS, cs) +import Network.HTTP.Types (Status, hContentType) +import Network.Wai (responseLBS) +import Servant.API (ReflectMethod, reflectMethod) +import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime) +import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, foldMapUnion, inject, statusOf) +import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction) + + +-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union, +-- and will construct a union value in an 'Applicative' (eg. 'Server'). +respond :: + forall (x :: *) (xs :: [*]) (f :: * -> *). + (Applicative f, HasStatus x, IsMember x xs) => + x -> + f (Union xs) +respond = pure . inject . I + +-- | Helper constraint used in @instance 'HasServer' 'UVerb'@. +type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus + +instance + ( ReflectMethod method, + AllMime contentTypes, + All (IsServerResource contentTypes) as, + Unique (Statuses as) -- for consistency with servant-swagger (server would work fine + -- wihtout; client is a bit of a corner case, because it dispatches + -- the parser based on the status code. with this uniqueness + -- constraint it won't have to run more than one parser in weird + -- corner cases. + ) => + HasServer (UVerb method contentTypes as) context + where + type ServerT (UVerb method contentTypes as) m = m (Union as) + + hoistServerWithContext _ _ nt s = nt s + + route :: + forall env. + Proxy (UVerb method contentTypes as) -> + Context context -> + Delayed env (Server (UVerb method contentTypes as)) -> + Router env + route _proxy _ctx action = leafRouter route' + where + method = reflectMethod (Proxy @method) + route' env request cont = do + let action' :: Delayed env (Handler (Union as)) + action' = + action + `addMethodCheck` methodCheck method request + `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request) + mkProxy :: a -> Proxy a + mkProxy _ = Proxy + + runAction action' env request cont $ \(output :: Union as) -> do + let encodeResource :: (AllCTRender contentTypes a, HasStatus a) => a -> (Status, Maybe (LBS, LBS)) + encodeResource res = + ( statusOf $ mkProxy res, + handleAcceptH (Proxy @contentTypes) (getAcceptHeader request) res + ) + pickResource :: Union as -> (Status, Maybe (LBS, LBS)) + pickResource = foldMapUnion (Proxy @(IsServerResource contentTypes)) encodeResource + + case pickResource output of + (_, Nothing) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does + (status, Just (contentT, body)) -> + let bdy = if allowedMethodHead method request then "" else body + in Route $ responseLBS status ((hContentType, cs contentT) : []) bdy diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 90e72667e..87c844212 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -7,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} module Servant.ServerSpec where @@ -49,14 +48,16 @@ import Network.Wai.Test import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, - Delete, EmptyAPI, Get, Header, Headers, HttpVersion, - IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb, - NoFraming, OctetStream, Patch, PlainText, Post, Put, - QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, - SourceIO, StdMethod (..), Stream, Strict, Verb, addHeader) + Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers, + HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..), + NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post, + Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, + ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union, + UVerb, Verb, addHeader) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), - emptyServer, err401, err403, err404, serve, serveWithContext) + emptyServer, err401, err403, err404, respond, serve, + serveWithContext) import Servant.Test.ComprehensiveAPI import qualified Servant.Types.SourceT as S import Test.Hspec @@ -87,6 +88,7 @@ comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext spec :: Spec spec = do verbSpec + uverbSpec captureSpec captureAllSpec queryParamSpec @@ -253,8 +255,8 @@ captureSpec = do with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) - (\ "captured" -> Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do + (\ "captured" -> Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) @@ -305,8 +307,8 @@ captureAllSpec = do with (return (serve (Proxy :: Proxy (CaptureAll "segments" String :> Raw)) - (\ _captured -> Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do + (\ _captured -> Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "consumes everything from pathInfo" $ do get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int]))) @@ -544,8 +546,8 @@ rawApi :: Proxy RawApi rawApi = Proxy rawApplication :: Show a => (Request -> a) -> Tagged m Application -rawApplication f = Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] +rawApplication f = Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] (cs $ show $ f request_) rawSpec :: Spec @@ -706,7 +708,7 @@ basicAuthApi = Proxy basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|> - (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "") + (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext = @@ -751,7 +753,7 @@ genAuthApi = Proxy genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety) - :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "") + :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") type instance AuthServerData (AuthProtect "auth") = () @@ -781,6 +783,73 @@ genAuthSpec = do it "plays nice with subsequent Raw endpoints" $ do get "/foo" `shouldRespondWith` 418 +-- }}} +------------------------------------------------------------------------------ +-- * UVerb {{{ +------------------------------------------------------------------------------ + +newtype PersonResponse = PersonResponse Person + deriving Generic +instance ToJSON PersonResponse +instance HasStatus PersonResponse where + type StatusOf PersonResponse = 200 + +newtype RedirectResponse = RedirectResponse String + deriving Generic +instance ToJSON RedirectResponse +instance HasStatus RedirectResponse where + type StatusOf RedirectResponse = 301 + +newtype AnimalResponse = AnimalResponse Animal + deriving Generic +instance ToJSON AnimalResponse +instance HasStatus AnimalResponse where + type StatusOf AnimalResponse = 203 + + +type UVerbApi + = "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse] + :<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse] + +uverbSpec :: Spec +uverbSpec = describe "Servant.API.UVerb " $ do + let + joe = Person "joe" 42 + mouse = Animal "Mouse" 7 + + personHandler + :: Bool + -> Handler (Union '[PersonResponse + ,RedirectResponse]) + personHandler True = respond $ RedirectResponse "over there!" + personHandler False = respond $ PersonResponse joe + + animalHandler = respond $ AnimalResponse mouse + + server :: Server UVerbApi + server = personHandler :<|> animalHandler + + with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do + context "A route returning either 301/String or 200/Person" $ do + context "when requesting the person" $ do + let theRequest = THW.get "/person/false" + it "returns status 200" $ + theRequest `shouldRespondWith` 200 + it "returns a person" $ do + response <- theRequest + liftIO $ decode' (simpleBody response) `shouldBe` Just joe + context "requesting the redirect" $ + it "returns a message and status 301" $ + THW.get "/person/true" + `shouldRespondWith` "\"over there!\"" {matchStatus = 301} + context "a route with a single response type" $ do + let theRequest = THW.get "/animal" + it "should return the defined status code" $ + theRequest `shouldRespondWith` 203 + it "should return the expected response" $ do + response <- theRequest + liftIO $ decode' (simpleBody response) `shouldBe` Just mouse + -- }}} ------------------------------------------------------------------------------ -- * Test data types {{{ diff --git a/servant/servant.cabal b/servant/servant.cabal index 3f33cff68..e02e093fa 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -54,6 +54,8 @@ library Servant.API.Stream Servant.API.Sub Servant.API.TypeLevel + Servant.API.UVerb + Servant.API.UVerb.Union Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext @@ -78,6 +80,7 @@ library base >= 4.9 && < 4.15 , bytestring >= 0.10.8.1 && < 0.11 , mtl >= 2.2.2 && < 2.3 + , sop-core >= 0.4.0.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.6 , text >= 1.2.3.0 && < 1.3 @@ -108,11 +111,13 @@ library hs-source-dirs: src default-language: Haskell2010 - other-extensions: CPP + other-extensions: AllowAmbiguousTypes + , CPP , ConstraintKinds , DataKinds , DeriveDataTypeable , DeriveGeneric + , ExplicitNamespaces , FlexibleContexts , FlexibleInstances , FunctionalDependencies @@ -121,11 +126,13 @@ library , MultiParamTypeClasses , OverloadedStrings , PolyKinds + , RankNTypes , ScopedTypeVariables , TupleSections , TypeFamilies , TypeOperators , UndecidableInstances + ghc-options: -Wall -Wno-redundant-constraints test-suite spec diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 772a38878..66b86d78e 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -32,6 +32,7 @@ module Servant.API ( -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, + module Servant.API.UVerb, -- * Streaming endpoints, distinguished by HTTP method module Servant.API.Stream, @@ -132,6 +133,9 @@ import Servant.API.Verbs PutCreated, PutNoContent, PutNonAuthoritative, ReflectMethod (reflectMethod), StdMethod (..), Verb, NoContentVerb) +import Servant.API.UVerb + (UVerb, Union, HasStatus, StatusOf, statusOf, Statuses, + WithStatus (..), IsMember, Unique, inject) import Servant.API.WithNamedContext (WithNamedContext) import Servant.Links diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 145ecfb5c..d6d200ada 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -419,7 +419,6 @@ instance MimeUnrender OctetStream BS.ByteString where mimeUnrender _ = Right . toStrict - -- $setup -- >>> :set -XFlexibleInstances -- >>> :set -XMultiParamTypeClasses diff --git a/servant/src/Servant/API/UVerb.hs b/servant/src/Servant/API/UVerb.hs new file mode 100644 index 000000000..4074adef8 --- /dev/null +++ b/servant/src/Servant/API/UVerb.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | An alternative to 'Verb' for end-points that respond with a resource value of any of an +-- open union of types, and specific status codes for each type in this union. (`UVerb` is +-- short for `UnionVerb`) +-- +-- This can be used for returning (rather than throwing) exceptions in a server as in, say +-- @'[Report, WaiError]@; or responding with either a 303 forward with a location header, or +-- 201 created with a different body type, depending on the circumstances. (All of this can +-- be done with vanilla servant-server by throwing exceptions, but it can't be represented in +-- the API types without something like `UVerb`.) +-- +-- See for a working example. +module Servant.API.UVerb + ( UVerb, + HasStatus (StatusOf), + statusOf, + HasStatuses (Statuses, statuses), + WithStatus (..), + module Servant.API.UVerb.Union, + ) +where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Proxy (Proxy (Proxy)) +import qualified GHC.Generics as GHC +import GHC.TypeLits (Nat) +import Network.HTTP.Types (Status, StdMethod) +import Servant.API.ContentTypes (MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent) +import Servant.API.Status (KnownStatus, statusVal) +import Servant.API.UVerb.Union + +class KnownStatus (StatusOf a) => HasStatus (a :: *) where + type StatusOf (a :: *) :: Nat + +statusOf :: forall a proxy. HasStatus a => proxy a -> Status +statusOf = const (statusVal (Proxy :: Proxy (StatusOf a))) + +instance KnownStatus n => HasStatus (WithStatus n a) where + type StatusOf (WithStatus n a) = n + +-- | If an API can respond with 'NoContent' we assume that this will happen +-- with the status code 204 No Content. If this needs to be overridden, +-- 'WithStatus' can be used. +instance HasStatus NoContent where + type StatusOf NoContent = 204 + +class HasStatuses (as :: [*]) where + type Statuses (as :: [*]) :: [Nat] + statuses :: Proxy as -> [Status] + +instance HasStatuses '[] where + type Statuses '[] = '[] + statuses _ = [] + +instance (HasStatus a, HasStatuses as) => HasStatuses (a ': as) where + type Statuses (a ': as) = StatusOf a ': Statuses as + statuses _ = statusOf (Proxy :: Proxy a) : statuses (Proxy :: Proxy as) + +newtype WithStatus (k :: Nat) a = WithStatus a + deriving (Eq, Show, GHC.Generic) + +instance (GHC.Generic (WithStatus n a), ToJSON a) => ToJSON (WithStatus n a) + +instance (GHC.Generic (WithStatus n a), FromJSON a) => FromJSON (WithStatus n a) + +instance MimeRender ctype a => MimeRender ctype (WithStatus _status a) where + mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a + +instance MimeUnrender ctype a => MimeUnrender ctype (WithStatus _status a) where + mimeUnrender contentTypeProxy input = + WithStatus <$> mimeUnrender contentTypeProxy input + +-- | A variant of 'Verb' that can have any of a number of response values and status codes. +-- +-- FUTUREWORK: it would be nice to make 'Verb' a special case of 'UVerb', and only write +-- instances for 'HasServer' etc. for the latter, getting them for the former for free. +-- Something like: +-- +-- @type Verb method statusCode contentTypes a = UVerb method contentTypes [WithStatus statusCode a]@ +-- +-- Backwards compatibility is tricky, though: this type alias would mean people would have to +-- use 'respond' instead of 'pure' or 'return', so all old handlers would have to be rewritten. +data UVerb (method :: StdMethod) (contentTypes :: [*]) (as :: [*]) diff --git a/servant/src/Servant/API/UVerb/Union.hs b/servant/src/Servant/API/UVerb/Union.hs new file mode 100644 index 000000000..1b776216c --- /dev/null +++ b/servant/src/Servant/API/UVerb/Union.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- + +Copyright Dennis Gosnell (c) 2017-2018 + +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 Author name here 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. + +-} + +-- | Type-level code for implementing and using 'UVerb'. Heavily inspired by +-- [world-piece](https://github.com/cdepillabout/world-peace). +module Servant.API.UVerb.Union +( IsMember +, Unique +, Union +, inject +, eject +, foldMapUnion +, matchUnion +) +where + +import Data.Proxy (Proxy) +import Data.SOP.BasicFunctors (I, unI) +import Data.SOP.Constraint +import Data.SOP.NS +import Data.Type.Bool (If) +import Data.Type.Equality (type (==)) +import GHC.TypeLits + +type Union = NS I + +-- | Convenience function to apply a function to an unknown union element using a type class. +-- All elements of the union must have instances in the type class, and the function is +-- applied unconditionally. +-- +-- See also: 'matchUnion'. +foldMapUnion :: + forall (c :: * -> Constraint) (a :: *) (as :: [*]). + All c as => + Proxy c -> + (forall x. c x => x -> a) -> + Union as -> + a +foldMapUnion proxy go = cfoldMap_NS proxy (go . unI) + +-- | Convenience function to extract a union element using 'cast', ie. return the value if the +-- selected type happens to be the actual type of the union in this value, or 'Nothing' +-- otherwise. +-- +-- See also: 'foldMapUnion'. +matchUnion :: forall (a :: *) (as :: [*]). (IsMember a as) => Union as -> Maybe a +matchUnion = fmap unI . eject + +-- * Stuff stolen from 'Data.WorldPeace" but for generics-sop + +-- (this could to go sop-core, except it's probably too specialized to the servant use-case.) + +type IsMember (a :: u) (as :: [u]) = (Unique as, CheckElemIsMember a as, UElem a as) + +class UElem x xs where + inject :: f x -> NS f xs + eject :: NS f xs -> Maybe (f x) + +instance {-# OVERLAPPING #-} UElem x (x ': xs) where + inject = Z + eject (Z x) = Just x + eject _ = Nothing + +instance {-# OVERLAPPING #-} UElem x xs => UElem x (x' ': xs) where + inject = S . inject + eject (Z _) = Nothing + eject (S ns) = eject ns + +-- | Check whether @a@ is in list. This will throw nice errors if the element is not in the +-- list, or if there is a duplicate in the list. +type family CheckElemIsMember (a :: k) (as :: [k]) :: Constraint where + CheckElemIsMember a as = + If (Elem a as) (() :: Constraint) (TypeError (NoElementError a as)) + +type NoElementError (r :: k) (rs :: [k]) = + 'Text "Expected one of:" + ':$$: 'Text " " ':<>: 'ShowType rs + ':$$: 'Text "But got:" + ':$$: 'Text " " ':<>: 'ShowType r + +type DuplicateElementError (rs :: [k]) = + 'Text "Duplicate element in list:" + ':$$: 'Text " " ':<>: 'ShowType rs + +type family Elem (x :: k) (xs :: [k]) :: Bool where + Elem _ '[] = 'False + Elem x (x' ': xs) = + If (x == x') 'True (Elem x xs) + +type family Unique xs :: Constraint where + Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs)) + +type family Nubbed xs :: Bool where + Nubbed '[] = 'True + Nubbed (x ': xs) = If (Elem x xs) 'False (Nubbed xs) + +_testNubbed :: ( ( Nubbed '[Bool, Int, Int] ~ 'False + , Nubbed '[Int, Int, Bool] ~ 'False + , Nubbed '[Int, Bool] ~ 'True + ) + => a) -> a +_testNubbed = id