diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md) +[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) + +0.12 +---- + +- First version. Factored out of `servant-client` all the functionality that was + independent of the `http-client` backend. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Servant Contributors + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Servant Contributors nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,30 @@ +# servant-client-core + +![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) + +HTTP-client-agnostic client functions for servant APIs. + +This library should mainly be of interest to backend- and combinator-writers. + +## For backend-writers + +If you are creating a new backend, you'll need to: + +1. Define a `RunClient` instance for your datatype (call it `MyMonad`) +2. Define a `ClientLike` instance. This will look like: + +``` haskell +instance ClientLike (MyMonad a) (MyMonad a) where + mkClient = id +``` + +3. Re-export the module Servant.Client.Core.Reexport so that your end-users + can be blissfully unaware of 'servant-client-core', and so each + backend-package comes closer to the warm hearth of the drop-in-replacement + equivalence class. + +## For combinator-writers + +You'll need to define a new `HasClient` instance for your combinator. There are +plenty of examples to guide you in the +[HasClient](src/Servant/Client/Core/Internal/HasClient.hs) module. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h new file mode 100644 --- /dev/null +++ b/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-client-core.cabal b/servant-client-core.cabal new file mode 100644 --- /dev/null +++ b/servant-client-core.cabal @@ -0,0 +1,82 @@ +name: servant-client-core +version: 0.12 +synopsis: Core functionality and class for client function generation for servant APIs +description: + This library provides backend-agnostic generation of client functions. For + more information, see the README. +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +homepage: http://haskell-servant.readthedocs.org/ +bug-reports: http://github.com/haskell-servant/servant/issues +cabal-version: >=1.10 +copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors +category: Web +build-type: Simple +extra-source-files: + include/*.h + CHANGELOG.md + README.md +tested-with: + GHC==7.8.4 + GHC==7.10.3 + GHC==8.0.2 + GHC==8.2.1 + +source-repository head + type: git + location: http://github.com/haskell-servant/servant.git + +library + exposed-modules: + Servant.Client.Core + Servant.Client.Core.Reexport + Servant.Client.Core.Internal.Auth + Servant.Client.Core.Internal.BaseUrl + Servant.Client.Core.Internal.BasicAuth + Servant.Client.Core.Internal.Generic + Servant.Client.Core.Internal.HasClient + Servant.Client.Core.Internal.Request + Servant.Client.Core.Internal.RunClient + build-depends: + base >= 4.7 && < 4.11 + , base-compat >= 0.9.1 && < 0.10 + , base64-bytestring >= 1.0.0.1 && < 1.1 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5 && < 0.6 + , exceptions >= 0.8 && < 0.9 + , generics-sop >= 0.1.0.0 && < 0.4 + , http-api-data >= 0.3.6 && < 0.4 + , http-media >= 0.6.2 && < 0.8 + , http-types >= 0.8.6 && < 0.11 + , mtl >= 2.1 && < 2.3 + , network-uri >= 2.6 && < 2.7 + , safe >= 0.3.9 && < 0.4 + , servant == 0.12.* + , text >= 1.2 && < 1.3 + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.16.2.2 && <0.19 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + include-dirs: include + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base + , base-compat + , deepseq + , servant-client-core + , hspec == 2.* + , QuickCheck >= 2.7 && < 2.11 + build-tool-depends: + hspec-discover:hspec-discover + other-modules: + Servant.Client.Core.Internal.BaseUrlSpec diff --git a/src/Servant/Client/Core.hs b/src/Servant/Client/Core.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core.hs @@ -0,0 +1,65 @@ +-- | This module provides backend-agnostic functionality for generating clients +-- from @servant@ APIs. By "backend," we mean something that concretely +-- executes the request, such as: +-- +-- * The @http-client@ library +-- * The @haxl@ library +-- * GHCJS via FFI +-- +-- etc. +-- +-- Each backend is encapsulated in a monad that is an instance of the +-- 'RunClient' class. +-- +-- This library is primarily of interest to backend-writers and +-- combinator-writers. For more information, see the README.md +module Servant.Client.Core + ( + -- * Client generation + clientIn + , HasClient(..) + + -- * Request + , Request + , RequestF(..) + , defaultRequest + , RequestBody(..) + + -- * Authentication + , mkAuthenticatedRequest + , basicAuthReq + , AuthenticatedRequest(..) + , AuthClientData + + -- * Generic Client + , ClientLike(..) + , genericMkClientL + , genericMkClientP + , ServantError(..) + , EmptyClient(..) + + + -- * Response + , Response(..) + , RunClient(..) + , module Servant.Client.Core.Internal.BaseUrl + + -- * Writing HasClient instances + -- | These functions need not be re-exported by backend libraries. + , addHeader + , appendToQueryString + , appendToPath + , setRequestBodyLBS + , setRequestBody + ) where +import Servant.Client.Core.Internal.Auth +import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..), + InvalidBaseUrlException, + Scheme (..), + parseBaseUrl, + showBaseUrl) +import Servant.Client.Core.Internal.BasicAuth +import Servant.Client.Core.Internal.HasClient +import Servant.Client.Core.Internal.Generic +import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.RunClient diff --git a/src/Servant/Client/Core/Internal/Auth.hs b/src/Servant/Client/Core/Internal/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Internal/Auth.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Authentication for clients + +module Servant.Client.Core.Internal.Auth where + +import Servant.Client.Core.Internal.Request (Request) + +-- | For a resource protected by authentication (e.g. AuthProtect), we need +-- to provide the client with some data used to add authentication data +-- to a request +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +type family AuthClientData a :: * + +-- | For better type inference and to avoid usage of a data family, we newtype +-- wrap the combination of some 'AuthClientData' and a function to add authentication +-- data to a request +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +newtype AuthenticatedRequest a = + AuthenticatedRequest { unAuthReq :: (AuthClientData a, AuthClientData a -> Request -> Request) } + +-- | Handy helper to avoid wrapping datatypes in tuples everywhere. +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +mkAuthenticatedRequest :: AuthClientData a + -> (AuthClientData a -> Request -> Request) + -> AuthenticatedRequest a +mkAuthenticatedRequest val func = AuthenticatedRequest (val, func) diff --git a/src/Servant/Client/Core/Internal/BaseUrl.hs b/src/Servant/Client/Core/Internal/BaseUrl.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Internal/BaseUrl.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ViewPatterns #-} +module Servant.Client.Core.Internal.BaseUrl where + +import Control.Monad.Catch (Exception, MonadThrow, throwM) +import Data.List +import Data.Typeable +import GHC.Generics +import Network.URI hiding (path) +import Safe +import Text.Read + +-- | URI scheme to use +data Scheme = + Http -- ^ http:// + | Https -- ^ https:// + deriving (Show, Eq, Ord, Generic) + +-- | Simple data type to represent the target of HTTP requests +-- for servant's automatically-generated clients. +data BaseUrl = BaseUrl + { baseUrlScheme :: Scheme -- ^ URI scheme to use + , baseUrlHost :: String -- ^ host (eg "haskell.org") + , baseUrlPort :: Int -- ^ port (eg 80) + , baseUrlPath :: String -- ^ path (eg "/a/b/c") + } deriving (Show, Ord, Generic) + +instance Eq BaseUrl where + BaseUrl a b c path == BaseUrl a' b' c' path' + = a == a' && b == b' && c == c' && s path == s path' + where s ('/':x) = x + s x = x + +showBaseUrl :: BaseUrl -> String +showBaseUrl (BaseUrl urlscheme host port path) = + schemeString ++ "//" ++ host ++ (portString path) + where + a b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b + schemeString = case urlscheme of + Http -> "http:" + Https -> "https:" + portString = case (urlscheme, port) of + (Http, 80) -> "" + (Https, 443) -> "" + _ -> ":" ++ show port + +data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable) +instance Exception InvalidBaseUrlException + +parseBaseUrl :: MonadThrow m => String -> m BaseUrl +parseBaseUrl s = case parseURI (removeTrailingSlash s) of + -- This is a rather hacky implementation and should be replaced with something + -- implemented in attoparsec (which is already a dependency anyhow (via aeson)). + Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") -> + return (BaseUrl Http host port path) + Just (URI "http:" (Just (URIAuth "" host "")) path "" "") -> + return (BaseUrl Http host 80 path) + Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") -> + return (BaseUrl Https host port path) + Just (URI "https:" (Just (URIAuth "" host "")) path "" "") -> + return (BaseUrl Https host 443 path) + _ -> if "://" `isInfixOf` s + then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s) + else parseBaseUrl ("http://" ++ s) + where + removeTrailingSlash str = case lastMay str of + Just '/' -> init str + _ -> str diff --git a/src/Servant/Client/Core/Internal/BasicAuth.hs b/src/Servant/Client/Core/Internal/BasicAuth.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Internal/BasicAuth.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | Basic Authentication for clients + +module Servant.Client.Core.Internal.BasicAuth where + +import Data.ByteString.Base64 (encode) +import Data.Monoid ((<>)) +import Data.Text.Encoding (decodeUtf8) +import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) +import Servant.Client.Core.Internal.Request (Request, addHeader) + +-- | Authenticate a request using Basic Authentication +basicAuthReq :: BasicAuthData -> Request -> Request +basicAuthReq (BasicAuthData user pass) req = + let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) + in addHeader "Authorization" authText req diff --git a/src/Servant/Client/Core/Internal/Generic.hs b/src/Servant/Client/Core/Internal/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Internal/Generic.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +#include "overlapping-compat.h" + +module Servant.Client.Core.Internal.Generic where + +import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to) +import Servant.API ((:<|>)(..)) + +-- | This class allows us to match client structure with client functions +-- produced with 'client' without explicit pattern-matching. +-- +-- The client structure needs a 'Generics.SOP.Generic' instance. +-- +-- Example: +-- +-- > type API +-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int +-- > :<|> "bar" :> QueryParam "a" Char :> QueryParam "b" String :> Post '[JSON] [Int] +-- > :<|> Capture "nested" Int :> NestedAPI +-- > +-- > type NestedAPI +-- > = Get '[JSON] String +-- > :<|> "baz" :> QueryParam "c" Char :> Post '[JSON] () +-- > +-- > data APIClient = APIClient +-- > { getFoo :: Int -> ClientM Int +-- > , postBar :: Maybe Char -> Maybe String -> ClientM [Int] +-- > , mkNestedClient :: Int -> NestedClient +-- > } deriving GHC.Generic +-- > +-- > instance Generics.SOP.Generic APIClient +-- > instance (Client API ~ client) => ClientLike client APIClient +-- > +-- > data NestedClient = NestedClient +-- > { getString :: ClientM String +-- > , postBaz :: Maybe Char -> ClientM () +-- > } deriving GHC.Generic +-- > +-- > instance Generics.SOP.Generic NestedClient +-- > instance (Client NestedAPI ~ client) => ClientLike client NestedClient +-- > +-- > mkAPIClient :: APIClient +-- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) +-- +-- By default, left-nested alternatives are expanded: +-- +-- > type API1 +-- > = "foo" :> Capture "x" Int :> Get '[JSON] Int +-- > :<|> "bar" :> QueryParam "a" Char :> Post '[JSON] String +-- > +-- > type API2 +-- > = "baz" :> QueryParam "c" Char :> Post '[JSON] () +-- > +-- > type API = API1 :<|> API2 +-- > +-- > data APIClient = APIClient +-- > { getFoo :: Int -> ClientM Int +-- > , postBar :: Maybe Char -> ClientM String +-- > , postBaz :: Maybe Char -> ClientM () +-- > } deriving GHC.Generic +-- > +-- > instance Generics.SOP.Generic APIClient +-- > instance (Client API ~ client) => ClientLike client APIClient +-- > +-- > mkAPIClient :: APIClient +-- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) +-- +-- If you want to define client for @API1@ as a separate data structure, +-- you can use 'genericMkClientP': +-- +-- > data APIClient1 = APIClient1 +-- > { getFoo :: Int -> ClientM Int +-- > , postBar :: Maybe Char -> ClientM String +-- > } deriving GHC.Generic +-- > +-- > instance Generics.SOP.Generic APIClient1 +-- > instance (Client API1 ~ client) => ClientLike client APIClient1 +-- > +-- > data APIClient = APIClient +-- > { mkAPIClient1 :: APIClient1 +-- > , postBaz :: Maybe Char -> ClientM () +-- > } deriving GHC.Generic +-- > +-- > instance Generics.SOP.Generic APIClient +-- > instance (Client API ~ client) => ClientLike client APIClient where +-- > mkClient = genericMkClientP +-- > +-- > mkAPIClient :: APIClient +-- > mkAPIClient = mkClient (client (Proxy :: Proxy API)) +class ClientLike client custom where + mkClient :: client -> custom + default mkClient :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs) + => client -> custom + mkClient = genericMkClientL + +instance ClientLike client custom + => ClientLike (a -> client) (a -> custom) where + mkClient c = mkClient . c + +-- | Match client structure with client functions, regarding left-nested API clients +-- as separate data structures. +class GClientLikeP client xs where + gMkClientP :: client -> NP I xs + +instance (GClientLikeP b (y ': xs), ClientLike a x) + => GClientLikeP (a :<|> b) (x ': y ': xs) where + gMkClientP (a :<|> b) = I (mkClient a) :* gMkClientP b + +instance ClientLike a x => GClientLikeP a '[x] where + gMkClientP a = I (mkClient a) :* Nil + +-- | Match client structure with client functions, expanding left-nested API clients +-- in the same structure. +class GClientLikeL (xs :: [*]) (ys :: [*]) where + gMkClientL :: NP I xs -> NP I ys + +instance GClientLikeL '[] '[] where + gMkClientL Nil = Nil + +instance (ClientLike x y, GClientLikeL xs ys) => GClientLikeL (x ': xs) (y ': ys) where + gMkClientL (I x :* xs) = I (mkClient x) :* gMkClientL xs + +type family ClientList (client :: *) (acc :: [*]) :: [*] where + ClientList (a :<|> b) acc = ClientList a (ClientList b acc) + ClientList a acc = a ': acc + +class GClientList client (acc :: [*]) where + gClientList :: client -> NP I acc -> NP I (ClientList client acc) + +instance (GClientList b acc, GClientList a (ClientList b acc)) + => GClientList (a :<|> b) acc where + gClientList (a :<|> b) acc = gClientList a (gClientList b acc) + +instance OVERLAPPABLE_ (ClientList client acc ~ (client ': acc)) + => GClientList client acc where + gClientList c acc = I c :* acc + +-- | Generate client structure from client type, expanding left-nested API (done by default). +genericMkClientL :: (Generic custom, Code custom ~ '[xs], GClientList client '[], GClientLikeL (ClientList client '[]) xs) + => client -> custom +genericMkClientL = to . SOP . Z . gMkClientL . flip gClientList Nil + +-- | Generate client structure from client type, regarding left-nested API clients as separate data structures. +genericMkClientP :: (Generic custom, Code custom ~ '[xs], GClientLikeP client xs) + => client -> custom +genericMkClientP = to . SOP . Z . gMkClientP + diff --git a/src/Servant/Client/Core/Internal/HasClient.hs b/src/Servant/Client/Core/Internal/HasClient.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Internal/HasClient.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +#include "overlapping-compat.h" +module Servant.Client.Core.Internal.HasClient where + +import Prelude () +import Prelude.Compat + +import Data.Foldable (toList) +import Data.List (foldl') +import Data.Proxy (Proxy (Proxy)) +import Data.Sequence (fromList) +import Data.String (fromString) +import Data.Text (pack) +import GHC.TypeLits (KnownSymbol, symbolVal) +import qualified Network.HTTP.Types as H +import Servant.API ((:<|>) ((:<|>)), (:>), + AuthProtect, BasicAuth, + BasicAuthData, + BuildHeadersTo (..), + Capture, CaptureAll, + Description, EmptyAPI, + Header, Headers (..), + HttpVersion, IsSecure, + MimeRender (mimeRender), + MimeUnrender (mimeUnrender), + NoContent (NoContent), + QueryFlag, QueryParam, + QueryParams, Raw, + ReflectMethod (..), + RemoteHost, ReqBody, + Summary, ToHttpApiData, + Vault, Verb, + WithNamedContext, + contentType, + getHeadersHList, + getResponse, + toQueryParam, + toUrlPiece) +import Servant.API.ContentTypes (contentTypes) + +import Servant.Client.Core.Internal.Auth +import Servant.Client.Core.Internal.BasicAuth +import Servant.Client.Core.Internal.Request +import Servant.Client.Core.Internal.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 + + +-- | 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 + +-- | 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 + +-- | 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 capture a :> api) where + + type Client m (Capture capture a :> api) = + a -> Client m api + + clientWithRoute pm Proxy req val = + clientWithRoute pm (Proxy :: Proxy api) + (appendToPath p req) + + where p = (toUrlPiece val) + +-- | 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 (toUrlPiece) vals + +instance OVERLAPPABLE_ + -- Note [Non-Empty Content Types] + ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient m (Verb method status cts' a) where + type Client m (Verb method status cts' a) = m a + clientWithRoute _pm Proxy req = do + response <- runRequest req + { requestAccept = fromList $ toList accept + , requestMethod = method + } + response `decodedAs` (Proxy :: Proxy ct) + where + accept = contentTypes (Proxy :: Proxy ct) + method = reflectMethod (Proxy :: Proxy method) + +instance OVERLAPPING_ + ( RunClient m, ReflectMethod method + ) => HasClient m (Verb method status cts NoContent) where + type Client m (Verb method status cts NoContent) + = m NoContent + clientWithRoute _pm Proxy req = do + _response <- runRequest req { requestMethod = method } + return NoContent + where method = reflectMethod (Proxy :: Proxy method) + +instance OVERLAPPING_ + -- Note [Non-Empty Content Types] + ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls + , ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient m (Verb method status cts' (Headers ls a)) where + type Client m (Verb method status cts' (Headers ls a)) + = m (Headers ls a) + clientWithRoute _pm Proxy req = do + response <- runRequest req + { requestMethod = method + , requestAccept = fromList $ toList accept + } + case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of + Left err -> throwServantError $ DecodeFailure (pack err) response + Right val -> return $ Headers + { getResponse = val + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response + } + where method = reflectMethod (Proxy :: Proxy method) + accept = contentTypes (Proxy :: Proxy ct) + +instance OVERLAPPING_ + ( RunClient m, BuildHeadersTo ls, ReflectMethod method + ) => HasClient m (Verb method status cts (Headers ls NoContent)) where + type Client m (Verb method status cts (Headers ls NoContent)) + = m (Headers ls NoContent) + clientWithRoute _pm Proxy req = do + let method = reflectMethod (Proxy :: Proxy method) + response <- runRequest req { requestMethod = method } + return $ Headers { getResponse = NoContent + , getHeadersHList = buildHeadersTo . toList $ responseHeaders response + } + + +-- | 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) + => HasClient m (Header sym a :> api) where + + type Client m (Header sym a :> api) = + Maybe a -> Client m api + + clientWithRoute pm Proxy req mval = + clientWithRoute pm (Proxy :: Proxy api) + (maybe req + (\value -> addHeader hname value req) + mval + ) + + where hname = fromString $ symbolVal (Proxy :: Proxy sym) + +-- | 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) + +-- | 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) + +-- | 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) + +-- | 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) + => HasClient m (QueryParam sym a :> api) where + + type Client m (QueryParam sym a :> api) = + Maybe 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) + (maybe req + (flip (appendToQueryString pname) req . Just) + mparamText + ) + + where pname = pack $ symbolVal (Proxy :: Proxy sym) + mparamText = fmap toQueryParam mparam + +-- | 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 . toQueryParam) paramlist + +-- | 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) + + +-- | 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 } + +-- | 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 (ct ': cts) a :> api) where + + type Client m (ReqBody (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 + ) + +-- | 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 = pack $ symbolVal (Proxy :: Proxy path) + +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 + +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 + +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 + +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) + +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) + +-- * 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) + + +{- 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). +-} diff --git a/src/Servant/Client/Core/Internal/Request.hs b/src/Servant/Client/Core/Internal/Request.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Internal/Request.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Client.Core.Internal.Request where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Catch (Exception) +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import Data.Semigroup ((<>)) +import qualified Data.Sequence as Seq +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Network.HTTP.Media (MediaType) +import Network.HTTP.Types (Header, HeaderName, HttpVersion, + Method, QueryItem, Status, http11, + methodGet) +import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece, + toHeader) + +-- | A type representing possible errors in a request +-- +-- Note that this type substantially changed in 0.12. +data ServantError = + -- | The server returned an error response + FailureResponse Response + -- | The body could not be decoded at the expected type + | DecodeFailure Text Response + -- | The content-type of the response is not supported + | UnsupportedContentType MediaType Response + -- | The content-type header is invalid + | InvalidContentTypeHeader Response + -- | There was a connection error, and no response was received + | ConnectionError Text + deriving (Eq, Show, Generic, Typeable) + +instance Exception ServantError + +data RequestF a = Request + { requestPath :: a + , requestQueryString :: Seq.Seq QueryItem + , requestBody :: Maybe (RequestBody, MediaType) + , requestAccept :: Seq.Seq MediaType + , requestHeaders :: Seq.Seq Header + , requestHttpVersion :: HttpVersion + , requestMethod :: Method + } deriving (Eq, Show, Functor, Generic, Typeable) + +type Request = RequestF Builder.Builder + +-- | The request body. Currently only lazy ByteStrings are supported. +newtype RequestBody = RequestBodyLBS LBS.ByteString + deriving (Eq, Ord, Read, Show, Typeable) + +data Response = Response + { responseStatusCode :: Status + , responseBody :: LBS.ByteString + , responseHeaders :: Seq.Seq Header + , responseHttpVersion :: HttpVersion + } deriving (Eq, Show, Generic, Typeable) + +-- A GET request to the top-level path +defaultRequest :: Request +defaultRequest = Request + { requestPath = "" + , requestQueryString = Seq.empty + , requestBody = Nothing + , requestAccept = Seq.empty + , requestHeaders = Seq.empty + , requestHttpVersion = http11 + , requestMethod = methodGet + } + +appendToPath :: Text -> Request -> Request +appendToPath p req + = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p } + +appendToQueryString :: Text -- ^ param name + -> Maybe Text -- ^ param value + -> Request + -> Request +appendToQueryString pname pvalue req + = req { requestQueryString = requestQueryString req + Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)} + +addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request +addHeader name val req + = req { requestHeaders = requestHeaders req Seq.|> (name, toHeader val)} + +-- | Set body and media type of the request being constructed. +-- +-- The body is set to the given bytestring using the 'RequestBodyLBS' +-- constructor. +-- +-- @since 0.12 +-- +setRequestBodyLBS :: LBS.ByteString -> MediaType -> Request -> Request +setRequestBodyLBS b t req + = req { requestBody = Just (RequestBodyLBS b, t) } + +-- | Set body and media type of the request being constructed. +-- +-- @since 0.12 +-- +setRequestBody :: RequestBody -> MediaType -> Request -> Request +setRequestBody b t req = req { requestBody = Just (b, t) } diff --git a/src/Servant/Client/Core/Internal/RunClient.hs b/src/Servant/Client/Core/Internal/RunClient.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Internal/RunClient.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | Types for possible backends to run client-side `Request` queries +module Servant.Client.Core.Internal.RunClient where + +import Prelude () +import Prelude.Compat + +import Control.Monad (unless) +import Data.Foldable (toList) +import Data.Proxy (Proxy) +import qualified Data.Text as T +import Network.HTTP.Media (MediaType, matches, + parseAccept, (//)) +import Servant.API (MimeUnrender, + contentTypes, + mimeUnrender) +import Servant.Client.Core.Internal.Request (Request, Response (..), + ServantError (..)) + +class (Monad m) => RunClient m where + -- | How to make a request. + runRequest :: Request -> m Response + throwServantError :: ServantError -> m a + catchServantError :: m a -> (ServantError -> m a) -> m a + +checkContentTypeHeader :: RunClient m => Response -> m MediaType +checkContentTypeHeader response = + case lookup "Content-Type" $ toList $ responseHeaders response of + Nothing -> return $ "application"//"octet-stream" + Just t -> case parseAccept t of + Nothing -> throwServantError $ InvalidContentTypeHeader response + Just t' -> return t' + +decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m) + => Response -> Proxy ct -> m a +decodedAs response contentType = do + responseContentType <- checkContentTypeHeader response + unless (any (matches responseContentType) accept) $ + throwServantError $ UnsupportedContentType responseContentType response + case mimeUnrender contentType $ responseBody response of + Left err -> throwServantError $ DecodeFailure (T.pack err) response + Right val -> return val + where + accept = toList $ contentTypes contentType diff --git a/src/Servant/Client/Core/Reexport.hs b/src/Servant/Client/Core/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client/Core/Reexport.hs @@ -0,0 +1,30 @@ +-- | This module is a utility for @servant-client-core@ backend writers. It +-- contains all the functionality from @servant-client-core@ that should be +-- re-exported. +module Servant.Client.Core.Reexport + ( + -- * HasClient + HasClient(..) + -- * Response (for @Raw@) + , Response(..) + + -- * Generic Client + , ClientLike(..) + , genericMkClientL + , genericMkClientP + , ServantError(..) + , EmptyClient(..) + + -- * BaseUrl + , BaseUrl(..) + , Scheme(..) + , showBaseUrl + , parseBaseUrl + , InvalidBaseUrlException + ) where + + +import Servant.Client.Core.Internal.BaseUrl +import Servant.Client.Core.Internal.HasClient +import Servant.Client.Core.Internal.Generic +import Servant.Client.Core.Internal.Request diff --git a/test/Servant/Client/Core/Internal/BaseUrlSpec.hs b/test/Servant/Client/Core/Internal/BaseUrlSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/Client/Core/Internal/BaseUrlSpec.hs @@ -0,0 +1,81 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Client.Core.Internal.BaseUrlSpec (spec) where + + +import Control.DeepSeq +import Prelude () +import Prelude.Compat +import Test.Hspec +import Test.QuickCheck + +import Servant.Client.Core.Internal.BaseUrl + +spec :: Spec +spec = do + let parse = parseBaseUrl :: String -> Maybe BaseUrl + describe "showBaseUrl" $ do + it "shows a BaseUrl" $ do + showBaseUrl (BaseUrl Http "foo.com" 80 "") `shouldBe` "http://foo.com" + it "shows a https BaseUrl" $ do + showBaseUrl (BaseUrl Https "foo.com" 443 "") `shouldBe` "https://foo.com" + it "shows the path of a BaseUrl" $ do + showBaseUrl (BaseUrl Http "foo.com" 80 "api") `shouldBe` "http://foo.com/api" + it "shows the path of an https BaseUrl" $ do + showBaseUrl (BaseUrl Https "foo.com" 443 "api") `shouldBe` "https://foo.com/api" + it "handles leading slashes in path" $ do + showBaseUrl (BaseUrl Https "foo.com" 443 "/api") `shouldBe` "https://foo.com/api" + + describe "httpBaseUrl" $ do + it "allows to construct default http BaseUrls" $ do + BaseUrl Http "bar" 80 "" `shouldBe` BaseUrl Http "bar" 80 "" + + describe "parseBaseUrl" $ do + it "is total" $ do + property $ \ string -> + deepseq (fmap show (parse string )) True + + it "is the inverse of showBaseUrl" $ do + property $ \ baseUrl -> counterexample (showBaseUrl baseUrl) $ + parse (showBaseUrl baseUrl) === Just baseUrl + + context "trailing slashes" $ do + it "allows trailing slashes" $ do + parse "foo.com/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "") + + it "allows trailing slashes in paths" $ do + parse "foo.com/api/" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") + + context "urls without scheme" $ do + it "assumes http" $ do + parse "foo.com" `shouldBe` Just (BaseUrl Http "foo.com" 80 "") + + it "allows port numbers" $ do + parse "foo.com:8080" `shouldBe` Just (BaseUrl Http "foo.com" 8080 "") + + it "can parse paths" $ do + parse "http://foo.com/api" `shouldBe` Just (BaseUrl Http "foo.com" 80 "api") + + it "rejects ftp urls" $ do + parse "ftp://foo.com" `shouldBe` Nothing + +instance Arbitrary BaseUrl where + arbitrary = BaseUrl <$> + elements [Http, Https] <*> + hostNameGen <*> + portGen <*> + pathGen + where + letters = ['a' .. 'z'] ++ ['A' .. 'Z'] + -- this does not perfectly mirror the url standard, but I hope it's good + -- enough. + hostNameGen = do + first <- elements letters + middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-']) + last' <- elements letters + return (first : middle ++ [last']) + portGen = frequency $ + (1, return 80) : + (1, return 443) : + (1, choose (1, 20000)) : + [] + pathGen = listOf1 . elements $ letters diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}