eeva/servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fix servant-server

Browse Source
This commit is contained in:
Oleg Grenrus 2018-03-27 16:15:33 +03:00
parent a701e8df23
commit 4e53c38ef1
3 changed files with 81 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
servant-server/src/Servant/Server/Internal.hs
View File

@ -1,25 +1,24 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# 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
#endif #endif
#ifdef HAS_TYPE_ERROR #ifdef HAS_TYPE_ERROR
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
#endif #endif
#include "overlapping-compat.h" #include "overlapping-compat.h"
@ -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
import qualified Data.ByteString as B (liftIO)
import qualified Data.ByteString.Builder as BB import Control.Monad.Trans.Resource
import qualified Data.ByteString.Char8 as BC8 (runResourceT)
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as B
import Data.Maybe (fromMaybe, mapMaybe, import qualified Data.ByteString.Builder as BB
isNothing, maybeToList) import qualified Data.ByteString.Char8 as BC8
import Data.Either (partitionEithers) import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map import Data.Either
import Data.String (IsString (..)) (partitionEithers)
import Data.String.Conversions (cs, (<>)) import qualified Data.Map.Strict as Map
import Data.Tagged (Tagged(..), retag, untag) import Data.Maybe
import qualified Data.Text as T (fromMaybe, isNothing, mapMaybe, maybeToList)
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 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.HTTP.Types hiding
import Network.Socket (SockAddr) (Header, ResponseHeaders)
import Network.Wai (Application, Request, import Network.Socket
httpVersion, isSecure, (SockAddr)
lazyRequestBody, import Network.Wai
rawQueryString, remoteHost, (Application, Request, httpVersion, isSecure, lazyRequestBody,
requestHeaders, requestMethod, rawQueryString, remoteHost, requestHeaders, requestMethod,
responseLBS, responseStream, responseLBS, responseStream, vault)
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))
@ -771,7 +771,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
-- ...Maybe you haven't applied enough arguments to -- ...Maybe you haven't applied enough arguments to
-- ...Capture' '[] "foo" -- ...Capture' '[] "foo"
-- ... -- ...
-- --
instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
where where
type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr) type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)

5
servant/src/Servant/API.hs
View File

@ -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 (..),

11
servant/src/Servant/API/ResponseHeaders.hs
View File

@ -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