From 8fd6a1d1e871f5761d341747e36fbb16075d00ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= Date: Mon, 1 Jul 2024 17:45:44 +0200 Subject: [PATCH] Integrate MultiVerb into the `servant` packages This commit is Part 1 of the integration, where only the `servant`Epackage is touched. `Verb` is redefined as an alias for `MultiVerb1` inEorder to make the transition transparent to users of `Verb`. --- servant-client-core/servant-client-core.cabal | 1 + .../src/Servant/Client/Core/HasClient.hs | 98 +++- .../src/Servant/Client/Core/Response.hs | 9 +- .../Servant/Client/Core/ResponseUnrender.hs | 131 +++++ servant-client/servant-client.cabal | 1 + .../test/Servant/ClientTestUtils.hs | 77 ++- servant-client/test/Servant/MiddlewareSpec.hs | 6 +- servant-server/servant-server.cabal | 3 +- servant-server/src/Servant/Server/Internal.hs | 52 +- .../src/Servant/Server/Internal/Context.hs | 21 +- .../Servant/Server/Internal/ResponseRender.hs | 184 +++++++ servant/servant.cabal | 7 +- servant/src/Servant/API/Alternative.hs | 3 +- servant/src/Servant/API/MultiVerb.hs | 486 ++++++++++++++++++ servant/src/Servant/API/TypeLevel/List.hs | 14 + servant/src/Servant/Links.hs | 5 + servant/src/Servant/Types/ResponseList.hs | 17 + 17 files changed, 1053 insertions(+), 62 deletions(-) create mode 100644 servant-client-core/src/Servant/Client/Core/ResponseUnrender.hs create mode 100644 servant-server/src/Servant/Server/Internal/ResponseRender.hs create mode 100644 servant/src/Servant/API/MultiVerb.hs create mode 100644 servant/src/Servant/API/TypeLevel/List.hs create mode 100644 servant/src/Servant/Types/ResponseList.hs diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 5cf45c168..4cbbc4061 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -91,6 +91,7 @@ library Servant.Client.Core.Reexport Servant.Client.Core.Request Servant.Client.Core.Response + Servant.Client.Core.ResponseUnrender Servant.Client.Core.RunClient Servant.Client.Free Servant.Client.Generic diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index f3a53ad58..676dc6870 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ApplicativeDo #-} {-# OPTIONS_GHC -Wno-missing-methods #-} module Servant.Client.Core.HasClient ( clientIn, @@ -8,7 +9,8 @@ module Servant.Client.Core.HasClient ( (//), (/:), foldMapUnion, - matchUnion + matchUnion, + fromSomeClientResponse ) where import Prelude () @@ -16,9 +18,10 @@ import Prelude.Compat import Control.Arrow (left, (+++)) +import qualified Data.Text as Text import Control.Monad (unless) -import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy as BSL import Data.Either (partitionEithers) import Data.Constraint (Dict(..)) @@ -42,13 +45,11 @@ import Data.SOP.Constraint import Data.SOP.NP (NP (..), cpure_NP) import Data.SOP.NS - (NS (S)) + (NS (..)) import Data.String (fromString) import Data.Text (Text, pack) -import Data.Proxy - (Proxy (Proxy)) import GHC.TypeLits (KnownNat, KnownSymbol, TypeError, symbolVal) import Network.HTTP.Types @@ -86,7 +87,12 @@ import Servant.Client.Core.BasicAuth import Servant.Client.Core.ClientError import Servant.Client.Core.Request import Servant.Client.Core.Response +import Servant.Client.Core.ResponseUnrender +import qualified Servant.Client.Core.Response as Response import Servant.Client.Core.RunClient +import Servant.API.MultiVerb +import qualified Network.HTTP.Media as M +import Data.Typeable -- * Accessing APIs as a Client @@ -108,7 +114,6 @@ import Servant.Client.Core.RunClient clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api clientIn p pm = clientWithRoute pm p defaultRequest - -- | This class lets us define how each API combinator influences the creation -- of an HTTP request. -- @@ -125,7 +130,6 @@ class RunClient m => HasClient m api where -> Client mon api -> Client mon' api - -- | A client querying function for @a ':<|>' b@ will actually hand you -- one function for querying @a@ and another one for querying @b@, -- stitching them together with ':<|>', which really is just like a pair. @@ -322,7 +326,7 @@ data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch deriving (Eq, Show) class UnrenderResponse (cts :: [Type]) (a :: Type) where - unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts + unrenderResponse :: Seq.Seq H.Header -> BSL.ByteString -> Proxy cts -> [Either (MediaType, String) a] instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where @@ -364,15 +368,13 @@ instance {-# OVERLAPPING #-} method = reflectMethod $ Proxy @method acceptStatus = statuses (Proxy @as) - response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept} + response@Response{responseBody=body, responseStatusCode=status, responseHeaders=headers} + <- 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 - headers = responseHeaders response - res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body + let res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body case res of Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response Right x -> return x @@ -396,7 +398,7 @@ instance {-# OVERLAPPING #-} All (UnrenderResponse cts) xs => Proxy cts -> Seq.Seq H.Header -> - BL.ByteString -> + BSL.ByteString -> NP ([] :.: Either (MediaType, String)) xs mimeUnrenders ctp headers body = cpure_NP (Proxy @(UnrenderResponse cts)) @@ -413,10 +415,10 @@ instance {-# OVERLAPPABLE #-} hoistClientMonad _ _ f ma = f ma - clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do - let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk + clientWithRoute _pm Proxy req = withStreamingRequest req' $ \Response{responseBody=body} -> do + let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BSL.ByteString -> Either String chunk framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' - fromSourceIO $ framingUnrender' $ responseBody gres + fromSourceIO $ framingUnrender' body where req' = req { requestAccept = fromList [contentType (Proxy :: Proxy ct)] @@ -433,13 +435,14 @@ instance {-# OVERLAPPING #-} hoistClientMonad _ _ f ma = f ma - clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do - let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk + clientWithRoute _pm Proxy req = withStreamingRequest req' $ + \Response{responseBody=body, responseHeaders=headers} -> do + let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BSL.ByteString -> Either String chunk framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' - val <- fromSourceIO $ framingUnrender' $ responseBody gres + val <- fromSourceIO $ framingUnrender' body return $ Headers { getResponse = val - , getHeadersHList = buildHeadersTo . toList $ responseHeaders gres + , getHeadersHList = buildHeadersTo $ toList headers } where @@ -757,7 +760,7 @@ instance sourceIO = framingRender framingP - (mimeRender ctypeP :: chunk -> BL.ByteString) + (mimeRender ctypeP :: chunk -> BSL.ByteString) (toSourceIO body) -- | Make the querying function append @path@ to the request path. @@ -862,7 +865,6 @@ data AsClientT (m :: Type -> Type) instance GenericMode (AsClientT m) where type AsClientT m :- api = Client m api - type GClientConstraints api m = ( GenericServant api (AsClientT m) , Client m (ToServantApi api) ~ ToServant api (AsClientT m) @@ -972,6 +974,52 @@ x // f = f x (/:) :: (a -> b -> c) -> b -> a -> c (/:) = flip +instance + ( ResponseListUnrender cs as, + AllMime cs, + ReflectMethod method, + AsUnion as r, + RunClient m + ) => + HasClient m (MultiVerb method cs as r) + where + type Client m (MultiVerb method cs as r) = m r + + clientWithRoute _ _ req = do + response@Response{responseBody=body} <- + runRequestAcceptStatus + (Just (responseListStatuses @cs @as)) + req + { requestMethod = method, + requestAccept = Seq.fromList accept + } + + c <- getResponseContentType response + unless (any (M.matches c) accept) $ do + throwClientError $ UnsupportedContentType c response + + -- NOTE: support streaming in the future + let sresp = + if BSL.null body + then SomeClientResponse $ response {Response.responseBody = ()} + else SomeClientResponse response + case responseListUnrender @cs @as c sresp of + StatusMismatch -> throwClientError (DecodeFailure "Status mismatch" response) + UnrenderError e -> throwClientError (DecodeFailure (Text.pack e) response) + UnrenderSuccess x -> pure (fromUnion @as x) + where + accept = allMime (Proxy @cs) + method = reflectMethod (Proxy @method) + + hoistClientMonad _ _ f = f + +getResponseContentType :: (RunClient m) => Response -> m M.MediaType +getResponseContentType response = + case lookup "Content-Type" (toList (responseHeaders response)) of + Nothing -> pure $ "application" M.// "octet-stream" + Just t -> case M.parseAccept t of + Nothing -> throwClientError $ InvalidContentTypeHeader response + Just t' -> pure t' {- Note [Non-Empty Content Types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1003,11 +1051,11 @@ checkContentTypeHeader response = decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) => Response -> Proxy ct -> m a -decodedAs response ct = do +decodedAs response@Response{responseBody=body} ct = do responseContentType <- checkContentTypeHeader response unless (any (matches responseContentType) accept) $ throwClientError $ UnsupportedContentType responseContentType response - case mimeUnrender ct $ responseBody response of + case mimeUnrender ct body of Left err -> throwClientError $ DecodeFailure (T.pack err) response Right val -> return val where diff --git a/servant-client-core/src/Servant/Client/Core/Response.hs b/servant-client-core/src/Servant/Client/Core/Response.hs index 16ca0667a..643ae1cfc 100644 --- a/servant-client-core/src/Servant/Client/Core/Response.hs +++ b/servant-client-core/src/Servant/Client/Core/Response.hs @@ -1,17 +1,17 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} module Servant.Client.Core.Response ( Response, StreamingResponse, ResponseF (..), + responseToInternalResponse, ) where import Prelude () @@ -31,6 +31,7 @@ import Network.HTTP.Types import Servant.API.Stream (SourceIO) +import Servant.Types.ResponseList data ResponseF a = Response { responseStatusCode :: Status @@ -51,3 +52,7 @@ instance NFData a => NFData (ResponseF a) where type Response = ResponseF LBS.ByteString type StreamingResponse = ResponseF (SourceIO BS.ByteString) + +responseToInternalResponse :: ResponseF a -> InternalResponse a +responseToInternalResponse Response{responseStatusCode, responseHeaders,responseBody} = + InternalResponse responseStatusCode responseHeaders responseBody diff --git a/servant-client-core/src/Servant/Client/Core/ResponseUnrender.hs b/servant-client-core/src/Servant/Client/Core/ResponseUnrender.hs new file mode 100644 index 000000000..b740dec57 --- /dev/null +++ b/servant-client-core/src/Servant/Client/Core/ResponseUnrender.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE ApplicativeDo #-} +module Servant.Client.Core.ResponseUnrender where + +import Control.Applicative +import Control.Monad +import Data.Kind (Type) +import Data.SOP +import Data.Typeable +import GHC.TypeLits +import Network.HTTP.Types.Status (Status) +import qualified Data.ByteString.Lazy as BSL +import qualified Network.HTTP.Media as M + +import Servant.API.ContentTypes +import Servant.API.MultiVerb +import Servant.API.Status +import Servant.API.UVerb.Union (Union) +import Servant.Client.Core.Response (ResponseF(..)) +import qualified Servant.Client.Core.Response as Response +import Servant.API.Stream (SourceIO) +import Data.ByteString (ByteString) + +data SomeClientResponse = forall a. Typeable a => SomeClientResponse (ResponseF a) + +fromSomeClientResponse + :: forall a m. (Alternative m, Typeable a) + => SomeClientResponse + -> m (ResponseF a) +fromSomeClientResponse (SomeClientResponse Response {..}) = do + body <- maybe empty pure $ cast @_ @a responseBody + pure $ + Response + { responseBody = body, + .. + } + +class ResponseUnrender cs a where + type ResponseBody a :: Type + type ResponseStatus a :: Nat + responseUnrender + :: M.MediaType + -> ResponseF (ResponseBody a) + -> UnrenderResult (ResponseType a) + +class (Typeable as) => ResponseListUnrender cs as where + responseListUnrender + :: M.MediaType + -> SomeClientResponse + -> UnrenderResult (Union (ResponseTypes as)) + + responseListStatuses :: [Status] + +instance ResponseListUnrender cs '[] where + responseListUnrender _ _ = StatusMismatch + responseListStatuses = [] + +instance + ( Typeable a, + Typeable (ResponseBody a), + ResponseUnrender cs a, + ResponseListUnrender cs as, + KnownStatus (ResponseStatus a) + ) => + ResponseListUnrender cs (a ': as) + where + responseListUnrender c output = + Z . I <$> (responseUnrender @cs @a c =<< fromSomeClientResponse output) + <|> S <$> responseListUnrender @cs @as c output + + responseListStatuses = statusVal (Proxy @(ResponseStatus a)) : responseListStatuses @cs @as + +instance + ( KnownStatus s, + MimeUnrender ct a + ) => + ResponseUnrender cs (RespondAs (ct :: Type) s desc a) + where + type ResponseStatus (RespondAs ct s desc a) = s + type ResponseBody (RespondAs ct s desc a) = BSL.ByteString + + responseUnrender _ output = do + guard (responseStatusCode output == statusVal (Proxy @s)) + either UnrenderError UnrenderSuccess $ + mimeUnrender (Proxy @ct) (Response.responseBody output) + +instance (KnownStatus s) => ResponseUnrender cs (RespondAs '() s desc ()) where + type ResponseStatus (RespondAs '() s desc ()) = s + type ResponseBody (RespondAs '() s desc ()) = () + + responseUnrender _ output = + guard (responseStatusCode output == statusVal (Proxy @s)) + +instance + (KnownStatus s) + => ResponseUnrender cs (RespondStreaming s desc framing ct) + where + type ResponseStatus (RespondStreaming s desc framing ct) = s + type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString + + responseUnrender _ resp = do + guard (Response.responseStatusCode resp == statusVal (Proxy @s)) + pure $ Response.responseBody resp + +instance + (AllMimeUnrender cs a, KnownStatus s) + => ResponseUnrender cs (Respond s desc a) where + type ResponseStatus (Respond s desc a) = s + type ResponseBody (Respond s desc a) = BSL.ByteString + + responseUnrender c output = do + guard (responseStatusCode output == statusVal (Proxy @s)) + let results = allMimeUnrender (Proxy @cs) + case lookup c results of + Nothing -> empty + Just f -> either UnrenderError UnrenderSuccess (f (responseBody output)) + +instance + ( AsHeaders xs (ResponseType r) a, + ServantHeaders hs xs, + ResponseUnrender cs r + ) => + ResponseUnrender cs (WithHeaders hs a r) + where + type ResponseStatus (WithHeaders hs a r) = ResponseStatus r + type ResponseBody (WithHeaders hs a r) = ResponseBody r + + responseUnrender c output = do + x <- responseUnrender @cs @r c output + case extractHeaders @hs (responseHeaders output) of + Nothing -> UnrenderError "Failed to parse headers" + Just hs -> pure $ fromHeaders @xs (hs, x) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index fdb9ce2ec..22b9e7227 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -161,6 +161,7 @@ test-suite spec , servant-client , servant-client-core , sop-core + , generics-sop , stm , text , transformers diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 1d6b57b19..b3eacd671 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} @@ -16,6 +15,7 @@ {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE EmptyCase #-} module Servant.ClientTestUtils where @@ -48,6 +48,7 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import GHC.Generics (Generic) +import qualified Generics.SOP as GSOP import qualified Network.HTTP.Client as C import qualified Network.HTTP.Types as HTTP import Network.Socket @@ -75,6 +76,7 @@ import qualified Servant.Client.Core.Auth as Auth import Servant.Server import Servant.Server.Experimental.Auth import Servant.Test.ComprehensiveAPI +import Servant.API.MultiVerb -- This declaration simply checks that all instances are in place. _ = client comprehensiveAPIWithoutStreaming @@ -119,7 +121,7 @@ data RecordRoutes mode = RecordRoutes , otherRoutes :: mode :- "other" :> Capture "someParam" Int :> NamedRoutes OtherRoutes } deriving Generic -data OtherRoutes mode = OtherRoutes +newtype OtherRoutes mode = OtherRoutes { something :: mode :- "something" :> Get '[JSON] [String] } deriving Generic @@ -145,6 +147,46 @@ instance ToDeepQuery Filter where , (["name"], Just (Text.pack name')) ] +----------------------------- +-- MultiVerb test endpoint -- +----------------------------- + +-- This is the list of all possible responses +type MultipleChoicesIntResponses = + '[ RespondEmpty 400 "Negative" + , Respond 200 "Even number" Bool + , Respond 200 "Odd number" Int + ] + +data MultipleChoicesIntResult + = NegativeNumber + | Even Bool + | Odd Int + deriving stock (Generic) + deriving (AsUnion MultipleChoicesIntResponses) + via GenericAsUnion MultipleChoicesIntResponses MultipleChoicesIntResult + +instance GSOP.Generic MultipleChoicesIntResult + +-- instance => AsUnion MultipleChoicesIntResponses MultipleChoicesIntResult where +-- toUnion NegativeNumber = Z (I ()) +-- toUnion (Even b) = S (Z (I b)) +-- toUnion (Odd i) = S (S (Z (I i))) +-- +-- fromUnion (Z (I ())) = NegativeNumber +-- fromUnion (S (Z (I b))) = Even b +-- fromUnion (S (S (Z (I i)))) = Odd i +-- fromUnion (S (S (S x))) = case x of {} + +-- This is our endpoint description +type MultipleChoicesInt = + Capture "int" Int + :> MultiVerb + 'GET + '[JSON] + MultipleChoicesIntResponses + MultipleChoicesIntResult + type Api = Get '[JSON] Person :<|> "get" :> Get '[JSON] Person @@ -187,6 +229,7 @@ type Api = WithStatus 301 Text] :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] :<|> NamedRoutes RecordRoutes + :<|> MultipleChoicesInt :<|> "captureVerbatim" :> Capture "someString" Verbatim :> Get '[PlainText] Text api :: Proxy Api @@ -221,6 +264,8 @@ uverbGetSuccessOrRedirect :: Bool WithStatus 301 Text]) uverbGetCreated :: ClientM (Union '[WithStatus 201 Person]) recordRoutes :: RecordRoutes (AsClientT ClientM) +multiChoicesInt :: Int -> ClientM MultipleChoicesIntResult +captureVerbatim :: Verbatim -> ClientM Text getRoot :<|> getGet @@ -249,6 +294,7 @@ getRoot :<|> uverbGetSuccessOrRedirect :<|> uverbGetCreated :<|> recordRoutes + :<|> multiChoicesInt :<|> captureVerbatim = client api server :: Application @@ -282,15 +328,15 @@ server = serve api ( } ) :<|> return alice - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") - :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess")) - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") + :<|> Tagged (\ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") + :<|> Tagged (\ request respond -> respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders request) "rawSuccess") + :<|> Tagged (\ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) - :<|> (return $ addHeader 1729 $ addHeader "eg2" True) + :<|> return (addHeader 1729 $ addHeader "eg2" True) :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True) - :<|> (return $ addHeader "cookie1" $ addHeader "cookie2" True) + :<|> return (addHeader "cookie1" $ addHeader "cookie2" True) :<|> return NoContent - :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") + :<|> Tagged (\ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") :<|> emptyServer :<|> (\shouldRedirect -> if shouldRedirect then respond (WithStatus @301 ("redirecting" :: Text)) @@ -303,6 +349,15 @@ server = serve api ( { something = pure ["foo", "bar", "pweet"] } } + :<|> (\param -> + if param < 0 + then pure NegativeNumber + else + if even param + then pure $ Odd 3 + else pure $ Even True + ) + :<|> pure . decodeUtf8 . unVerbatim ) @@ -318,10 +373,10 @@ failApi = Proxy failServer :: Application failServer = serve failApi ( - (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "") + Tagged (\ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "") :<|> (\ _capture -> Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/json")] "") - :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "") - :<|> (Tagged $ \_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "") + :<|> Tagged (\_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "fooooo")] "") + :<|> Tagged (\_request respond -> respond $ Wai.responseLBS HTTP.ok200 [("content-type", "application/x-www-form-urlencoded"), ("X-Example1", "1"), ("X-Example2", "foo")] "") ) -- * basic auth stuff diff --git a/servant-client/test/Servant/MiddlewareSpec.hs b/servant-client/test/Servant/MiddlewareSpec.hs index 648ca1311..9b7c2a943 100644 --- a/servant-client/test/Servant/MiddlewareSpec.hs +++ b/servant-client/test/Servant/MiddlewareSpec.hs @@ -16,9 +16,7 @@ module Servant.MiddlewareSpec (spec) where -import Control.Arrow - ( left, - ) +import Control.Arrow (left) import Control.Concurrent (newEmptyMVar, putMVar, takeMVar) import Control.Exception (Exception, throwIO, try) import Control.Monad.IO.Class @@ -114,4 +112,4 @@ spec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do left show <$> runClientWithMiddleware getGet mid baseUrl `shouldReturn` Right alice ref <- readIORef ref - ref `shouldBe` ["req1", "req2", "req3", "resp3", "resp2", "resp1"] \ No newline at end of file + ref `shouldBe` ["req1", "req2", "req3", "resp3", "resp2", "resp1"] diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 441022e1d..fd0bc41f5 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -101,8 +101,9 @@ library Servant.Server.Internal.DelayedIO Servant.Server.Internal.ErrorFormatter Servant.Server.Internal.Handler - Servant.Server.Internal.Router + Servant.Server.Internal.ResponseRender Servant.Server.Internal.RouteResult + Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServerError Servant.Server.StaticFiles diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a2818d18b..a8e0e5834 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} module Servant.Server.Internal ( module Servant.Server.Internal @@ -42,7 +43,7 @@ import GHC.Generics import GHC.TypeLits (KnownNat, KnownSymbol, TypeError, ErrorMessage (..), symbolVal) import qualified Network.HTTP.Media as NHM import Network.HTTP.Types hiding - (Header, ResponseHeaders) + (statusCode, Header, ResponseHeaders) import Network.Socket (SockAddr) import Network.Wai @@ -87,7 +88,8 @@ import Servant.Server.Internal.Router import Servant.Server.Internal.RouteResult import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError - +import Servant.Server.Internal.ResponseRender +import Servant.API.MultiVerb import Servant.API.TypeLevel (AtMostOneFragment, FragmentUnique) class HasServer api context where @@ -1121,3 +1123,47 @@ instance toServant server servantSrvN :: ServerT (ToServantApi api) n = hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM + + +instance + ( HasAcceptCheck cs, + ResponseListRender cs as, + AsUnion as r, + ReflectMethod method + ) => + HasServer (MultiVerb method cs as r) ctx + where + type ServerT (MultiVerb method cs as r) m = m r + + hoistServerWithContext _ _ f = f + + route :: + forall env. + Proxy (MultiVerb method cs as r) -> + Context ctx -> + Delayed env (Handler r) -> + Router env + route _ _ action = leafRouter $ \env req k -> do + let acc = getAcceptHeader req + action' = + action + `addMethodCheck` methodCheck method req + `addAcceptCheck` acceptCheck' (Proxy @cs) acc + runAction action' env req k $ \output -> do + let mresp = responseListRender @cs @as acc (toUnion @as output) + someResponseToWai <$> case mresp of + Nothing -> FailFatal err406 + Just resp + | allowedMethodHead method req -> pure (setEmptyBody resp) + | otherwise -> pure resp + where + method = reflectMethod (Proxy @method) + +class HasAcceptCheck cs where + acceptCheck' :: Proxy cs -> AcceptHeader -> DelayedIO () + +instance (AllMime cs) => HasAcceptCheck cs where + acceptCheck' = acceptCheck + +instance HasAcceptCheck '() where + acceptCheck' _ _ = pure () diff --git a/servant-server/src/Servant/Server/Internal/Context.hs b/servant-server/src/Servant/Server/Internal/Context.hs index c9b584c96..8f275877f 100644 --- a/servant-server/src/Servant/Server/Internal/Context.hs +++ b/servant-server/src/Servant/Server/Internal/Context.hs @@ -2,18 +2,22 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Servant.Server.Internal.Context where +module Servant.Server.Internal.Context + ( module Servant.Server.Internal.Context + , module Servant.API.TypeLevel.List + ) where -import Data.Kind +import Data.Kind (Type) import Data.Proxy import GHC.TypeLits +import Servant.API.TypeLevel.List + (type (.++)) -- | 'Context's are used to pass values to combinators. (They are __not__ meant -- to be used to pass parameters to your handlers, i.e. they should not replace @@ -48,15 +52,6 @@ instance Eq (Context '[]) where instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 --- | Append two type-level lists. --- --- Hint: import it as --- --- > import Servant.Server (type (.++)) -type family (.++) (l1 :: [Type]) (l2 :: [Type]) where - '[] .++ a = a - (a ': as) .++ b = a ': (as .++ b) - -- | Append two contexts. (.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2) EmptyContext .++ a = a @@ -92,7 +87,7 @@ instance {-# OVERLAPPING #-} -- to have multiple values of the same type in your 'Context' and need to access -- them, we provide 'NamedContext'. You can think of it as sub-namespaces for -- 'Context's. -data NamedContext (name :: Symbol) (subContext :: [Type]) +newtype NamedContext (name :: Symbol) (subContext :: [Type]) = NamedContext (Context subContext) -- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you diff --git a/servant-server/src/Servant/Server/Internal/ResponseRender.hs b/servant-server/src/Servant/Server/Internal/ResponseRender.hs new file mode 100644 index 000000000..086f16d8e --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/ResponseRender.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE EmptyCase #-} + +module Servant.Server.Internal.ResponseRender where + +import Data.ByteString (ByteString) +import Data.Kind (Type) +import Data.Typeable +import GHC.TypeLits +import qualified Data.ByteString.Lazy as BSL +import qualified Network.Wai as Wai +import Network.HTTP.Types (Status, hContentType) +import Data.SOP +import qualified Servant.Types.SourceT as S +import qualified Data.ByteString.Builder as BB +import qualified Data.Sequence as Seq + +import Servant.API.ContentTypes (AcceptHeader (..), AllMimeRender, MimeRender, Accept, allMimeRender, mimeRender, contentType) +import Servant.API.MultiVerb +import Servant.API.Status +import Servant.API.Stream (SourceIO) +import Servant.API.UVerb.Union +import Servant.Types.ResponseList +import qualified Network.HTTP.Media as M +import Data.Foldable (toList) +import Data.Sequence ((<|)) + +class (Typeable a) => IsWaiBody a where + responseToWai :: InternalResponse a -> Wai.Response + +instance IsWaiBody BSL.ByteString where + responseToWai r = + Wai.responseLBS + (statusCode r) + (toList (headers r)) + (responseBody r) + +instance IsWaiBody () where + responseToWai r = + Wai.responseLBS + (statusCode r) + (toList (headers r)) + mempty + +instance IsWaiBody (SourceIO ByteString) where + responseToWai r = + Wai.responseStream + (statusCode r) + (toList (headers r)) + $ \output flush -> do + S.foreach + (const (pure ())) + (\chunk -> output (BB.byteString chunk) *> flush) + (responseBody r) + +data SomeResponse = forall a. (IsWaiBody a) => SomeResponse (InternalResponse a) + +class ResponseListRender cs as where + responseListRender + :: AcceptHeader + -> Union (ResponseTypes as) + -> Maybe SomeResponse + responseListStatuses :: [Status] + +instance ResponseListRender cs '[] where + responseListRender _ x = case x of {} + responseListStatuses = [] + +class (IsWaiBody (ResponseBody a)) => ResponseRender cs a where + type ResponseStatus a :: Nat + type ResponseBody a :: Type + responseRender + :: AcceptHeader + -> ResponseType a + -> Maybe (InternalResponse (ResponseBody a)) + +instance + ( ResponseRender cs a, + ResponseListRender cs as, + KnownStatus (ResponseStatus a) + ) => + ResponseListRender cs (a ': as) + where + responseListRender acc (Z (I x)) = fmap SomeResponse (responseRender @cs @a acc x) + responseListRender acc (S x) = responseListRender @cs @as acc x + + responseListStatuses = statusVal (Proxy @(ResponseStatus a)) : responseListStatuses @cs @as + +instance + ( AsHeaders xs (ResponseType r) a, + ServantHeaders hs xs, + ResponseRender cs r + ) => + ResponseRender cs (WithHeaders hs a r) + where + type ResponseStatus (WithHeaders hs a r) = ResponseStatus r + type ResponseBody (WithHeaders hs a r) = ResponseBody r + + responseRender acc x = addHeaders <$> responseRender @cs @r acc y + where + (hs, y) = toHeaders @xs x + addHeaders r = + r + { headers = headers r <> Seq.fromList (constructHeaders @hs hs) + } + +instance + ( KnownStatus s, + MimeRender ct a + ) => + ResponseRender cs (RespondAs (ct :: Type) s desc a) + where + type ResponseStatus (RespondAs ct s desc a) = s + type ResponseBody (RespondAs ct s desc a) = BSL.ByteString + + responseRender _ x = + pure . addContentType @ct $ + InternalResponse + { statusCode = statusVal (Proxy @s), + responseBody = mimeRender (Proxy @ct) x, + headers = mempty + } + +instance (KnownStatus s) => ResponseRender cs (RespondAs '() s desc ()) where + type ResponseStatus (RespondAs '() s desc ()) = s + type ResponseBody (RespondAs '() s desc ()) = () + + responseRender _ _ = + pure $ + InternalResponse + { statusCode = statusVal (Proxy @s), + responseBody = (), + headers = mempty + } + +instance + (Accept ct, KnownStatus s) + => ResponseRender cs (RespondStreaming s desc framing ct) + where + type ResponseStatus (RespondStreaming s desc framing ct) = s + type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString + responseRender _ x = + pure . addContentType @ct $ + InternalResponse + { statusCode = statusVal (Proxy @s), + responseBody = x, + headers = mempty + } + +instance + (AllMimeRender cs a, KnownStatus s) + => ResponseRender cs (Respond s desc a) where + type ResponseStatus (Respond s desc a) = s + type ResponseBody (Respond s desc a) = BSL.ByteString + + -- Note: here it seems like we are rendering for all possible content types, + -- only to choose the correct one afterwards. However, render results besides the + -- one picked by 'M.mapAcceptMedia' are not evaluated, and therefore nor are the + -- corresponding rendering functions. + responseRender (AcceptHeader acc) x = + M.mapAcceptMedia (map (uncurry mkRenderOutput) (allMimeRender (Proxy @cs) x)) acc + where + mkRenderOutput :: M.MediaType -> BSL.ByteString -> (M.MediaType, InternalResponse BSL.ByteString) + mkRenderOutput c body = + (c,) . addContentType' c $ + InternalResponse + { statusCode = statusVal (Proxy @s), + responseBody = body, + headers = mempty + } + +addContentType :: forall ct a. (Accept ct) => InternalResponse a -> InternalResponse a +addContentType = addContentType' (contentType (Proxy @ct)) + +addContentType' :: M.MediaType -> InternalResponse a -> InternalResponse a +addContentType' c r = r {headers = (hContentType, M.renderHeader c) <| headers r} + +setEmptyBody :: SomeResponse -> SomeResponse +setEmptyBody (SomeResponse r) = SomeResponse (go r) + where + go :: InternalResponse a -> InternalResponse BSL.ByteString + go InternalResponse {..} = InternalResponse {responseBody = mempty, ..} + +someResponseToWai :: SomeResponse -> Wai.Response +someResponseToWai (SomeResponse r) = responseToWai r diff --git a/servant/servant.cabal b/servant/servant.cabal index e8d28d0b2..fc7a709ba 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -104,7 +104,9 @@ library Servant.API.Sub Servant.API.TypeErrors Servant.API.TypeLevel + Servant.API.TypeLevel.List Servant.API.UVerb + Servant.API.MultiVerb Servant.API.UVerb.Union Servant.API.Vault Servant.API.Verbs @@ -112,7 +114,9 @@ library Servant.API.WithResource -- Types - exposed-modules: Servant.Types.SourceT + exposed-modules: + Servant.Types.SourceT + Servant.Types.ResponseList -- Test stuff exposed-modules: Servant.Test.ComprehensiveAPI @@ -131,6 +135,7 @@ library , containers >=0.6.5.1 && <0.8 , mtl ^>=2.2.2 || ^>=2.3.1 , sop-core >=0.4.0.0 && <0.6 + , generics-sop ^>=0.5.1 , text >=1.2.3.0 && <2.2 , transformers >=0.5.2.0 && <0.7 diff --git a/servant/src/Servant/API/Alternative.hs b/servant/src/Servant/API/Alternative.hs index f6b0f4df4..052469ad9 100644 --- a/servant/src/Servant/API/Alternative.hs +++ b/servant/src/Servant/API/Alternative.hs @@ -27,7 +27,7 @@ import Data.Typeable -- :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] () -- POST /books -- :} data a :<|> b = a :<|> b - deriving (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded) + deriving stock (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded) infixr 3 :<|> instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where @@ -35,7 +35,6 @@ instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where instance (Monoid a, Monoid b) => Monoid (a :<|> b) where mempty = mempty :<|> mempty - (a :<|> b) `mappend` (a' :<|> b') = (a `mappend` a') :<|> (b `mappend` b') instance Bifoldable (:<|>) where bifoldMap f g ~(a :<|> b) = f a `mappend` g b diff --git a/servant/src/Servant/API/MultiVerb.hs b/servant/src/Servant/API/MultiVerb.hs new file mode 100644 index 000000000..3033a6f74 --- /dev/null +++ b/servant/src/Servant/API/MultiVerb.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE EmptyCase #-} + +-- | MultiVerb is a part of the type-level eDSL that allows you to express complex routes +-- while retaining a high level of precision with good ergonomics. + +module Servant.API.MultiVerb + ( -- ** MultiVerb types + MultiVerb, + MultiVerb1, + -- ** Response types + Respond, + RespondAs, + RespondEmpty, + RespondStreaming, + -- ** Headers + WithHeaders, + DescHeader, + OptHeader, + AsHeaders (..), + ServantHeaders(..), + ServantHeader(..), + -- ** Unions of responses + AsUnion (..), + eitherToUnion, + eitherFromUnion, + maybeToUnion, + maybeFromUnion, + -- ** Internal machinery + AsConstructor (..), + GenericAsConstructor (..), + GenericAsUnion (..), + ResponseType, + ResponseTypes, + UnrenderResult(..), + ) where + + +import Control.Applicative (Alternative(..), empty) +import Control.Monad (ap, MonadPlus(..)) +import Data.ByteString (ByteString) +import Data.Kind +import Data.Proxy +import Data.SOP +import Data.Sequence (Seq(..)) +import GHC.TypeLits +import Generics.SOP as GSOP +import Network.HTTP.Types as HTTP +import Web.HttpApiData (FromHttpApiData, ToHttpApiData, parseHeader, toHeader) +import qualified Data.CaseInsensitive as CI +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Servant.API.TypeLevel.List +import Servant.API.Stream (SourceIO) +import Servant.API.UVerb.Union (Union) +import Servant.API.Header (Header') + +-- | A type to describe a 'MultiVerb' response. +-- +-- Includes status code, description, and return type. The content type of the +-- response is determined dynamically using the accept header and the list of +-- supported content types specified in the containing 'MultiVerb' type. +data Respond (s :: Nat) (description :: Symbol) (a :: Type) + +-- | A type to describe a 'MultiVerb' response with a fixed content type. +-- +-- Similar to 'Respond', but hardcodes the content type to be used for +-- generating the response. +data RespondAs ct (s :: Nat) (description :: Symbol) (a :: Type) + +-- | A type to describe a 'MultiVerb' response with an empty body. +-- +-- Includes status code and description. +type RespondEmpty s description = RespondAs '() s description () + +-- | A type to describe a streaming 'MultiVerb' response. +-- +-- Includes status code, description, framing strategy and content type. Note +-- that the handler return type is hardcoded to be 'SourceIO ByteString'. +data RespondStreaming (s :: Nat) (description :: Symbol) (framing :: Type) (ct :: Type) + +-- | The result of parsing a response as a union alternative of type 'a'. +-- +-- 'StatusMismatch' indicates that the response does not refer to the given +-- alternative, because the status code does not match the one produced by that +-- alternative. +-- +-- 'UnrenderError' and 'UnrenderSuccess' represent respectively a failing and +-- successful parse of the response body as a value of type 'a'. +-- +-- The 'UnrenderResult' type constructor has monad and alternative instances +-- corresponding to those of 'Either (Maybe (Last String)) a'. +data UnrenderResult a = StatusMismatch | UnrenderError String | UnrenderSuccess a + deriving (Eq, Show, Functor) + +instance Applicative UnrenderResult where + pure = UnrenderSuccess + (<*>) = ap + +instance Monad UnrenderResult where + return = pure + StatusMismatch >>= _ = StatusMismatch + UnrenderError e >>= _ = UnrenderError e + UnrenderSuccess x >>= f = f x + +instance Alternative UnrenderResult where + empty = mzero + (<|>) = mplus + +instance MonadPlus UnrenderResult where + mzero = StatusMismatch + mplus StatusMismatch m = m + mplus (UnrenderError e) StatusMismatch = UnrenderError e + mplus (UnrenderError _) m = m + mplus m@(UnrenderSuccess _) _ = m + +type family ResponseType a :: Type + +type instance ResponseType (Respond s description a) = a + +type instance ResponseType (RespondAs ct s description a) = a + +type instance ResponseType (RespondStreaming s description framing ct) = SourceIO ByteString + + +-- | This type adds response headers to a 'MultiVerb' response. +data WithHeaders (headers :: [Type]) (returnType :: Type) (response :: Type) + +-- | This is used to convert a response containing headers to a custom type +-- including the information in the headers. +class AsHeaders xs a b where + fromHeaders :: (NP I xs, a) -> b + toHeaders :: b -> (NP I xs, a) + +-- single-header empty response +instance AsHeaders '[a] () a where + toHeaders a = (I a :* Nil, ()) + fromHeaders = unI . hd . fst + +-- single-header non-empty response, return value is a tuple of the response and the header +instance AsHeaders '[h] a (a, h) where + toHeaders (t, cc) = (I cc :* Nil, t) + fromHeaders (I cc :* Nil, t) = (t, cc) + +data DescHeader (name :: Symbol) (description :: Symbol) (a :: Type) + +-- | A wrapper to turn a response header into an optional one. +data OptHeader h + +class ServantHeaders headers xs | headers -> xs where + constructHeaders :: NP I xs -> [HTTP.Header] + extractHeaders :: Seq HTTP.Header -> Maybe (NP I xs) + +instance ServantHeaders '[] '[] where + constructHeaders Nil = [] + extractHeaders _ = Just Nil + +headerName :: forall name. (KnownSymbol name) => HTTP.HeaderName +headerName = + CI.mk + . Text.encodeUtf8 + . Text.pack + $ symbolVal (Proxy @name) + +instance + ( KnownSymbol name, + ServantHeader h name x, + FromHttpApiData x, + ServantHeaders headers xs + ) => + ServantHeaders (h ': headers) (x ': xs) + where + constructHeaders (I x :* xs) = + constructHeader @h x + <> constructHeaders @headers xs + + -- NOTE: should we concatenate all the matching headers instead of just taking the first one? + extractHeaders headers = do + let name' = headerName @name + (headers0, headers1) = Seq.partition (\(h, _) -> h == name') headers + x <- case headers0 of + Seq.Empty -> empty + ((_, h) :<| _) -> either (const empty) pure (parseHeader h) + xs <- extractHeaders @headers headers1 + pure (I x :* xs) + +class ServantHeader h (name :: Symbol) x | h -> name x where + constructHeader :: x -> [HTTP.Header] + +instance + (KnownSymbol name, ToHttpApiData x) => + ServantHeader (Header' mods name x) name x + where + constructHeader x = [(headerName @name, toHeader x)] + +instance + (KnownSymbol name, ToHttpApiData x) => + ServantHeader (DescHeader name description x) name x + where + constructHeader x = [(headerName @name, toHeader x)] + +instance (ServantHeader h name x) => ServantHeader (OptHeader h) name (Maybe x) where + constructHeader = foldMap (constructHeader @h) + +type instance ResponseType (WithHeaders headers returnType response) = returnType + + +type family ResponseTypes (as :: [Type]) where + ResponseTypes '[] = '[] + ResponseTypes (a ': as) = ResponseType a ': ResponseTypes as + + +-- | This type can be used in Servant to produce an endpoint which can return +-- multiple values with various content types and status codes. It is similar to +-- 'Servant.API.UVerb.UVerb' and behaves similarly, but it has some important differences: +-- +-- * Descriptions and statuses can be attached to individual responses without +-- using wrapper types and without affecting the handler return type. +-- * The return type of the handler can be decoupled from the types of the +-- individual responses. One can use a 'Union' type just like for 'Servant.API.UVerb.UVerb', +-- but 'MultiVerb' also supports using an arbitrary type with an 'AsUnion' +-- instance. +-- * Headers can be attached to individual responses, also without affecting +-- the handler return type. +-- +-- ==== __Example__ +-- Let us create an endpoint that captures an 'Int' and has the following logic: +-- +-- * If the number is negative, we return status code 400 and an empty body; +-- * If the number is even, we return a 'Bool' in the response body; +-- * If the number is odd, we return another 'Int' in the response body. +-- +-- > import qualified Generics.SOP as GSOP +-- +-- > -- All possible HTTP responses +-- > type Responses = +-- > '[ type RespondEmpty 400 "Negative" +-- > , type Respond 200 "Even number" Bool +-- > , type Respond 200 "Odd number" Int +-- > ] +-- > +-- > -- All possible return types +-- > data Result +-- > = NegativeNumber +-- > | Odd Int +-- > | Even Bool +-- > deriving stock (Generic) +-- > deriving (AsUnion Responses) +-- > via GenericAsUnion Responses Result +-- > +-- > instance GSOP.Generic Result +-- +-- These deriving statements above tie together the responses and the return values, and the order in which they are defined matters. For instance, if @Even@ and @Odd@ had switched places in the definition of @Result@, this would provoke an error: +-- +-- +-- > • No instance for ‘AsConstructor +-- > ((:) @Type Int ('[] @Type)) (Respond 200 "Even number" Bool)’ +-- > arising from the 'deriving' clause of a data type declaration +-- +-- If you would prefer to write an intance of 'AsUnion' by yourself, read more in the typeclass' documentation. +-- +-- Finally, let us write our endpoint description: +-- +-- > type MultipleChoicesInt = +-- > Capture "int" Int +-- > :> MultiVerb +-- > 'GET +-- > '[JSON] +-- > Responses +-- > Result +data MultiVerb (method :: StdMethod) cs (as :: [Type]) (r :: Type) + +-- | A 'MultiVerb' endpoint with a single response. Ideal to ensure that there can only be one response. +type MultiVerb1 m cs a = MultiVerb m cs '[a] (ResponseType a) + +-- | This class is used to convert a handler return type to a union type +-- including all possible responses of a 'MultiVerb' endpoint. +-- +-- Any glue code necessary to convert application types to and from the +-- canonical 'Union' type corresponding to a 'MultiVerb' endpoint should be +-- packaged into an 'AsUnion' instance. +-- +-- ==== __Example__ +-- Let us take the example endpoint from the 'MultiVerb' documentation. +-- There, we derived the 'AsUnion' instance with the help of Generics. +-- The manual way of implementing the instance is: +-- +-- > instance Responses ~ res => AsUnion res Result where +-- > toUnion NegativeNumber = Z (I ()) +-- > toUnion (Even b) = S (Z (I b)) +-- > toUnion (Odd i) = S (S (Z (I i))) +-- > +-- > fromUnion (Z (I ())) = NegativeNumber +-- > fromUnion (S (Z (I b))) = Even b +-- > fromUnion (S (S (Z (I i)))) = Odd i +-- > fromUnion (S (S (S x))) = case x of {} +-- The last 'fromUnion' equation is here to please the pattern checker. +class AsUnion (as :: [Type]) (r :: Type) where + toUnion :: r -> Union (ResponseTypes as) + fromUnion :: Union (ResponseTypes as) -> r + +-- | Unions can be used directly as handler return types using this trivial +-- instance. +instance (rs ~ ResponseTypes as) => AsUnion as (Union rs) where + toUnion = id + fromUnion = id + +-- | A handler with a single response. +instance (ResponseType r ~ a) => AsUnion '[r] a where + toUnion = Z . I + fromUnion = unI . unZ + +_foo :: Union '[Int] +_foo = toUnion @'[Respond 200 "test" Int] @Int 3 + +class InjectAfter as bs where + injectAfter :: Union bs -> Union (as .++ bs) + +instance InjectAfter '[] bs where + injectAfter = id + +instance (InjectAfter as bs) => InjectAfter (a ': as) bs where + injectAfter = S . injectAfter @as @bs + +class InjectBefore as bs where + injectBefore :: Union as -> Union (as .++ bs) + +instance InjectBefore '[] bs where + injectBefore x = case x of {} + +instance (InjectBefore as bs) => InjectBefore (a ': as) bs where + injectBefore (Z x) = Z x + injectBefore (S x) = S (injectBefore @as @bs x) + +eitherToUnion :: + forall as bs a b. + (InjectAfter as bs, InjectBefore as bs) => + (a -> Union as) -> + (b -> Union bs) -> + (Either a b -> Union (as .++ bs)) +eitherToUnion f _ (Left a) = injectBefore @as @bs (f a) +eitherToUnion _ g (Right b) = injectAfter @as @bs (g b) + +class EitherFromUnion as bs where + eitherFromUnion :: + (Union as -> a) -> + (Union bs -> b) -> + (Union (as .++ bs) -> Either a b) + +instance EitherFromUnion '[] bs where + eitherFromUnion _ g = Right . g + +instance (EitherFromUnion as bs) => EitherFromUnion (a ': as) bs where + eitherFromUnion f _ (Z x) = Left (f (Z x)) + eitherFromUnion f g (S x) = eitherFromUnion @as @bs (f . S) g x + +maybeToUnion :: + forall as a. + (InjectAfter as '[()], InjectBefore as '[()]) => + (a -> Union as) -> + (Maybe a -> Union (as .++ '[()])) +maybeToUnion f (Just a) = injectBefore @as @'[()] (f a) +maybeToUnion _ Nothing = injectAfter @as @'[()] (Z (I ())) + +maybeFromUnion :: + forall as a. + (EitherFromUnion as '[()]) => + (Union as -> a) -> + (Union (as .++ '[()]) -> Maybe a) +maybeFromUnion f = + leftToMaybe . eitherFromUnion @as @'[()] f (const (Z (I ()))) + where + leftToMaybe = either Just (const Nothing) + +-- | This class can be instantiated to get automatic derivation of 'AsUnion' +-- instances via 'GenericAsUnion'. The idea is that one has to make sure that for +-- each response @r@ in a 'MultiVerb' endpoint, there is an instance of +-- @AsConstructor xs r@ for some @xs@, and that the list @xss@ of all the +-- corresponding @xs@ is equal to 'GSOP.Code' of the handler type. Then one can +-- write: +-- @ +-- type Responses = ... +-- data Result = ... +-- deriving stock (Generic) +-- deriving (AsUnion Responses) via (GenericAsUnion Responses Result) +-- +-- instance GSOP.Generic Result +-- @ +-- and get an 'AsUnion' instance for free. +-- +-- There are a few predefined instances for constructors taking a single type +-- corresponding to a simple response, and for empty responses, but in more +-- general cases one either has to define an 'AsConstructor' instance by hand, +-- or derive it via 'GenericAsConstructor'. +class AsConstructor xs r where + toConstructor :: ResponseType r -> NP I xs + fromConstructor :: NP I xs -> ResponseType r + +class AsConstructors xss rs where + toSOP :: Union (ResponseTypes rs) -> SOP I xss + fromSOP :: SOP I xss -> Union (ResponseTypes rs) + +instance AsConstructors '[] '[] where + toSOP x = case x of {} + fromSOP x = case x of {} + +instance AsConstructor '[a] (Respond code description a) where + toConstructor x = I x :* Nil + fromConstructor = unI . hd + +instance AsConstructor '[a] (RespondAs (ct :: Type) code description a) where + toConstructor x = I x :* Nil + fromConstructor = unI . hd + +instance AsConstructor '[] (RespondEmpty code description) where + toConstructor _ = Nil + fromConstructor _ = () + +newtype GenericAsConstructor r = GenericAsConstructor r + +type instance ResponseType (GenericAsConstructor r) = ResponseType r + +instance + (GSOP.Code (ResponseType r) ~ '[xs], GSOP.Generic (ResponseType r)) => + AsConstructor xs (GenericAsConstructor r) + where + toConstructor = unZ . unSOP . GSOP.from + fromConstructor = GSOP.to . SOP . Z + +instance + (AsConstructor xs r, AsConstructors xss rs) => + AsConstructors (xs ': xss) (r ': rs) + where + toSOP (Z (I x)) = SOP . Z $ toConstructor @xs @r x + toSOP (S x) = SOP . S . unSOP $ toSOP @xss @rs x + + fromSOP (SOP (Z x)) = Z (I (fromConstructor @xs @r x)) + fromSOP (SOP (S x)) = S (fromSOP @xss @rs (SOP x)) + +-- | This type is meant to be used with @deriving via@ in order to automatically +-- generate an 'AsUnion' instance using 'Generics.SOP'. +-- +-- See 'AsConstructor' for more information and examples. +newtype GenericAsUnion rs a = GenericAsUnion a + +instance + (GSOP.Code a ~ xss, GSOP.Generic a, AsConstructors xss rs) => + AsUnion rs (GenericAsUnion rs a) + where + toUnion (GenericAsUnion x) = fromSOP @xss @rs (GSOP.from x) + fromUnion = GenericAsUnion . GSOP.to . toSOP @xss @rs + +-- | A handler for a pair of empty responses can be implemented simply by +-- returning a boolean value. The convention is that the "failure" case, normally +-- represented by 'False', corresponds to the /first/ response. +instance + AsUnion + '[ RespondEmpty s1 desc1, + RespondEmpty s2 desc2 + ] + Bool + where + toUnion False = Z (I ()) + toUnion True = S (Z (I ())) + + fromUnion (Z (I ())) = False + fromUnion (S (Z (I ()))) = True + fromUnion (S (S x)) = case x of {} + +-- | A handler for a pair of responses where the first is empty can be +-- implemented simply by returning a 'Maybe' value. The convention is that the +-- "failure" case, normally represented by 'Nothing', corresponds to the /first/ +-- response. +instance + {-# OVERLAPPABLE #-} + (ResponseType r1 ~ (), ResponseType r2 ~ a) => + AsUnion '[r1, r2] (Maybe a) + where + toUnion Nothing = Z (I ()) + toUnion (Just x) = S (Z (I x)) + + fromUnion (Z (I ())) = Nothing + fromUnion (S (Z (I x))) = Just x + fromUnion (S (S x)) = case x of {} diff --git a/servant/src/Servant/API/TypeLevel/List.hs b/servant/src/Servant/API/TypeLevel/List.hs new file mode 100644 index 000000000..e22c44670 --- /dev/null +++ b/servant/src/Servant/API/TypeLevel/List.hs @@ -0,0 +1,14 @@ +module Servant.API.TypeLevel.List + (type (.++) + ) where + +import Data.Kind + +-- | Append two type-level lists. +-- +-- Import it as +-- +-- > import Servant.API.TypeLevel.List (type (.++)) +type family (.++) (l1 :: [Type]) (l2 :: [Type]) where + '[] .++ a = a + (a ': as) .++ b = a ': (as .++ b) diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index 82c285d9d..d05bc5bba 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -183,6 +183,7 @@ import Servant.API.WithNamedContext import Servant.API.WithResource (WithResource) import Web.HttpApiData +import Servant.API.MultiVerb -- | A safe link datatype. -- The only way of constructing a 'Link' is using 'safeLink', which means any @@ -665,3 +666,7 @@ instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasLink ty) => HasLink (ty :> sub) instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api + +instance HasLink (MultiVerb method cs as r) where + type MkLink (MultiVerb method cs as r) a = a + toLink toA _ = toA diff --git a/servant/src/Servant/Types/ResponseList.hs b/servant/src/Servant/Types/ResponseList.hs new file mode 100644 index 000000000..0009b2dee --- /dev/null +++ b/servant/src/Servant/Types/ResponseList.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveTraversable #-} + +-- | This module offers other servant libraries a minimalistic HTTP response type. +-- +-- It is purely an internal API and SHOULD NOT be used by end-users of Servant. +module Servant.Types.ResponseList where + +import Network.HTTP.Types (Status, Header) +import Data.Sequence (Seq) +import GHC.Generics (Generic) +import Data.Data (Typeable) + +data InternalResponse a = InternalResponse + { statusCode :: Status + , headers :: Seq Header + , responseBody :: a + } deriving stock (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable)