Fix servant-server
This commit is contained in:
parent
a701e8df23
commit
4e53c38ef1
|
@ -12,7 +12,6 @@
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
|
|
||||||
#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
|
#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
|
||||||
#define HAS_TYPE_ERROR
|
#define HAS_TYPE_ERROR
|
||||||
|
@ -34,73 +33,74 @@ module Servant.Server.Internal
|
||||||
, module Servant.Server.Internal.ServantErr
|
, module Servant.Server.Internal.ServantErr
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad (join, when)
|
import Control.Monad
|
||||||
import Control.Monad.Trans (liftIO)
|
(join, when)
|
||||||
import Control.Monad.Trans.Resource (runResourceT)
|
import Control.Monad.Trans
|
||||||
|
(liftIO)
|
||||||
|
import Control.Monad.Trans.Resource
|
||||||
|
(runResourceT)
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import qualified Data.ByteString.Builder as BB
|
import qualified Data.ByteString.Builder as BB
|
||||||
import qualified Data.ByteString.Char8 as BC8
|
import qualified Data.ByteString.Char8 as BC8
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import qualified Data.ByteString.Lazy as BL
|
||||||
import Data.Maybe (fromMaybe, mapMaybe,
|
import Data.Either
|
||||||
isNothing, maybeToList)
|
(partitionEithers)
|
||||||
import Data.Either (partitionEithers)
|
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
import Data.String (IsString (..))
|
import Data.Maybe
|
||||||
import Data.String.Conversions (cs, (<>))
|
(fromMaybe, isNothing, mapMaybe, maybeToList)
|
||||||
import Data.Tagged (Tagged(..), retag, untag)
|
import Data.String
|
||||||
|
(IsString (..))
|
||||||
|
import Data.String.Conversions
|
||||||
|
(cs, (<>))
|
||||||
|
import Data.Tagged
|
||||||
|
(Tagged (..), retag, untag)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
|
import GHC.TypeLits
|
||||||
symbolVal)
|
(KnownNat, KnownSymbol, natVal, symbolVal)
|
||||||
import Network.HTTP.Types hiding (Header, ResponseHeaders)
|
|
||||||
import qualified Network.HTTP.Media as NHM
|
import qualified Network.HTTP.Media as NHM
|
||||||
import Network.Socket (SockAddr)
|
import Network.HTTP.Types hiding
|
||||||
import Network.Wai (Application, Request,
|
(Header, ResponseHeaders)
|
||||||
httpVersion, isSecure,
|
import Network.Socket
|
||||||
lazyRequestBody,
|
(SockAddr)
|
||||||
rawQueryString, remoteHost,
|
import Network.Wai
|
||||||
requestHeaders, requestMethod,
|
(Application, Request, httpVersion, isSecure, lazyRequestBody,
|
||||||
responseLBS, responseStream,
|
rawQueryString, remoteHost, requestHeaders, requestMethod,
|
||||||
vault)
|
responseLBS, responseStream, vault)
|
||||||
import Prelude ()
|
import Prelude ()
|
||||||
import Prelude.Compat
|
import Prelude.Compat
|
||||||
import Web.HttpApiData (FromHttpApiData, parseHeader,
|
import Servant.API
|
||||||
parseQueryParam,
|
((:<|>) (..), (:>), Accept (..), BasicAuth,
|
||||||
parseUrlPieceMaybe,
|
BoundaryStrategy (..), Capture', CaptureAll, Description,
|
||||||
parseUrlPieces)
|
EmptyAPI, FramingRender (..), Header', If, IsSecure (..),
|
||||||
import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture',
|
QueryFlag, QueryParam', QueryParams, Raw,
|
||||||
CaptureAll, Verb, EmptyAPI,
|
ReflectMethod (reflectMethod), RemoteHost, ReqBody',
|
||||||
ReflectMethod(reflectMethod),
|
SBool (..), SBoolI (..), Stream, StreamGenerator (..),
|
||||||
IsSecure(..), Header', QueryFlag,
|
Summary, ToStreamGenerator (..), Vault, Verb,
|
||||||
QueryParam', QueryParams, Raw,
|
WithNamedContext)
|
||||||
RemoteHost, ReqBody', Vault,
|
import Servant.API.ContentTypes
|
||||||
WithNamedContext,
|
(AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
|
||||||
Description, Summary,
|
AllMime, MimeRender (..), canHandleAcceptH)
|
||||||
Accept(..),
|
import Servant.API.Modifiers
|
||||||
FramingRender(..), Stream,
|
(FoldLenient, FoldRequired, RequestArgument,
|
||||||
StreamGenerator(..), ToStreamGenerator(..),
|
unfoldRequestArgument)
|
||||||
BoundaryStrategy(..),
|
import Servant.API.ResponseHeaders
|
||||||
If, SBool (..), SBoolI (..))
|
(DynHeaders (..), GetHeaders, Headers, getHeaders,
|
||||||
import Servant.API.Modifiers (unfoldRequestArgument, RequestArgument, FoldRequired, FoldLenient)
|
getResponse)
|
||||||
import Servant.API.ContentTypes (AcceptHeader (..),
|
import Web.HttpApiData
|
||||||
AllCTRender (..),
|
(FromHttpApiData, parseHeader, parseQueryParam,
|
||||||
AllCTUnrender (..),
|
parseUrlPieceMaybe, parseUrlPieces)
|
||||||
AllMime,
|
|
||||||
MimeRender(..),
|
|
||||||
canHandleAcceptH)
|
|
||||||
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
|
|
||||||
getResponse, DynHeaders,
|
|
||||||
DynResponse, withDynHeaders)
|
|
||||||
|
|
||||||
import Servant.Server.Internal.Context
|
|
||||||
import Servant.Server.Internal.BasicAuth
|
import Servant.Server.Internal.BasicAuth
|
||||||
|
import Servant.Server.Internal.Context
|
||||||
import Servant.Server.Internal.Handler
|
import Servant.Server.Internal.Handler
|
||||||
import Servant.Server.Internal.Router
|
import Servant.Server.Internal.Router
|
||||||
import Servant.Server.Internal.RoutingApplication
|
import Servant.Server.Internal.RoutingApplication
|
||||||
import Servant.Server.Internal.ServantErr
|
import Servant.Server.Internal.ServantErr
|
||||||
|
|
||||||
#ifdef HAS_TYPE_ERROR
|
#ifdef HAS_TYPE_ERROR
|
||||||
import GHC.TypeLits (TypeError, ErrorMessage (..))
|
import GHC.TypeLits
|
||||||
|
(ErrorMessage (..), TypeError)
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
class HasServer api context where
|
class HasServer api context where
|
||||||
|
@ -286,7 +286,7 @@ instance OVERLAPPING_
|
||||||
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
||||||
) => HasServer (Verb method status ctypes (DynHeaders a)) context where
|
) => HasServer (Verb method status ctypes (DynHeaders a)) context where
|
||||||
|
|
||||||
type ServerT (Verb method status ctypes (DynHeaders a)) m = m (DynResponse a)
|
type ServerT (Verb method status ctypes (DynHeaders a)) m = m (DynHeaders a)
|
||||||
hoistServerWithContext _ _ nt s = nt s
|
hoistServerWithContext _ _ nt s = nt s
|
||||||
|
|
||||||
route Proxy _ = methodRouter (\x -> (Map.toList (dynHeaders x), dynResponse x))
|
route Proxy _ = methodRouter (\x -> (Map.toList (dynHeaders x), dynResponse x))
|
||||||
|
|
|
@ -109,11 +109,10 @@ import Servant.API.RemoteHost
|
||||||
import Servant.API.ReqBody
|
import Servant.API.ReqBody
|
||||||
(ReqBody, ReqBody')
|
(ReqBody, ReqBody')
|
||||||
import Servant.API.ResponseHeaders
|
import Servant.API.ResponseHeaders
|
||||||
(AddHeader, BuildHeadersTo (buildHeadersTo),
|
(AddHeader, BuildHeadersTo (buildHeadersTo), DynHeaders (..),
|
||||||
DynHeaders(..), DynResponse(..), withDynHeaders,
|
|
||||||
GetHeaders (getHeaders), HList (..), Headers (..),
|
GetHeaders (getHeaders), HList (..), Headers (..),
|
||||||
ResponseHeader (..), addHeader, getHeadersHList, getResponse,
|
ResponseHeader (..), addHeader, getHeadersHList, getResponse,
|
||||||
noHeader)
|
noHeader, withDynHeaders)
|
||||||
import Servant.API.Stream
|
import Servant.API.Stream
|
||||||
(BoundaryStrategy (..), BuildFromStream (..),
|
(BoundaryStrategy (..), BuildFromStream (..),
|
||||||
ByteStringParser (..), FramingRender (..),
|
ByteStringParser (..), FramingRender (..),
|
||||||
|
|
|
@ -36,7 +36,6 @@ module Servant.API.ResponseHeaders
|
||||||
|
|
||||||
, -- * "Dynamic" response headers
|
, -- * "Dynamic" response headers
|
||||||
DynHeaders(..)
|
DynHeaders(..)
|
||||||
, DynResponse(..)
|
|
||||||
, withDynHeaders
|
, withDynHeaders
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
@ -177,22 +176,20 @@ noHeader = addOptionalHeader MissingHeader
|
||||||
|
|
||||||
-- | Combinator to use when you want your endpoint to return a response
|
-- | Combinator to use when you want your endpoint to return a response
|
||||||
-- along with some response headers, dynamically,
|
-- along with some response headers, dynamically,
|
||||||
-- by simply building a value of type 'DynResponse a', which is just a
|
-- by simply building a value of type 'DynHeaders a', which is just a
|
||||||
-- response of type @a@ along with a map from header names to header values.
|
-- response of type @a@ along with a map from header names to header values.
|
||||||
--
|
--
|
||||||
-- For all other interpretations than the server one, this combinator basically
|
-- For all other interpretations than the server one, this combinator basically
|
||||||
-- has no effect and behaves just as if you were using @a@ directly.
|
-- has no effect and behaves just as if you were using @a@ directly.
|
||||||
data DynHeaders a
|
data DynHeaders a = DynHeaders
|
||||||
|
|
||||||
data DynResponse a = DynResponse
|
|
||||||
{ dynResponse :: a
|
{ dynResponse :: a
|
||||||
, dynHeaders :: Map HTTP.HeaderName ByteString
|
, dynHeaders :: Map HTTP.HeaderName ByteString
|
||||||
} deriving (Typeable, Eq, Show, Functor)
|
} deriving (Typeable, Eq, Show, Functor)
|
||||||
|
|
||||||
-- | Build a \"response with headers\", where the headers are
|
-- | Build a \"response with headers\", where the headers are
|
||||||
-- provided at runtime as a 'Map' from header name to header value.
|
-- provided at runtime as a 'Map' from header name to header value.
|
||||||
withDynHeaders :: a -> Map HTTP.HeaderName ByteString -> DynResponse a
|
withDynHeaders :: a -> Map HTTP.HeaderName ByteString -> DynHeaders a
|
||||||
withDynHeaders = DynResponse
|
withDynHeaders = DynHeaders
|
||||||
|
|
||||||
-- $setup
|
-- $setup
|
||||||
-- >>> import Servant.API
|
-- >>> import Servant.API
|
||||||
|
|
Loading…
Reference in New Issue
Block a user