wip dynamic headers
This commit is contained in:
parent
db2b6d36b2
commit
a701e8df23
8 changed files with 97 additions and 6 deletions
|
@ -1,5 +1,5 @@
|
||||||
{ pkgs ? import <nixpkgs> {}
|
{ pkgs ? import <nixpkgs> {}
|
||||||
, compiler ? "ghc821"
|
, compiler ? "ghc822"
|
||||||
, tutorial ? false
|
, tutorial ? false
|
||||||
}:
|
}:
|
||||||
|
|
||||||
|
|
|
@ -36,7 +36,8 @@ import Servant.API ((:<|>) ((:<|>)), (:>),
|
||||||
BuildFromStream (..),
|
BuildFromStream (..),
|
||||||
ByteStringParser (..),
|
ByteStringParser (..),
|
||||||
Capture', CaptureAll,
|
Capture', CaptureAll,
|
||||||
Description, EmptyAPI,
|
Description, DynHeaders,
|
||||||
|
EmptyAPI,
|
||||||
FramingUnrender (..),
|
FramingUnrender (..),
|
||||||
Header', Headers (..),
|
Header', Headers (..),
|
||||||
HttpVersion, IsSecure,
|
HttpVersion, IsSecure,
|
||||||
|
@ -282,6 +283,36 @@ instance OVERLAPPING_
|
||||||
|
|
||||||
hoistClientMonad _ _ f ma = f ma
|
hoistClientMonad _ _ f ma = f ma
|
||||||
|
|
||||||
|
instance OVERLAPPING_
|
||||||
|
( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
|
||||||
|
) => HasClient m (Verb method status cts' (DynHeaders a)) where
|
||||||
|
type Client m (Verb method status cts' (DynHeaders a)) = m 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 val
|
||||||
|
|
||||||
|
where 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 (DynHeaders NoContent)) where
|
||||||
|
type Client m (Verb method status cts (DynHeaders NoContent)) = m NoContent
|
||||||
|
clientWithRoute _pm Proxy req = do
|
||||||
|
response <- runRequest req { requestMethod = method }
|
||||||
|
return NoContent
|
||||||
|
|
||||||
|
where method = reflectMethod (Proxy :: Proxy method)
|
||||||
|
|
||||||
|
hoistClientMonad _ _ f ma = f ma
|
||||||
|
|
||||||
instance OVERLAPPABLE_
|
instance OVERLAPPABLE_
|
||||||
( RunClient m, MimeUnrender ct a, ReflectMethod method,
|
( RunClient m, MimeUnrender ct a, ReflectMethod method,
|
||||||
FramingUnrender framing a, BuildFromStream a (f a)
|
FramingUnrender framing a, BuildFromStream a (f a)
|
||||||
|
|
|
@ -858,6 +858,22 @@ instance OVERLAPPING_
|
||||||
status = fromInteger $ natVal (Proxy :: Proxy status)
|
status = fromInteger $ natVal (Proxy :: Proxy status)
|
||||||
p = Proxy :: Proxy a
|
p = Proxy :: Proxy a
|
||||||
|
|
||||||
|
instance OVERLAPPING_
|
||||||
|
( ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
|
||||||
|
, ReflectMethod method
|
||||||
|
) => HasDocs (Verb method status (ct ': cts) (DynHeaders a)) where
|
||||||
|
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||||
|
single endpoint' action'
|
||||||
|
|
||||||
|
where endpoint' = endpoint & method .~ method'
|
||||||
|
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||||
|
& response.respTypes .~ allMime t
|
||||||
|
& response.respStatus .~ status
|
||||||
|
t = Proxy :: Proxy (ct ': cts)
|
||||||
|
method' = reflectMethod (Proxy :: Proxy method)
|
||||||
|
status = fromInteger $ natVal (Proxy :: Proxy status)
|
||||||
|
p = Proxy :: Proxy a
|
||||||
|
|
||||||
instance (KnownSymbol sym, HasDocs api)
|
instance (KnownSymbol sym, HasDocs api)
|
||||||
=> HasDocs (Header' mods sym a :> api) where
|
=> HasDocs (Header' mods sym a :> api) where
|
||||||
docsFor Proxy (endpoint, action) =
|
docsFor Proxy (endpoint, action) =
|
||||||
|
|
|
@ -44,6 +44,7 @@ import qualified Data.ByteString.Lazy as BL
|
||||||
import Data.Maybe (fromMaybe, mapMaybe,
|
import Data.Maybe (fromMaybe, mapMaybe,
|
||||||
isNothing, maybeToList)
|
isNothing, maybeToList)
|
||||||
import Data.Either (partitionEithers)
|
import Data.Either (partitionEithers)
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
import Data.String (IsString (..))
|
import Data.String (IsString (..))
|
||||||
import Data.String.Conversions (cs, (<>))
|
import Data.String.Conversions (cs, (<>))
|
||||||
import Data.Tagged (Tagged(..), retag, untag)
|
import Data.Tagged (Tagged(..), retag, untag)
|
||||||
|
@ -88,7 +89,8 @@ import Servant.API.ContentTypes (AcceptHeader (..),
|
||||||
MimeRender(..),
|
MimeRender(..),
|
||||||
canHandleAcceptH)
|
canHandleAcceptH)
|
||||||
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
|
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
|
||||||
getResponse)
|
getResponse, DynHeaders,
|
||||||
|
DynResponse, withDynHeaders)
|
||||||
|
|
||||||
import Servant.Server.Internal.Context
|
import Servant.Server.Internal.Context
|
||||||
import Servant.Server.Internal.BasicAuth
|
import Servant.Server.Internal.BasicAuth
|
||||||
|
@ -280,6 +282,17 @@ instance OVERLAPPING_
|
||||||
where method = reflectMethod (Proxy :: Proxy method)
|
where method = reflectMethod (Proxy :: Proxy method)
|
||||||
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
||||||
|
|
||||||
|
instance OVERLAPPING_
|
||||||
|
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
|
||||||
|
) => HasServer (Verb method status ctypes (DynHeaders a)) context where
|
||||||
|
|
||||||
|
type ServerT (Verb method status ctypes (DynHeaders a)) m = m (DynResponse a)
|
||||||
|
hoistServerWithContext _ _ nt s = nt s
|
||||||
|
|
||||||
|
route Proxy _ = methodRouter (\x -> (Map.toList (dynHeaders x), dynResponse x))
|
||||||
|
method (Proxy :: Proxy ctypes) status
|
||||||
|
where method = reflectMethod (Proxy :: Proxy method)
|
||||||
|
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
||||||
|
|
||||||
instance OVERLAPPABLE_
|
instance OVERLAPPABLE_
|
||||||
( MimeRender ctype a, ReflectMethod method,
|
( MimeRender ctype a, ReflectMethod method,
|
||||||
|
|
|
@ -71,6 +71,7 @@ library
|
||||||
build-depends:
|
build-depends:
|
||||||
base >= 4.7 && < 4.11
|
base >= 4.7 && < 4.11
|
||||||
, bytestring >= 0.10.4.0 && < 0.11
|
, bytestring >= 0.10.4.0 && < 0.11
|
||||||
|
, containers >= 0.5 && < 0.6
|
||||||
, mtl >= 2.1 && < 2.3
|
, mtl >= 2.1 && < 2.3
|
||||||
, text >= 1.2.3.0 && < 1.3
|
, text >= 1.2.3.0 && < 1.3
|
||||||
|
|
||||||
|
|
|
@ -110,6 +110,7 @@ import Servant.API.ReqBody
|
||||||
(ReqBody, ReqBody')
|
(ReqBody, ReqBody')
|
||||||
import Servant.API.ResponseHeaders
|
import Servant.API.ResponseHeaders
|
||||||
(AddHeader, BuildHeadersTo (buildHeadersTo),
|
(AddHeader, BuildHeadersTo (buildHeadersTo),
|
||||||
|
DynHeaders(..), DynResponse(..), withDynHeaders,
|
||||||
GetHeaders (getHeaders), HList (..), Headers (..),
|
GetHeaders (getHeaders), HList (..), Headers (..),
|
||||||
ResponseHeader (..), addHeader, getHeadersHList, getResponse,
|
ResponseHeader (..), addHeader, getHeadersHList, getResponse,
|
||||||
noHeader)
|
noHeader)
|
||||||
|
|
|
@ -34,6 +34,7 @@ type ComprehensiveAPIWithoutRaw =
|
||||||
ReqBody '[JSON] Int :> GET :<|>
|
ReqBody '[JSON] Int :> GET :<|>
|
||||||
ReqBody' '[Lenient] '[JSON] Int :> GET :<|>
|
ReqBody' '[Lenient] '[JSON] Int :> GET :<|>
|
||||||
Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>
|
Get '[JSON] (Headers '[Header "foo" Int] NoContent) :<|>
|
||||||
|
Get '[JSON] (DynHeaders NoContent) :<|>
|
||||||
"foo" :> GET :<|>
|
"foo" :> GET :<|>
|
||||||
Vault :> GET :<|>
|
Vault :> GET :<|>
|
||||||
Verb 'POST 204 '[JSON] NoContent :<|>
|
Verb 'POST 204 '[JSON] NoContent :<|>
|
||||||
|
|
|
@ -23,7 +23,8 @@
|
||||||
-- The value is added to the header specified by the type (@Location@ in the
|
-- The value is added to the header specified by the type (@Location@ in the
|
||||||
-- example above).
|
-- example above).
|
||||||
module Servant.API.ResponseHeaders
|
module Servant.API.ResponseHeaders
|
||||||
( Headers(..)
|
( -- * "Static" response headers, tracked at the type-level
|
||||||
|
Headers(..)
|
||||||
, ResponseHeader (..)
|
, ResponseHeader (..)
|
||||||
, AddHeader
|
, AddHeader
|
||||||
, addHeader
|
, addHeader
|
||||||
|
@ -32,11 +33,18 @@ module Servant.API.ResponseHeaders
|
||||||
, GetHeaders(getHeaders)
|
, GetHeaders(getHeaders)
|
||||||
, HeaderValMap
|
, HeaderValMap
|
||||||
, HList(..)
|
, HList(..)
|
||||||
|
|
||||||
|
, -- * "Dynamic" response headers
|
||||||
|
DynHeaders(..)
|
||||||
|
, DynResponse(..)
|
||||||
|
, withDynHeaders
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.ByteString.Char8 as BS
|
import Data.ByteString.Char8 as BS
|
||||||
(ByteString, init, pack, unlines)
|
(ByteString, init, pack, unlines)
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
import Data.Map
|
||||||
|
(Map)
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
(Typeable)
|
(Typeable)
|
||||||
|
@ -51,8 +59,9 @@ import Prelude.Compat
|
||||||
import Servant.API.Header
|
import Servant.API.Header
|
||||||
(Header)
|
(Header)
|
||||||
|
|
||||||
-- | Response Header objects. You should never need to construct one directly.
|
-- | Response Header objects where each header name is tracked at the type-level.
|
||||||
-- Instead, use 'addOptionalHeader'.
|
-- You should never need to construct one directly. Instead, use
|
||||||
|
-- 'addOptionalHeader'.
|
||||||
data Headers ls a = Headers { getResponse :: a
|
data Headers ls a = Headers { getResponse :: a
|
||||||
-- ^ The underlying value of a 'Headers'
|
-- ^ The underlying value of a 'Headers'
|
||||||
, getHeadersHList :: HList ls
|
, getHeadersHList :: HList ls
|
||||||
|
@ -166,6 +175,25 @@ addHeader = addOptionalHeader . Header
|
||||||
noHeader :: AddHeader h v orig new => orig -> new
|
noHeader :: AddHeader h v orig new => orig -> new
|
||||||
noHeader = addOptionalHeader MissingHeader
|
noHeader = addOptionalHeader MissingHeader
|
||||||
|
|
||||||
|
-- | Combinator to use when you want your endpoint to return a response
|
||||||
|
-- along with some response headers, dynamically,
|
||||||
|
-- by simply building a value of type 'DynResponse a', which is just a
|
||||||
|
-- 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
|
||||||
|
-- has no effect and behaves just as if you were using @a@ directly.
|
||||||
|
data DynHeaders a
|
||||||
|
|
||||||
|
data DynResponse a = DynResponse
|
||||||
|
{ dynResponse :: a
|
||||||
|
, dynHeaders :: Map HTTP.HeaderName ByteString
|
||||||
|
} deriving (Typeable, Eq, Show, Functor)
|
||||||
|
|
||||||
|
-- | Build a \"response with headers\", where the headers are
|
||||||
|
-- provided at runtime as a 'Map' from header name to header value.
|
||||||
|
withDynHeaders :: a -> Map HTTP.HeaderName ByteString -> DynResponse a
|
||||||
|
withDynHeaders = DynResponse
|
||||||
|
|
||||||
-- $setup
|
-- $setup
|
||||||
-- >>> import Servant.API
|
-- >>> import Servant.API
|
||||||
-- >>> import Data.Aeson
|
-- >>> import Data.Aeson
|
||||||
|
|
Loading…
Reference in a new issue