Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

WIP: Issue 841: Rework of Verb #969

Closed
wants to merge 8 commits into from
Closed

WIP: Issue 841: Rework of Verb #969

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
8 commits
Select commit Hold shift + click to select a range
98f86ca
Refactor servant. Stream stuff not included
phadej Apr 17, 2018
31e8a57
Issue 841: Refactor servant-server
phadej Jun 2, 2018
5b5c4c0
WIP: servant-client
phadej Jun 11, 2018
9744f78
fixup! Refactor servant. Stream stuff not included
phadej Jun 23, 2018
f2296eb
fixup! Issue 841: Refactor servant-server
phadej Jun 23, 2018
b71ae74
squash! Refactor servant. Stream stuff not included
phadej Jun 23, 2018
fc167c3
fixup! Issue 841: Refactor servant-server
phadej Jun 23, 2018
e71bb90
WIP servant-client
phadej Jun 23, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
194 changes: 96 additions & 98 deletions servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
Expand All @@ -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
Expand Down Expand Up @@ -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@,
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
20 changes: 20 additions & 0 deletions servant-client-core/src/Servant/Client/Core/Internal/RunClient.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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)
Expand Down
Loading