diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index 59b34bfd0..6749acb84 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} @@ -12,56 +13,46 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#include "overlapping-compat.h" module Servant.Client.Core.Internal.HasClient where -import Prelude () +import Prelude () import Prelude.Compat -import Control.Concurrent (newMVar, modifyMVar) -import Data.Foldable (toList) +import Control.Concurrent + (modifyMVar, newMVar) import qualified Data.ByteString.Lazy as BL -import Data.List (foldl') -import Data.Proxy (Proxy (Proxy)) -import Data.Semigroup ((<>)) -import Data.Sequence (fromList) -import Data.String (fromString) -import Data.Text (Text, pack) -import GHC.TypeLits (KnownSymbol, symbolVal) +import Data.Foldable + (toList) +import Data.List + (foldl') +import Data.Proxy + (Proxy (Proxy)) +import Data.Semigroup + ((<>)) +import Data.Sequence + (fromList) +import Data.String + (fromString) +import Data.Text + (Text, pack) +import GHC.TypeLits + (KnownSymbol, symbolVal) import qualified Network.HTTP.Types as H -import Servant.API ((:<|>) ((:<|>)), (:>), - AuthProtect, BasicAuth, - BasicAuthData, - BuildHeadersTo (..), - BuildFromStream (..), - ByteStringParser (..), - Capture', CaptureAll, - Description, EmptyAPI, - FramingUnrender (..), - Header', Headers (..), - HttpVersion, IsSecure, - MimeRender (mimeRender), - MimeUnrender (mimeUnrender), - NoContent (NoContent), - QueryFlag, QueryParam', - QueryParams, Raw, - ReflectMethod (..), - RemoteHost, ReqBody', - ResultStream(..), - SBoolI, - Stream, - Summary, ToHttpApiData, - Vault, Verb, - WithNamedContext, - contentType, - getHeadersHList, - getResponse, - toQueryParam, - toUrlPiece) -import Servant.API.ContentTypes (contentTypes) -import Servant.API.Modifiers (FoldRequired, - RequiredArgument, - foldRequiredArgument) +import Servant.API + ((:<|>) ((:<|>)), (:>), Accept, AuthProtect, BasicAuth, + BasicAuthData, BuildFromStream (..), BuildHeadersTo (..), + ByteStringParser (..), Capture', CaptureAll, Description, + EmptyAPI, FramingUnrender (..), Header', Headers (..), + HttpVersion, IsSecure, MimeRender (mimeRender), + MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag, + QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost, + ReqBody', Result, ResultStream (..), SBoolI, Stream, Summary, + ToHttpApiData, Vault, Verb, VerbNoContent, WithNamedContext, contentType, + getHeadersHList, getResponse, toQueryParam, toUrlPiece) +import Servant.API.ContentTypes + (contentTypes) +import Servant.API.Modifiers + (FoldRequired, RequiredArgument, foldRequiredArgument) import Servant.Client.Core.Internal.Auth import Servant.Client.Core.Internal.BasicAuth @@ -105,6 +96,10 @@ class RunClient m => HasClient m api where -> Client mon api -> Client mon' api +class HasClientR (api :: *) (contentTypes :: [*]) where + type ClientR api :: * + + clientWithRouteR :: Proxy api -> Proxy contentTypes -> Response -> Either ServantError (ClientR api) -- | A client querying function for @a ':<|>' b@ will actually hand you -- one function for querying @a@ and another one for querying @b@, @@ -216,78 +211,62 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout) hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as) -instance OVERLAPPABLE_ - -- Note [Non-Empty Content Types] - ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient m (Verb method status cts' a) where - type Client m (Verb method status cts' a) = m a + + +instance + ( RunClient m, HasClientR api contentTypes, ReflectMethod method, contentTypes ~ (ct ': cts), Accept ct + ) => HasClient m (Verb method contentTypes api) where + type Client m (Verb method contentTypes api) = m (ClientR api) + clientWithRoute _pm Proxy req = do - response <- runRequest req - { requestAccept = fromList $ toList accept - , requestMethod = method + response <- runRequest req + { requestMethod = method + , requestAccept = fromList $ toList accept } - response `decodedAs` (Proxy :: Proxy ct) + either throwServantError pure $ + clientWithRouteR (Proxy :: Proxy api) (Proxy :: Proxy contentTypes) response where - accept = contentTypes (Proxy :: Proxy ct) method = reflectMethod (Proxy :: Proxy method) + accept = contentTypes (Proxy :: Proxy ct) hoistClientMonad _ _ f ma = f ma -instance OVERLAPPING_ - ( RunClient m, ReflectMethod method - ) => HasClient m (Verb method status cts NoContent) where - type Client m (Verb method status cts NoContent) - = m NoContent +instance + ( RunClient m, HasClientR api '[], ReflectMethod method + ) => HasClient m (VerbNoContent method api) where + type Client m (VerbNoContent method api) = m (ClientR api) + clientWithRoute _pm Proxy req = do - _response <- runRequest req { requestMethod = method } - return NoContent - where method = reflectMethod (Proxy :: Proxy method) + response <- runRequest req + { requestMethod = method + } + either throwServantError pure $ + clientWithRouteR (Proxy :: Proxy api) (Proxy :: Proxy '[]) response + where + method = reflectMethod (Proxy :: Proxy method) hoistClientMonad _ _ f ma = f ma -instance OVERLAPPING_ - -- Note [Non-Empty Content Types] - ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls - , ReflectMethod method, cts' ~ (ct ': cts) - ) => HasClient m (Verb method status cts' (Headers ls a)) where - type Client m (Verb method status cts' (Headers ls a)) - = m (Headers ls a) - clientWithRoute _pm Proxy req = do - response <- runRequest req - { requestMethod = method - , requestAccept = fromList $ toList accept - } - case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of - Left err -> throwServantError $ DecodeFailure (pack err) response - Right val -> return $ Headers - { getResponse = val - , getHeadersHList = buildHeadersTo . toList $ responseHeaders response - } - where method = reflectMethod (Proxy :: Proxy method) - accept = contentTypes (Proxy :: Proxy ct) +instance (ctypes ~ (ct ': cts), MimeUnrender ct a) => HasClientR (Result status a) ctypes where + type ClientR (Result status a) = a - hoistClientMonad _ _ f ma = f ma + clientWithRouteR Proxy _cts res = res `decodedAs2` (Proxy :: Proxy ct) -instance OVERLAPPING_ - ( RunClient m, BuildHeadersTo ls, ReflectMethod method - ) => HasClient m (Verb method status cts (Headers ls NoContent)) where - type Client m (Verb method status cts (Headers ls NoContent)) - = m (Headers ls NoContent) - clientWithRoute _pm Proxy req = do - let method = reflectMethod (Proxy :: Proxy method) - response <- runRequest req { requestMethod = method } - return $ Headers { getResponse = NoContent - , getHeadersHList = buildHeadersTo . toList $ responseHeaders response - } +instance + ( contentTypes ~ '[ct], MimeUnrender ct a, FramingUnrender framing a, BuildFromStream a b + ) => HasClientR (Stream status framing b) contentTypes where - hoistClientMonad _ _ f ma = f ma + type ClientR (Stream status framing b) = b + + clientWithRouteR Proxy _cts res = error "question" + +{- instance OVERLAPPABLE_ ( RunClient m, MimeUnrender ct a, ReflectMethod method, - FramingUnrender framing a, BuildFromStream a (f a) - ) => HasClient m (Stream method status framing ct (f a)) where + FramingUnrender framing a, BuildFromStream a b + ) => HasClient m (Stream method status framing ct b) where - type Client m (Stream method status framing ct (f a)) = m (f a) clientWithRoute _pm Proxy req = do sresp <- streamingRequest req @@ -331,6 +310,25 @@ instance OVERLAPPABLE_ k go hoistClientMonad _ _ f ma = f ma +-} + + + + +instance HasClientR (NoContent status) ctypes where + type ClientR (NoContent status) = NoContent status + + clientWithRouteR _api _ct _ = Right NoContent + +instance (HasClientR api ctypes, BuildHeadersTo ls) => HasClientR (Headers ls :> api) ctypes where + type ClientR (Headers ls :> api) = Headers ls (ClientR api) + + clientWithRouteR Proxy ct res = do + x <- clientWithRouteR (Proxy :: Proxy api) ct res + return $ Headers + { getResponse = x + , getHeadersHList = buildHeadersTo . toList $ responseHeaders res + } -- | If you use a 'Header' in one of your endpoints in your API, -- the corresponding querying function will automatically take diff --git a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs index ac6e02ac7..0567bfead 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs @@ -39,6 +39,14 @@ checkContentTypeHeader response = Nothing -> throwServantError $ InvalidContentTypeHeader response Just t' -> return t' +checkContentTypeHeader2 :: Response -> Either ServantError MediaType +checkContentTypeHeader2 response = + case lookup "Content-Type" $ toList $ responseHeaders response of + Nothing -> return $ "application"//"octet-stream" + Just t -> case parseAccept t of + Nothing -> Left $ InvalidContentTypeHeader response + Just t' -> return t' + decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) => Response -> Proxy ct -> m a decodedAs response contentType = do @@ -51,6 +59,18 @@ decodedAs response contentType = do where accept = toList $ contentTypes contentType +decodedAs2 :: forall ct a. (MimeUnrender ct a) + => Response -> Proxy ct -> Either ServantError a +decodedAs2 response contentType = do + responseContentType <- checkContentTypeHeader2 response + unless (any (matches responseContentType) accept) $ + Left $ UnsupportedContentType responseContentType response + case mimeUnrender contentType $ responseBody response of + Left err -> Left $ DecodeFailure (T.pack err) response + Right val -> return val + where + accept = toList $ contentTypes contentType + instance ClientF ~ f => RunClient (Free f) where runRequest req = liftF (RunRequest req id) streamingRequest req = liftF (StreamingRequest req id) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 265f622ff..ae06533b3 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -26,56 +26,57 @@ #include "overlapping-compat.h" module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where -import Prelude () +import Prelude () import Prelude.Compat -import Control.Arrow (left) -import Control.Concurrent (ThreadId, forkIO, - killThread) -import Control.Exception (bracket) -import Control.Monad.Error.Class (throwError) +import Control.Arrow + (left) +import Control.Concurrent + (ThreadId, forkIO, killThread) +import Control.Exception + (bracket) +import Control.Monad.Error.Class + (throwError) import Data.Aeson -import Data.Char (chr, isPrint) -import Data.Foldable (forM_) -import Data.Semigroup ((<>)) -import Data.Monoid () + (FromJSON, ToJSON) +import Data.Char + (chr, isPrint) +import Data.Foldable + (forM_) +import Data.Monoid () import Data.Proxy +import Data.Semigroup + ((<>)) import qualified Generics.SOP as SOP -import GHC.Generics (Generic) +import GHC.Generics + (Generic) import qualified Network.HTTP.Client as C import qualified Network.HTTP.Types as HTTP import Network.Socket import qualified Network.Wai as Wai import Network.Wai.Handler.Warp -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe + (unsafePerformIO) import Test.Hspec import Test.Hspec.QuickCheck import Test.HUnit import Test.QuickCheck -import Web.FormUrlEncoded (FromForm, ToForm) - -import Servant.API ((:<|>) ((:<|>)), - (:>), AuthProtect, - BasicAuth, - BasicAuthData (..), - Capture, - CaptureAll, Delete, - DeleteNoContent, - EmptyAPI, addHeader, - FormUrlEncoded, - Get, Header, - Headers, JSON, - NoContent (NoContent), - Post, Put, Raw, - QueryFlag, - QueryParam, - QueryParams, - ReqBody, - getHeaders) + (Arbitrary (..), Gen, NonEmptyList (..), elements, + forAllShrink, ioProperty, listOf1, property, (===)) +import Web.FormUrlEncoded + (FromForm, ToForm) + +import Servant.API + ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, + BasicAuthData (..), Capture, CaptureAll, Delete, + DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header, + Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag, + QueryParam, QueryParams, Raw, ReqBody, Result, StdMethod (..), + Verb, addHeader, getHeaders) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Client -import qualified Servant.Client.Core.Internal.Request as Req -import qualified Servant.Client.Core.Internal.Auth as Auth +import qualified Servant.Client.Core.Internal.Auth as Auth +import qualified Servant.Client.Core.Internal.Request as Req import Servant.Server import Servant.Server.Experimental.Auth @@ -119,7 +120,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] type Api = Get '[JSON] Person :<|> "get" :> Get '[JSON] Person - :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent + :<|> "deleteEmpty" :> DeleteNoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person] :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person @@ -134,8 +135,8 @@ type Api = QueryFlag "third" :> ReqBody '[JSON] [(String, [Rational])] :> Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) - :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) - :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent + :<|> "headers" :> Verb 'GET '[JSON] (Headers TestHeaders :> Result 200 Bool) + :<|> "deleteContentType" :> DeleteNoContent :<|> "empty" :> EmptyAPI api :: Proxy Api @@ -143,7 +144,7 @@ api = Proxy getRoot :: ClientM Person getGet :: ClientM Person -getDeleteEmpty :: ClientM NoContent +getDeleteEmpty :: ClientM (NoContent 204) getCapture :: String -> ClientM Person getCaptureAll :: [String] -> ClientM [Person] getBody :: Person -> ClientM Person @@ -155,7 +156,7 @@ getRawFailure :: HTTP.Method -> ClientM Response getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) getRespHeaders :: ClientM (Headers TestHeaders Bool) -getDeleteContentType :: ClientM NoContent +getDeleteContentType :: ClientM (NoContent 204) getRoot :<|> getGet diff --git a/servant-server/example/greet.hs b/servant-server/example/greet.hs index 662c2c33f..2f3a4e5f1 100644 --- a/servant-server/example/greet.hs +++ b/servant-server/example/greet.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeOperators #-} import Data.Aeson + (FromJSON, ToJSON) import Data.Monoid import Data.Proxy import Data.Text @@ -31,10 +32,12 @@ type TestApi = -- POST /greet with a Greet as JSON in the request body, -- returns a Greet as JSON - :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet + :<|> "greet" + :> ReqBody '[JSON] Greet + :> Verb 'POST '[JSON] (Result 400 Text :<|> Result 200 Greet) -- DELETE /greet/:greetid - :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent + :<|> "greet" :> Capture "greetid" Text :> DeleteNoContent testApi :: Proxy TestApi testApi = Proxy @@ -52,7 +55,8 @@ server = helloH :<|> postGreetH :<|> deleteGreetH helloH name (Just False) = return . Greet $ "Hello, " <> name helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name - postGreetH greet = return greet + postGreetH (Greet "by") = return (Left "wrong greet") + postGreetH greet = return (Right greet) deleteGreetH _ = return NoContent @@ -69,4 +73,6 @@ runTestServer port = run port test -- Put this all to work! main :: IO () -main = runTestServer 8001 +main = do + putStrLn "Try: curl http://localhost:8001/hello/world" + runTestServer 8001 diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 5d2e6590f..9c2f4f626 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -91,6 +91,7 @@ library , network >= 2.6.3.5 && < 2.8 , string-conversions >= 0.4.0.1 && < 0.5 , resourcet >= 1.1.11 && < 1.3 + , profunctors >= 5.2.2 && < 5.3 , tagged >= 0.8.5 && < 0.9 , transformers-base >= 0.4.4 && < 0.5 , transformers-compat >= 0.6.2 && < 0.7 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index a8058e3b4..05b7058ad 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,28 +1,29 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} #if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802 #define HAS_TYPE_ERROR #endif #ifdef HAS_TYPE_ERROR -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} #endif -#include "overlapping-compat.h" +#define Type * module Servant.Server.Internal ( module Servant.Server.Internal @@ -34,89 +35,118 @@ module Servant.Server.Internal , module Servant.Server.Internal.ServantErr ) where -import Control.Monad (join, when) -import Control.Monad.Trans (liftIO) -import Control.Monad.Trans.Resource (runResourceT) -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Char8 as BC8 -import qualified Data.ByteString.Lazy as BL -import Data.Maybe (fromMaybe, mapMaybe, - isNothing, maybeToList) -import Data.Either (partitionEithers) -import Data.Semigroup ((<>)) -import Data.String (IsString (..)) -import Data.String.Conversions (cs) -import Data.Tagged (Tagged(..), retag, untag) -import qualified Data.Text as T +import Control.Monad + (join) +import Control.Monad.Trans + (liftIO) +import Control.Monad.Trans.Resource + (runResourceT) +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.ByteString.Lazy as BL +import Data.Either + (partitionEithers) +import Data.Maybe + (fromMaybe, mapMaybe) +import Data.Profunctor + (Profunctor (..)) +import Data.Semigroup + ((<>)) +import Data.String + (IsString (..)) +import Data.String.Conversions + (cs) +import Data.Tagged + (Tagged (..), retag, untag) +import qualified Data.Text as T import Data.Typeable -import GHC.TypeLits (KnownNat, KnownSymbol, natVal, - symbolVal) -import Network.HTTP.Types hiding (Header, ResponseHeaders) -import qualified Network.HTTP.Media as NHM -import Network.Socket (SockAddr) -import Network.Wai (Application, Request, - httpVersion, isSecure, - lazyRequestBody, - rawQueryString, remoteHost, - requestHeaders, requestMethod, - responseLBS, responseStream, - vault) -import Prelude () +import GHC.TypeLits + (KnownNat, KnownSymbol, natVal, symbolVal) +import qualified Network.HTTP.Media as NHM +import Network.HTTP.Types hiding + (Header, ResponseHeaders) +import Network.Socket + (SockAddr) +import Network.Wai + (Application, Request, httpVersion, isSecure, lazyRequestBody, + rawQueryString, remoteHost, requestHeaders, requestMethod, + responseLBS, responseStream, vault) +import Prelude () import Prelude.Compat -import Web.HttpApiData (FromHttpApiData, parseHeader, - parseQueryParam, - parseUrlPieceMaybe, - parseUrlPieces) -import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture', - CaptureAll, Verb, EmptyAPI, - ReflectMethod(reflectMethod), - IsSecure(..), Header', QueryFlag, - QueryParam', QueryParams, Raw, - RemoteHost, ReqBody', Vault, - WithNamedContext, - Description, Summary, - Accept(..), - FramingRender(..), Stream, - StreamGenerator(..), ToStreamGenerator(..), - BoundaryStrategy(..), - If, SBool (..), SBoolI (..)) -import Servant.API.Modifiers (unfoldRequestArgument, RequestArgument, FoldRequired, FoldLenient) -import Servant.API.ContentTypes (AcceptHeader (..), - AllCTRender (..), - AllCTUnrender (..), - AllMime, - MimeRender(..), - canHandleAcceptH) -import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, - getResponse) +import Servant.API + ((:<|>) (..), (:>), Accept (..), BasicAuth, + BoundaryStrategy (..), Capture', CaptureAll, Description, + EmptyAPI, FramingRender (..), Header', If, IsSecure (..), + NoContent (..), QueryFlag, QueryParam', QueryParams, Raw, + ReflectMethod (reflectMethod), RemoteHost, ReqBody', Result, + SBool (..), SBoolI (..), Stream, StreamGenerator (..), + Summary, ToStreamGenerator (..), Vault, Verb, VerbNoContent, + WithNamedContext) +import Servant.API.ContentTypes + (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), + AllMime, MimeRender (..), canHandleAcceptH) +import Servant.API.Modifiers + (FoldLenient, FoldRequired, RequestArgument, + unfoldRequestArgument) +import Servant.API.ResponseHeaders + (GetHeaders', Headers, getHeaders, getResponse) +import Web.HttpApiData + (FromHttpApiData, parseHeader, parseQueryParam, + parseUrlPieceMaybe, parseUrlPieces) -import Servant.Server.Internal.Context import Servant.Server.Internal.BasicAuth +import Servant.Server.Internal.Context import Servant.Server.Internal.Handler import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr #ifdef HAS_TYPE_ERROR -import GHC.TypeLits (TypeError, ErrorMessage (..)) +import GHC.TypeLits + (ErrorMessage (..), TypeError) #endif -class HasServer api context where - type ServerT api (m :: * -> *) :: * - - route :: - Proxy api - -> Context context - -> Delayed env (Server api) - -> Router env +import qualified Network.Wai as Wai - hoistServerWithContext - :: Proxy api - -> Proxy context - -> (forall x. m x -> n x) - -> ServerT api m - -> ServerT api n +class HasServer api context where + type ServerT api (m :: * -> *) :: * + + route :: + Proxy api + -> Context context + -> Delayed env (Server api) + -> Router env + + hoistServerWithContext + :: Proxy api + -> Proxy context + -> (forall x. m x -> n x) + -> ServerT api m + -> ServerT api n + +class HasServerR (api :: Type) (contentTypes :: [Type]) where + type ServerR api :: Type + + routeR + :: Proxy api + -> Proxy contentTypes + -> Context context + -> Request + -> RouteResultR (ServerR api) Wai.Response + +-- | convert @a@ to @RouteResult b@ (b is Wai.Response) +newtype RouteResultR a b = RouteResultR { runRouteResultR :: a -> RouteResult b } + deriving Functor + +instance Profunctor RouteResultR where + dimap f g = mapRouteResultR $ \r -> fmap g . r . f + +mapRouteResultR + :: ((a -> RouteResult b) -> c -> RouteResult d) + -> RouteResultR a b + -> RouteResultR c d +mapRouteResultR f (RouteResultR r) = RouteResultR (f r) type Server api = ServerT api Handler @@ -239,114 +269,156 @@ acceptCheck proxy accH | canHandleAcceptH proxy (AcceptHeader accH) = return () | otherwise = delayedFail err406 -methodRouter :: (AllCTRender ctypes a) - => (b -> ([(HeaderName, B.ByteString)], a)) - -> Method -> Proxy ctypes -> Status - -> Delayed env (Handler b) - -> Router env -methodRouter splitHeaders method proxy status action = leafRouter route' +instance (HasServerR api contentTypes, ReflectMethod method, AllMime contentTypes) + => HasServer (Verb method contentTypes api) context + where + type ServerT (Verb method contentTypes api) m = m (ServerR api) + hoistServerWithContext _ _ nt s = nt s + + route Proxy context subserver = leafRouter $ \env request respond -> + case routeR (Proxy :: Proxy api) contentTypesP context request of + RouteResultR k -> runAction subserver' env request respond $ \output -> + if allowedMethodHead method request + then emptyBodyResponse <$> k output + else k output + where + subserver' = subserver + `addMethodCheck` withRequest methodCheck' + `addAcceptCheck` withRequest (acceptCheck contentTypesP . acceptHeader) + + method = reflectMethod (Proxy :: Proxy method) + contentTypesP = Proxy :: Proxy contentTypes + + methodCheck' :: Request -> DelayedIO () + methodCheck' request + | allowedMethod method request = return () + | otherwise = delayedFail err405 + + acceptHeader request = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + +-- TODO: combine with Verb +-- +-- We require HasServerR api '[] -- without any contenttypes! +-- In GHC-8.6 we could require @forall ct. HasSereverR api ct@ +instance (HasServerR api '[], ReflectMethod method) + => HasServer (VerbNoContent method api) context + where + type ServerT (VerbNoContent method api) m = m (ServerR api) + hoistServerWithContext _ _ nt s = nt s + + route Proxy context subserver = leafRouter $ \env request respond -> + case routeR (Proxy :: Proxy api) (Proxy :: Proxy '[]) context request of + RouteResultR k -> runAction subserver' env request respond $ \output -> + if allowedMethodHead method request + then emptyBodyResponse <$> k output + else k output + where + subserver' = subserver + `addMethodCheck` withRequest methodCheck' + + method = reflectMethod (Proxy :: Proxy method) + + methodCheck' :: Request -> DelayedIO () + methodCheck' request + | allowedMethod method request = return () + | otherwise = delayedFail err405 + +emptyBodyResponse :: Wai.Response -> Wai.Response +emptyBodyResponse res = responseLBS (Wai.responseStatus res) (Wai.responseHeaders res) mempty + +instance (KnownNat status, AllCTRender contentTypes a) + => HasServerR (Result status a) contentTypes + where + type ServerR (Result status a) = a + + routeR _proxy contentTypesP _context request = RouteResultR $ \a -> + case handleAcceptH contentTypesP (AcceptHeader acceptHeader) a of + -- this should not happen (checked before), so we make it fatal if it does + Nothing -> FailFatal err406 + Just (contentT, body) -> + Route $ responseLBS status ((hContentType, cs contentT) : headers) body + where + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + acceptHeader = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + headers = [] + +instance + ( KnownNat status, MimeRender ctype a, contentTypes ~ '[ctype] + , FramingRender framing ctype, ToStreamGenerator b a, Show a + ) + => HasServerR (Stream status framing b) contentTypes where - route' env request respond = - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` acceptCheck proxy accH - ) env request respond $ \ output -> do - let (headers, b) = splitHeaders output - case handleAcceptH proxy (AcceptHeader accH) b of - Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does - Just (contentT, body) -> - let bdy = if allowedMethodHead method request then "" else body - in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy - -instance OVERLAPPABLE_ - ( AllCTRender ctypes a, ReflectMethod method, KnownNat status - ) => HasServer (Verb method status ctypes a) context where - - type ServerT (Verb method status ctypes a) m = m a - hoistServerWithContext _ _ nt s = nt s - - route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status - where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) - -instance OVERLAPPING_ - ( AllCTRender ctypes a, ReflectMethod method, KnownNat status - , GetHeaders (Headers h a) - ) => HasServer (Verb method status ctypes (Headers h a)) context where - - type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) - hoistServerWithContext _ _ nt s = nt s - - route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status - where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) - - -instance OVERLAPPABLE_ - ( MimeRender ctype a, ReflectMethod method, KnownNat status, - FramingRender framing ctype, ToStreamGenerator b a - ) => HasServer (Stream method status framing ctype b) context where - - type ServerT (Stream method status framing ctype b) m = m b - hoistServerWithContext _ _ nt s = nt s - - route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) - where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) - -instance OVERLAPPING_ - ( MimeRender ctype a, ReflectMethod method, KnownNat status, - FramingRender framing ctype, ToStreamGenerator b a, - GetHeaders (Headers h b) - ) => HasServer (Stream method status framing ctype (Headers h b)) context where - - type ServerT (Stream method status framing ctype (Headers h b)) m = m (Headers h b) - hoistServerWithContext _ _ nt s = nt s - - route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) - where method = reflectMethod (Proxy :: Proxy method) - status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) - - -streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator b a) => - (c -> ([(HeaderName, B.ByteString)], b)) - -> Method - -> Status - -> Proxy framing - -> Proxy ctype - -> Delayed env (Handler c) - -> Router env -streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond -> - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request - cmediatype = NHM.matchAccept [contentType ctypeproxy] accH - accCheck = when (isNothing cmediatype) $ delayedFail err406 - contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype) - in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` accCheck - ) env request respond $ \ output -> - let (headers, fa) = splitHeaders output - k = getStreamGenerator . toStreamGenerator $ fa in - Route $ responseStream status (contentHeader : headers) $ \write flush -> do - write . BB.lazyByteString $ header framingproxy ctypeproxy - case boundary framingproxy ctypeproxy of - BoundaryStrategyBracket f -> - let go x = let bs = mimeRender ctypeproxy x - (before, after) = f bs - in write ( BB.lazyByteString before - <> BB.lazyByteString bs - <> BB.lazyByteString after) >> flush - in k go go - BoundaryStrategyIntersperse sep -> k - (\x -> do - write . BB.lazyByteString . mimeRender ctypeproxy $ x - flush) - (\x -> do - write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender ctypeproxy $ x - flush) - BoundaryStrategyGeneral f -> - let go = (>> flush) . write . BB.lazyByteString . f . mimeRender ctypeproxy - in k go go - write . BB.lazyByteString $ trailer framingproxy ctypeproxy + type ServerR (Stream status framing b) = b + + routeR _proxy _ct _context request = RouteResultR $ \a -> + case NHM.matchAccept [contentType ctypeP] acceptHeader of + -- this should not happen (checked before), so we make it fatal if it does + Nothing -> FailFatal err406 + Just mt -> + Route $ responseStream status (contentHeader mt : headers) $ \write flush -> do + let k = getStreamGenerator (toStreamGenerator a) + write . BB.lazyByteString $ header framingP ctypeP + case boundary framingP ctypeP of + BoundaryStrategyBracket f -> + let go x = let bs = mimeRender ctypeP x + (before, after) = f bs + in write ( BB.lazyByteString before + <> BB.lazyByteString bs + <> BB.lazyByteString after) >> flush + in k go go + BoundaryStrategyIntersperse sep -> k + (\x -> do + write . BB.lazyByteString . mimeRender ctypeP $ x + flush) + (\x -> do + write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender ctypeP $ x + flush) + BoundaryStrategyGeneral f -> + let go x = do + write . BB.lazyByteString . f . mimeRender ctypeP $ x + flush + in k go go + write . BB.lazyByteString $ trailer framingP ctypeP + where + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + headers = [] + + acceptHeader = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + contentHeader mt = (hContentType, NHM.renderHeader [mt]) + + ctypeP = Proxy :: Proxy ctype + framingP = Proxy :: Proxy framing + +instance KnownNat status => HasServerR (NoContent status) contentTypes where + type ServerR (NoContent status) = NoContent status + + routeR _proxy _ct _context _request = RouteResultR $ \_ -> + Route $ responseLBS status headers mempty + where + headers = [] + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) + +instance (HasServerR a ct, HasServerR b ct) => HasServerR (a :<|> b) ct where + type ServerR (a :<|> b) = Either (ServerR a) (ServerR b) + + routeR _api ct context request = RouteResultR $ \e -> case e of + Left x -> runRouteResultR (routeR (Proxy :: Proxy a) ct context request) x + Right y -> runRouteResultR (routeR (Proxy :: Proxy b) ct context request) y + +instance (HasServerR api ct, GetHeaders' hs) => HasServerR (Headers hs :> api) ct where + type ServerR (Headers hs :> api) = Headers hs (ServerR api) + + routeR _api _ct context request = mapRouteResultR addHeaders $ + routeR (Proxy :: Proxy api) (Proxy :: Proxy ct) context request + where + addHeaders + :: (ServerR api -> RouteResult Wai.Response) + -> Headers hs (ServerR api) + -> RouteResult Wai.Response + addHeaders f x = Wai.mapResponseHeaders (++ headers) <$> f output + where + output = getResponse x + headers = getHeaders x -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -762,7 +834,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA -- ...Maybe you haven't applied enough arguments to -- ...Capture' '[] "foo" -- ... --- +-- instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context where type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr) @@ -784,7 +856,7 @@ type HasServerArrowKindError arr = -- ...Maybe you have used '->' instead of ':>' between -- ...Capture' '[] "foo" Int -- ...and --- ...Verb 'GET 200 '[JSON] Int +-- ...Verb 'GET '[JSON] (Result 200 Int) -- ... -- -- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int) @@ -793,7 +865,7 @@ type HasServerArrowKindError arr = -- ...Maybe you have used '->' instead of ':>' between -- ...Capture' '[] "foo" Int -- ...and --- ...Verb 'GET 200 '[JSON] Int +-- ...Verb 'GET '[JSON] (Result 200 Int) -- ... -- instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs index 44cf76545..1729aaf5d 100644 --- a/servant-server/test/Servant/Server/RouterSpec.hs +++ b/servant-server/test/Servant/Server/RouterSpec.hs @@ -76,7 +76,7 @@ makeTrivialRouter :: (HasServer layout '[]) => Proxy layout -> Router () makeTrivialRouter p = route p EmptyContext (emptyDelayed (FailFatal err501)) -type End = Get '[JSON] NoContent +type End = GetNoContent -- The latter version looks more efficient, -- but the former should be compiled to the diff --git a/servant-server/test/Servant/Server/StreamingSpec.hs b/servant-server/test/Servant/Server/StreamingSpec.hs index 215664eeb..3a53a4e29 100644 --- a/servant-server/test/Servant/Server/StreamingSpec.hs +++ b/servant-server/test/Servant/Server/StreamingSpec.hs @@ -23,7 +23,7 @@ import qualified System.Timeout import Test.Hspec type TestAPI = - ReqBody '[OctetStream] Lazy.ByteString :> Get '[JSON] NoContent + ReqBody '[OctetStream] Lazy.ByteString :> GetNoContent testAPI :: Proxy TestAPI testAPI = Proxy @@ -65,7 +65,7 @@ spec = do -- - receives the first chunk -- - notifies serverReceivedFirstChunk -- - receives the rest of the request - let handler :: Lazy.ByteString -> Handler NoContent + let handler :: Lazy.ByteString -> Handler (NoContent 204) handler input = liftIO $ do let prefix = Lazy.take 3 input prefix `shouldBe` "foo" @@ -75,7 +75,7 @@ spec = do app = serve testAPI handler response <- executeRequest app request - statusCode (responseStatus response) `shouldBe` 200 + statusCode (responseStatus response) `shouldBe` 204 executeRequest :: Application -> Request -> IO Response executeRequest app request = do diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 1a715fc17..fabd76de0 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -49,12 +49,12 @@ import Network.Wai.Test simpleHeaders, simpleStatus) import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, - BasicAuthData (BasicAuthData), Capture, CaptureAll, Delete, - EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..), - JSON, NoContent (..), NoFraming, OctetStream, Patch, + BasicAuthData (BasicAuthData), Capture, CaptureAll, + DeleteNoContent, EmptyAPI, Get, Header, Headers, HttpVersion, + IsSecure (..), JSON, NoContent (..), NoFraming, OctetStream, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, - RemoteHost, ReqBody, StdMethod (..), Stream, - StreamGenerator (..), Verb, addHeader) + RemoteHost, ReqBody, Result, StdMethod (..), Stream, + StreamGenerator (..), Verb, VerbNoContent, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), @@ -94,7 +94,7 @@ spec = do headerSpec rawSpec alternativeSpec - responseHeadersSpec + -- responseHeadersSpec miscCombinatorSpec basicAuthSpec genAuthSpec @@ -104,14 +104,14 @@ spec = do ------------------------------------------------------------------------------ type VerbApi method status - = Verb method status '[JSON] Person - :<|> "noContent" :> Verb method status '[JSON] NoContent - :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) - :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent) - :<|> "accept" :> ( Verb method status '[JSON] Person - :<|> Verb method status '[PlainText] String + = Verb method '[JSON] (Result status Person) + :<|> "noContent" :> VerbNoContent method (NoContent status) + :<|> "header" :> Verb method '[JSON] (Headers '[Header "H" Int] :> Result status Person) + :<|> "headerNC" :> VerbNoContent method (Headers '[Header "H" Int] :> NoContent status) + :<|> "accept" :> ( Verb method '[JSON] (Result status Person) + :<|> Verb method '[PlainText] (Result status String) ) - :<|> "stream" :> Stream method status NoFraming OctetStream (StreamGenerator BS.ByteString) + :<|> "stream" :> Verb method '[OctetStream] (Stream status NoFraming (StreamGenerator BS.ByteString)) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do @@ -191,7 +191,8 @@ verbSpec = describe "Servant.API.Verb" $ do it "works for Stream as for Result" $ do response <- THW.request method "/stream" [] "" liftIO $ statusCode (simpleStatus response) `shouldBe` status - liftIO $ simpleBody response `shouldBe` "bytestring" + unless (method == methodHead) $ + liftIO $ simpleBody response `shouldBe` "bytestring" test "GET 200" get200 methodGet 200 test "POST 210" post210 methodPost 210 @@ -464,20 +465,21 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do -- * headerSpec {{{ ------------------------------------------------------------------------------ -type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] NoContent +type HeaderApi a = Header "MyHeader" a :> DeleteNoContent + headerApi :: Proxy a -> Proxy (HeaderApi a) headerApi _ = Proxy headerSpec :: Spec headerSpec = describe "Servant.API.Header" $ do - let expectsInt :: Maybe Int -> Handler NoContent + let expectsInt :: Maybe Int -> Handler (NoContent 204) expectsInt (Just x) = do when (x /= 5) $ error "Expected 5" return NoContent expectsInt Nothing = error "Expected an int" - let expectsString :: Maybe String -> Handler NoContent + let expectsString :: Maybe String -> Handler (NoContent 204) expectsString (Just x) = do when (x /= "more from you") $ error "Expected more from you" return NoContent @@ -487,13 +489,13 @@ headerSpec = describe "Servant.API.Header" $ do let delete' x = THW.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ - delete' "/" "" `shouldRespondWith` 200 + delete' "/" "" `shouldRespondWith` 204 with (return (serve (headerApi (Proxy :: Proxy String)) expectsString)) $ do let delete' x = THW.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ - delete' "/" "" `shouldRespondWith` 200 + delete' "/" "" `shouldRespondWith` 204 with (return (serve (headerApi (Proxy :: Proxy Int)) expectsInt)) $ do let delete' x = THW.request methodDelete x [("MyHeader", "not a number")] @@ -546,7 +548,7 @@ type AlternativeApi = :<|> "foo" :> Get '[PlainText] T.Text :<|> "bar" :> Post '[JSON] Animal :<|> "bar" :> Put '[JSON] Animal - :<|> "bar" :> Delete '[JSON] NoContent + :<|> "bar" :> DeleteNoContent alternativeApi :: Proxy AlternativeApi alternativeApi = Proxy @@ -584,12 +586,12 @@ alternativeSpec = do ------------------------------------------------------------------------------ -- * responseHeaderSpec {{{ ------------------------------------------------------------------------------ -type ResponseHeadersApi = - Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) - :<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) - :<|> Put '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) - :<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) +type ResponseHeadersApi = + Verb 'GET '[JSON] (Headers '[Header "H1" Int, Header "H2" String] :> Result 200 String) + :<|> Verb 'POST '[JSON] (Headers '[Header "H1" Int, Header "H2" String] :> Result 200 String) + :<|> Verb 'PUT '[JSON] (Headers '[Header "H1" Int, Header "H2" String] :> Result 200 String) + :<|> Verb 'PATCH '[JSON] (Headers '[Header "H1" Int, Header "H2" String] :> Result 200 String) responseHeadersServer :: Server ResponseHeadersApi responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi" @@ -618,8 +620,8 @@ responseHeadersSpec = describe "ResponseHeaders" $ do forM_ methods $ \method -> THW.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 - -- }}} + ------------------------------------------------------------------------------ -- * miscCombinatorSpec {{{ ------------------------------------------------------------------------------ diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 4ae2b8ef6..466a63f58 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -84,8 +84,7 @@ import Servant.API.Capture (Capture, Capture', CaptureAll) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, JSON, MimeRender (..), - MimeUnrender (..), NoContent (NoContent), OctetStream, - PlainText) + MimeUnrender (..), OctetStream, PlainText) import Servant.API.Description (Description, Summary) import Servant.API.Empty @@ -127,11 +126,12 @@ import Servant.API.Verbs (Delete, DeleteAccepted, DeleteNoContent, DeleteNonAuthoritative, Get, GetAccepted, GetNoContent, GetNonAuthoritative, GetPartialContent, GetResetContent, - Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative, - Post, PostAccepted, PostCreated, PostNoContent, - PostNonAuthoritative, PostResetContent, Put, PutAccepted, - PutNoContent, PutNonAuthoritative, - ReflectMethod (reflectMethod), StdMethod (..), Verb) + NoContent (..), Patch, PatchAccepted, PatchNoContent, + PatchNonAuthoritative, Post, PostAccepted, PostCreated, + PostNoContent, PostNonAuthoritative, PostResetContent, Put, + PutAccepted, PutNoContent, PutNonAuthoritative, + ReflectMethod (reflectMethod), Result, StdMethod (..), Verb, + VerbNoContent) import Servant.API.WithNamedContext (WithNamedContext) import Servant.Utils.Links diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 797d05835..191008d2f 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -57,9 +57,6 @@ module Servant.API.ContentTypes , MimeRender(..) , MimeUnrender(..) - -- * NoContent - , NoContent(..) - -- * Internal , AcceptHeader(..) , AllCTRender(..) @@ -295,20 +292,6 @@ instance OVERLAPPABLE_ pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy (ctyp' ': ctyps) - --- Ideally we would like to declare a 'MimeRender a NoContent' instance, and --- then this would be taken care of. However there is no more specific instance --- between that and 'MimeRender JSON a', so we do this instead -instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where - allMimeRender _ _ = map (, "") $ NE.toList $ contentTypes pctyp - where - pctyp = Proxy :: Proxy ctyp - -instance OVERLAPPING_ - ( AllMime (ctyp ': ctyp' ': ctyps) - ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where - allMimeRender p _ = zip (allMime p) (repeat "") - -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeUnrender -------------------------------------------------------------------------- @@ -365,9 +348,6 @@ instance MimeRender OctetStream ByteString where instance MimeRender OctetStream BS.ByteString where mimeRender _ = fromStrict --- | A type for responses without content-body. -data NoContent = NoContent - deriving (Show, Eq, Read, Generic) -------------------------------------------------------------------------- diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs index ed1b520c3..afd02fddf 100644 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -4,45 +4,53 @@ -- | This is a module containing an API with all `Servant.API` combinators. It -- is used for testing only (in particular, checking that instances exist for -- the core servant classes for each combinator), and should not be imported. -module Servant.API.Internal.Test.ComprehensiveAPI where +module Servant.API.Internal.Test.ComprehensiveAPI ( + ComprehensiveAPI, + comprehensiveAPI, + ComprehensiveAPIWithoutRaw, + comprehensiveAPIWithoutRaw, + ) where +import Data.ByteString + (ByteString) import Data.Proxy + (Proxy (..)) import Servant.API -type GET = Get '[JSON] NoContent +type GET = VerbNoContent 'GET (NoContent 200) -type ComprehensiveAPI = - ComprehensiveAPIWithoutRaw :<|> - Raw +-- | API using most built-in combinators and 'Raw'. +type ComprehensiveAPI = ComprehensiveAPIWithoutRaw :<|> Raw comprehensiveAPI :: Proxy ComprehensiveAPI comprehensiveAPI = Proxy -type ComprehensiveAPIWithoutRaw = - GET :<|> - Get '[JSON] Int :<|> - Capture' '[Description "example description"] "foo" Int :> GET :<|> - Header "foo" Int :> GET :<|> - Header' '[Required, Lenient] "bar" Int :> GET :<|> - HttpVersion :> GET :<|> - IsSecure :> GET :<|> - QueryParam "foo" Int :> GET :<|> - QueryParam' '[Required, Lenient] "bar" Int :> GET :<|> - QueryParams "foo" Int :> GET :<|> - QueryFlag "foo" :> GET :<|> - RemoteHost :> GET :<|> - ReqBody '[JSON] Int :> GET :<|> - ReqBody' '[Lenient] '[JSON] Int :> GET :<|> - Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|> - "foo" :> GET :<|> - Vault :> GET :<|> - Verb 'POST 204 '[JSON] NoContent :<|> - Verb 'POST 204 '[JSON] Int :<|> - WithNamedContext "foo" '[] GET :<|> - CaptureAll "foo" Int :> GET :<|> - Summary "foo" :> GET :<|> - Description "foo" :> GET :<|> - EmptyAPI +-- | API using most built-in combinators, but not 'Raw'. +type ComprehensiveAPIWithoutRaw = GET + :<|> Get '[JSON] Int + :<|> Capture' '[Description "example description"] "foo" Int :> GET + :<|> Header "foo" Int :> GET + :<|> Header' '[Required, Lenient] "bar" Int :> GET + :<|> HttpVersion :> GET + :<|> IsSecure :> GET + :<|> QueryParam "foo" Int :> GET + :<|> QueryParam' '[Required, Lenient] "bar" Int :> GET + :<|> QueryParams "foo" Int :> GET + :<|> QueryFlag "foo" :> GET + :<|> RemoteHost :> GET + :<|> ReqBody '[JSON] Int :> GET + :<|> ReqBody' '[Lenient] '[JSON] Int :> GET + :<|> VerbNoContent 'GET (Headers '[Header "foo" Int] :> NoContent 200) + :<|> "foo" :> GET + :<|> Vault :> GET + :<|> PostNoContent + :<|> Verb 'POST '[JSON] (Result 204 Int) + :<|> StreamGet 200 '[OctetStream] NoFraming (StreamGenerator ByteString) + :<|> WithNamedContext "foo" '[] GET + :<|> CaptureAll "foo" Int :> GET + :<|> Summary "foo" :> GET + :<|> Description "foo" :> GET + :<|> EmptyAPI comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw comprehensiveAPIWithoutRaw = Proxy diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index a0036c932..7a2fed3d8 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -30,6 +30,8 @@ module Servant.API.ResponseHeaders , noHeader , BuildHeadersTo(buildHeadersTo) , GetHeaders(getHeaders) + , GetHeaders'(getHeaders') + , GetHeadersFromHList(getHeadersFromHList) , HeaderValMap , HList(..) ) where diff --git a/servant/src/Servant/API/Stream.hs b/servant/src/Servant/API/Stream.hs index 6a44eae91..7239dfeaf 100644 --- a/servant/src/Servant/API/Stream.hs +++ b/servant/src/Servant/API/Stream.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Stream where @@ -33,12 +33,15 @@ import Network.HTTP.Types.Method import Text.Read (readMaybe) +import Servant.API.Verbs + (Verb) + -- | A Stream endpoint for a given method emits a stream of encoded values at a given Content-Type, delimited by a framing strategy. Stream endpoints always return response code 200 on success. Type synonyms are provided for standard methods. -data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *) +data Stream (status :: Nat) (framing :: *) (a :: *) deriving (Typeable, Generic) -type StreamGet = Stream 'GET 200 -type StreamPost = Stream 'POST 200 +type StreamGet status ct framing a = Verb 'GET ct (Stream status framing a) +type StreamPost status ct framing a = Verb 'POST ct (Stream status framing a) -- | Stream endpoints may be implemented as producing a @StreamGenerator@ -- a function that itself takes two emit functions -- the first to be used on the first value the stream emits, and the second to be used on all subsequent values (to allow interspersed framing strategies such as comma separation). newtype StreamGenerator a = StreamGenerator {getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO ()} @@ -47,14 +50,14 @@ newtype StreamGenerator a = StreamGenerator {getStreamGenerator :: (a -> IO ()) class ToStreamGenerator a b | a -> b where toStreamGenerator :: a -> StreamGenerator b -instance ToStreamGenerator (StreamGenerator a) a - where toStreamGenerator x = x +instance ToStreamGenerator (StreamGenerator a) a where + toStreamGenerator x = x -- | Clients reading from streaming endpoints can be implemented as producing a @ResultStream@ that captures the setup, takedown, and incremental logic for a read, being an IO continuation that takes a producer of Just either values or errors that terminates with a Nothing. newtype ResultStream a = ResultStream (forall b. (IO (Maybe (Either String a)) -> IO b) -> IO b) -- | BuildFromStream is intended to be implemented for types such as Conduit, Pipe, etc. By implementing this class, all such streaming abstractions can be used directly on the client side for talking to streaming endpoints. -class BuildFromStream a b where +class BuildFromStream a b | b -> a where buildFromStream :: ResultStream a -> b instance BuildFromStream a (ResultStream a) diff --git a/servant/src/Servant/API/TypeLevel.hs b/servant/src/Servant/API/TypeLevel.hs index 70968e4e0..5e91cac17 100644 --- a/servant/src/Servant/API/TypeLevel.hs +++ b/servant/src/Servant/API/TypeLevel.hs @@ -133,8 +133,7 @@ type family IsElem endpoint api :: Constraint where IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb - IsElem (Verb m s ct typ) (Verb m s ct' typ) - = IsSubList ct ct' + IsElem (Verb m ct sb) (Verb m ct' sb') = IsSubList ct ct' IsElem e e = () IsElem e a = IsElem' e a @@ -261,6 +260,7 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). -- -- The doctests in this module are run with following preamble: -- +-- >>> :set -XConstraintKinds -- >>> :set -XPolyKinds -- >>> :set -XGADTs -- >>> import Data.Proxy diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs index a82e8a046..9b2641460 100644 --- a/servant/src/Servant/API/Verbs.hs +++ b/servant/src/Servant/API/Verbs.hs @@ -25,10 +25,21 @@ import Network.HTTP.Types.Method -- convenience, type synonyms for each verb with a 200 response code are -- provided, but you are free to define your own: -- --- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a -data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) (a :: *) +-- >>> type Post204 contentTypes a = Verb 'POST contentTypes (Result a) +data Verb (method :: k1) (contentTypes :: [*]) (api :: *) deriving (Typeable, Generic) +-- | A type for responses. +data Result (statusCode :: Nat) (a :: *) + deriving (Typeable, Generic) + +data VerbNoContent (method :: k1) (api :: *) + deriving (Typeable, Generic) + +-- | A type for responses without content-body. +data NoContent (statusCode :: Nat) = NoContent + deriving (Show, Eq, Read, Generic) + -- * 200 responses -- -- The 200 response is the workhorse of web servers, but also fairly generic. @@ -39,15 +50,15 @@ data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) (a :: *) -- the relevant information is summarily presented here. -- | 'GET' with 200 status code. -type Get = Verb 'GET 200 +type Get ct a = Verb 'GET ct (Result 200 a) -- | 'POST' with 200 status code. -type Post = Verb 'POST 200 +type Post ct a = Verb 'POST ct (Result 200 a) -- | 'PUT' with 200 status code. -type Put = Verb 'PUT 200 +type Put ct a = Verb 'PUT ct (Result 200 a) -- | 'DELETE' with 200 status code. -type Delete = Verb 'DELETE 200 +type Delete ct a = Verb 'DELETE ct (Result 200 a) -- | 'PATCH' with 200 status code. -type Patch = Verb 'PATCH 200 +type Patch ct a = Verb 'PATCH ct (Result 200 a) -- * Other responses @@ -63,7 +74,7 @@ type Patch = Verb 'PATCH 200 -- | 'POST' with 201 status code. -- -type PostCreated = Verb 'POST 201 +type PostCreated ct a = Verb 'POST ct (Result 201 a) -- ** 202 Accepted @@ -74,15 +85,15 @@ type PostCreated = Verb 'POST 201 -- estimate of when the processing will be finished. -- | 'GET' with 202 status code. -type GetAccepted = Verb 'GET 202 +type GetAccepted ct a = Verb 'GET ct (Result 202 a) -- | 'POST' with 202 status code. -type PostAccepted = Verb 'POST 202 +type PostAccepted ct a = Verb 'POST ct (Result 202 a) -- | 'DELETE' with 202 status code. -type DeleteAccepted = Verb 'DELETE 202 +type DeleteAccepted ct a = Verb 'DELETE ct (Result 202 a) -- | 'PATCH' with 202 status code. -type PatchAccepted = Verb 'PATCH 202 +type PatchAccepted ct a = Verb 'PATCH ct (Result 202 a) -- | 'PUT' with 202 status code. -type PutAccepted = Verb 'PUT 202 +type PutAccepted ct a = Verb 'PUT ct (Result 202 a) -- ** 203 Non-Authoritative Information @@ -91,15 +102,15 @@ type PutAccepted = Verb 'PUT 202 -- information may come from a third-party. -- | 'GET' with 203 status code. -type GetNonAuthoritative = Verb 'GET 203 +type GetNonAuthoritative ct a = Verb 'GET ct (Result 203 a) -- | 'POST' with 203 status code. -type PostNonAuthoritative = Verb 'POST 203 +type PostNonAuthoritative ct a = Verb 'POST ct (Result 203 a) -- | 'DELETE' with 203 status code. -type DeleteNonAuthoritative = Verb 'DELETE 203 +type DeleteNonAuthoritative ct a = Verb 'DELETE ct (Result 203 a) -- | 'PATCH' with 203 status code. -type PatchNonAuthoritative = Verb 'PATCH 203 +type PatchNonAuthoritative ct a = Verb 'PATCH ct (Result 203 a) -- | 'PUT' with 203 status code. -type PutNonAuthoritative = Verb 'PUT 203 +type PutNonAuthoritative ct a = Verb 'PUT ct (Result 203 a) -- ** 204 No Content @@ -110,15 +121,15 @@ type PutNonAuthoritative = Verb 'PUT 203 -- If the document view should be reset, use @205 Reset Content@. -- | 'GET' with 204 status code. -type GetNoContent = Verb 'GET 204 +type GetNoContent = VerbNoContent 'GET (NoContent 204) -- | 'POST' with 204 status code. -type PostNoContent = Verb 'POST 204 +type PostNoContent = VerbNoContent 'POST (NoContent 204) -- | 'DELETE' with 204 status code. -type DeleteNoContent = Verb 'DELETE 204 +type DeleteNoContent = VerbNoContent 'DELETE (NoContent 204) -- | 'PATCH' with 204 status code. -type PatchNoContent = Verb 'PATCH 204 +type PatchNoContent = VerbNoContent 'PATCH (NoContent 204) -- | 'PUT' with 204 status code. -type PutNoContent = Verb 'PUT 204 +type PutNoContent = VerbNoContent 'PUT (NoContent 204) -- ** 205 Reset Content @@ -129,15 +140,15 @@ type PutNoContent = Verb 'PUT 204 -- If the document view should not be reset, use @204 No Content@. -- | 'GET' with 205 status code. -type GetResetContent = Verb 'GET 205 +type GetResetContent = VerbNoContent 'GET (NoContent 205) -- | 'POST' with 205 status code. -type PostResetContent = Verb 'POST 205 +type PostResetContent = VerbNoContent 'POST (NoContent 205) -- | 'DELETE' with 205 status code. -type DeleteResetContent = Verb 'DELETE 205 +type DeleteResetContent = VerbNoContent 'DELETE (NoContent 205) -- | 'PATCH' with 205 status code. -type PatchResetContent = Verb 'PATCH 205 +type PatchResetContent = VerbNoContent 'PATCH (NoContent 205) -- | 'PUT' with 205 status code. -type PutResetContent = Verb 'PUT 205 +type PutResetContent = VerbNoContent 'PUT (NoContent 205) -- ** 206 Partial Content @@ -149,7 +160,7 @@ type PutResetContent = Verb 'PUT 205 -- RFC7233 Section 4.1> -- | 'GET' with 206 status code. -type GetPartialContent = Verb 'GET 206 +type GetPartialContent ct a = Verb 'GET ct (Result 206 a) class ReflectMethod a where diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 5002bcca4..effe367aa 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -20,7 +20,7 @@ -- >>> import Data.Proxy -- >>> -- >>> type Hello = "hello" :> Get '[JSON] Int --- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent +-- >>> type Bye = "bye" :> QueryParam "name" String :> DeleteNoContent -- >>> type API = Hello :<|> Bye -- >>> let api = Proxy :: Proxy API -- @@ -46,11 +46,11 @@ -- If the API has an endpoint with parameters then we can generate links with -- or without those: -- --- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent) +-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> DeleteNoContent) -- >>> toUrlPiece $ safeLink api with (Just "Hubert") -- "bye?name=Hubert" -- --- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent) +-- >>> let without = Proxy :: Proxy ("bye" :> DeleteNoContent) -- >>> toUrlPiece $ safeLink api without -- "bye" -- @@ -82,7 +82,7 @@ -- Attempting to construct a link to an endpoint that does not exist in api -- will result in a type error like this: -- --- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent) +-- >>> let bad_link = Proxy :: Proxy ("hello" :> DeleteNoContent) -- >>> safeLink api bad_link -- ... -- ...Could not deduce... @@ -160,15 +160,13 @@ import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody (ReqBody') -import Servant.API.Stream - (Stream) import Servant.API.Sub (type (:>)) import Servant.API.TypeLevel import Servant.API.Vault (Vault) import Servant.API.Verbs - (Verb) + (Verb, VerbNoContent) import Servant.API.WithNamedContext (WithNamedContext) import Web.HttpApiData @@ -452,16 +450,16 @@ instance HasLink EmptyAPI where toLink _ _ _ = EmptyAPI -- Verb (terminal) instances -instance HasLink (Verb m s ct a) where - type MkLink (Verb m s ct a) r = r +instance HasLink (Verb method ct a) where + type MkLink (Verb method ct a) r = r toLink toA _ = toA -instance HasLink Raw where - type MkLink Raw a = a +instance HasLink (VerbNoContent method a) where + type MkLink (VerbNoContent method a) r = r toLink toA _ = toA -instance HasLink (Stream m fr ct a) where - type MkLink (Stream m fr ct a) r = r +instance HasLink Raw where + type MkLink Raw a = a toLink toA _ = toA -- AuthProtext instances diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index 1ebb0fc64..26cc29ea5 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -20,24 +20,24 @@ import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWit type TestApi = -- Capture and query params - "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] NoContent - :<|> "hi" :> Capture "name" String :> QueryParam' '[Required] "capital" Bool :> Delete '[JSON] NoContent - :<|> "all" :> CaptureAll "names" String :> Get '[JSON] NoContent + "hello" :> Capture "name" String :> QueryParam "capital" Bool :> Delete '[JSON] Int + :<|> "hi" :> Capture "name" String :> QueryParam' '[Required] "capital" Bool :> Delete '[JSON] Int + :<|> "all" :> CaptureAll "names" String :> Get '[JSON] Int -- Flags - :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent + :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] Int -- All of the verbs - :<|> "get" :> Get '[JSON] NoContent - :<|> "put" :> Put '[JSON] NoContent - :<|> "post" :> ReqBody '[JSON] Bool :> Post '[JSON] NoContent - :<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent + :<|> "get" :> Get '[JSON] Int + :<|> "put" :> Put '[JSON] Int + :<|> "post" :> ReqBody '[JSON] Bool :> Post '[JSON] Int + :<|> "delete" :> Header "ponies" String :> Delete '[JSON] Int :<|> "raw" :> Raw :<|> NoEndpoint type LinkableApi = - "all" :> CaptureAll "names" String :> Get '[JSON] NoContent - :<|> "get" :> Get '[JSON] NoContent + "all" :> CaptureAll "names" String :> Get '[JSON] Int + :<|> "get" :> Get '[JSON] Int apiLink :: (IsElem endpoint TestApi, HasLink endpoint) @@ -53,35 +53,35 @@ shouldBeLink link expected = spec :: Spec spec = describe "Servant.Utils.Links" $ do it "generates correct links for capture query params" $ do - let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent) + let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] Int) apiLink l1 "hi" `shouldBeLink` "hello/hi" let l2 = Proxy :: Proxy ("hello" :> Capture "name" String :> QueryParam "capital" Bool - :> Delete '[JSON] NoContent) + :> Delete '[JSON] Int) apiLink l2 "bye" (Just True) `shouldBeLink` "hello/bye?capital=true" let l4 = Proxy :: Proxy ("hi" :> Capture "name" String :> QueryParam' '[Required] "capital" Bool - :> Delete '[JSON] NoContent) + :> Delete '[JSON] Int) apiLink l4 "privet" False `shouldBeLink` "hi/privet?capital=false" it "generates correct links for CaptureAll" $ do - apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] NoContent)) + apiLink (Proxy :: Proxy ("all" :> CaptureAll "names" String :> Get '[JSON] Int)) ["roads", "lead", "to", "rome"] `shouldBeLink` "all/roads/lead/to/rome" it "generates correct links for query flags" $ do let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy" - :> QueryFlag "fast" :> Delete '[JSON] NoContent) + :> QueryFlag "fast" :> Delete '[JSON] Int) apiLink l1 True True `shouldBeLink` "balls?bouncy&fast" apiLink l1 False True `shouldBeLink` "balls?fast" it "generates correct links for all of the verbs" $ do - apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get" - apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put" - apiLink (Proxy :: Proxy ("post" :> Post '[JSON] NoContent)) `shouldBeLink` "post" - apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] NoContent)) `shouldBeLink` "delete" + apiLink (Proxy :: Proxy ("get" :> Get '[JSON] Int)) `shouldBeLink` "get" + apiLink (Proxy :: Proxy ("put" :> Put '[JSON] Int)) `shouldBeLink` "put" + apiLink (Proxy :: Proxy ("post" :> Post '[JSON] Int)) `shouldBeLink` "post" + apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] Int)) `shouldBeLink` "delete" apiLink (Proxy :: Proxy ("raw" :> Raw)) `shouldBeLink` "raw" it "can generate all links for an API that has only linkable endpoints" $ do @@ -132,10 +132,10 @@ spec = describe "Servant.Utils.Links" $ do -- sanity check -- >>> toUrlPiece $ apiLink (Proxy :: Proxy AllGood) -- "get" -type WrongPath = "getTypo" :> Get '[JSON] NoContent +type WrongPath = "getTypo" :> Get '[JSON] Int type WrongReturnType = "get" :> Get '[JSON] Bool -type WrongContentType = "get" :> Get '[OctetStream] NoContent -type WrongMethod = "get" :> Post '[JSON] NoContent +type WrongContentType = "get" :> Get '[OctetStream] Int +type WrongMethod = "get" :> Post '[JSON] Int type NotALink = "hello" :> ReqBody '[JSON] Bool :> Get '[JSON] Bool -type AllGood = "get" :> Get '[JSON] NoContent +type AllGood = "get" :> Get '[JSON] Int type NoEndpoint = "empty" :> EmptyAPI