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