Merge e32b28c7c4 into a4194dc490
This commit is contained in:
nbacquey
GitHub
commit
072fabc529
|
|
@ -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
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,975 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Servant.Client.Core.HasClient.Internal (
|
||||
clientIn,
|
||||
HasClient (..),
|
||||
EmptyClient (..),
|
||||
AsClientT,
|
||||
(//),
|
||||
(/:),
|
||||
foldMapUnion,
|
||||
matchUnion,
|
||||
) where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Arrow
|
||||
(left, (+++))
|
||||
import Control.Monad
|
||||
(unless)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Either
|
||||
(partitionEithers)
|
||||
import Data.Constraint (Dict(..))
|
||||
import Data.Foldable
|
||||
(toList)
|
||||
import Data.List
|
||||
(foldl')
|
||||
import Data.Sequence
|
||||
(fromList)
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP.Media
|
||||
(MediaType, matches, parseAccept)
|
||||
import qualified Network.HTTP.Media as Media
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.SOP.BasicFunctors
|
||||
(I (I), (:.:) (Comp))
|
||||
import Data.SOP.Constraint
|
||||
(All)
|
||||
import Data.SOP.NP
|
||||
(NP (..), cpure_NP)
|
||||
import Data.SOP.NS
|
||||
(NS (S))
|
||||
import Data.String
|
||||
(fromString)
|
||||
import Data.Text
|
||||
(Text, pack)
|
||||
import Data.Proxy
|
||||
(Proxy (Proxy))
|
||||
import GHC.TypeLits
|
||||
(KnownNat, KnownSymbol, symbolVal)
|
||||
import Network.HTTP.Types
|
||||
(Status)
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Servant.API
|
||||
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
|
||||
BuildHeadersTo (..), Capture', CaptureAll, Description,
|
||||
EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
|
||||
FromSourceIO (..), Header', Headers (..), HttpVersion,
|
||||
IsSecure, MimeRender (mimeRender),
|
||||
MimeUnrender (mimeUnrender), NoContent (NoContent),
|
||||
NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
|
||||
ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
|
||||
StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
|
||||
Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
|
||||
getResponse, toEncodedUrlPiece, NamedRoutes)
|
||||
import Servant.API.Generic
|
||||
(GenericMode(..), ToServant, ToServantApi
|
||||
, GenericServant, toServant, fromServant)
|
||||
import Servant.API.ContentTypes
|
||||
(contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
|
||||
import Servant.API.Status
|
||||
(statusFromNat)
|
||||
import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
|
||||
import Servant.API.Modifiers
|
||||
(FoldRequired, RequiredArgument, foldRequiredArgument)
|
||||
import Servant.API.UVerb
|
||||
(HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
|
||||
|
||||
import Servant.Client.Core.Auth
|
||||
import Servant.Client.Core.BasicAuth
|
||||
import Servant.Client.Core.ClientError
|
||||
import Servant.Client.Core.Request
|
||||
import Servant.Client.Core.Response
|
||||
import Servant.Client.Core.RunClient
|
||||
|
||||
-- * Accessing APIs as a Client
|
||||
|
||||
-- | 'clientIn' allows you to produce operations to query an API from a client
|
||||
-- within a 'RunClient' monad.
|
||||
--
|
||||
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > clientM :: Proxy ClientM
|
||||
-- > clientM = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: ClientM [Book]
|
||||
-- > postNewBook :: Book -> ClientM Book
|
||||
-- > (getAllBooks :<|> postNewBook) = myApi `clientIn` clientM
|
||||
clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api
|
||||
clientIn p pm = clientWithRoute pm p defaultRequest
|
||||
|
||||
|
||||
-- | This class lets us define how each API combinator influences the creation
|
||||
-- of an HTTP request.
|
||||
--
|
||||
-- Unless you are writing a new backend for @servant-client-core@ or new
|
||||
-- combinators that you want to support client-generation, you can ignore this
|
||||
-- class.
|
||||
class RunClient m => HasClient m api where
|
||||
type Client (m :: * -> *) (api :: *) :: *
|
||||
clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api
|
||||
hoistClientMonad
|
||||
:: Proxy m
|
||||
-> Proxy api
|
||||
-> (forall x. mon x -> mon' x)
|
||||
-> Client mon api
|
||||
-> Client mon' api
|
||||
|
||||
|
||||
-- | A client querying function for @a ':<|>' b@ will actually hand you
|
||||
-- one function for querying @a@ and another one for querying @b@,
|
||||
-- stitching them together with ':<|>', which really is just like a pair.
|
||||
--
|
||||
-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
|
||||
-- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: ClientM [Book]
|
||||
-- > postNewBook :: Book -> ClientM Book
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi
|
||||
instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where
|
||||
type Client m (a :<|> b) = Client m a :<|> Client m b
|
||||
clientWithRoute pm Proxy req =
|
||||
clientWithRoute pm (Proxy :: Proxy a) req :<|>
|
||||
clientWithRoute pm (Proxy :: Proxy b) req
|
||||
|
||||
hoistClientMonad pm _ f (ca :<|> cb) =
|
||||
hoistClientMonad pm (Proxy :: Proxy a) f ca :<|>
|
||||
hoistClientMonad pm (Proxy :: Proxy b) f cb
|
||||
|
||||
-- | Singleton type representing a client for an empty API.
|
||||
data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
|
||||
|
||||
-- | The client for 'EmptyAPI' is simply 'EmptyClient'.
|
||||
--
|
||||
-- > type MyAPI = "books" :> Get '[JSON] [Book] -- GET /books
|
||||
-- > :<|> "nothing" :> EmptyAPI
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: ClientM [Book]
|
||||
-- > (getAllBooks :<|> EmptyClient) = client myApi
|
||||
instance RunClient m => HasClient m EmptyAPI where
|
||||
type Client m EmptyAPI = EmptyClient
|
||||
clientWithRoute _pm Proxy _ = EmptyClient
|
||||
hoistClientMonad _ _ _ EmptyClient = EmptyClient
|
||||
|
||||
-- | If you use a 'Capture' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'Capture'.
|
||||
-- That function will take care of inserting a textual representation
|
||||
-- of this value at the right place in the request path.
|
||||
--
|
||||
-- You can control how values for this type are turned into
|
||||
-- text by specifying a 'ToHttpApiData' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBook :: Text -> ClientM Book
|
||||
-- > getBook = client myApi
|
||||
-- > -- then you can just use "getBook" to query that endpoint
|
||||
instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
|
||||
=> HasClient m (Capture' mods capture a :> api) where
|
||||
|
||||
type Client m (Capture' mods capture a :> api) =
|
||||
a -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req val =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(appendToPath p req)
|
||||
|
||||
where p = toEncodedUrlPiece val
|
||||
|
||||
hoistClientMonad pm _ f cl = \a ->
|
||||
hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
|
||||
|
||||
-- | If you use a 'CaptureAll' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take an
|
||||
-- additional argument of a list of the type specified by your
|
||||
-- 'CaptureAll'. That function will take care of inserting a textual
|
||||
-- representation of this value at the right place in the request
|
||||
-- path.
|
||||
--
|
||||
-- You can control how these values are turned into text by specifying
|
||||
-- a 'ToHttpApiData' instance of your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
|
||||
-- >
|
||||
-- > myApi :: Proxy
|
||||
-- > myApi = Proxy
|
||||
--
|
||||
-- > getSourceFile :: [Text] -> ClientM SourceFile
|
||||
-- > getSourceFile = client myApi
|
||||
-- > -- then you can use "getSourceFile" to query that endpoint
|
||||
instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
|
||||
=> HasClient m (CaptureAll capture a :> sublayout) where
|
||||
|
||||
type Client m (CaptureAll capture a :> sublayout) =
|
||||
[a] -> Client m sublayout
|
||||
|
||||
clientWithRoute pm Proxy req vals =
|
||||
clientWithRoute pm (Proxy :: Proxy sublayout)
|
||||
(foldl' (flip appendToPath) req ps)
|
||||
|
||||
where ps = map toEncodedUrlPiece vals
|
||||
|
||||
hoistClientMonad pm _ f cl = \as ->
|
||||
hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
|
||||
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
-- Note [Non-Empty Content Types]
|
||||
( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
|
||||
, KnownNat status
|
||||
) => HasClient m (Verb method status cts' a) where
|
||||
type Client m (Verb method status cts' a) = m a
|
||||
clientWithRoute _pm Proxy req = do
|
||||
response <- runRequestAcceptStatus (Just [status]) req
|
||||
{ requestAccept = fromList $ toList accept
|
||||
, requestMethod = method
|
||||
}
|
||||
response `decodedAs` (Proxy :: Proxy ct)
|
||||
where
|
||||
accept = contentTypes (Proxy :: Proxy ct)
|
||||
method = reflectMethod (Proxy :: Proxy method)
|
||||
status = statusFromNat (Proxy :: Proxy status)
|
||||
|
||||
hoistClientMonad _ _ f ma = f ma
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
( RunClient m, ReflectMethod method, KnownNat status
|
||||
) => HasClient m (Verb method status cts NoContent) where
|
||||
type Client m (Verb method status cts NoContent)
|
||||
= m NoContent
|
||||
clientWithRoute _pm Proxy req = do
|
||||
_response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
|
||||
return NoContent
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
status = statusFromNat (Proxy :: Proxy status)
|
||||
|
||||
hoistClientMonad _ _ f ma = f ma
|
||||
|
||||
instance (RunClient m, ReflectMethod method) =>
|
||||
HasClient m (NoContentVerb method) where
|
||||
type Client m (NoContentVerb method)
|
||||
= m NoContent
|
||||
clientWithRoute _pm Proxy req = do
|
||||
_response <- runRequest req { requestMethod = method }
|
||||
return NoContent
|
||||
where method = reflectMethod (Proxy :: Proxy method)
|
||||
|
||||
hoistClientMonad _ _ f ma = f ma
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
-- Note [Non-Empty Content Types]
|
||||
( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
|
||||
, ReflectMethod method, cts' ~ (ct ': cts)
|
||||
) => HasClient m (Verb method status cts' (Headers ls a)) where
|
||||
type Client m (Verb method status cts' (Headers ls a))
|
||||
= m (Headers ls a)
|
||||
clientWithRoute _pm Proxy req = do
|
||||
response <- runRequestAcceptStatus (Just [status]) req
|
||||
{ requestMethod = method
|
||||
, requestAccept = fromList $ toList accept
|
||||
}
|
||||
val <- response `decodedAs` (Proxy :: Proxy ct)
|
||||
return $ Headers { getResponse = val
|
||||
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
|
||||
}
|
||||
where
|
||||
method = reflectMethod (Proxy :: Proxy method)
|
||||
accept = contentTypes (Proxy :: Proxy ct)
|
||||
status = statusFromNat (Proxy :: Proxy status)
|
||||
|
||||
hoistClientMonad _ _ f ma = f ma
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
|
||||
) => HasClient m (Verb method status cts (Headers ls NoContent)) where
|
||||
type Client m (Verb method status cts (Headers ls NoContent))
|
||||
= m (Headers ls NoContent)
|
||||
clientWithRoute _pm Proxy req = do
|
||||
response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
|
||||
return $ Headers { getResponse = NoContent
|
||||
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
|
||||
}
|
||||
where
|
||||
method = reflectMethod (Proxy :: Proxy method)
|
||||
status = statusFromNat (Proxy :: Proxy status)
|
||||
|
||||
hoistClientMonad _ _ f ma = f ma
|
||||
|
||||
data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
|
||||
deriving (Eq, Show)
|
||||
|
||||
class UnrenderResponse (cts :: [*]) (a :: *) where
|
||||
unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
|
||||
-> [Either (MediaType, String) a]
|
||||
|
||||
instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where
|
||||
unrenderResponse _ body = map parse . allMimeUnrender
|
||||
where parse (mediaType, parser) = left ((,) mediaType) (parser body)
|
||||
|
||||
instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h)
|
||||
=> UnrenderResponse cts (Headers h a) where
|
||||
unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body
|
||||
where
|
||||
setHeaders :: a -> Headers h a
|
||||
setHeaders x = Headers x (buildHeadersTo (toList hs))
|
||||
|
||||
instance {-# OVERLAPPING #-} UnrenderResponse cts a
|
||||
=> UnrenderResponse cts (WithStatus n a) where
|
||||
unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
( RunClient m,
|
||||
contentTypes ~ (contentType ': otherContentTypes),
|
||||
-- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem
|
||||
-- allow this in instance types as of 8.8.3.)
|
||||
as ~ (a ': as'),
|
||||
AllMime contentTypes,
|
||||
ReflectMethod method,
|
||||
All (UnrenderResponse contentTypes) as,
|
||||
All HasStatus as, HasStatuses as',
|
||||
Unique (Statuses as)
|
||||
) =>
|
||||
HasClient m (UVerb method contentTypes as)
|
||||
where
|
||||
type Client m (UVerb method contentTypes as) = m (Union as)
|
||||
|
||||
clientWithRoute _ _ request = do
|
||||
let accept = Seq.fromList . allMime $ Proxy @contentTypes
|
||||
-- offering to accept all mime types listed in the api gives best compatibility. eg.,
|
||||
-- we might not own the server implementation, and the server may choose to support
|
||||
-- only part of the api.
|
||||
|
||||
method = reflectMethod $ Proxy @method
|
||||
acceptStatus = statuses (Proxy @as)
|
||||
response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}
|
||||
responseContentType <- checkContentTypeHeader response
|
||||
unless (any (matches responseContentType) accept) $ do
|
||||
throwClientError $ UnsupportedContentType responseContentType response
|
||||
|
||||
let status = responseStatusCode response
|
||||
body = responseBody response
|
||||
headers = responseHeaders response
|
||||
res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
|
||||
case res of
|
||||
Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
|
||||
Right x -> return x
|
||||
where
|
||||
-- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the
|
||||
-- failures it encountered along the way
|
||||
-- TODO; better name, rewrite haddocs.
|
||||
tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)
|
||||
tryParsers _ Nil = Left [ClientNoMatchingStatus]
|
||||
tryParsers status (Comp x :* xs)
|
||||
| status == statusOf (Comp x) =
|
||||
case partitionEithers x of
|
||||
(err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs
|
||||
(_, (res : _)) -> Right . inject . I $ res
|
||||
| otherwise = -- no reason to parse in the first place. This ain't the one we're looking for
|
||||
(ClientStatusMismatch :) +++ S $ tryParsers status xs
|
||||
|
||||
-- | Given a list of types, parses the given response body as each type
|
||||
mimeUnrenders ::
|
||||
forall cts xs.
|
||||
All (UnrenderResponse cts) xs =>
|
||||
Proxy cts ->
|
||||
Seq.Seq H.Header ->
|
||||
BL.ByteString ->
|
||||
NP ([] :.: Either (MediaType, String)) xs
|
||||
mimeUnrenders ctp headers body = cpure_NP
|
||||
(Proxy @(UnrenderResponse cts))
|
||||
(Comp . unrenderResponse headers body $ ctp)
|
||||
|
||||
hoistClientMonad _ _ nt s = nt s
|
||||
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
|
||||
FramingUnrender framing, FromSourceIO chunk a
|
||||
) => HasClient m (Stream method status framing ct a) where
|
||||
|
||||
type Client m (Stream method status framing ct a) = m a
|
||||
|
||||
hoistClientMonad _ _ f ma = f ma
|
||||
|
||||
clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
|
||||
let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
|
||||
framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
|
||||
return $ fromSourceIO $ framingUnrender' $ responseBody gres
|
||||
where
|
||||
req' = req
|
||||
{ requestAccept = fromList [contentType (Proxy :: Proxy ct)]
|
||||
, requestMethod = reflectMethod (Proxy :: Proxy method)
|
||||
}
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
|
||||
FramingUnrender framing, FromSourceIO chunk a,
|
||||
BuildHeadersTo hs
|
||||
) => HasClient m (Stream method status framing ct (Headers hs a)) where
|
||||
|
||||
type Client m (Stream method status framing ct (Headers hs a)) = m (Headers hs a)
|
||||
|
||||
hoistClientMonad _ _ f ma = f ma
|
||||
|
||||
clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
|
||||
let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
|
||||
framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
|
||||
val = fromSourceIO $ framingUnrender' $ responseBody gres
|
||||
return $ Headers
|
||||
{ getResponse = val
|
||||
, getHeadersHList = buildHeadersTo . toList $ responseHeaders gres
|
||||
}
|
||||
|
||||
where
|
||||
req' = req
|
||||
{ requestAccept = fromList [contentType (Proxy :: Proxy ct)]
|
||||
, requestMethod = reflectMethod (Proxy :: Proxy method)
|
||||
}
|
||||
|
||||
-- | If you use a 'Header' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'Header',
|
||||
-- wrapped in Maybe.
|
||||
--
|
||||
-- That function will take care of encoding this argument as Text
|
||||
-- in the request headers.
|
||||
--
|
||||
-- All you need is for your type to have a 'ToHttpApiData' instance.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > newtype Referer = Referer { referrer :: Text }
|
||||
-- > deriving (Eq, Show, Generic, ToHttpApiData)
|
||||
-- >
|
||||
-- > -- GET /view-my-referer
|
||||
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > viewReferer :: Maybe Referer -> ClientM Book
|
||||
-- > viewReferer = client myApi
|
||||
-- > -- then you can just use "viewRefer" to query that endpoint
|
||||
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
|
||||
=> HasClient m (Header' mods sym a :> api) where
|
||||
|
||||
type Client m (Header' mods sym a :> api) =
|
||||
RequiredArgument mods a -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req mval =
|
||||
clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
|
||||
(Proxy :: Proxy mods) add (maybe req add) mval
|
||||
where
|
||||
hname = fromString $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
add :: a -> Request
|
||||
add value = addHeader hname value req
|
||||
|
||||
hoistClientMonad pm _ f cl = \arg ->
|
||||
hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
|
||||
|
||||
-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
|
||||
-- functions.
|
||||
instance HasClient m api
|
||||
=> HasClient m (HttpVersion :> api) where
|
||||
|
||||
type Client m (HttpVersion :> api) =
|
||||
Client m api
|
||||
|
||||
clientWithRoute pm Proxy =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
|
||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
|
||||
|
||||
-- | Ignore @'Summary'@ in client functions.
|
||||
instance HasClient m api => HasClient m (Summary desc :> api) where
|
||||
type Client m (Summary desc :> api) = Client m api
|
||||
|
||||
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
|
||||
|
||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
|
||||
|
||||
-- | Ignore @'Description'@ in client functions.
|
||||
instance HasClient m api => HasClient m (Description desc :> api) where
|
||||
type Client m (Description desc :> api) = Client m api
|
||||
|
||||
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
|
||||
|
||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
|
||||
|
||||
-- | If you use a 'QueryParam' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'QueryParam',
|
||||
-- enclosed in Maybe.
|
||||
--
|
||||
-- If you give Nothing, nothing will be added to the query string.
|
||||
--
|
||||
-- If you give a non-'Nothing' value, this function will take care
|
||||
-- of inserting a textual representation of this value in the query string.
|
||||
--
|
||||
-- You can control how values for your type are turned into
|
||||
-- text by specifying a 'ToHttpApiData' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: Maybe Text -> ClientM [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy Nothing' for all books
|
||||
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
|
||||
=> HasClient m (QueryParam' mods sym a :> api) where
|
||||
|
||||
type Client m (QueryParam' mods sym a :> api) =
|
||||
RequiredArgument mods a -> Client m api
|
||||
|
||||
-- if mparam = Nothing, we don't add it to the query string
|
||||
clientWithRoute pm Proxy req mparam =
|
||||
clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
|
||||
(Proxy :: Proxy mods) add (maybe req add) mparam
|
||||
where
|
||||
add :: a -> Request
|
||||
add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
|
||||
|
||||
pname :: Text
|
||||
pname = pack $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
hoistClientMonad pm _ f cl = \arg ->
|
||||
hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
|
||||
|
||||
-- | If you use a 'QueryParams' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument, a list of values of the type specified
|
||||
-- by your 'QueryParams'.
|
||||
--
|
||||
-- If you give an empty list, nothing will be added to the query string.
|
||||
--
|
||||
-- Otherwise, this function will take care
|
||||
-- of inserting a textual representation of your values in the query string,
|
||||
-- under the same query string parameter name.
|
||||
--
|
||||
-- You can control how values for your type are turned into
|
||||
-- text by specifying a 'ToHttpApiData' instance for your type.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooksBy :: [Text] -> ClientM [Book]
|
||||
-- > getBooksBy = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooksBy []' for all books
|
||||
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
|
||||
-- > -- to get all books by Asimov and Heinlein
|
||||
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
|
||||
=> HasClient m (QueryParams sym a :> api) where
|
||||
|
||||
type Client m (QueryParams sym a :> api) =
|
||||
[a] -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req paramlist =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
|
||||
req
|
||||
paramlist'
|
||||
)
|
||||
|
||||
where pname = pack $ symbolVal (Proxy :: Proxy sym)
|
||||
paramlist' = map (Just . encodeQueryParamValue) paramlist
|
||||
|
||||
hoistClientMonad pm _ f cl = \as ->
|
||||
hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
|
||||
|
||||
-- | If you use a 'QueryFlag' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional 'Bool' argument.
|
||||
--
|
||||
-- If you give 'False', nothing will be added to the query string.
|
||||
--
|
||||
-- Otherwise, this function will insert a value-less query string
|
||||
-- parameter under the name associated to your 'QueryFlag'.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooks :: Bool -> ClientM [Book]
|
||||
-- > getBooks = client myApi
|
||||
-- > -- then you can just use "getBooks" to query that endpoint.
|
||||
-- > -- 'getBooksBy False' for all books
|
||||
-- > -- 'getBooksBy True' to only get _already published_ books
|
||||
instance (KnownSymbol sym, HasClient m api)
|
||||
=> HasClient m (QueryFlag sym :> api) where
|
||||
|
||||
type Client m (QueryFlag sym :> api) =
|
||||
Bool -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req flag =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(if flag
|
||||
then appendToQueryString paramname Nothing req
|
||||
else req
|
||||
)
|
||||
|
||||
where paramname = pack $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
hoistClientMonad pm _ f cl = \b ->
|
||||
hoistClientMonad pm (Proxy :: Proxy api) f (cl b)
|
||||
|
||||
-- | Pick a 'Method' and specify where the server you want to query is. You get
|
||||
-- back the full `Response`.
|
||||
instance RunClient m => HasClient m Raw where
|
||||
type Client m Raw
|
||||
= H.Method -> m Response
|
||||
|
||||
clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw
|
||||
clientWithRoute _pm Proxy req httpMethod = do
|
||||
runRequest req { requestMethod = httpMethod }
|
||||
|
||||
hoistClientMonad _ _ f cl = \meth -> f (cl meth)
|
||||
|
||||
-- | If you use a 'ReqBody' in one of your endpoints in your API,
|
||||
-- the corresponding querying function will automatically take
|
||||
-- an additional argument of the type specified by your 'ReqBody'.
|
||||
-- That function will take care of encoding this argument as JSON and
|
||||
-- of using it as the request body.
|
||||
--
|
||||
-- All you need is for your type to have a 'ToJSON' instance.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > addBook :: Book -> ClientM Book
|
||||
-- > addBook = client myApi
|
||||
-- > -- then you can just use "addBook" to query that endpoint
|
||||
instance (MimeRender ct a, HasClient m api)
|
||||
=> HasClient m (ReqBody' mods (ct ': cts) a :> api) where
|
||||
|
||||
type Client m (ReqBody' mods (ct ': cts) a :> api) =
|
||||
a -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req body =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(let ctProxy = Proxy :: Proxy ct
|
||||
in setRequestBodyLBS (mimeRender ctProxy body)
|
||||
-- We use first contentType from the Accept list
|
||||
(contentType ctProxy)
|
||||
req
|
||||
)
|
||||
|
||||
hoistClientMonad pm _ f cl = \a ->
|
||||
hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
|
||||
|
||||
instance
|
||||
( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
|
||||
) => HasClient m (StreamBody' mods framing ctype a :> api)
|
||||
where
|
||||
|
||||
type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api
|
||||
|
||||
hoistClientMonad pm _ f cl = \a ->
|
||||
hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
|
||||
|
||||
clientWithRoute pm Proxy req body
|
||||
= clientWithRoute pm (Proxy :: Proxy api)
|
||||
$ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req
|
||||
where
|
||||
ctypeP = Proxy :: Proxy ctype
|
||||
framingP = Proxy :: Proxy framing
|
||||
|
||||
sourceIO = framingRender
|
||||
framingP
|
||||
(mimeRender ctypeP :: chunk -> BL.ByteString)
|
||||
(toSourceIO body)
|
||||
|
||||
-- | Make the querying function append @path@ to the request path.
|
||||
instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
|
||||
type Client m (path :> api) = Client m api
|
||||
|
||||
clientWithRoute pm Proxy req =
|
||||
clientWithRoute pm (Proxy :: Proxy api)
|
||||
(appendToPath p req)
|
||||
|
||||
where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
|
||||
|
||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
|
||||
|
||||
instance HasClient m api => HasClient m (Vault :> api) where
|
||||
type Client m (Vault :> api) = Client m api
|
||||
|
||||
clientWithRoute pm Proxy req =
|
||||
clientWithRoute pm (Proxy :: Proxy api) req
|
||||
|
||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
|
||||
|
||||
instance HasClient m api => HasClient m (RemoteHost :> api) where
|
||||
type Client m (RemoteHost :> api) = Client m api
|
||||
|
||||
clientWithRoute pm Proxy req =
|
||||
clientWithRoute pm (Proxy :: Proxy api) req
|
||||
|
||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
|
||||
|
||||
instance HasClient m api => HasClient m (IsSecure :> api) where
|
||||
type Client m (IsSecure :> api) = Client m api
|
||||
|
||||
clientWithRoute pm Proxy req =
|
||||
clientWithRoute pm (Proxy :: Proxy api) req
|
||||
|
||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
|
||||
|
||||
instance HasClient m subapi =>
|
||||
HasClient m (WithNamedContext name context subapi) where
|
||||
|
||||
type Client m (WithNamedContext name context subapi) = Client m subapi
|
||||
clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
|
||||
|
||||
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
|
||||
|
||||
instance ( HasClient m api
|
||||
) => HasClient m (AuthProtect tag :> api) where
|
||||
type Client m (AuthProtect tag :> api)
|
||||
= AuthenticatedRequest (AuthProtect tag) -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =
|
||||
clientWithRoute pm (Proxy :: Proxy api) (func val req)
|
||||
|
||||
hoistClientMonad pm _ f cl = \authreq ->
|
||||
hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
|
||||
|
||||
-- | Ignore @'Fragment'@ in client functions.
|
||||
-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
|
||||
-- >
|
||||
-- > myApi :: Proxy MyApi
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getBooks :: ClientM [Book]
|
||||
-- > getBooks = client myApi
|
||||
-- > -- then you can just use "getBooksBy" to query that endpoint.
|
||||
-- > -- 'getBooks' for all books.
|
||||
instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
|
||||
) => HasClient m (Fragment a :> api) where
|
||||
|
||||
type Client m (Fragment a :> api) = Client m api
|
||||
|
||||
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
|
||||
|
||||
hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
|
||||
|
||||
-- * Basic Authentication
|
||||
|
||||
instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
|
||||
type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api
|
||||
|
||||
clientWithRoute pm Proxy req val =
|
||||
clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)
|
||||
|
||||
hoistClientMonad pm _ f cl = \bauth ->
|
||||
hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
|
||||
|
||||
-- | A type that specifies that an API record contains a client implementation.
|
||||
data AsClientT (m :: * -> *)
|
||||
instance GenericMode (AsClientT m) where
|
||||
type AsClientT m :- api = Client m api
|
||||
|
||||
|
||||
type GClientConstraints api m =
|
||||
( GenericServant api (AsClientT m)
|
||||
, Client m (ToServantApi api) ~ ToServant api (AsClientT m)
|
||||
)
|
||||
|
||||
class GClient (api :: * -> *) m where
|
||||
gClientProof :: Dict (GClientConstraints api m)
|
||||
|
||||
instance GClientConstraints api m => GClient api m where
|
||||
gClientProof = Dict
|
||||
|
||||
instance
|
||||
( forall n. GClient api n
|
||||
, HasClient m (ToServantApi api)
|
||||
, RunClient m
|
||||
)
|
||||
=> HasClient m (NamedRoutes api) where
|
||||
type Client m (NamedRoutes api) = api (AsClientT m)
|
||||
|
||||
clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
|
||||
clientWithRoute pm _ request =
|
||||
case gClientProof @api @m of
|
||||
Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
|
||||
|
||||
hoistClientMonad
|
||||
:: forall ma mb.
|
||||
Proxy m
|
||||
-> Proxy (NamedRoutes api)
|
||||
-> (forall x. ma x -> mb x)
|
||||
-> Client ma (NamedRoutes api)
|
||||
-> Client mb (NamedRoutes api)
|
||||
hoistClientMonad _ _ nat clientA =
|
||||
case (gClientProof @api @ma, gClientProof @api @mb) of
|
||||
(Dict, Dict) ->
|
||||
fromServant @api @(AsClientT mb) $
|
||||
hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
|
||||
toServant @api @(AsClientT ma) clientA
|
||||
|
||||
infixl 1 //
|
||||
infixl 2 /:
|
||||
|
||||
-- | Helper to make code using records of clients more readable.
|
||||
--
|
||||
-- Can be mixed with (/:) for supplying arguments.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- @
|
||||
-- type Api = NamedRoutes RootApi
|
||||
--
|
||||
-- data RootApi mode = RootApi
|
||||
-- { subApi :: mode :- NamedRoutes SubApi
|
||||
-- , …
|
||||
-- } deriving Generic
|
||||
--
|
||||
-- data SubApi mode = SubApi
|
||||
-- { endpoint :: mode :- Get '[JSON] Person
|
||||
-- , …
|
||||
-- } deriving Generic
|
||||
--
|
||||
-- api :: Proxy API
|
||||
-- api = Proxy
|
||||
--
|
||||
-- rootClient :: RootApi (AsClientT ClientM)
|
||||
-- rootClient = client api
|
||||
--
|
||||
-- endpointClient :: ClientM Person
|
||||
-- endpointClient = client // subApi // endpoint
|
||||
-- @
|
||||
(//) :: a -> (a -> b) -> b
|
||||
x // f = f x
|
||||
|
||||
-- | Convenience function for supplying arguments to client functions when
|
||||
-- working with records of clients.
|
||||
--
|
||||
-- Intended to be used in conjunction with '(//)'.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- @
|
||||
-- type Api = NamedRoutes RootApi
|
||||
--
|
||||
-- data RootApi mode = RootApi
|
||||
-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
|
||||
-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
|
||||
-- , …
|
||||
-- } deriving Generic
|
||||
--
|
||||
-- data SubApi mode = SubApi
|
||||
-- { endpoint :: mode :- Get '[JSON] Person
|
||||
-- , …
|
||||
-- } deriving Generic
|
||||
--
|
||||
-- api :: Proxy API
|
||||
-- api = Proxy
|
||||
--
|
||||
-- rootClient :: RootApi (AsClientT ClientM)
|
||||
-- rootClient = client api
|
||||
--
|
||||
-- hello :: String -> ClientM String
|
||||
-- hello name = rootClient // hello /: name
|
||||
--
|
||||
-- endpointClient :: ClientM Person
|
||||
-- endpointClient = client // subApi /: "foobar123" // endpoint
|
||||
-- @
|
||||
(/:) :: (a -> b -> c) -> b -> a -> c
|
||||
(/:) = flip
|
||||
|
||||
|
||||
{- Note [Non-Empty Content Types]
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
Rather than have
|
||||
|
||||
instance (..., cts' ~ (ct ': cts)) => ... cts' ...
|
||||
|
||||
It may seem to make more sense to have:
|
||||
|
||||
instance (...) => ... (ct ': cts) ...
|
||||
|
||||
But this means that if another instance exists that does *not* require
|
||||
non-empty lists, but is otherwise more specific, no instance will be overall
|
||||
more specific. This in turn generally means adding yet another instance (one
|
||||
for empty and one for non-empty lists).
|
||||
-}
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- helpers
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
checkContentTypeHeader :: RunClient m => Response -> m MediaType
|
||||
checkContentTypeHeader response =
|
||||
case lookup "Content-Type" $ toList $ responseHeaders response of
|
||||
Nothing -> return $ "application" Media.// "octet-stream"
|
||||
Just t -> case parseAccept t of
|
||||
Nothing -> throwClientError $ InvalidContentTypeHeader response
|
||||
Just t' -> return t'
|
||||
|
||||
decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
|
||||
=> Response -> Proxy ct -> m a
|
||||
decodedAs response ct = do
|
||||
responseContentType <- checkContentTypeHeader response
|
||||
unless (any (matches responseContentType) accept) $
|
||||
throwClientError $ UnsupportedContentType responseContentType response
|
||||
case mimeUnrender ct $ responseBody response of
|
||||
Left err -> throwClientError $ DecodeFailure (T.pack err) response
|
||||
Right val -> return val
|
||||
where
|
||||
accept = toList $ contentTypes ct
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -53,6 +53,9 @@ library
|
|||
Servant.Server.StaticFiles
|
||||
Servant.Server.UVerb
|
||||
|
||||
other-modules:
|
||||
Servant.Server.TypeErrors
|
||||
|
||||
-- deprecated
|
||||
exposed-modules:
|
||||
Servant.Utils.StaticFiles
|
||||
|
|
|
|||
|
|
@ -126,6 +126,7 @@ import Data.Text
|
|||
import Network.Wai
|
||||
(Application)
|
||||
import Servant.Server.Internal
|
||||
import Servant.Server.TypeErrors ()
|
||||
import Servant.Server.UVerb
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ import qualified Data.ByteString as B
|
|||
import qualified Data.ByteString.Builder as BB
|
||||
import qualified Data.ByteString.Char8 as BC8
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Constraint (Constraint, Dict(..))
|
||||
import Data.Constraint (Dict(..))
|
||||
import Data.Either
|
||||
(partitionEithers)
|
||||
import Data.Maybe
|
||||
|
|
@ -57,7 +57,7 @@ import qualified Data.Text as T
|
|||
import Data.Typeable
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits
|
||||
(KnownNat, KnownSymbol, TypeError, symbolVal)
|
||||
(KnownNat, KnownSymbol, symbolVal)
|
||||
import qualified Network.HTTP.Media as NHM
|
||||
import Network.HTTP.Types hiding
|
||||
(Header, ResponseHeaders)
|
||||
|
|
@ -91,12 +91,9 @@ import Servant.API.ResponseHeaders
|
|||
import Servant.API.Status
|
||||
(statusFromNat)
|
||||
import qualified Servant.Types.SourceT as S
|
||||
import Servant.API.TypeErrors
|
||||
import Web.HttpApiData
|
||||
(FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
|
||||
parseUrlPieces)
|
||||
import Data.Kind
|
||||
(Type)
|
||||
|
||||
import Servant.Server.Internal.BasicAuth
|
||||
import Servant.Server.Internal.Context
|
||||
|
|
@ -109,8 +106,6 @@ import Servant.Server.Internal.RouteResult
|
|||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ServerError
|
||||
|
||||
import GHC.TypeLits
|
||||
(ErrorMessage (..), TypeError)
|
||||
import Servant.API.TypeLevel
|
||||
(AtLeastOneFragment, FragmentUnique)
|
||||
|
||||
|
|
@ -819,67 +814,6 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
|
|||
|
||||
hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Custom type errors
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- Erroring instance for 'HasServer' when a combinator is not fully applied
|
||||
instance TypeError (PartialApplication
|
||||
#if __GLASGOW_HASKELL__ >= 904
|
||||
@(Type -> [Type] -> Constraint)
|
||||
#endif
|
||||
HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
|
||||
where
|
||||
type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
|
||||
route = error "unreachable"
|
||||
hoistServerWithContext _ _ _ _ = error "unreachable"
|
||||
|
||||
-- | This instance prevents from accidentally using '->' instead of ':>'
|
||||
--
|
||||
-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
|
||||
-- ...
|
||||
-- ...No instance HasServer (a -> b).
|
||||
-- ...Maybe you have used '->' instead of ':>' between
|
||||
-- ...Capture' '[] "foo" Int
|
||||
-- ...and
|
||||
-- ...Verb 'GET 200 '[JSON] Int
|
||||
-- ...
|
||||
--
|
||||
-- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int)
|
||||
-- ...
|
||||
-- ...No instance HasServer (a -> b).
|
||||
-- ...Maybe you have used '->' instead of ':>' between
|
||||
-- ...Capture' '[] "foo" Int
|
||||
-- ...and
|
||||
-- ...Verb 'GET 200 '[JSON] Int
|
||||
-- ...
|
||||
--
|
||||
instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context
|
||||
where
|
||||
type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b)
|
||||
route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)"
|
||||
hoistServerWithContext _ _ _ = id
|
||||
|
||||
type HasServerArrowTypeError a b =
|
||||
'Text "No instance HasServer (a -> b)."
|
||||
':$$: 'Text "Maybe you have used '->' instead of ':>' between "
|
||||
':$$: 'ShowType a
|
||||
':$$: 'Text "and"
|
||||
':$$: 'ShowType b
|
||||
|
||||
-- Erroring instances for 'HasServer' for unknown API combinators
|
||||
|
||||
-- XXX: This omits the @context@ parameter, e.g.:
|
||||
--
|
||||
-- "There is no instance for HasServer (Bool :> …)". Do we care ?
|
||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
|
||||
#if __GLASGOW_HASKELL__ >= 904
|
||||
@(Type -> [Type] -> Constraint)
|
||||
#endif
|
||||
HasServer ty) => HasServer (ty :> sub) context
|
||||
|
||||
instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
|
||||
|
||||
-- | Ignore @'Fragment'@ in server handlers.
|
||||
-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -19,7 +19,8 @@ module Servant.Server.UsingContextSpec.TestCombinators where
|
|||
|
||||
import GHC.TypeLits
|
||||
|
||||
import Servant
|
||||
import Servant hiding
|
||||
(inject)
|
||||
|
||||
data ExtractFromContext
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
--
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue