diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal
index 1d15594f3..1dd23c1ac 100644
--- a/servant-client-core/servant-client-core.cabal
+++ b/servant-client-core/servant-client-core.cabal
@@ -44,6 +44,8 @@ library
other-modules:
Servant.Client.Core.Internal
+ Servant.Client.Core.HasClient.Internal
+ Servant.Client.Core.HasClient.TypeErrors
-- Bundled with GHC: Lower bound to not force re-installs
-- text and mtl are bundled starting with GHC-8.4
diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs
index fe2a15f87..7c30115bf 100644
--- a/servant-client-core/src/Servant/Client/Core/HasClient.hs
+++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs
@@ -1,993 +1,8 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE QuantifiedConstraints #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Servant.Client.Core.HasClient (
- clientIn,
- HasClient (..),
- EmptyClient (..),
- AsClientT,
- (//),
- (/:),
- foldMapUnion,
- matchUnion,
- ) where
-
-import Prelude ()
-import Prelude.Compat
-
-import Control.Arrow
- (left, (+++))
-import Control.Monad
- (unless)
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BL
-import Data.Either
- (partitionEithers)
-import Data.Constraint (Dict(..))
-import Data.Foldable
- (toList)
-import Data.List
- (foldl')
-import Data.Sequence
- (fromList)
-import qualified Data.Text as T
-import Network.HTTP.Media
- (MediaType, matches, parseAccept)
-import qualified Network.HTTP.Media as Media
-import qualified Data.Sequence as Seq
-import Data.SOP.BasicFunctors
- (I (I), (:.:) (Comp))
-import Data.SOP.Constraint
- (All)
-import Data.SOP.NP
- (NP (..), cpure_NP)
-import Data.SOP.NS
- (NS (S))
-import Data.String
- (fromString)
-import Data.Text
- (Text, pack)
-import Data.Proxy
- (Proxy (Proxy))
-import GHC.TypeLits
- (KnownNat, KnownSymbol, TypeError, symbolVal)
-import Network.HTTP.Types
- (Status)
-import qualified Network.HTTP.Types as H
-import Servant.API
- ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
- BuildHeadersTo (..), Capture', CaptureAll, Description,
- EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
- FromSourceIO (..), Header', Headers (..), HttpVersion,
- IsSecure, MimeRender (mimeRender),
- MimeUnrender (mimeUnrender), NoContent (NoContent),
- NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
- ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
- StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
- Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
- getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
-import Servant.API.Generic
- (GenericMode(..), ToServant, ToServantApi
- , GenericServant, toServant, fromServant)
-import Servant.API.ContentTypes
- (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
-import Servant.API.Status
- (statusFromNat)
-import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
-import Servant.API.Modifiers
- (FoldRequired, RequiredArgument, foldRequiredArgument)
-import Servant.API.TypeErrors
-import Servant.API.UVerb
- (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
-
-import Servant.Client.Core.Auth
-import Servant.Client.Core.BasicAuth
-import Servant.Client.Core.ClientError
-import Servant.Client.Core.Request
-import Servant.Client.Core.Response
-import Servant.Client.Core.RunClient
-
--- * Accessing APIs as a Client
-
--- | 'clientIn' allows you to produce operations to query an API from a client
--- within a 'RunClient' monad.
---
--- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
--- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
--- >
--- > myApi :: Proxy MyApi
--- > myApi = Proxy
--- >
--- > clientM :: Proxy ClientM
--- > clientM = Proxy
--- >
--- > getAllBooks :: ClientM [Book]
--- > postNewBook :: Book -> ClientM Book
--- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM
-clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api
-clientIn p pm = clientWithRoute pm p defaultRequest
-
-
--- | This class lets us define how each API combinator influences the creation
--- of an HTTP request.
---
--- Unless you are writing a new backend for @servant-client-core@ or new
--- combinators that you want to support client-generation, you can ignore this
--- class.
-class RunClient m => HasClient m api where
- type Client (m :: * -> *) (api :: *) :: *
- clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api
- hoistClientMonad
- :: Proxy m
- -> Proxy api
- -> (forall x. mon x -> mon' x)
- -> Client mon api
- -> Client mon' api
-
-
--- | A client querying function for @a ':<|>' b@ will actually hand you
--- one function for querying @a@ and another one for querying @b@,
--- stitching them together with ':<|>', which really is just like a pair.
---
--- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
--- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
--- >
--- > myApi :: Proxy MyApi
--- > myApi = Proxy
--- >
--- > getAllBooks :: ClientM [Book]
--- > postNewBook :: Book -> ClientM Book
--- > (getAllBooks :<|> postNewBook) = client myApi
-instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where
- type Client m (a :<|> b) = Client m a :<|> Client m b
- clientWithRoute pm Proxy req =
- clientWithRoute pm (Proxy :: Proxy a) req :<|>
- clientWithRoute pm (Proxy :: Proxy b) req
-
- hoistClientMonad pm _ f (ca :<|> cb) =
- hoistClientMonad pm (Proxy :: Proxy a) f ca :<|>
- hoistClientMonad pm (Proxy :: Proxy b) f cb
-
--- | Singleton type representing a client for an empty API.
-data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
-
--- | The client for 'EmptyAPI' is simply 'EmptyClient'.
---
--- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books
--- > :<|> "nothing" :> EmptyAPI
--- >
--- > myApi :: Proxy MyApi
--- > myApi = Proxy
--- >
--- > getAllBooks :: ClientM [Book]
--- > (getAllBooks :<|> EmptyClient) = client myApi
-instance RunClient m => HasClient m EmptyAPI where
- type Client m EmptyAPI = EmptyClient
- clientWithRoute _pm Proxy _ = EmptyClient
- hoistClientMonad _ _ _ EmptyClient = EmptyClient
-
--- | If you use a 'Capture' in one of your endpoints in your API,
--- the corresponding querying function will automatically take
--- an additional argument of the type specified by your 'Capture'.
--- That function will take care of inserting a textual representation
--- of this value at the right place in the request path.
---
--- You can control how values for this type are turned into
--- text by specifying a 'ToHttpApiData' instance for your type.
---
--- Example:
---
--- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
--- >
--- > myApi :: Proxy MyApi
--- > myApi = Proxy
--- >
--- > getBook :: Text -> ClientM Book
--- > getBook = client myApi
--- > -- then you can just use "getBook" to query that endpoint
-instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
- => HasClient m (Capture' mods capture a :> api) where
-
- type Client m (Capture' mods capture a :> api) =
- a -> Client m api
-
- clientWithRoute pm Proxy req val =
- clientWithRoute pm (Proxy :: Proxy api)
- (appendToPath p req)
-
- where p = toEncodedUrlPiece val
-
- hoistClientMonad pm _ f cl = \a ->
- hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
-
--- | If you use a 'CaptureAll' in one of your endpoints in your API,
--- the corresponding querying function will automatically take an
--- additional argument of a list of the type specified by your
--- 'CaptureAll'. That function will take care of inserting a textual
--- representation of this value at the right place in the request
--- path.
---
--- You can control how these values are turned into text by specifying
--- a 'ToHttpApiData' instance of your type.
---
--- Example:
---
--- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
--- >
--- > myApi :: Proxy
--- > myApi = Proxy
---
--- > getSourceFile :: [Text] -> ClientM SourceFile
--- > getSourceFile = client myApi
--- > -- then you can use "getSourceFile" to query that endpoint
-instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
- => HasClient m (CaptureAll capture a :> sublayout) where
-
- type Client m (CaptureAll capture a :> sublayout) =
- [a] -> Client m sublayout
-
- clientWithRoute pm Proxy req vals =
- clientWithRoute pm (Proxy :: Proxy sublayout)
- (foldl' (flip appendToPath) req ps)
-
- where ps = map toEncodedUrlPiece vals
-
- 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)
- , KnownNat status
- ) => HasClient m (Verb method status cts' a) where
- type Client m (Verb method status cts' a) = m a
- clientWithRoute _pm Proxy req = do
- response <- runRequestAcceptStatus (Just [status]) req
- { requestAccept = fromList $ toList accept
- , requestMethod = method
- }
- response `decodedAs` (Proxy :: Proxy ct)
- where
- accept = contentTypes (Proxy :: Proxy ct)
- method = reflectMethod (Proxy :: Proxy method)
- status = statusFromNat (Proxy :: Proxy status)
-
- hoistClientMonad _ _ f ma = f ma
-
-instance {-# OVERLAPPING #-}
- ( RunClient m, ReflectMethod method, KnownNat status
- ) => HasClient m (Verb method status cts NoContent) where
- type Client m (Verb method status cts NoContent)
- = m NoContent
- clientWithRoute _pm Proxy req = do
- _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
- return NoContent
- where method = reflectMethod (Proxy :: Proxy method)
- status = statusFromNat (Proxy :: Proxy status)
-
- hoistClientMonad _ _ f ma = f ma
-
-instance (RunClient m, ReflectMethod method) =>
- HasClient m (NoContentVerb method) where
- type Client m (NoContentVerb method)
- = 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 {-# OVERLAPPING #-}
- -- Note [Non-Empty Content Types]
- ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
- , 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 <- runRequestAcceptStatus (Just [status]) req
- { requestMethod = method
- , requestAccept = fromList $ toList accept
- }
- val <- response `decodedAs` (Proxy :: Proxy ct)
- return $ Headers { getResponse = val
- , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
- }
- where
- method = reflectMethod (Proxy :: Proxy method)
- accept = contentTypes (Proxy :: Proxy ct)
- status = statusFromNat (Proxy :: Proxy status)
-
- hoistClientMonad _ _ f ma = f ma
-
-instance {-# OVERLAPPING #-}
- ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
- ) => 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
- response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
- return $ Headers { getResponse = NoContent
- , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
- }
- where
- method = reflectMethod (Proxy :: Proxy method)
- status = statusFromNat (Proxy :: Proxy status)
-
- hoistClientMonad _ _ f ma = f ma
-
-data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
- deriving (Eq, Show)
-
-class UnrenderResponse (cts :: [*]) (a :: *) where
- unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
- -> [Either (MediaType, String) a]
-
-instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where
- unrenderResponse _ body = map parse . allMimeUnrender
- where parse (mediaType, parser) = left ((,) mediaType) (parser body)
-
-instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h)
- => UnrenderResponse cts (Headers h a) where
- unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body
- where
- setHeaders :: a -> Headers h a
- setHeaders x = Headers x (buildHeadersTo (toList hs))
-
-instance {-# OVERLAPPING #-} UnrenderResponse cts a
- => UnrenderResponse cts (WithStatus n a) where
- unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body
-
-instance {-# OVERLAPPING #-}
- ( RunClient m,
- contentTypes ~ (contentType ': otherContentTypes),
- -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem
- -- allow this in instance types as of 8.8.3.)
- as ~ (a ': as'),
- AllMime contentTypes,
- ReflectMethod method,
- All (UnrenderResponse contentTypes) as,
- All HasStatus as, HasStatuses as',
- Unique (Statuses as)
- ) =>
- HasClient m (UVerb method contentTypes as)
- where
- type Client m (UVerb method contentTypes as) = m (Union as)
-
- clientWithRoute _ _ request = do
- let accept = Seq.fromList . allMime $ Proxy @contentTypes
- -- offering to accept all mime types listed in the api gives best compatibility. eg.,
- -- we might not own the server implementation, and the server may choose to support
- -- only part of the api.
-
- method = reflectMethod $ Proxy @method
- acceptStatus = statuses (Proxy @as)
- response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}
- responseContentType <- checkContentTypeHeader response
- unless (any (matches responseContentType) accept) $ do
- throwClientError $ UnsupportedContentType responseContentType response
-
- let status = responseStatusCode response
- body = responseBody response
- headers = responseHeaders response
- res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
- case res of
- Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
- Right x -> return x
- where
- -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the
- -- failures it encountered along the way
- -- TODO; better name, rewrite haddocs.
- tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)
- tryParsers _ Nil = Left [ClientNoMatchingStatus]
- tryParsers status (Comp x :* xs)
- | status == statusOf (Comp x) =
- case partitionEithers x of
- (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs
- (_, (res : _)) -> Right . inject . I $ res
- | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for
- (ClientStatusMismatch :) +++ S $ tryParsers status xs
-
- -- | Given a list of types, parses the given response body as each type
- mimeUnrenders ::
- forall cts xs.
- All (UnrenderResponse cts) xs =>
- Proxy cts ->
- Seq.Seq H.Header ->
- BL.ByteString ->
- NP ([] :.: Either (MediaType, String)) xs
- mimeUnrenders ctp headers body = cpure_NP
- (Proxy @(UnrenderResponse cts))
- (Comp . unrenderResponse headers body $ ctp)
-
- hoistClientMonad _ _ nt s = nt s
-
-instance {-# OVERLAPPABLE #-}
- ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
- FramingUnrender framing, FromSourceIO chunk a
- ) => HasClient m (Stream method status framing ct a) where
-
- type Client m (Stream method status framing ct a) = m a
-
- hoistClientMonad _ _ f ma = f ma
-
- clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
- let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
- framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
- return $ fromSourceIO $ framingUnrender' $ responseBody gres
- where
- req' = req
- { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
- , requestMethod = reflectMethod (Proxy :: Proxy method)
- }
-
-instance {-# OVERLAPPING #-}
- ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
- FramingUnrender framing, FromSourceIO chunk a,
- BuildHeadersTo hs
- ) => HasClient m (Stream method status framing ct (Headers hs a)) where
-
- type Client m (Stream method status framing ct (Headers hs a)) = m (Headers hs a)
-
- hoistClientMonad _ _ f ma = f ma
-
- clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
- let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
- framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
- val = fromSourceIO $ framingUnrender' $ responseBody gres
- return $ Headers
- { getResponse = val
- , getHeadersHList = buildHeadersTo . toList $ responseHeaders gres
- }
-
- where
- req' = req
- { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
- , requestMethod = reflectMethod (Proxy :: Proxy method)
- }
-
--- | If you use a 'Header' in one of your endpoints in your API,
--- the corresponding querying function will automatically take
--- an additional argument of the type specified by your 'Header',
--- wrapped in Maybe.
---
--- That function will take care of encoding this argument as Text
--- in the request headers.
---
--- All you need is for your type to have a 'ToHttpApiData' instance.
---
--- Example:
---
--- > newtype Referer = Referer { referrer :: Text }
--- > deriving (Eq, Show, Generic, ToHttpApiData)
--- >
--- > -- GET /view-my-referer
--- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
--- >
--- > myApi :: Proxy MyApi
--- > myApi = Proxy
--- >
--- > viewReferer :: Maybe Referer -> ClientM Book
--- > viewReferer = client myApi
--- > -- then you can just use "viewRefer" to query that endpoint
--- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
-instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
- => HasClient m (Header' mods sym a :> api) where
-
- type Client m (Header' mods sym a :> api) =
- RequiredArgument mods a -> Client m api
-
- clientWithRoute pm Proxy req mval =
- clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
- (Proxy :: Proxy mods) add (maybe req add) mval
- where
- hname = fromString $ symbolVal (Proxy :: Proxy sym)
-
- add :: a -> Request
- add value = addHeader hname value req
-
- hoistClientMonad pm _ f cl = \arg ->
- hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
-
--- | Using a 'HttpVersion' combinator in your API doesn't affect the client
--- functions.
-instance HasClient m api
- => HasClient m (HttpVersion :> api) where
-
- type Client m (HttpVersion :> api) =
- Client m api
-
- clientWithRoute pm Proxy =
- clientWithRoute pm (Proxy :: Proxy api)
-
- hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
-
--- | Ignore @'Summary'@ in client functions.
-instance HasClient m api => HasClient m (Summary desc :> api) where
- type Client m (Summary desc :> api) = Client m api
-
- clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
-
- hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
-
--- | Ignore @'Description'@ in client functions.
-instance HasClient m api => HasClient m (Description desc :> api) where
- type Client m (Description desc :> api) = Client m api
-
- clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
-
- hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
-
--- | If you use a 'QueryParam' in one of your endpoints in your API,
--- the corresponding querying function will automatically take
--- an additional argument of the type specified by your 'QueryParam',
--- enclosed in Maybe.
---
--- If you give Nothing, nothing will be added to the query string.
---
--- If you give a non-'Nothing' value, this function will take care
--- of inserting a textual representation of this value in the query string.
---
--- You can control how values for your type are turned into
--- text by specifying a 'ToHttpApiData' instance for your type.
---
--- Example:
---
--- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
--- >
--- > myApi :: Proxy MyApi
--- > myApi = Proxy
--- >
--- > getBooksBy :: Maybe Text -> ClientM [Book]
--- > getBooksBy = client myApi
--- > -- then you can just use "getBooksBy" to query that endpoint.
--- > -- 'getBooksBy Nothing' for all books
--- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
-instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
- => HasClient m (QueryParam' mods sym a :> api) where
-
- type Client m (QueryParam' mods sym a :> api) =
- RequiredArgument mods a -> Client m api
-
- -- if mparam = Nothing, we don't add it to the query string
- clientWithRoute pm Proxy req mparam =
- clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
- (Proxy :: Proxy mods) add (maybe req add) mparam
- where
- add :: a -> Request
- add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
-
- pname :: Text
- pname = pack $ symbolVal (Proxy :: Proxy sym)
-
- hoistClientMonad pm _ f cl = \arg ->
- hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
-
--- | If you use a 'QueryParams' in one of your endpoints in your API,
--- the corresponding querying function will automatically take
--- an additional argument, a list of values of the type specified
--- by your 'QueryParams'.
---
--- If you give an empty list, nothing will be added to the query string.
---
--- Otherwise, this function will take care
--- of inserting a textual representation of your values in the query string,
--- under the same query string parameter name.
---
--- You can control how values for your type are turned into
--- text by specifying a 'ToHttpApiData' instance for your type.
---
--- Example:
---
--- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
--- >
--- > myApi :: Proxy MyApi
--- > myApi = Proxy
--- >
--- > getBooksBy :: [Text] -> ClientM [Book]
--- > getBooksBy = client myApi
--- > -- then you can just use "getBooksBy" to query that endpoint.
--- > -- 'getBooksBy []' for all books
--- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
--- > -- to get all books by Asimov and Heinlein
-instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
- => HasClient m (QueryParams sym a :> api) where
-
- type Client m (QueryParams sym a :> api) =
- [a] -> Client m api
-
- clientWithRoute pm Proxy req paramlist =
- clientWithRoute pm (Proxy :: Proxy api)
- (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
- req
- paramlist'
- )
-
- where pname = pack $ symbolVal (Proxy :: Proxy sym)
- paramlist' = map (Just . encodeQueryParamValue) paramlist
-
- hoistClientMonad pm _ f cl = \as ->
- hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
-
--- | If you use a 'QueryFlag' in one of your endpoints in your API,
--- the corresponding querying function will automatically take
--- an additional 'Bool' argument.
---
--- If you give 'False', nothing will be added to the query string.
---
--- Otherwise, this function will insert a value-less query string
--- parameter under the name associated to your 'QueryFlag'.
---
--- Example:
---
--- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
--- >
--- > myApi :: Proxy MyApi
--- > myApi = Proxy
--- >
--- > getBooks :: Bool -> ClientM [Book]
--- > getBooks = client myApi
--- > -- then you can just use "getBooks" to query that endpoint.
--- > -- 'getBooksBy False' for all books
--- > -- 'getBooksBy True' to only get _already published_ books
-instance (KnownSymbol sym, HasClient m api)
- => HasClient m (QueryFlag sym :> api) where
-
- type Client m (QueryFlag sym :> api) =
- Bool -> Client m api
-
- clientWithRoute pm Proxy req flag =
- clientWithRoute pm (Proxy :: Proxy api)
- (if flag
- then appendToQueryString paramname Nothing req
- else req
- )
-
- where paramname = pack $ symbolVal (Proxy :: Proxy sym)
-
- hoistClientMonad pm _ f cl = \b ->
- hoistClientMonad pm (Proxy :: Proxy api) f (cl b)
-
--- | Pick a 'Method' and specify where the server you want to query is. You get
--- back the full `Response`.
-instance RunClient m => HasClient m Raw where
- type Client m Raw
- = H.Method -> m Response
-
- clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw
- clientWithRoute _pm Proxy req httpMethod = do
- runRequest req { requestMethod = httpMethod }
-
- hoistClientMonad _ _ f cl = \meth -> f (cl meth)
-
--- | If you use a 'ReqBody' in one of your endpoints in your API,
--- the corresponding querying function will automatically take
--- an additional argument of the type specified by your 'ReqBody'.
--- That function will take care of encoding this argument as JSON and
--- of using it as the request body.
---
--- All you need is for your type to have a 'ToJSON' instance.
---
--- Example:
---
--- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
--- >
--- > myApi :: Proxy MyApi
--- > myApi = Proxy
--- >
--- > addBook :: Book -> ClientM Book
--- > addBook = client myApi
--- > -- then you can just use "addBook" to query that endpoint
-instance (MimeRender ct a, HasClient m api)
- => HasClient m (ReqBody' mods (ct ': cts) a :> api) where
-
- type Client m (ReqBody' mods (ct ': cts) a :> api) =
- a -> Client m api
-
- clientWithRoute pm Proxy req body =
- clientWithRoute pm (Proxy :: Proxy api)
- (let ctProxy = Proxy :: Proxy ct
- in setRequestBodyLBS (mimeRender ctProxy body)
- -- We use first contentType from the Accept list
- (contentType ctProxy)
- req
- )
-
- hoistClientMonad pm _ f cl = \a ->
- hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
-
-instance
- ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
- ) => HasClient m (StreamBody' mods framing ctype a :> api)
- where
-
- type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api
-
- hoistClientMonad pm _ f cl = \a ->
- hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
-
- clientWithRoute pm Proxy req body
- = clientWithRoute pm (Proxy :: Proxy api)
- $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req
- where
- ctypeP = Proxy :: Proxy ctype
- framingP = Proxy :: Proxy framing
-
- sourceIO = framingRender
- framingP
- (mimeRender ctypeP :: chunk -> BL.ByteString)
- (toSourceIO body)
-
--- | Make the querying function append @path@ to the request path.
-instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
- type Client m (path :> api) = Client m api
-
- clientWithRoute pm Proxy req =
- clientWithRoute pm (Proxy :: Proxy api)
- (appendToPath p req)
-
- where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
-
- hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
-
-instance HasClient m api => HasClient m (Vault :> api) where
- type Client m (Vault :> api) = Client m api
-
- clientWithRoute pm Proxy req =
- clientWithRoute pm (Proxy :: Proxy api) req
-
- hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
-
-instance HasClient m api => HasClient m (RemoteHost :> api) where
- type Client m (RemoteHost :> api) = Client m api
-
- clientWithRoute pm Proxy req =
- clientWithRoute pm (Proxy :: Proxy api) req
-
- hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
-
-instance HasClient m api => HasClient m (IsSecure :> api) where
- type Client m (IsSecure :> api) = Client m api
-
- clientWithRoute pm Proxy req =
- clientWithRoute pm (Proxy :: Proxy api) req
-
- hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
-
-instance HasClient m subapi =>
- HasClient m (WithNamedContext name context subapi) where
-
- type Client m (WithNamedContext name context subapi) = Client m subapi
- clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
-
- hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
-
-instance ( HasClient m api
- ) => HasClient m (AuthProtect tag :> api) where
- type Client m (AuthProtect tag :> api)
- = AuthenticatedRequest (AuthProtect tag) -> Client m api
-
- clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =
- clientWithRoute pm (Proxy :: Proxy api) (func val req)
-
- hoistClientMonad pm _ f cl = \authreq ->
- hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
-
--- | Ignore @'Fragment'@ in client functions.
--- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
---
--- Example:
---
--- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
--- >
--- > myApi :: Proxy MyApi
--- > myApi = Proxy
--- >
--- > getBooks :: ClientM [Book]
--- > getBooks = client myApi
--- > -- then you can just use "getBooksBy" to query that endpoint.
--- > -- 'getBooks' for all books.
-instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
- ) => HasClient m (Fragment a :> api) where
-
- type Client m (Fragment a :> api) = Client m api
-
- clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
-
- hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
-
--- * Basic Authentication
-
-instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
- type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api
-
- clientWithRoute pm Proxy req val =
- clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)
-
- hoistClientMonad pm _ f cl = \bauth ->
- hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
-
--- | A type that specifies that an API record contains a client implementation.
-data AsClientT (m :: * -> *)
-instance GenericMode (AsClientT m) where
- type AsClientT m :- api = Client m api
-
-
-type GClientConstraints api m =
- ( GenericServant api (AsClientT m)
- , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
- )
-
-class GClient (api :: * -> *) m where
- gClientProof :: Dict (GClientConstraints api m)
-
-instance GClientConstraints api m => GClient api m where
- gClientProof = Dict
-
-instance
- ( forall n. GClient api n
- , HasClient m (ToServantApi api)
- , RunClient m
- )
- => HasClient m (NamedRoutes api) where
- type Client m (NamedRoutes api) = api (AsClientT m)
-
- clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
- clientWithRoute pm _ request =
- case gClientProof @api @m of
- Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
-
- hoistClientMonad
- :: forall ma mb.
- Proxy m
- -> Proxy (NamedRoutes api)
- -> (forall x. ma x -> mb x)
- -> Client ma (NamedRoutes api)
- -> Client mb (NamedRoutes api)
- hoistClientMonad _ _ nat clientA =
- case (gClientProof @api @ma, gClientProof @api @mb) of
- (Dict, Dict) ->
- fromServant @api @(AsClientT mb) $
- hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
- toServant @api @(AsClientT ma) clientA
-
-infixl 1 //
-infixl 2 /:
-
--- | Helper to make code using records of clients more readable.
---
--- Can be mixed with (/:) for supplying arguments.
---
--- Example:
---
--- @
--- type Api = NamedRoutes RootApi
---
--- data RootApi mode = RootApi
--- { subApi :: mode :- NamedRoutes SubApi
--- , …
--- } deriving Generic
---
--- data SubApi mode = SubApi
--- { endpoint :: mode :- Get '[JSON] Person
--- , …
--- } deriving Generic
---
--- api :: Proxy API
--- api = Proxy
---
--- rootClient :: RootApi (AsClientT ClientM)
--- rootClient = client api
---
--- endpointClient :: ClientM Person
--- endpointClient = client // subApi // endpoint
--- @
-(//) :: a -> (a -> b) -> b
-x // f = f x
-
--- | Convenience function for supplying arguments to client functions when
--- working with records of clients.
---
--- Intended to be used in conjunction with '(//)'.
---
--- Example:
---
--- @
--- type Api = NamedRoutes RootApi
---
--- data RootApi mode = RootApi
--- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
--- , hello :: mode :- Capture "name" String :> Get '[JSON] String
--- , …
--- } deriving Generic
---
--- data SubApi mode = SubApi
--- { endpoint :: mode :- Get '[JSON] Person
--- , …
--- } deriving Generic
---
--- api :: Proxy API
--- api = Proxy
---
--- rootClient :: RootApi (AsClientT ClientM)
--- rootClient = client api
---
--- hello :: String -> ClientM String
--- hello name = rootClient // hello /: name
---
--- endpointClient :: ClientM Person
--- endpointClient = client // subApi /: "foobar123" // endpoint
--- @
-(/:) :: (a -> b -> c) -> b -> a -> c
-(/:) = flip
-
-
-{- Note [Non-Empty Content Types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Rather than have
-
- instance (..., cts' ~ (ct ': cts)) => ... cts' ...
-
-It may seem to make more sense to have:
-
- instance (...) => ... (ct ': cts) ...
-
-But this means that if another instance exists that does *not* require
-non-empty lists, but is otherwise more specific, no instance will be overall
-more specific. This in turn generally means adding yet another instance (one
-for empty and one for non-empty lists).
--}
-
--------------------------------------------------------------------------------
--- helpers
--------------------------------------------------------------------------------
-
-checkContentTypeHeader :: RunClient m => Response -> m MediaType
-checkContentTypeHeader response =
- case lookup "Content-Type" $ toList $ responseHeaders response of
- Nothing -> return $ "application" Media.// "octet-stream"
- Just t -> case parseAccept t of
- Nothing -> throwClientError $ InvalidContentTypeHeader response
- Just t' -> return t'
-
-decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
- => Response -> Proxy ct -> m a
-decodedAs response ct = do
- responseContentType <- checkContentTypeHeader response
- unless (any (matches responseContentType) accept) $
- throwClientError $ UnsupportedContentType responseContentType response
- case mimeUnrender ct $ responseBody response of
- Left err -> throwClientError $ DecodeFailure (T.pack err) response
- Right val -> return val
- where
- accept = toList $ contentTypes ct
-
--------------------------------------------------------------------------------
--- Custom type errors
--------------------------------------------------------------------------------
-
--- Erroring instance for HasClient' when a combinator is not fully applied
-instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)
- where
- type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
- clientWithRoute _ _ _ = error "unreachable"
- hoistClientMonad _ _ _ _ = error "unreachable"
-
--- Erroring instances for 'HasClient' for unknown API combinators
-instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
-
-instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api
+-- | Wrapper for Servant.Client.Core.HasClient.Internal, which brings in scope the
+-- instance declarations in Servant.Client.Core.HasClient.TypeErrors
+module Servant.Client.Core.HasClient
+ ( module Servant.Client.Core.HasClient.Internal
+ ) where
+
+import Servant.Client.Core.HasClient.Internal
+import Servant.Client.Core.HasClient.TypeErrors ()
diff --git a/servant-client-core/src/Servant/Client/Core/HasClient/Internal.hs b/servant-client-core/src/Servant/Client/Core/HasClient/Internal.hs
new file mode 100644
index 000000000..e4db171eb
--- /dev/null
+++ b/servant-client-core/src/Servant/Client/Core/HasClient/Internal.hs
@@ -0,0 +1,975 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Servant.Client.Core.HasClient.Internal (
+ clientIn,
+ HasClient (..),
+ EmptyClient (..),
+ AsClientT,
+ (//),
+ (/:),
+ foldMapUnion,
+ matchUnion,
+ ) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.Arrow
+ (left, (+++))
+import Control.Monad
+ (unless)
+import qualified Data.ByteString.Lazy as BL
+import Data.Either
+ (partitionEithers)
+import Data.Constraint (Dict(..))
+import Data.Foldable
+ (toList)
+import Data.List
+ (foldl')
+import Data.Sequence
+ (fromList)
+import qualified Data.Text as T
+import Network.HTTP.Media
+ (MediaType, matches, parseAccept)
+import qualified Network.HTTP.Media as Media
+import qualified Data.Sequence as Seq
+import Data.SOP.BasicFunctors
+ (I (I), (:.:) (Comp))
+import Data.SOP.Constraint
+ (All)
+import Data.SOP.NP
+ (NP (..), cpure_NP)
+import Data.SOP.NS
+ (NS (S))
+import Data.String
+ (fromString)
+import Data.Text
+ (Text, pack)
+import Data.Proxy
+ (Proxy (Proxy))
+import GHC.TypeLits
+ (KnownNat, KnownSymbol, symbolVal)
+import Network.HTTP.Types
+ (Status)
+import qualified Network.HTTP.Types as H
+import Servant.API
+ ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
+ BuildHeadersTo (..), Capture', CaptureAll, Description,
+ EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
+ FromSourceIO (..), Header', Headers (..), HttpVersion,
+ IsSecure, MimeRender (mimeRender),
+ MimeUnrender (mimeUnrender), NoContent (NoContent),
+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
+ ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
+ StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
+ Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
+ getResponse, toEncodedUrlPiece, NamedRoutes)
+import Servant.API.Generic
+ (GenericMode(..), ToServant, ToServantApi
+ , GenericServant, toServant, fromServant)
+import Servant.API.ContentTypes
+ (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
+import Servant.API.Status
+ (statusFromNat)
+import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
+import Servant.API.Modifiers
+ (FoldRequired, RequiredArgument, foldRequiredArgument)
+import Servant.API.UVerb
+ (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
+
+import Servant.Client.Core.Auth
+import Servant.Client.Core.BasicAuth
+import Servant.Client.Core.ClientError
+import Servant.Client.Core.Request
+import Servant.Client.Core.Response
+import Servant.Client.Core.RunClient
+
+-- * Accessing APIs as a Client
+
+-- | 'clientIn' allows you to produce operations to query an API from a client
+-- within a 'RunClient' monad.
+--
+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > clientM :: Proxy ClientM
+-- > clientM = Proxy
+-- >
+-- > getAllBooks :: ClientM [Book]
+-- > postNewBook :: Book -> ClientM Book
+-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM
+clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api
+clientIn p pm = clientWithRoute pm p defaultRequest
+
+
+-- | This class lets us define how each API combinator influences the creation
+-- of an HTTP request.
+--
+-- Unless you are writing a new backend for @servant-client-core@ or new
+-- combinators that you want to support client-generation, you can ignore this
+-- class.
+class RunClient m => HasClient m api where
+ type Client (m :: * -> *) (api :: *) :: *
+ clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api
+ hoistClientMonad
+ :: Proxy m
+ -> Proxy api
+ -> (forall x. mon x -> mon' x)
+ -> Client mon api
+ -> Client mon' api
+
+
+-- | A client querying function for @a ':<|>' b@ will actually hand you
+-- one function for querying @a@ and another one for querying @b@,
+-- stitching them together with ':<|>', which really is just like a pair.
+--
+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getAllBooks :: ClientM [Book]
+-- > postNewBook :: Book -> ClientM Book
+-- > (getAllBooks :<|> postNewBook) = client myApi
+instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where
+ type Client m (a :<|> b) = Client m a :<|> Client m b
+ clientWithRoute pm Proxy req =
+ clientWithRoute pm (Proxy :: Proxy a) req :<|>
+ clientWithRoute pm (Proxy :: Proxy b) req
+
+ hoistClientMonad pm _ f (ca :<|> cb) =
+ hoistClientMonad pm (Proxy :: Proxy a) f ca :<|>
+ hoistClientMonad pm (Proxy :: Proxy b) f cb
+
+-- | Singleton type representing a client for an empty API.
+data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
+
+-- | The client for 'EmptyAPI' is simply 'EmptyClient'.
+--
+-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books
+-- > :<|> "nothing" :> EmptyAPI
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getAllBooks :: ClientM [Book]
+-- > (getAllBooks :<|> EmptyClient) = client myApi
+instance RunClient m => HasClient m EmptyAPI where
+ type Client m EmptyAPI = EmptyClient
+ clientWithRoute _pm Proxy _ = EmptyClient
+ hoistClientMonad _ _ _ EmptyClient = EmptyClient
+
+-- | If you use a 'Capture' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional argument of the type specified by your 'Capture'.
+-- That function will take care of inserting a textual representation
+-- of this value at the right place in the request path.
+--
+-- You can control how values for this type are turned into
+-- text by specifying a 'ToHttpApiData' instance for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBook :: Text -> ClientM Book
+-- > getBook = client myApi
+-- > -- then you can just use "getBook" to query that endpoint
+instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
+ => HasClient m (Capture' mods capture a :> api) where
+
+ type Client m (Capture' mods capture a :> api) =
+ a -> Client m api
+
+ clientWithRoute pm Proxy req val =
+ clientWithRoute pm (Proxy :: Proxy api)
+ (appendToPath p req)
+
+ where p = toEncodedUrlPiece val
+
+ hoistClientMonad pm _ f cl = \a ->
+ hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
+
+-- | If you use a 'CaptureAll' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take an
+-- additional argument of a list of the type specified by your
+-- 'CaptureAll'. That function will take care of inserting a textual
+-- representation of this value at the right place in the request
+-- path.
+--
+-- You can control how these values are turned into text by specifying
+-- a 'ToHttpApiData' instance of your type.
+--
+-- Example:
+--
+-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
+-- >
+-- > myApi :: Proxy
+-- > myApi = Proxy
+--
+-- > getSourceFile :: [Text] -> ClientM SourceFile
+-- > getSourceFile = client myApi
+-- > -- then you can use "getSourceFile" to query that endpoint
+instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
+ => HasClient m (CaptureAll capture a :> sublayout) where
+
+ type Client m (CaptureAll capture a :> sublayout) =
+ [a] -> Client m sublayout
+
+ clientWithRoute pm Proxy req vals =
+ clientWithRoute pm (Proxy :: Proxy sublayout)
+ (foldl' (flip appendToPath) req ps)
+
+ where ps = map toEncodedUrlPiece vals
+
+ 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)
+ , KnownNat status
+ ) => HasClient m (Verb method status cts' a) where
+ type Client m (Verb method status cts' a) = m a
+ clientWithRoute _pm Proxy req = do
+ response <- runRequestAcceptStatus (Just [status]) req
+ { requestAccept = fromList $ toList accept
+ , requestMethod = method
+ }
+ response `decodedAs` (Proxy :: Proxy ct)
+ where
+ accept = contentTypes (Proxy :: Proxy ct)
+ method = reflectMethod (Proxy :: Proxy method)
+ status = statusFromNat (Proxy :: Proxy status)
+
+ hoistClientMonad _ _ f ma = f ma
+
+instance {-# OVERLAPPING #-}
+ ( RunClient m, ReflectMethod method, KnownNat status
+ ) => HasClient m (Verb method status cts NoContent) where
+ type Client m (Verb method status cts NoContent)
+ = m NoContent
+ clientWithRoute _pm Proxy req = do
+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
+ return NoContent
+ where method = reflectMethod (Proxy :: Proxy method)
+ status = statusFromNat (Proxy :: Proxy status)
+
+ hoistClientMonad _ _ f ma = f ma
+
+instance (RunClient m, ReflectMethod method) =>
+ HasClient m (NoContentVerb method) where
+ type Client m (NoContentVerb method)
+ = 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 {-# OVERLAPPING #-}
+ -- Note [Non-Empty Content Types]
+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
+ , 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 <- runRequestAcceptStatus (Just [status]) req
+ { requestMethod = method
+ , requestAccept = fromList $ toList accept
+ }
+ val <- response `decodedAs` (Proxy :: Proxy ct)
+ return $ Headers { getResponse = val
+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
+ }
+ where
+ method = reflectMethod (Proxy :: Proxy method)
+ accept = contentTypes (Proxy :: Proxy ct)
+ status = statusFromNat (Proxy :: Proxy status)
+
+ hoistClientMonad _ _ f ma = f ma
+
+instance {-# OVERLAPPING #-}
+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
+ ) => 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
+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
+ return $ Headers { getResponse = NoContent
+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
+ }
+ where
+ method = reflectMethod (Proxy :: Proxy method)
+ status = statusFromNat (Proxy :: Proxy status)
+
+ hoistClientMonad _ _ f ma = f ma
+
+data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
+ deriving (Eq, Show)
+
+class UnrenderResponse (cts :: [*]) (a :: *) where
+ unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
+ -> [Either (MediaType, String) a]
+
+instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where
+ unrenderResponse _ body = map parse . allMimeUnrender
+ where parse (mediaType, parser) = left ((,) mediaType) (parser body)
+
+instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h)
+ => UnrenderResponse cts (Headers h a) where
+ unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body
+ where
+ setHeaders :: a -> Headers h a
+ setHeaders x = Headers x (buildHeadersTo (toList hs))
+
+instance {-# OVERLAPPING #-} UnrenderResponse cts a
+ => UnrenderResponse cts (WithStatus n a) where
+ unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body
+
+instance {-# OVERLAPPING #-}
+ ( RunClient m,
+ contentTypes ~ (contentType ': otherContentTypes),
+ -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem
+ -- allow this in instance types as of 8.8.3.)
+ as ~ (a ': as'),
+ AllMime contentTypes,
+ ReflectMethod method,
+ All (UnrenderResponse contentTypes) as,
+ All HasStatus as, HasStatuses as',
+ Unique (Statuses as)
+ ) =>
+ HasClient m (UVerb method contentTypes as)
+ where
+ type Client m (UVerb method contentTypes as) = m (Union as)
+
+ clientWithRoute _ _ request = do
+ let accept = Seq.fromList . allMime $ Proxy @contentTypes
+ -- offering to accept all mime types listed in the api gives best compatibility. eg.,
+ -- we might not own the server implementation, and the server may choose to support
+ -- only part of the api.
+
+ method = reflectMethod $ Proxy @method
+ acceptStatus = statuses (Proxy @as)
+ response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}
+ responseContentType <- checkContentTypeHeader response
+ unless (any (matches responseContentType) accept) $ do
+ throwClientError $ UnsupportedContentType responseContentType response
+
+ let status = responseStatusCode response
+ body = responseBody response
+ headers = responseHeaders response
+ res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
+ case res of
+ Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
+ Right x -> return x
+ where
+ -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the
+ -- failures it encountered along the way
+ -- TODO; better name, rewrite haddocs.
+ tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)
+ tryParsers _ Nil = Left [ClientNoMatchingStatus]
+ tryParsers status (Comp x :* xs)
+ | status == statusOf (Comp x) =
+ case partitionEithers x of
+ (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs
+ (_, (res : _)) -> Right . inject . I $ res
+ | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for
+ (ClientStatusMismatch :) +++ S $ tryParsers status xs
+
+ -- | Given a list of types, parses the given response body as each type
+ mimeUnrenders ::
+ forall cts xs.
+ All (UnrenderResponse cts) xs =>
+ Proxy cts ->
+ Seq.Seq H.Header ->
+ BL.ByteString ->
+ NP ([] :.: Either (MediaType, String)) xs
+ mimeUnrenders ctp headers body = cpure_NP
+ (Proxy @(UnrenderResponse cts))
+ (Comp . unrenderResponse headers body $ ctp)
+
+ hoistClientMonad _ _ nt s = nt s
+
+instance {-# OVERLAPPABLE #-}
+ ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
+ FramingUnrender framing, FromSourceIO chunk a
+ ) => HasClient m (Stream method status framing ct a) where
+
+ type Client m (Stream method status framing ct a) = m a
+
+ hoistClientMonad _ _ f ma = f ma
+
+ clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
+ let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
+ framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
+ return $ fromSourceIO $ framingUnrender' $ responseBody gres
+ where
+ req' = req
+ { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
+ , requestMethod = reflectMethod (Proxy :: Proxy method)
+ }
+
+instance {-# OVERLAPPING #-}
+ ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
+ FramingUnrender framing, FromSourceIO chunk a,
+ BuildHeadersTo hs
+ ) => HasClient m (Stream method status framing ct (Headers hs a)) where
+
+ type Client m (Stream method status framing ct (Headers hs a)) = m (Headers hs a)
+
+ hoistClientMonad _ _ f ma = f ma
+
+ clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
+ let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
+ framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
+ val = fromSourceIO $ framingUnrender' $ responseBody gres
+ return $ Headers
+ { getResponse = val
+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders gres
+ }
+
+ where
+ req' = req
+ { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
+ , requestMethod = reflectMethod (Proxy :: Proxy method)
+ }
+
+-- | If you use a 'Header' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional argument of the type specified by your 'Header',
+-- wrapped in Maybe.
+--
+-- That function will take care of encoding this argument as Text
+-- in the request headers.
+--
+-- All you need is for your type to have a 'ToHttpApiData' instance.
+--
+-- Example:
+--
+-- > newtype Referer = Referer { referrer :: Text }
+-- > deriving (Eq, Show, Generic, ToHttpApiData)
+-- >
+-- > -- GET /view-my-referer
+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > viewReferer :: Maybe Referer -> ClientM Book
+-- > viewReferer = client myApi
+-- > -- then you can just use "viewRefer" to query that endpoint
+-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
+ => HasClient m (Header' mods sym a :> api) where
+
+ type Client m (Header' mods sym a :> api) =
+ RequiredArgument mods a -> Client m api
+
+ clientWithRoute pm Proxy req mval =
+ clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
+ (Proxy :: Proxy mods) add (maybe req add) mval
+ where
+ hname = fromString $ symbolVal (Proxy :: Proxy sym)
+
+ add :: a -> Request
+ add value = addHeader hname value req
+
+ hoistClientMonad pm _ f cl = \arg ->
+ hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
+
+-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
+-- functions.
+instance HasClient m api
+ => HasClient m (HttpVersion :> api) where
+
+ type Client m (HttpVersion :> api) =
+ Client m api
+
+ clientWithRoute pm Proxy =
+ clientWithRoute pm (Proxy :: Proxy api)
+
+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
+-- | Ignore @'Summary'@ in client functions.
+instance HasClient m api => HasClient m (Summary desc :> api) where
+ type Client m (Summary desc :> api) = Client m api
+
+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
+
+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
+-- | Ignore @'Description'@ in client functions.
+instance HasClient m api => HasClient m (Description desc :> api) where
+ type Client m (Description desc :> api) = Client m api
+
+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
+
+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
+-- | If you use a 'QueryParam' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional argument of the type specified by your 'QueryParam',
+-- enclosed in Maybe.
+--
+-- If you give Nothing, nothing will be added to the query string.
+--
+-- If you give a non-'Nothing' value, this function will take care
+-- of inserting a textual representation of this value in the query string.
+--
+-- You can control how values for your type are turned into
+-- text by specifying a 'ToHttpApiData' instance for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooksBy :: Maybe Text -> ClientM [Book]
+-- > getBooksBy = client myApi
+-- > -- then you can just use "getBooksBy" to query that endpoint.
+-- > -- 'getBooksBy Nothing' for all books
+-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
+ => HasClient m (QueryParam' mods sym a :> api) where
+
+ type Client m (QueryParam' mods sym a :> api) =
+ RequiredArgument mods a -> Client m api
+
+ -- if mparam = Nothing, we don't add it to the query string
+ clientWithRoute pm Proxy req mparam =
+ clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
+ (Proxy :: Proxy mods) add (maybe req add) mparam
+ where
+ add :: a -> Request
+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
+
+ pname :: Text
+ pname = pack $ symbolVal (Proxy :: Proxy sym)
+
+ hoistClientMonad pm _ f cl = \arg ->
+ hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
+
+-- | If you use a 'QueryParams' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional argument, a list of values of the type specified
+-- by your 'QueryParams'.
+--
+-- If you give an empty list, nothing will be added to the query string.
+--
+-- Otherwise, this function will take care
+-- of inserting a textual representation of your values in the query string,
+-- under the same query string parameter name.
+--
+-- You can control how values for your type are turned into
+-- text by specifying a 'ToHttpApiData' instance for your type.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooksBy :: [Text] -> ClientM [Book]
+-- > getBooksBy = client myApi
+-- > -- then you can just use "getBooksBy" to query that endpoint.
+-- > -- 'getBooksBy []' for all books
+-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
+-- > -- to get all books by Asimov and Heinlein
+instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
+ => HasClient m (QueryParams sym a :> api) where
+
+ type Client m (QueryParams sym a :> api) =
+ [a] -> Client m api
+
+ clientWithRoute pm Proxy req paramlist =
+ clientWithRoute pm (Proxy :: Proxy api)
+ (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
+ req
+ paramlist'
+ )
+
+ where pname = pack $ symbolVal (Proxy :: Proxy sym)
+ paramlist' = map (Just . encodeQueryParamValue) paramlist
+
+ hoistClientMonad pm _ f cl = \as ->
+ hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
+
+-- | If you use a 'QueryFlag' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional 'Bool' argument.
+--
+-- If you give 'False', nothing will be added to the query string.
+--
+-- Otherwise, this function will insert a value-less query string
+-- parameter under the name associated to your 'QueryFlag'.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooks :: Bool -> ClientM [Book]
+-- > getBooks = client myApi
+-- > -- then you can just use "getBooks" to query that endpoint.
+-- > -- 'getBooksBy False' for all books
+-- > -- 'getBooksBy True' to only get _already published_ books
+instance (KnownSymbol sym, HasClient m api)
+ => HasClient m (QueryFlag sym :> api) where
+
+ type Client m (QueryFlag sym :> api) =
+ Bool -> Client m api
+
+ clientWithRoute pm Proxy req flag =
+ clientWithRoute pm (Proxy :: Proxy api)
+ (if flag
+ then appendToQueryString paramname Nothing req
+ else req
+ )
+
+ where paramname = pack $ symbolVal (Proxy :: Proxy sym)
+
+ hoistClientMonad pm _ f cl = \b ->
+ hoistClientMonad pm (Proxy :: Proxy api) f (cl b)
+
+-- | Pick a 'Method' and specify where the server you want to query is. You get
+-- back the full `Response`.
+instance RunClient m => HasClient m Raw where
+ type Client m Raw
+ = H.Method -> m Response
+
+ clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw
+ clientWithRoute _pm Proxy req httpMethod = do
+ runRequest req { requestMethod = httpMethod }
+
+ hoistClientMonad _ _ f cl = \meth -> f (cl meth)
+
+-- | If you use a 'ReqBody' in one of your endpoints in your API,
+-- the corresponding querying function will automatically take
+-- an additional argument of the type specified by your 'ReqBody'.
+-- That function will take care of encoding this argument as JSON and
+-- of using it as the request body.
+--
+-- All you need is for your type to have a 'ToJSON' instance.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > addBook :: Book -> ClientM Book
+-- > addBook = client myApi
+-- > -- then you can just use "addBook" to query that endpoint
+instance (MimeRender ct a, HasClient m api)
+ => HasClient m (ReqBody' mods (ct ': cts) a :> api) where
+
+ type Client m (ReqBody' mods (ct ': cts) a :> api) =
+ a -> Client m api
+
+ clientWithRoute pm Proxy req body =
+ clientWithRoute pm (Proxy :: Proxy api)
+ (let ctProxy = Proxy :: Proxy ct
+ in setRequestBodyLBS (mimeRender ctProxy body)
+ -- We use first contentType from the Accept list
+ (contentType ctProxy)
+ req
+ )
+
+ hoistClientMonad pm _ f cl = \a ->
+ hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
+
+instance
+ ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
+ ) => HasClient m (StreamBody' mods framing ctype a :> api)
+ where
+
+ type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api
+
+ hoistClientMonad pm _ f cl = \a ->
+ hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
+
+ clientWithRoute pm Proxy req body
+ = clientWithRoute pm (Proxy :: Proxy api)
+ $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req
+ where
+ ctypeP = Proxy :: Proxy ctype
+ framingP = Proxy :: Proxy framing
+
+ sourceIO = framingRender
+ framingP
+ (mimeRender ctypeP :: chunk -> BL.ByteString)
+ (toSourceIO body)
+
+-- | Make the querying function append @path@ to the request path.
+instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
+ type Client m (path :> api) = Client m api
+
+ clientWithRoute pm Proxy req =
+ clientWithRoute pm (Proxy :: Proxy api)
+ (appendToPath p req)
+
+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
+
+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
+instance HasClient m api => HasClient m (Vault :> api) where
+ type Client m (Vault :> api) = Client m api
+
+ clientWithRoute pm Proxy req =
+ clientWithRoute pm (Proxy :: Proxy api) req
+
+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
+instance HasClient m api => HasClient m (RemoteHost :> api) where
+ type Client m (RemoteHost :> api) = Client m api
+
+ clientWithRoute pm Proxy req =
+ clientWithRoute pm (Proxy :: Proxy api) req
+
+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
+instance HasClient m api => HasClient m (IsSecure :> api) where
+ type Client m (IsSecure :> api) = Client m api
+
+ clientWithRoute pm Proxy req =
+ clientWithRoute pm (Proxy :: Proxy api) req
+
+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
+
+instance HasClient m subapi =>
+ HasClient m (WithNamedContext name context subapi) where
+
+ type Client m (WithNamedContext name context subapi) = Client m subapi
+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
+
+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
+
+instance ( HasClient m api
+ ) => HasClient m (AuthProtect tag :> api) where
+ type Client m (AuthProtect tag :> api)
+ = AuthenticatedRequest (AuthProtect tag) -> Client m api
+
+ clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =
+ clientWithRoute pm (Proxy :: Proxy api) (func val req)
+
+ hoistClientMonad pm _ f cl = \authreq ->
+ hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
+
+-- | Ignore @'Fragment'@ in client functions.
+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
+--
+-- Example:
+--
+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
+-- >
+-- > myApi :: Proxy MyApi
+-- > myApi = Proxy
+-- >
+-- > getBooks :: ClientM [Book]
+-- > getBooks = client myApi
+-- > -- then you can just use "getBooksBy" to query that endpoint.
+-- > -- 'getBooks' for all books.
+instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
+ ) => HasClient m (Fragment a :> api) where
+
+ type Client m (Fragment a :> api) = Client m api
+
+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
+
+ hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
+
+-- * Basic Authentication
+
+instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
+ type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api
+
+ clientWithRoute pm Proxy req val =
+ clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)
+
+ hoistClientMonad pm _ f cl = \bauth ->
+ hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
+
+-- | A type that specifies that an API record contains a client implementation.
+data AsClientT (m :: * -> *)
+instance GenericMode (AsClientT m) where
+ type AsClientT m :- api = Client m api
+
+
+type GClientConstraints api m =
+ ( GenericServant api (AsClientT m)
+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
+ )
+
+class GClient (api :: * -> *) m where
+ gClientProof :: Dict (GClientConstraints api m)
+
+instance GClientConstraints api m => GClient api m where
+ gClientProof = Dict
+
+instance
+ ( forall n. GClient api n
+ , HasClient m (ToServantApi api)
+ , RunClient m
+ )
+ => HasClient m (NamedRoutes api) where
+ type Client m (NamedRoutes api) = api (AsClientT m)
+
+ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
+ clientWithRoute pm _ request =
+ case gClientProof @api @m of
+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
+
+ hoistClientMonad
+ :: forall ma mb.
+ Proxy m
+ -> Proxy (NamedRoutes api)
+ -> (forall x. ma x -> mb x)
+ -> Client ma (NamedRoutes api)
+ -> Client mb (NamedRoutes api)
+ hoistClientMonad _ _ nat clientA =
+ case (gClientProof @api @ma, gClientProof @api @mb) of
+ (Dict, Dict) ->
+ fromServant @api @(AsClientT mb) $
+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
+ toServant @api @(AsClientT ma) clientA
+
+infixl 1 //
+infixl 2 /:
+
+-- | Helper to make code using records of clients more readable.
+--
+-- Can be mixed with (/:) for supplying arguments.
+--
+-- Example:
+--
+-- @
+-- type Api = NamedRoutes RootApi
+--
+-- data RootApi mode = RootApi
+-- { subApi :: mode :- NamedRoutes SubApi
+-- , …
+-- } deriving Generic
+--
+-- data SubApi mode = SubApi
+-- { endpoint :: mode :- Get '[JSON] Person
+-- , …
+-- } deriving Generic
+--
+-- api :: Proxy API
+-- api = Proxy
+--
+-- rootClient :: RootApi (AsClientT ClientM)
+-- rootClient = client api
+--
+-- endpointClient :: ClientM Person
+-- endpointClient = client // subApi // endpoint
+-- @
+(//) :: a -> (a -> b) -> b
+x // f = f x
+
+-- | Convenience function for supplying arguments to client functions when
+-- working with records of clients.
+--
+-- Intended to be used in conjunction with '(//)'.
+--
+-- Example:
+--
+-- @
+-- type Api = NamedRoutes RootApi
+--
+-- data RootApi mode = RootApi
+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
+-- , …
+-- } deriving Generic
+--
+-- data SubApi mode = SubApi
+-- { endpoint :: mode :- Get '[JSON] Person
+-- , …
+-- } deriving Generic
+--
+-- api :: Proxy API
+-- api = Proxy
+--
+-- rootClient :: RootApi (AsClientT ClientM)
+-- rootClient = client api
+--
+-- hello :: String -> ClientM String
+-- hello name = rootClient // hello /: name
+--
+-- endpointClient :: ClientM Person
+-- endpointClient = client // subApi /: "foobar123" // endpoint
+-- @
+(/:) :: (a -> b -> c) -> b -> a -> c
+(/:) = flip
+
+
+{- Note [Non-Empty Content Types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Rather than have
+
+ instance (..., cts' ~ (ct ': cts)) => ... cts' ...
+
+It may seem to make more sense to have:
+
+ instance (...) => ... (ct ': cts) ...
+
+But this means that if another instance exists that does *not* require
+non-empty lists, but is otherwise more specific, no instance will be overall
+more specific. This in turn generally means adding yet another instance (one
+for empty and one for non-empty lists).
+-}
+
+-------------------------------------------------------------------------------
+-- helpers
+-------------------------------------------------------------------------------
+
+checkContentTypeHeader :: RunClient m => Response -> m MediaType
+checkContentTypeHeader response =
+ case lookup "Content-Type" $ toList $ responseHeaders response of
+ Nothing -> return $ "application" Media.// "octet-stream"
+ Just t -> case parseAccept t of
+ Nothing -> throwClientError $ InvalidContentTypeHeader response
+ Just t' -> return t'
+
+decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
+ => Response -> Proxy ct -> m a
+decodedAs response ct = do
+ responseContentType <- checkContentTypeHeader response
+ unless (any (matches responseContentType) accept) $
+ throwClientError $ UnsupportedContentType responseContentType response
+ case mimeUnrender ct $ responseBody response of
+ Left err -> throwClientError $ DecodeFailure (T.pack err) response
+ Right val -> return val
+ where
+ accept = toList $ contentTypes ct
diff --git a/servant-client-core/src/Servant/Client/Core/HasClient/TypeErrors.hs b/servant-client-core/src/Servant/Client/Core/HasClient/TypeErrors.hs
new file mode 100644
index 000000000..bddb6a4f3
--- /dev/null
+++ b/servant-client-core/src/Servant/Client/Core/HasClient/TypeErrors.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
+
+-- | This module contains erroring instances for @Servant.Client.Core.HasClient.Internal@.
+-- They are separated from the bulk of the code, because they raise "missing methods"
+-- warnings. These warnings are expected, but ignoring them would lead to missing
+-- relevant warnings in @Servant.Client.Core.HasClient.Internal@. Therefore, we put them
+-- in a separate file, and ignore the warnings here.
+module Servant.Client.Core.HasClient.TypeErrors ()
+ where
+
+import Prelude ()
+import Prelude.Compat
+
+import GHC.TypeLits
+ (TypeError)
+import Servant.API
+ ((:>))
+import Servant.API.TypeErrors
+
+import Servant.Client.Core.HasClient.Internal
+import Servant.Client.Core.RunClient
+
+-- Erroring instance for HasClient' when a combinator is not fully applied
+instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)
+ where
+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
+ clientWithRoute _ _ _ = error "unreachable"
+ hoistClientMonad _ _ _ _ = error "unreachable"
+
+-- Erroring instances for 'HasClient' for unknown API combinators
+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
+
+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api
diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs
index 8db0c9f24..999805dc7 100644
--- a/servant-client/src/Servant/Client/Internal/HttpClient.hs
+++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs
@@ -43,14 +43,12 @@ import qualified Data.ByteString as BS
import Data.ByteString.Builder
(toLazyByteString)
import qualified Data.ByteString.Lazy as BSL
-import Data.Either
- (either)
import Data.Foldable
(foldl',toList)
import Data.Functor.Alt
(Alt (..))
import Data.Maybe
- (maybe, maybeToList)
+ (maybeToList)
import Data.Proxy
(Proxy (..))
import Data.Sequence
@@ -63,7 +61,7 @@ import GHC.Generics
import Network.HTTP.Media
(renderHeader)
import Network.HTTP.Types
- (hContentType, renderQuery, statusIsSuccessful, urlEncode, Status)
+ (hContentType, statusIsSuccessful, urlEncode, Status)
import Servant.Client.Core
import qualified Network.HTTP.Client as Client
diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs
index 41a06572c..0b5a79dee 100644
--- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs
+++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs
@@ -24,8 +24,6 @@ import Control.DeepSeq
(NFData, force)
import Control.Exception
(evaluate, throwIO)
-import Control.Monad
- (unless)
import Control.Monad.Base
(MonadBase (..))
import Control.Monad.Codensity
diff --git a/servant-client/test/Servant/StreamSpec.hs b/servant-client/test/Servant/StreamSpec.hs
index 850185769..0afa53dd5 100644
--- a/servant-client/test/Servant/StreamSpec.hs
+++ b/servant-client/test/Servant/StreamSpec.hs
@@ -21,16 +21,9 @@
module Servant.StreamSpec (spec) where
-import Control.Monad
- (when)
-import Control.Monad.Codensity
- (Codensity (..))
-import Control.Monad.IO.Class
- (MonadIO (..))
import Control.Monad.Trans.Except
import qualified Data.ByteString as BS
import Data.Proxy
-import qualified Data.TDigest as TD
import qualified Network.HTTP.Client as C
import Prelude ()
import Prelude.Compat
@@ -46,20 +39,10 @@ import System.Entropy
(getEntropy, getHardwareEntropy)
import System.IO.Unsafe
(unsafePerformIO)
-import System.Mem
- (performGC)
import Test.Hspec
import Servant.ClientTestUtils (Person(..))
import qualified Servant.ClientTestUtils as CT
-#if MIN_VERSION_base(4,10,0)
-import GHC.Stats
- (gc, gcdetails_live_bytes, getRTSStats)
-#else
-import GHC.Stats
- (currentBytesUsed, getGCStats)
-#endif
-
-- This declaration simply checks that all instances are in place.
-- Note: this is streaming client
_ = client comprehensiveAPI
@@ -78,9 +61,9 @@ api :: Proxy StreamApi
api = Proxy
getGetNL, getGetNS :: ClientM (SourceIO Person)
-getGetALot :: ClientM (SourceIO BS.ByteString)
+_getGetALot :: ClientM (SourceIO BS.ByteString)
getStreamBody :: SourceT IO BS.ByteString -> ClientM (SourceIO BS.ByteString)
-getGetNL :<|> getGetNS :<|> getGetALot :<|> getStreamBody = client api
+getGetNL :<|> getGetNS :<|> _getGetALot :<|> getStreamBody = client api
alice :: Person
alice = Person "Alice" 42
@@ -134,50 +117,3 @@ streamSpec = beforeAll (CT.startWaiApp server) $ afterAll CT.endWaiApp $ do
where
input = ["foo", "", "bar"]
output = ["foo", "bar"]
-
-{-
- it "streams in constant memory" $ \(_, baseUrl) -> do
- Right rs <- runClient getGetALot baseUrl
- performGC
- -- usage0 <- getUsage
- -- putStrLn $ "Start: " ++ show usage0
- tdigest <- memoryUsage $ joinCodensitySourceT rs
-
- -- putStrLn $ "Median: " ++ show (TD.median tdigest)
- -- putStrLn $ "Mean: " ++ show (TD.mean tdigest)
- -- putStrLn $ "Stddev: " ++ show (TD.stddev tdigest)
-
- -- forM_ [0.01, 0.1, 0.2, 0.5, 0.8, 0.9, 0.99] $ \q ->
- -- putStrLn $ "q" ++ show q ++ ": " ++ show (TD.quantile q tdigest)
-
- let Just stddev = TD.stddev tdigest
-
- -- standard deviation of 100k is ok, we generate 256M of data after all.
- -- On my machine deviation is 40k-50k
- stddev `shouldSatisfy` (< 100000)
-
-memoryUsage :: SourceT IO BS.ByteString -> IO (TD.TDigest 25)
-memoryUsage src = unSourceT src $ loop mempty (0 :: Int)
- where
- loop !acc !_ Stop = return acc
- loop !_ !_ (Error err) = fail err -- !
- loop !acc !n (Skip s) = loop acc n s
- loop !acc !n (Effect ms) = ms >>= loop acc n
- loop !acc !n (Yield _bs s) = do
- usage <- liftIO getUsage
- -- We perform GC in between as we generate garbage.
- when (n `mod` 1024 == 0) $ liftIO performGC
- loop (TD.insert usage acc) (n + 1) s
-
-getUsage :: IO Double
-getUsage = fromIntegral .
-#if MIN_VERSION_base(4,10,0)
- gcdetails_live_bytes . gc <$> getRTSStats
-#else
- currentBytesUsed <$> getGCStats
-#endif
- memUsed `shouldSatisfy` (< megabytes 22)
-
-megabytes :: Num a => a -> a
-megabytes n = n * (1000 ^ (2 :: Int))
--}
diff --git a/servant-conduit/example/Main.hs b/servant-conduit/example/Main.hs
index 85ababe00..a50bb707e 100644
--- a/servant-conduit/example/Main.hs
+++ b/servant-conduit/example/Main.hs
@@ -17,8 +17,6 @@ import Data.Maybe
(fromMaybe)
import Network.HTTP.Client
(defaultManagerSettings, newManager)
-import Network.Wai
- (Application)
import System.Environment
(getArgs, lookupEnv)
import Text.Read
diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs
index b5c4bf1f7..e545a0358 100644
--- a/servant-docs/src/Servant/Docs/Internal.hs
+++ b/servant-docs/src/Servant/Docs/Internal.hs
@@ -55,7 +55,7 @@ import Data.String.Conversions
import Data.Text
(Text, unpack)
import GHC.Generics
- (Generic, Rep, K1(K1), M1(M1), U1(U1), V1,
+ (K1(K1), M1(M1), U1(U1), V1,
(:*:)((:*:)), (:+:)(L1, R1))
import qualified GHC.Generics as G
import GHC.TypeLits
@@ -964,7 +964,7 @@ instance {-# OVERLAPPABLE #-}
instance (ReflectMethod method) =>
HasDocs (NoContentVerb method) where
- docsFor Proxy (endpoint, action) DocOptions{..} =
+ docsFor Proxy (endpoint, action) _ =
single endpoint' action'
where endpoint' = endpoint & method .~ method'
@@ -982,7 +982,7 @@ instance (ReflectMethod method) =>
instance {-# OVERLAPPABLE #-}
(Accept ct, KnownNat status, ReflectMethod method)
=> HasDocs (Stream method status framing ct a) where
- docsFor Proxy (endpoint, action) DocOptions{..} =
+ docsFor Proxy (endpoint, action) _ =
single endpoint' action'
where endpoint' = endpoint & method .~ method'
diff --git a/servant-machines/example/Main.hs b/servant-machines/example/Main.hs
index 3f1a0bd6d..0ea35cf7f 100644
--- a/servant-machines/example/Main.hs
+++ b/servant-machines/example/Main.hs
@@ -17,8 +17,6 @@ import Data.Void
(Void)
import Network.HTTP.Client
(defaultManagerSettings, newManager)
-import Network.Wai
- (Application)
import System.Environment
(getArgs, lookupEnv)
import Text.Read
diff --git a/servant-pipes/example/Main.hs b/servant-pipes/example/Main.hs
index 8683f651e..6d0f1f38f 100644
--- a/servant-pipes/example/Main.hs
+++ b/servant-pipes/example/Main.hs
@@ -15,8 +15,6 @@ import Data.Maybe
(fromMaybe)
import Network.HTTP.Client
(defaultManagerSettings, newManager)
-import Network.Wai
- (Application)
import System.Environment
(getArgs, lookupEnv)
import System.IO
diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal
index 15cba22ce..278b17beb 100644
--- a/servant-server/servant-server.cabal
+++ b/servant-server/servant-server.cabal
@@ -53,6 +53,9 @@ library
Servant.Server.StaticFiles
Servant.Server.UVerb
+ other-modules:
+ Servant.Server.TypeErrors
+
-- deprecated
exposed-modules:
Servant.Utils.StaticFiles
diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs
index 79d092b95..9c07c761c 100644
--- a/servant-server/src/Servant/Server.hs
+++ b/servant-server/src/Servant/Server.hs
@@ -126,6 +126,7 @@ import Data.Text
import Network.Wai
(Application)
import Servant.Server.Internal
+import Servant.Server.TypeErrors ()
import Servant.Server.UVerb
diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs
index a4d74564e..f2473e087 100644
--- a/servant-server/src/Servant/Server/Internal.hs
+++ b/servant-server/src/Servant/Server/Internal.hs
@@ -42,7 +42,7 @@ 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.Constraint (Constraint, Dict(..))
+import Data.Constraint (Dict(..))
import Data.Either
(partitionEithers)
import Data.Maybe
@@ -57,7 +57,7 @@ import qualified Data.Text as T
import Data.Typeable
import GHC.Generics
import GHC.TypeLits
- (KnownNat, KnownSymbol, TypeError, symbolVal)
+ (KnownNat, KnownSymbol, symbolVal)
import qualified Network.HTTP.Media as NHM
import Network.HTTP.Types hiding
(Header, ResponseHeaders)
@@ -91,12 +91,9 @@ import Servant.API.ResponseHeaders
import Servant.API.Status
(statusFromNat)
import qualified Servant.Types.SourceT as S
-import Servant.API.TypeErrors
import Web.HttpApiData
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
parseUrlPieces)
-import Data.Kind
- (Type)
import Servant.Server.Internal.BasicAuth
import Servant.Server.Internal.Context
@@ -109,8 +106,6 @@ import Servant.Server.Internal.RouteResult
import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServerError
-import GHC.TypeLits
- (ErrorMessage (..), TypeError)
import Servant.API.TypeLevel
(AtLeastOneFragment, FragmentUnique)
@@ -819,67 +814,6 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
--------------------------------------------------------------------------------
--- Custom type errors
--------------------------------------------------------------------------------
-
--- Erroring instance for 'HasServer' when a combinator is not fully applied
-instance TypeError (PartialApplication
-#if __GLASGOW_HASKELL__ >= 904
- @(Type -> [Type] -> Constraint)
-#endif
- HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
- where
- type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
- route = error "unreachable"
- hoistServerWithContext _ _ _ _ = error "unreachable"
-
--- | This instance prevents from accidentally using '->' instead of ':>'
---
--- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
--- ...
--- ...No instance HasServer (a -> b).
--- ...Maybe you have used '->' instead of ':>' between
--- ...Capture' '[] "foo" Int
--- ...and
--- ...Verb 'GET 200 '[JSON] Int
--- ...
---
--- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int)
--- ...
--- ...No instance HasServer (a -> b).
--- ...Maybe you have used '->' instead of ':>' between
--- ...Capture' '[] "foo" Int
--- ...and
--- ...Verb 'GET 200 '[JSON] Int
--- ...
---
-instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context
- where
- type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b)
- route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)"
- hoistServerWithContext _ _ _ = id
-
-type HasServerArrowTypeError a b =
- 'Text "No instance HasServer (a -> b)."
- ':$$: 'Text "Maybe you have used '->' instead of ':>' between "
- ':$$: 'ShowType a
- ':$$: 'Text "and"
- ':$$: 'ShowType b
-
--- Erroring instances for 'HasServer' for unknown API combinators
-
--- XXX: This omits the @context@ parameter, e.g.:
---
--- "There is no instance for HasServer (Bool :> …)". Do we care ?
-instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
-#if __GLASGOW_HASKELL__ >= 904
- @(Type -> [Type] -> Constraint)
-#endif
- HasServer ty) => HasServer (ty :> sub) context
-
-instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
-
-- | Ignore @'Fragment'@ in server handlers.
-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
--
diff --git a/servant-server/src/Servant/Server/TypeErrors.hs b/servant-server/src/Servant/Server/TypeErrors.hs
new file mode 100644
index 000000000..6a8690ba7
--- /dev/null
+++ b/servant-server/src/Servant/Server/TypeErrors.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
+
+#if __GLASGOW_HASKELL__ >= 904
+{-# LANGUAGE TypeApplications #-}
+#endif
+
+-- | This module contains erroring instances for @Servant.Server.Internal@.
+-- They are separated from the bulk of the code, because they raise "missing methods"
+-- warnings. These warnings are expected, but ignoring them would lead to missing
+-- relevant warnings in @SServant.Server.Internal@. Therefore, we put them in a separate
+-- file, and ignore the warnings here.
+module Servant.Server.TypeErrors ()
+ where
+
+import Data.Constraint (Constraint)
+import GHC.TypeLits
+ (TypeError)
+import Prelude ()
+import Prelude.Compat
+import Servant.API
+ ((:>))
+import Servant.API.TypeErrors
+
+import Servant.Server.Internal
+
+import GHC.TypeLits
+ (ErrorMessage (..))
+
+#if __GLASGOW_HASKELL__ >= 904
+import Data.Kind (Type)
+#endif
+
+-- Erroring instance for 'HasServer' when a combinator is not fully applied
+instance TypeError (PartialApplication
+#if __GLASGOW_HASKELL__ >= 904
+ @(Type -> [Type] -> Constraint)
+#endif
+ HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
+ where
+ type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
+ route = error "unreachable"
+ hoistServerWithContext _ _ _ _ = error "unreachable"
+
+-- | This instance prevents from accidentally using '->' instead of ':>'
+--
+-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
+-- ...
+-- ...No instance HasServer (a -> b).
+-- ...Maybe you have used '->' instead of ':>' between
+-- ...Capture' '[] "foo" Int
+-- ...and
+-- ...Verb 'GET 200 '[JSON] Int
+-- ...
+--
+-- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int)
+-- ...
+-- ...No instance HasServer (a -> b).
+-- ...Maybe you have used '->' instead of ':>' between
+-- ...Capture' '[] "foo" Int
+-- ...and
+-- ...Verb 'GET 200 '[JSON] Int
+-- ...
+--
+instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context
+ where
+ type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b)
+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)"
+ hoistServerWithContext _ _ _ = id
+
+type HasServerArrowTypeError a b =
+ 'Text "No instance HasServer (a -> b)."
+ ':$$: 'Text "Maybe you have used '->' instead of ':>' between "
+ ':$$: 'ShowType a
+ ':$$: 'Text "and"
+ ':$$: 'ShowType b
+
+-- Erroring instances for 'HasServer' for unknown API combinators
+
+-- XXX: This omits the @context@ parameter, e.g.:
+--
+-- "There is no instance for HasServer (Bool :> …)". Do we care ?
+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
+#if __GLASGOW_HASKELL__ >= 904
+ @(Type -> [Type] -> Constraint)
+#endif
+ HasServer ty) => HasServer (ty :> sub) context
+
+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
+
+-- $setup
+-- >>> :set -XDataKinds
+-- >>> :set -XTypeOperators
+-- >>> import Data.Typeable
+-- >>> import Servant.API
+-- >>> import Servant.Server
diff --git a/servant-server/test/Servant/Server/StreamingSpec.hs b/servant-server/test/Servant/Server/StreamingSpec.hs
index 43ff3f69b..78cf7d786 100644
--- a/servant-server/test/Servant/Server/StreamingSpec.hs
+++ b/servant-server/test/Servant/Server/StreamingSpec.hs
@@ -4,6 +4,8 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+
-- | This module tests whether streaming works from client to server
-- with a server implemented with servant-server.
module Servant.Server.StreamingSpec where
@@ -19,7 +21,8 @@ import Network.Wai
import Network.Wai.Internal
import Prelude ()
import Prelude.Compat
-import Servant
+import Servant hiding
+ (respond)
import qualified System.Timeout
import Test.Hspec
diff --git a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs
index 1701a07d4..10f62592a 100644
--- a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs
+++ b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs
@@ -19,7 +19,8 @@ module Servant.Server.UsingContextSpec.TestCombinators where
import GHC.TypeLits
-import Servant
+import Servant hiding
+ (inject)
data ExtractFromContext
diff --git a/servant-swagger/src/Servant/Swagger/Internal.hs b/servant-swagger/src/Servant/Swagger/Internal.hs
index 66cb05956..82dde9ee7 100644
--- a/servant-swagger/src/Servant/Swagger/Internal.hs
+++ b/servant-swagger/src/Servant/Swagger/Internal.hs
@@ -38,7 +38,6 @@ import Network.HTTP.Media (MediaType)
import Servant.API
import Servant.API.Description (FoldDescription,
reflectDescription)
-import Servant.API.Generic (ToServantApi, AsApi)
import Servant.API.Modifiers (FoldRequired)
import Servant.Swagger.Internal.TypeLevel.API
diff --git a/servant/servant.cabal b/servant/servant.cabal
index a3dc401dd..bc8679b9c 100644
--- a/servant/servant.cabal
+++ b/servant/servant.cabal
@@ -75,6 +75,10 @@ library
exposed-modules:
Servant.Links
+ other-modules:
+ Servant.Links.Internal
+ Servant.Links.TypeErrors
+
-- Bundled with GHC: Lower bound to not force re-installs
-- text and mtl are bundled starting with GHC-8.4
--
diff --git a/servant/src/Servant/API/TypeErrors.hs b/servant/src/Servant/API/TypeErrors.hs
index 81a0e7eb2..0cb2cda86 100644
--- a/servant/src/Servant/API/TypeErrors.hs
+++ b/servant/src/Servant/API/TypeErrors.hs
@@ -4,6 +4,8 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
+
-- | This module defines the error messages used in type-level errors.
-- Type-level errors can signal non-existing instances, for instance when
-- a combinator is not applied to the correct number of arguments.
@@ -14,7 +16,6 @@ module Servant.API.TypeErrors (
NoInstanceForSub,
) where
-import Data.Kind
import GHC.TypeLits
-- | No instance exists for @tycls (expr :> ...)@ because
diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs
index 74314e0a4..3ce7388b7 100644
--- a/servant/src/Servant/Links.hs
+++ b/servant/src/Servant/Links.hs
@@ -1,669 +1,8 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE QuantifiedConstraints #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-{-# OPTIONS_HADDOCK not-home #-}
-
--- | Type safe generation of internal links.
---
--- Given an API with a few endpoints:
---
--- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators
--- >>> import Servant.API
--- >>> import Servant.Links
--- >>> import Web.HttpApiData (toUrlPiece)
--- >>> import Data.Proxy
--- >>>
--- >>> type Hello = "hello" :> Get '[JSON] Int
--- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
--- >>> type API = Hello :<|> Bye
--- >>> let api = Proxy :: Proxy API
---
--- It is possible to generate links that are guaranteed to be within 'API' with
--- 'safeLink'. The first argument to 'safeLink' is a type representing the API
--- you would like to restrict links to. The second argument is the destination
--- endpoint you would like the link to point to, this will need to end with a
--- verb like GET or POST. Further arguments may be required depending on the
--- type of the endpoint. If everything lines up you will get a 'Link' out the
--- other end.
---
--- You may omit 'QueryParam's and the like should you not want to provide them,
--- but types which form part of the URL path like 'Capture' must be included.
--- The reason you may want to omit 'QueryParam's is that safeLink is a bit
--- magical: if parameters are included that could take input it will return a
--- function that accepts that input and generates a link. This is best shown
--- with an example. Here, a link is generated with no parameters:
---
--- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)
--- >>> toUrlPiece (safeLink api hello :: Link)
--- "hello"
---
--- 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)
--- >>> toUrlPiece $ safeLink api with (Just "Hubert")
--- "bye?name=Hubert"
---
--- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)
--- >>> toUrlPiece $ safeLink api without
--- "bye"
---
--- If you would like to create a helper for generating links only within that API,
--- you can partially apply safeLink if you specify a correct type signature
--- like so:
---
--- >>> :set -XConstraintKinds
--- >>> :{
--- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
--- >>> => Proxy endpoint -> MkLink endpoint Link
--- >>> apiLink = safeLink api
--- >>> :}
---
--- `safeLink'` allows you to specialise the output:
---
--- >>> safeLink' toUrlPiece api without
--- "bye"
---
--- >>> :{
--- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)
--- >>> => Proxy endpoint -> MkLink endpoint Text
--- >>> apiTextLink = safeLink' toUrlPiece api
--- >>> :}
---
--- >>> apiTextLink without
--- "bye"
---
--- 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)
--- >>> safeLink api bad_link
--- ...
--- ...Could not ...
--- ...
---
--- This error is essentially saying that the type family couldn't find
--- bad_link under api after trying the open (but empty) type family
--- `IsElem'` as a last resort.
---
--- @since 0.14.1
-module Servant.Links (
- module Servant.API.TypeLevel,
-
- -- * Building and using safe links
- --
- -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
- safeLink
- , safeLink'
- , allLinks
- , allLinks'
- , URI(..)
- -- * Generics
- , AsLink
- , fieldLink
- , fieldLink'
- , allFieldLinks
- , allFieldLinks'
- -- * Adding custom types
- , HasLink(..)
- , Link
- , linkURI
- , linkURI'
- , LinkArrayElementStyle (..)
- -- ** Link accessors
- , Param (..)
- , linkSegments
- , linkQueryParams
- , linkFragment
-) where
-
-import Data.List
-import Data.Constraint
-import Data.Proxy
- (Proxy (..))
-import Data.Singletons.Bool
- (SBool (..), SBoolI (..))
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as TE
-import Data.Type.Bool
- (If)
-import GHC.TypeLits
- (KnownSymbol, TypeError, symbolVal)
-import Network.URI
- (URI (..), escapeURIString, isUnreserved)
-import Prelude ()
-import Prelude.Compat
-
-import Servant.API.Alternative
- ((:<|>) ((:<|>)))
-import Servant.API.BasicAuth
- (BasicAuth)
-import Servant.API.Capture
- (Capture', CaptureAll)
-import Servant.API.Description
- (Description, Summary)
-import Servant.API.Empty
- (EmptyAPI (..))
-import Servant.API.Experimental.Auth
- (AuthProtect)
-import Servant.API.Fragment
- (Fragment)
-import Servant.API.Generic
-import Servant.API.Header
- (Header')
-import Servant.API.HttpVersion
- (HttpVersion)
-import Servant.API.IsSecure
- (IsSecure)
-import Servant.API.Modifiers
- (FoldRequired)
-import Servant.API.NamedRoutes
- (NamedRoutes)
-import Servant.API.QueryParam
- (QueryFlag, QueryParam', QueryParams)
-import Servant.API.Raw
- (Raw)
-import Servant.API.RemoteHost
- (RemoteHost)
-import Servant.API.ReqBody
- (ReqBody')
-import Servant.API.Stream
- (Stream, StreamBody')
-import Servant.API.Sub
- (type (:>))
-import Servant.API.TypeErrors
-import Servant.API.TypeLevel
-import Servant.API.UVerb
-import Servant.API.Vault
- (Vault)
-import Servant.API.Verbs
- (Verb, NoContentVerb)
-import Servant.API.WithNamedContext
- (WithNamedContext)
-import Web.HttpApiData
-import Data.Kind
- (Type)
-
--- | A safe link datatype.
--- The only way of constructing a 'Link' is using 'safeLink', which means any
--- 'Link' is guaranteed to be part of the mentioned API.
-data Link = Link
- { _segments :: [Escaped]
- , _queryParams :: [Param]
- , _fragment :: Fragment'
- } deriving Show
-
-newtype Escaped = Escaped String
-
-type Fragment' = Maybe String
-
-escaped :: String -> Escaped
-escaped = Escaped . escapeURIString isUnreserved
-
-getEscaped :: Escaped -> String
-getEscaped (Escaped s) = s
-
-instance Show Escaped where
- showsPrec d (Escaped s) = showsPrec d s
- show (Escaped s) = show s
-
-linkSegments :: Link -> [String]
-linkSegments = map getEscaped . _segments
-
-linkQueryParams :: Link -> [Param]
-linkQueryParams = _queryParams
-
-linkFragment :: Link -> Fragment'
-linkFragment = _fragment
-
-instance ToHttpApiData Link where
- toHeader = TE.encodeUtf8 . toUrlPiece
- toUrlPiece l =
- let uri = linkURI l
- in Text.pack $ uriPath uri ++ uriQuery uri ++ uriFragment uri
-
--- | Query parameter.
-data Param
- = SingleParam String Text.Text
- | ArrayElemParam String Text.Text
- | FlagParam String
- deriving Show
-
-addSegment :: Escaped -> Link -> Link
-addSegment seg l = l { _segments = _segments l <> [seg] }
-
-addQueryParam :: Param -> Link -> Link
-addQueryParam qp l =
- l { _queryParams = _queryParams l <> [qp] }
-
-addFragment :: Fragment' -> Link -> Link
-addFragment fr l = l { _fragment = fr }
-
--- | Transform 'Link' into 'URI'.
---
--- >>> type API = "something" :> Get '[JSON] Int
--- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
--- something
---
--- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
--- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
--- sum?x[]=1&x[]=2&x[]=3
---
--- >>> type API = "foo/bar" :> Get '[JSON] Int
--- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
--- foo%2Fbar
---
--- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
--- >>> let someRoute = Proxy :: Proxy SomeRoute
--- >>> safeLink someRoute someRoute "test@example.com"
--- Link {_segments = ["abc","test%40example.com"], _queryParams = [], _fragment = Nothing}
---
--- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
--- abc/test%40example.com
---
-linkURI :: Link -> URI
-linkURI = linkURI' LinkArrayElementBracket
-
--- | How to encode array query elements.
-data LinkArrayElementStyle
- = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@
- | LinkArrayElementPlain -- ^ @foo=1&foo=2@
- deriving (Eq, Ord, Show, Enum, Bounded)
-
--- | Configurable 'linkURI'.
---
--- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
--- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
--- sum?x[]=1&x[]=2&x[]=3
---
--- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
--- sum?x=1&x=2&x=3
---
-linkURI' :: LinkArrayElementStyle -> Link -> URI
-linkURI' addBrackets (Link segments q_params mfragment) =
- URI mempty -- No scheme (relative)
- Nothing -- Or authority (relative)
- (intercalate "/" $ map getEscaped segments)
- (makeQueries q_params)
- (makeFragment mfragment)
- where
- makeQueries :: [Param] -> String
- makeQueries [] = ""
- makeQueries xs =
- "?" <> intercalate "&" (fmap makeQuery xs)
-
- makeQuery :: Param -> String
- makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)
- makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
- makeQuery (FlagParam k) = escape k
-
- makeFragment :: Fragment' -> String
- makeFragment Nothing = ""
- makeFragment (Just fr) = "#" <> escape fr
-
- style = case addBrackets of
- LinkArrayElementBracket -> "[]="
- LinkArrayElementPlain -> "="
-
-escape :: String -> String
-escape = escapeURIString isUnreserved
-
--- | Create a valid (by construction) relative URI with query params.
---
--- This function will only typecheck if `endpoint` is part of the API `api`
-safeLink
- :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
- => Proxy api -- ^ The whole API that this endpoint is a part of
- -> Proxy endpoint -- ^ The API endpoint you would like to point to
- -> MkLink endpoint Link
-safeLink = safeLink' id
-
--- | More general 'safeLink'.
---
-safeLink'
- :: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)
- => (Link -> a)
- -> Proxy api -- ^ The whole API that this endpoint is a part of
- -> Proxy endpoint -- ^ The API endpoint you would like to point to
- -> MkLink endpoint a
-safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty mempty)
-
--- | Create all links in an API.
---
--- Note that the @api@ type must be restricted to the endpoints that have
--- valid links to them.
---
--- >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double
--- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API)
--- >>> :t fooLink
--- fooLink :: Text -> Link
--- >>> :t barLink
--- barLink :: Int -> Link
---
--- Note: nested APIs don't work well with this approach
---
--- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link
--- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *
--- = Char -> (Int -> Link) :<|> (Double -> Link)
-allLinks
- :: forall api. HasLink api
- => Proxy api
- -> MkLink api Link
-allLinks = allLinks' id
-
--- | More general 'allLinks'. See `safeLink'`.
-allLinks'
- :: forall api a. HasLink api
- => (Link -> a)
- -> Proxy api
- -> MkLink api a
-allLinks' toA api = toLink toA api (Link mempty mempty mempty)
-
--------------------------------------------------------------------------------
--- Generics
--------------------------------------------------------------------------------
-
--- | Given an API record field, create a link for that route. Only the field's
--- type is used.
---
--- @
--- data Record route = Record
--- { _get :: route :- Capture "id" Int :> Get '[JSON] String
--- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool
--- }
--- deriving ('Generic')
---
--- getLink :: Int -> Link
--- getLink = 'fieldLink' _get
--- @
---
--- @since 0.14.1
-fieldLink
- :: ( IsElem endpoint (ToServantApi routes), HasLink endpoint
- , GenericServant routes AsApi
- )
- => (routes AsApi -> endpoint)
- -> MkLink endpoint Link
-fieldLink = fieldLink' id
-
--- | More general version of 'fieldLink'
---
--- @since 0.14.1
-fieldLink'
- :: forall routes endpoint a.
- ( IsElem endpoint (ToServantApi routes), HasLink endpoint
- , GenericServant routes AsApi
- )
- => (Link -> a)
- -> (routes AsApi -> endpoint)
- -> MkLink endpoint a
-fieldLink' toA _ = safeLink' toA (genericApi (Proxy :: Proxy routes)) (Proxy :: Proxy endpoint)
-
--- | A type that specifies that an API record contains a set of links.
---
--- @since 0.14.1
-data AsLink (a :: *)
-instance GenericMode (AsLink a) where
- type (AsLink a) :- api = MkLink api a
-
--- | Get all links as a record.
---
--- @since 0.14.1
-allFieldLinks
- :: ( HasLink (ToServantApi routes)
- , GenericServant routes (AsLink Link)
- , ToServant routes (AsLink Link) ~ MkLink (ToServantApi routes) Link
- )
- => routes (AsLink Link)
-allFieldLinks = allFieldLinks' id
-
--- | More general version of 'allFieldLinks'.
---
--- @since 0.14.1
-allFieldLinks'
- :: forall routes a.
- ( HasLink (ToServantApi routes)
- , GenericServant routes (AsLink a)
- , ToServant routes (AsLink a) ~ MkLink (ToServantApi routes) a
- )
- => (Link -> a)
- -> routes (AsLink a)
-allFieldLinks' toA
- = fromServant
- $ allLinks' toA (Proxy :: Proxy (ToServantApi routes))
-
--------------------------------------------------------------------------------
--- HasLink
--------------------------------------------------------------------------------
-
--- | Construct a toLink for an endpoint.
-class HasLink endpoint where
- type MkLink endpoint (a :: *)
- toLink
- :: (Link -> a)
- -> Proxy endpoint -- ^ The API endpoint you would like to point to
- -> Link
- -> MkLink endpoint a
-
--- Naked symbol instance
-instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
- type MkLink (sym :> sub) a = MkLink sub a
- toLink toA _ =
- toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
- where
- seg = symbolVal (Proxy :: Proxy sym)
-
--- QueryParam instances
-instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
- => HasLink (QueryParam' mods sym v :> sub)
- where
- type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
- toLink toA _ l mv =
- toLink toA (Proxy :: Proxy sub) $
- case sbool :: SBool (FoldRequired mods) of
- STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
- SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
- where
- k :: String
- k = symbolVal (Proxy :: Proxy sym)
-
-instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
- => HasLink (QueryParams sym v :> sub)
- where
- type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
- toLink toA _ l =
- toLink toA (Proxy :: Proxy sub) .
- foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
- where
- k = symbolVal (Proxy :: Proxy sym)
-
-instance (KnownSymbol sym, HasLink sub)
- => HasLink (QueryFlag sym :> sub)
- where
- type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
- toLink toA _ l False =
- toLink toA (Proxy :: Proxy sub) l
- toLink toA _ l True =
- toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
- where
- k = symbolVal (Proxy :: Proxy sym)
-
--- :<|> instance - Generate all links at once
-instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
- type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
- toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
-
--- Misc instances
-instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
- type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
- toLink toA _ = toLink toA (Proxy :: Proxy sub)
-
-instance HasLink sub => HasLink (StreamBody' mods framing ct a :> sub) where
- type MkLink (StreamBody' mods framing ct a :> sub) r = MkLink sub r
- toLink toA _ = toLink toA (Proxy :: Proxy sub)
-
-instance (ToHttpApiData v, HasLink sub)
- => HasLink (Capture' mods sym v :> sub)
- where
- type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
- toLink toA _ l v =
- toLink toA (Proxy :: Proxy sub) $
- addSegment (escaped . Text.unpack $ toUrlPiece v) l
-
-instance (ToHttpApiData v, HasLink sub)
- => HasLink (CaptureAll sym v :> sub)
- where
- type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
- toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
- foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
-
-instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
- type MkLink (Header' mods sym a :> sub) r = MkLink sub r
- toLink = simpleToLink (Proxy :: Proxy sub)
-
-instance HasLink sub => HasLink (Vault :> sub) where
- type MkLink (Vault :> sub) a = MkLink sub a
- toLink = simpleToLink (Proxy :: Proxy sub)
-
-instance HasLink sub => HasLink (Description s :> sub) where
- type MkLink (Description s :> sub) a = MkLink sub a
- toLink = simpleToLink (Proxy :: Proxy sub)
-
-instance HasLink sub => HasLink (Summary s :> sub) where
- type MkLink (Summary s :> sub) a = MkLink sub a
- toLink = simpleToLink (Proxy :: Proxy sub)
-
-instance HasLink sub => HasLink (HttpVersion :> sub) where
- type MkLink (HttpVersion:> sub) a = MkLink sub a
- toLink = simpleToLink (Proxy :: Proxy sub)
-
-instance HasLink sub => HasLink (IsSecure :> sub) where
- type MkLink (IsSecure :> sub) a = MkLink sub a
- toLink = simpleToLink (Proxy :: Proxy sub)
-
-instance HasLink sub => HasLink (WithNamedContext name context sub) where
- type MkLink (WithNamedContext name context sub) a = MkLink sub a
- toLink toA _ = toLink toA (Proxy :: Proxy sub)
-
-instance HasLink sub => HasLink (RemoteHost :> sub) where
- type MkLink (RemoteHost :> sub) a = MkLink sub a
- toLink = simpleToLink (Proxy :: Proxy sub)
-
-instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
- type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
- toLink = simpleToLink (Proxy :: Proxy sub)
-
-instance HasLink EmptyAPI where
- type MkLink EmptyAPI a = EmptyAPI
- toLink _ _ _ = EmptyAPI
-
--- Verb (terminal) instances
-instance HasLink (Verb m s ct a) where
- type MkLink (Verb m s ct a) r = r
- toLink toA _ = toA
-
-instance HasLink (NoContentVerb m) where
- type MkLink (NoContentVerb m) r = r
- toLink toA _ = toA
-
-instance HasLink Raw where
- type MkLink Raw a = a
- toLink toA _ = toA
-
-instance HasLink (Stream m status fr ct a) where
- type MkLink (Stream m status fr ct a) r = r
- toLink toA _ = toA
-
--- UVerb instances
-instance HasLink (UVerb m ct a) where
- type MkLink (UVerb m ct a) r = r
- toLink toA _ = toA
--- Instance for NamedRoutes combinator
-
-type GLinkConstraints routes a =
- ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a)
- , GenericServant routes (AsLink a)
- )
-
-class GLink (routes :: * -> *) (a :: *) where
- gLinkProof :: Dict (GLinkConstraints routes a)
-
-instance GLinkConstraints routes a => GLink routes a where
- gLinkProof = Dict
-
-instance
- ( HasLink (ToServantApi routes)
- , forall a. GLink routes a
- ) => HasLink (NamedRoutes routes) where
-
- type MkLink (NamedRoutes routes) a = routes (AsLink a)
-
- toLink
- :: forall a. (Link -> a)
- -> Proxy (NamedRoutes routes)
- -> Link
- -> routes (AsLink a)
-
- toLink toA _ l = case gLinkProof @routes @a of
- Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l
-
--- AuthProtext instances
-instance HasLink sub => HasLink (AuthProtect tag :> sub) where
- type MkLink (AuthProtect tag :> sub) a = MkLink sub a
- toLink = simpleToLink (Proxy :: Proxy sub)
-
-instance (HasLink sub, ToHttpApiData v)
- => HasLink (Fragment v :> sub) where
- type MkLink (Fragment v :> sub) a = v -> MkLink sub a
- toLink toA _ l mv =
- toLink toA (Proxy :: Proxy sub) $
- addFragment ((Just . Text.unpack . toQueryParam) mv) l
-
--- | Helper for implementing 'toLink' for combinators not affecting link
--- structure.
-simpleToLink
- :: forall sub a combinator.
- (HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)
- => Proxy sub
- -> (Link -> a)
- -> Proxy (combinator :> sub)
- -> Link
- -> MkLink (combinator :> sub) a
-simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
-
-
--- $setup
--- >>> import Servant.API
--- >>> import Data.Text (Text)
-
--- Erroring instance for 'HasLink' when a combinator is not fully applied
-instance TypeError (PartialApplication
-#if __GLASGOW_HASKELL__ >= 904
- @(Type -> Constraint)
-#endif
- HasLink arr) => HasLink ((arr :: a -> b) :> sub)
- where
- type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)
- toLink = error "unreachable"
-
--- Erroring instances for 'HasLink' for unknown API combinators
-instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
-#if __GLASGOW_HASKELL__ >= 904
- @(Type -> Constraint)
-#endif
- HasLink ty) => HasLink (ty :> sub)
-
-instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api
+-- | Wrapper for Servant.Links.Internal, which brings in scope the instance declarations
+-- in Servant.Links.TypeErrors
+module Servant.Links
+ ( module Servant.Links.Internal
+ ) where
+
+import Servant.Links.Internal
+import Servant.Links.TypeErrors ()
diff --git a/servant/src/Servant/Links/Internal.hs b/servant/src/Servant/Links/Internal.hs
new file mode 100644
index 000000000..066480851
--- /dev/null
+++ b/servant/src/Servant/Links/Internal.hs
@@ -0,0 +1,647 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- | Type safe generation of internal links.
+--
+-- Given an API with a few endpoints:
+--
+-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators
+-- >>> import Servant.API
+-- >>> import Servant.Links
+-- >>> import Web.HttpApiData (toUrlPiece)
+-- >>> import Data.Proxy
+-- >>>
+-- >>> type Hello = "hello" :> Get '[JSON] Int
+-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
+-- >>> type API = Hello :<|> Bye
+-- >>> let api = Proxy :: Proxy API
+--
+-- It is possible to generate links that are guaranteed to be within 'API' with
+-- 'safeLink'. The first argument to 'safeLink' is a type representing the API
+-- you would like to restrict links to. The second argument is the destination
+-- endpoint you would like the link to point to, this will need to end with a
+-- verb like GET or POST. Further arguments may be required depending on the
+-- type of the endpoint. If everything lines up you will get a 'Link' out the
+-- other end.
+--
+-- You may omit 'QueryParam's and the like should you not want to provide them,
+-- but types which form part of the URL path like 'Capture' must be included.
+-- The reason you may want to omit 'QueryParam's is that safeLink is a bit
+-- magical: if parameters are included that could take input it will return a
+-- function that accepts that input and generates a link. This is best shown
+-- with an example. Here, a link is generated with no parameters:
+--
+-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)
+-- >>> toUrlPiece (safeLink api hello :: Link)
+-- "hello"
+--
+-- 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)
+-- >>> toUrlPiece $ safeLink api with (Just "Hubert")
+-- "bye?name=Hubert"
+--
+-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)
+-- >>> toUrlPiece $ safeLink api without
+-- "bye"
+--
+-- If you would like to create a helper for generating links only within that API,
+-- you can partially apply safeLink if you specify a correct type signature
+-- like so:
+--
+-- >>> :set -XConstraintKinds
+-- >>> :{
+-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
+-- >>> => Proxy endpoint -> MkLink endpoint Link
+-- >>> apiLink = safeLink api
+-- >>> :}
+--
+-- `safeLink'` allows you to specialise the output:
+--
+-- >>> safeLink' toUrlPiece api without
+-- "bye"
+--
+-- >>> :{
+-- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)
+-- >>> => Proxy endpoint -> MkLink endpoint Text
+-- >>> apiTextLink = safeLink' toUrlPiece api
+-- >>> :}
+--
+-- >>> apiTextLink without
+-- "bye"
+--
+-- 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)
+-- >>> safeLink api bad_link
+-- ...
+-- ...Could not ...
+-- ...
+--
+-- This error is essentially saying that the type family couldn't find
+-- bad_link under api after trying the open (but empty) type family
+-- `IsElem'` as a last resort.
+--
+-- @since 0.14.1
+module Servant.Links.Internal (
+ module Servant.API.TypeLevel,
+
+ -- * Building and using safe links
+ --
+ -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
+ safeLink
+ , safeLink'
+ , allLinks
+ , allLinks'
+ , URI(..)
+ -- * Generics
+ , AsLink
+ , fieldLink
+ , fieldLink'
+ , allFieldLinks
+ , allFieldLinks'
+ -- * Adding custom types
+ , HasLink(..)
+ , Link
+ , linkURI
+ , linkURI'
+ , LinkArrayElementStyle (..)
+ -- ** Link accessors
+ , Param (..)
+ , linkSegments
+ , linkQueryParams
+ , linkFragment
+) where
+
+import Data.List
+import Data.Constraint
+import Data.Proxy
+ (Proxy (..))
+import Data.Singletons.Bool
+ (SBool (..), SBoolI (..))
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as TE
+import Data.Type.Bool
+ (If)
+import GHC.TypeLits
+ (KnownSymbol, symbolVal)
+import Network.URI
+ (URI (..), escapeURIString, isUnreserved)
+import Prelude ()
+import Prelude.Compat
+
+import Servant.API.Alternative
+ ((:<|>) ((:<|>)))
+import Servant.API.BasicAuth
+ (BasicAuth)
+import Servant.API.Capture
+ (Capture', CaptureAll)
+import Servant.API.Description
+ (Description, Summary)
+import Servant.API.Empty
+ (EmptyAPI (..))
+import Servant.API.Experimental.Auth
+ (AuthProtect)
+import Servant.API.Fragment
+ (Fragment)
+import Servant.API.Generic
+import Servant.API.Header
+ (Header')
+import Servant.API.HttpVersion
+ (HttpVersion)
+import Servant.API.IsSecure
+ (IsSecure)
+import Servant.API.Modifiers
+ (FoldRequired)
+import Servant.API.NamedRoutes
+ (NamedRoutes)
+import Servant.API.QueryParam
+ (QueryFlag, QueryParam', QueryParams)
+import Servant.API.Raw
+ (Raw)
+import Servant.API.RemoteHost
+ (RemoteHost)
+import Servant.API.ReqBody
+ (ReqBody')
+import Servant.API.Stream
+ (Stream, StreamBody')
+import Servant.API.Sub
+ (type (:>))
+import Servant.API.TypeLevel
+import Servant.API.UVerb
+import Servant.API.Vault
+ (Vault)
+import Servant.API.Verbs
+ (Verb, NoContentVerb)
+import Servant.API.WithNamedContext
+ (WithNamedContext)
+import Web.HttpApiData
+
+-- | A safe link datatype.
+-- The only way of constructing a 'Link' is using 'safeLink', which means any
+-- 'Link' is guaranteed to be part of the mentioned API.
+data Link = Link
+ { _segments :: [Escaped]
+ , _queryParams :: [Param]
+ , _fragment :: Fragment'
+ } deriving Show
+
+newtype Escaped = Escaped String
+
+type Fragment' = Maybe String
+
+escaped :: String -> Escaped
+escaped = Escaped . escapeURIString isUnreserved
+
+getEscaped :: Escaped -> String
+getEscaped (Escaped s) = s
+
+instance Show Escaped where
+ showsPrec d (Escaped s) = showsPrec d s
+ show (Escaped s) = show s
+
+linkSegments :: Link -> [String]
+linkSegments = map getEscaped . _segments
+
+linkQueryParams :: Link -> [Param]
+linkQueryParams = _queryParams
+
+linkFragment :: Link -> Fragment'
+linkFragment = _fragment
+
+instance ToHttpApiData Link where
+ toHeader = TE.encodeUtf8 . toUrlPiece
+ toUrlPiece l =
+ let uri = linkURI l
+ in Text.pack $ uriPath uri ++ uriQuery uri ++ uriFragment uri
+
+-- | Query parameter.
+data Param
+ = SingleParam String Text.Text
+ | ArrayElemParam String Text.Text
+ | FlagParam String
+ deriving Show
+
+addSegment :: Escaped -> Link -> Link
+addSegment seg l = l { _segments = _segments l <> [seg] }
+
+addQueryParam :: Param -> Link -> Link
+addQueryParam qp l =
+ l { _queryParams = _queryParams l <> [qp] }
+
+addFragment :: Fragment' -> Link -> Link
+addFragment fr l = l { _fragment = fr }
+
+-- | Transform 'Link' into 'URI'.
+--
+-- >>> type API = "something" :> Get '[JSON] Int
+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
+-- something
+--
+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
+-- sum?x[]=1&x[]=2&x[]=3
+--
+-- >>> type API = "foo/bar" :> Get '[JSON] Int
+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
+-- foo%2Fbar
+--
+-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
+-- >>> let someRoute = Proxy :: Proxy SomeRoute
+-- >>> safeLink someRoute someRoute "test@example.com"
+-- Link {_segments = ["abc","test%40example.com"], _queryParams = [], _fragment = Nothing}
+--
+-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
+-- abc/test%40example.com
+--
+linkURI :: Link -> URI
+linkURI = linkURI' LinkArrayElementBracket
+
+-- | How to encode array query elements.
+data LinkArrayElementStyle
+ = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@
+ | LinkArrayElementPlain -- ^ @foo=1&foo=2@
+ deriving (Eq, Ord, Show, Enum, Bounded)
+
+-- | Configurable 'linkURI'.
+--
+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
+-- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
+-- sum?x[]=1&x[]=2&x[]=3
+--
+-- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
+-- sum?x=1&x=2&x=3
+--
+linkURI' :: LinkArrayElementStyle -> Link -> URI
+linkURI' addBrackets (Link segments q_params mfragment) =
+ URI mempty -- No scheme (relative)
+ Nothing -- Or authority (relative)
+ (intercalate "/" $ map getEscaped segments)
+ (makeQueries q_params)
+ (makeFragment mfragment)
+ where
+ makeQueries :: [Param] -> String
+ makeQueries [] = ""
+ makeQueries xs =
+ "?" <> intercalate "&" (fmap makeQuery xs)
+
+ makeQuery :: Param -> String
+ makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)
+ makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
+ makeQuery (FlagParam k) = escape k
+
+ makeFragment :: Fragment' -> String
+ makeFragment Nothing = ""
+ makeFragment (Just fr) = "#" <> escape fr
+
+ style = case addBrackets of
+ LinkArrayElementBracket -> "[]="
+ LinkArrayElementPlain -> "="
+
+escape :: String -> String
+escape = escapeURIString isUnreserved
+
+-- | Create a valid (by construction) relative URI with query params.
+--
+-- This function will only typecheck if `endpoint` is part of the API `api`
+safeLink
+ :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
+ => Proxy api -- ^ The whole API that this endpoint is a part of
+ -> Proxy endpoint -- ^ The API endpoint you would like to point to
+ -> MkLink endpoint Link
+safeLink = safeLink' id
+
+-- | More general 'safeLink'.
+--
+safeLink'
+ :: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)
+ => (Link -> a)
+ -> Proxy api -- ^ The whole API that this endpoint is a part of
+ -> Proxy endpoint -- ^ The API endpoint you would like to point to
+ -> MkLink endpoint a
+safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty mempty)
+
+-- | Create all links in an API.
+--
+-- Note that the @api@ type must be restricted to the endpoints that have
+-- valid links to them.
+--
+-- >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double
+-- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API)
+-- >>> :t fooLink
+-- fooLink :: Text -> Link
+-- >>> :t barLink
+-- barLink :: Int -> Link
+--
+-- Note: nested APIs don't work well with this approach
+--
+-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link
+-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *
+-- = Char -> (Int -> Link) :<|> (Double -> Link)
+allLinks
+ :: forall api. HasLink api
+ => Proxy api
+ -> MkLink api Link
+allLinks = allLinks' id
+
+-- | More general 'allLinks'. See `safeLink'`.
+allLinks'
+ :: forall api a. HasLink api
+ => (Link -> a)
+ -> Proxy api
+ -> MkLink api a
+allLinks' toA api = toLink toA api (Link mempty mempty mempty)
+
+-------------------------------------------------------------------------------
+-- Generics
+-------------------------------------------------------------------------------
+
+-- | Given an API record field, create a link for that route. Only the field's
+-- type is used.
+--
+-- @
+-- data Record route = Record
+-- { _get :: route :- Capture "id" Int :> Get '[JSON] String
+-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool
+-- }
+-- deriving ('Generic')
+--
+-- getLink :: Int -> Link
+-- getLink = 'fieldLink' _get
+-- @
+--
+-- @since 0.14.1
+fieldLink
+ :: ( IsElem endpoint (ToServantApi routes), HasLink endpoint
+ , GenericServant routes AsApi
+ )
+ => (routes AsApi -> endpoint)
+ -> MkLink endpoint Link
+fieldLink = fieldLink' id
+
+-- | More general version of 'fieldLink'
+--
+-- @since 0.14.1
+fieldLink'
+ :: forall routes endpoint a.
+ ( IsElem endpoint (ToServantApi routes), HasLink endpoint
+ , GenericServant routes AsApi
+ )
+ => (Link -> a)
+ -> (routes AsApi -> endpoint)
+ -> MkLink endpoint a
+fieldLink' toA _ = safeLink' toA (genericApi (Proxy :: Proxy routes)) (Proxy :: Proxy endpoint)
+
+-- | A type that specifies that an API record contains a set of links.
+--
+-- @since 0.14.1
+data AsLink (a :: *)
+instance GenericMode (AsLink a) where
+ type (AsLink a) :- api = MkLink api a
+
+-- | Get all links as a record.
+--
+-- @since 0.14.1
+allFieldLinks
+ :: ( HasLink (ToServantApi routes)
+ , GenericServant routes (AsLink Link)
+ , ToServant routes (AsLink Link) ~ MkLink (ToServantApi routes) Link
+ )
+ => routes (AsLink Link)
+allFieldLinks = allFieldLinks' id
+
+-- | More general version of 'allFieldLinks'.
+--
+-- @since 0.14.1
+allFieldLinks'
+ :: forall routes a.
+ ( HasLink (ToServantApi routes)
+ , GenericServant routes (AsLink a)
+ , ToServant routes (AsLink a) ~ MkLink (ToServantApi routes) a
+ )
+ => (Link -> a)
+ -> routes (AsLink a)
+allFieldLinks' toA
+ = fromServant
+ $ allLinks' toA (Proxy :: Proxy (ToServantApi routes))
+
+-------------------------------------------------------------------------------
+-- HasLink
+-------------------------------------------------------------------------------
+
+-- | Construct a toLink for an endpoint.
+class HasLink endpoint where
+ type MkLink endpoint (a :: *)
+ toLink
+ :: (Link -> a)
+ -> Proxy endpoint -- ^ The API endpoint you would like to point to
+ -> Link
+ -> MkLink endpoint a
+
+-- Naked symbol instance
+instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
+ type MkLink (sym :> sub) a = MkLink sub a
+ toLink toA _ =
+ toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
+ where
+ seg = symbolVal (Proxy :: Proxy sym)
+
+-- QueryParam instances
+instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
+ => HasLink (QueryParam' mods sym v :> sub)
+ where
+ type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
+ toLink toA _ l mv =
+ toLink toA (Proxy :: Proxy sub) $
+ case sbool :: SBool (FoldRequired mods) of
+ STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
+ SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
+ where
+ k :: String
+ k = symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
+ => HasLink (QueryParams sym v :> sub)
+ where
+ type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
+ toLink toA _ l =
+ toLink toA (Proxy :: Proxy sub) .
+ foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
+ where
+ k = symbolVal (Proxy :: Proxy sym)
+
+instance (KnownSymbol sym, HasLink sub)
+ => HasLink (QueryFlag sym :> sub)
+ where
+ type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
+ toLink toA _ l False =
+ toLink toA (Proxy :: Proxy sub) l
+ toLink toA _ l True =
+ toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
+ where
+ k = symbolVal (Proxy :: Proxy sym)
+
+-- :<|> instance - Generate all links at once
+instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
+ type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
+ toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
+
+-- Misc instances
+instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
+ type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
+ toLink toA _ = toLink toA (Proxy :: Proxy sub)
+
+instance HasLink sub => HasLink (StreamBody' mods framing ct a :> sub) where
+ type MkLink (StreamBody' mods framing ct a :> sub) r = MkLink sub r
+ toLink toA _ = toLink toA (Proxy :: Proxy sub)
+
+instance (ToHttpApiData v, HasLink sub)
+ => HasLink (Capture' mods sym v :> sub)
+ where
+ type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
+ toLink toA _ l v =
+ toLink toA (Proxy :: Proxy sub) $
+ addSegment (escaped . Text.unpack $ toUrlPiece v) l
+
+instance (ToHttpApiData v, HasLink sub)
+ => HasLink (CaptureAll sym v :> sub)
+ where
+ type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
+ toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
+ foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
+
+instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
+ type MkLink (Header' mods sym a :> sub) r = MkLink sub r
+ toLink = simpleToLink (Proxy :: Proxy sub)
+
+instance HasLink sub => HasLink (Vault :> sub) where
+ type MkLink (Vault :> sub) a = MkLink sub a
+ toLink = simpleToLink (Proxy :: Proxy sub)
+
+instance HasLink sub => HasLink (Description s :> sub) where
+ type MkLink (Description s :> sub) a = MkLink sub a
+ toLink = simpleToLink (Proxy :: Proxy sub)
+
+instance HasLink sub => HasLink (Summary s :> sub) where
+ type MkLink (Summary s :> sub) a = MkLink sub a
+ toLink = simpleToLink (Proxy :: Proxy sub)
+
+instance HasLink sub => HasLink (HttpVersion :> sub) where
+ type MkLink (HttpVersion:> sub) a = MkLink sub a
+ toLink = simpleToLink (Proxy :: Proxy sub)
+
+instance HasLink sub => HasLink (IsSecure :> sub) where
+ type MkLink (IsSecure :> sub) a = MkLink sub a
+ toLink = simpleToLink (Proxy :: Proxy sub)
+
+instance HasLink sub => HasLink (WithNamedContext name context sub) where
+ type MkLink (WithNamedContext name context sub) a = MkLink sub a
+ toLink toA _ = toLink toA (Proxy :: Proxy sub)
+
+instance HasLink sub => HasLink (RemoteHost :> sub) where
+ type MkLink (RemoteHost :> sub) a = MkLink sub a
+ toLink = simpleToLink (Proxy :: Proxy sub)
+
+instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
+ type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
+ toLink = simpleToLink (Proxy :: Proxy sub)
+
+instance HasLink EmptyAPI where
+ type MkLink EmptyAPI a = EmptyAPI
+ toLink _ _ _ = EmptyAPI
+
+-- Verb (terminal) instances
+instance HasLink (Verb m s ct a) where
+ type MkLink (Verb m s ct a) r = r
+ toLink toA _ = toA
+
+instance HasLink (NoContentVerb m) where
+ type MkLink (NoContentVerb m) r = r
+ toLink toA _ = toA
+
+instance HasLink Raw where
+ type MkLink Raw a = a
+ toLink toA _ = toA
+
+instance HasLink (Stream m status fr ct a) where
+ type MkLink (Stream m status fr ct a) r = r
+ toLink toA _ = toA
+
+-- UVerb instances
+instance HasLink (UVerb m ct a) where
+ type MkLink (UVerb m ct a) r = r
+ toLink toA _ = toA
+-- Instance for NamedRoutes combinator
+
+type GLinkConstraints routes a =
+ ( MkLink (ToServant routes AsApi) a ~ ToServant routes (AsLink a)
+ , GenericServant routes (AsLink a)
+ )
+
+class GLink (routes :: * -> *) (a :: *) where
+ gLinkProof :: Dict (GLinkConstraints routes a)
+
+instance GLinkConstraints routes a => GLink routes a where
+ gLinkProof = Dict
+
+instance
+ ( HasLink (ToServantApi routes)
+ , forall a. GLink routes a
+ ) => HasLink (NamedRoutes routes) where
+
+ type MkLink (NamedRoutes routes) a = routes (AsLink a)
+
+ toLink
+ :: forall a. (Link -> a)
+ -> Proxy (NamedRoutes routes)
+ -> Link
+ -> routes (AsLink a)
+
+ toLink toA _ l = case gLinkProof @routes @a of
+ Dict -> fromServant $ toLink toA (Proxy @(ToServantApi routes)) l
+
+-- AuthProtext instances
+instance HasLink sub => HasLink (AuthProtect tag :> sub) where
+ type MkLink (AuthProtect tag :> sub) a = MkLink sub a
+ toLink = simpleToLink (Proxy :: Proxy sub)
+
+instance (HasLink sub, ToHttpApiData v)
+ => HasLink (Fragment v :> sub) where
+ type MkLink (Fragment v :> sub) a = v -> MkLink sub a
+ toLink toA _ l mv =
+ toLink toA (Proxy :: Proxy sub) $
+ addFragment ((Just . Text.unpack . toQueryParam) mv) l
+
+-- | Helper for implementing 'toLink' for combinators not affecting link
+-- structure.
+simpleToLink
+ :: forall sub a combinator.
+ (HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)
+ => Proxy sub
+ -> (Link -> a)
+ -> Proxy (combinator :> sub)
+ -> Link
+ -> MkLink (combinator :> sub) a
+simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
+
+
+-- $setup
+-- >>> import Servant.API
+-- >>> import Data.Text (Text)
diff --git a/servant/src/Servant/Links/TypeErrors.hs b/servant/src/Servant/Links/TypeErrors.hs
new file mode 100644
index 000000000..75233fae1
--- /dev/null
+++ b/servant/src/Servant/Links/TypeErrors.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
+
+#if __GLASGOW_HASKELL__ >= 904
+{-# LANGUAGE TypeApplications #-}
+#endif
+
+-- | This module contains erroring instances for @Servant.Links.Internal@.
+-- They are separated from the bulk of the code, because they raise "missing methods"
+-- warnings. These warnings are expected, but ignoring them would lead to missing
+-- relevant warnings in @Servant.Links.Internal@. Therefore, we put them in a separate
+-- file, and ignore the warnings here.
+module Servant.Links.TypeErrors ()
+ where
+
+import Data.Constraint
+import GHC.TypeLits
+ (TypeError)
+import Prelude ()
+import Prelude.Compat
+
+import Servant.API.Sub
+ (type (:>))
+import Servant.API.TypeErrors
+import Servant.Links.Internal
+
+#if __GLASGOW_HASKELL__ >= 904
+import Data.Kind (Type)
+#endif
+
+-- Erroring instance for 'HasLink' when a combinator is not fully applied
+instance TypeError (PartialApplication
+#if __GLASGOW_HASKELL__ >= 904
+ @(Type -> Constraint)
+#endif
+ HasLink arr) => HasLink ((arr :: a -> b) :> sub)
+ where
+ type MkLink (arr :> sub) _ = TypeError (PartialApplication (HasLink :: * -> Constraint) arr)
+ toLink = error "unreachable"
+
+-- Erroring instances for 'HasLink' for unknown API combinators
+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
+#if __GLASGOW_HASKELL__ >= 904
+ @(Type -> Constraint)
+#endif
+ HasLink ty) => HasLink (ty :> sub)
+
+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasLink api)) => HasLink api