diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Zalora South East Asia Pte Ltd + +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 Zalora South East Asia Pte Ltd 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/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/servant-client.cabal b/servant-client.cabal new file mode 100644 --- /dev/null +++ b/servant-client.cabal @@ -0,0 +1,78 @@ +name: servant-client +version: 0.2 +synopsis: automatical derivation of haskell functions that let you query servant webservices +description: + This library lets you derive automatically Haskell functions that + let you query each endpoint of a webservice. + . + Example below. + . + > type MyApi = "books" :> Get [Book] -- GET /books + > :<|> "books" :> ReqBody Book :> Post Book -- POST /books + > + > myApi :: Proxy MyApi + > myApi = Proxy + > + > getAllBooks :: BaseUrl -> EitherT String IO [Book] + > postNewBook :: Book -> BaseUrl -> EitherT String IO Book + > (getAllBooks :<|> postNewBook) = client myApi +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni +maintainer: alpmestan@gmail.com +copyright: 2014 Zalora South East Asia Pte Ltd +category: Web +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC >= 7.8 +homepage: http://haskell-servant.github.io/ +Bug-reports: http://github.com/haskell-servant/servant-client/issues +source-repository head + type: git + location: http://github.com/haskell-servant/servant-client.git + +library + exposed-modules: + Servant.Client + Servant.Common.BaseUrl + Servant.Common.Req + build-depends: + base >=4.7 && <5 + , aeson + , attoparsec + , bytestring + , either + , exceptions + , http-client + , http-types + , network-uri >= 2.6 + , safe + , servant >= 0.2 + , string-conversions + , text + , transformers + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: + -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base == 4.* + , aeson + , bytestring + , deepseq + , either + , hspec == 2.* + , http-types + , network >= 2.6 + , QuickCheck + , servant >= 0.2 + , servant-client + , wai + , warp diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Client.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | This module provides 'client' which can automatically generate +-- querying functions for each endpoint just from the type representing your +-- API. +module Servant.Client + ( client + , HasClient(..) + , module Servant.Common.BaseUrl + ) where + +import Control.Monad.Trans.Either +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import Data.List +import Data.Proxy +import Data.String.Conversions +import Data.Text (unpack) +import GHC.TypeLits +import qualified Network.HTTP.Types as H +import Servant.API +import Servant.Common.BaseUrl +import Servant.Common.Req +import Servant.Common.Text + +-- * Accessing APIs as a Client + +-- | 'client' allows you to produce operations to query an API from a client. +-- +-- > type MyApi = "books" :> Get [Book] -- GET /books +-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: BaseUrl -> EitherT String IO [Book] +-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book +-- > (getAllBooks :<|> postNewBook) = client myApi +client :: HasClient layout => Proxy layout -> Client layout +client p = clientWithRoute p defReq + +-- | This class lets us define how each API combinator +-- influences the creation of an HTTP request. It's mostly +-- an internal class, you can just use 'client'. +class HasClient layout where + type Client layout :: * + clientWithRoute :: Proxy layout -> Req -> Client layout + +-- | 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 [Book] -- GET /books +-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getAllBooks :: BaseUrl -> EitherT String IO [Book] +-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book +-- > (getAllBooks :<|> postNewBook) = client myApi +instance (HasClient a, HasClient b) => HasClient (a :<|> b) where + type Client (a :<|> b) = Client a :<|> Client b + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy a) req :<|> + clientWithRoute (Proxy :: Proxy b) req + +-- | 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 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> Capture "isbn" Text :> Get Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBook :: Text -> BaseUrl -> EitherT String IO Book +-- > getBook = client myApi +-- > -- then you can just use "getBook" to query that endpoint +instance (KnownSymbol capture, ToText a, HasClient sublayout) + => HasClient (Capture capture a :> sublayout) where + + type Client (Capture capture a :> sublayout) = + a -> Client sublayout + + clientWithRoute Proxy req val = + clientWithRoute (Proxy :: Proxy sublayout) $ + appendToPath p req + + where p = unpack (toText val) + +-- | If you have a 'Delete' endpoint in your API, the client +-- side querying function that is created when calling 'client' +-- will just require an argument that specifies the scheme, host +-- and port to send the request to. +instance HasClient Delete where + type Client Delete = BaseUrl -> EitherT String IO () + + clientWithRoute Proxy req host = + performRequestJSON H.methodDelete req 204 host + +-- | If you have a 'Get' endpoint in your API, the client +-- side querying function that is created when calling 'client' +-- will just require an argument that specifies the scheme, host +-- and port to send the request to. +instance FromJSON result => HasClient (Get result) where + type Client (Get result) = BaseUrl -> EitherT String IO result + clientWithRoute Proxy req host = + performRequestJSON H.methodGet req 200 host + +-- | 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 'ToText' instance. +-- +-- Example: +-- +-- > newtype Referer = Referer Text +-- > deriving (Eq, Show, FromText, ToText) +-- > +-- > -- GET /view-my-referer +-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get Referer +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > viewReferer :: Maybe Referer -> BaseUrl -> EitherT String IO Book +-- > viewReferer = client myApi +-- > -- then you can just use "viewRefer" to query that endpoint +-- > -- specifying Nothing or Just "http://haskell.org/" as arguments +instance (KnownSymbol sym, ToText a, HasClient sublayout) + => HasClient (Header sym a :> sublayout) where + + type Client (Header sym a :> sublayout) = + Maybe a -> Client sublayout + + clientWithRoute Proxy req mval = + clientWithRoute (Proxy :: Proxy sublayout) $ + maybe req (\value -> addHeader hname value req) mval + + where hname = symbolVal (Proxy :: Proxy sym) + +-- | If you have a 'Post' endpoint in your API, the client +-- side querying function that is created when calling 'client' +-- will just require an argument that specifies the scheme, host +-- and port to send the request to. +instance FromJSON a => HasClient (Post a) where + type Client (Post a) = BaseUrl -> EitherT String IO a + + clientWithRoute Proxy req uri = + performRequestJSON H.methodPost req 201 uri + +-- | If you have a 'Put' endpoint in your API, the client +-- side querying function that is created when calling 'client' +-- will just require an argument that specifies the scheme, host +-- and port to send the request to. +instance FromJSON a => HasClient (Put a) where + type Client (Put a) = BaseUrl -> EitherT String IO a + + clientWithRoute Proxy req host = + performRequestJSON H.methodPut req 200 host + +-- | 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 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParam "author" Text :> Get [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: Maybe Text -> BaseUrl -> EitherT String IO [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, ToText a, HasClient sublayout) + => HasClient (QueryParam sym a :> sublayout) where + + type Client (QueryParam sym a :> sublayout) = + Maybe a -> Client sublayout + + -- if mparam = Nothing, we don't add it to the query string + clientWithRoute Proxy req mparam = + clientWithRoute (Proxy :: Proxy sublayout) $ + appendToQueryString pname mparamText req + + where pname = cs pname' + pname' = symbolVal (Proxy :: Proxy sym) + mparamText = fmap toText 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 'ToText' instance for your type. +-- +-- Example: +-- +-- > type MyApi = "books" :> QueryParams "authors" Text :> Get [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooksBy :: [Text] -> BaseUrl -> EitherT String IO [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, ToText a, HasClient sublayout) + => HasClient (QueryParams sym a :> sublayout) where + + type Client (QueryParams sym a :> sublayout) = + [a] -> Client sublayout + + clientWithRoute Proxy req paramlist = + clientWithRoute (Proxy :: Proxy sublayout) $ + foldl' (\ value req' -> appendToQueryString pname req' value) req paramlist' + + where pname = cs pname' + pname' = symbolVal (Proxy :: Proxy sym) + paramlist' = map (Just . toText) 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 [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: Bool -> BaseUrl -> EitherT String IO [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 sublayout) + => HasClient (QueryFlag sym :> sublayout) where + + type Client (QueryFlag sym :> sublayout) = + Bool -> Client sublayout + + clientWithRoute Proxy req flag = + clientWithRoute (Proxy :: Proxy sublayout) $ + if flag + then appendToQueryString paramname Nothing req + else req + + where paramname = cs $ symbolVal (Proxy :: Proxy sym) + +-- | Pick a 'Method' and specify where the server you want to query is. You get +-- back the status code and the response body as a 'ByteString'. +instance HasClient Raw where + type Client Raw = H.Method -> BaseUrl -> EitherT String IO (Int, ByteString) + + clientWithRoute :: Proxy Raw -> Req -> Client Raw + clientWithRoute Proxy req httpMethod host = + performRequest httpMethod req (const True) host + +-- | 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 Book :> Post Book +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > addBook :: Book -> BaseUrl -> EitherT String IO Book +-- > addBook = client myApi +-- > -- then you can just use "addBook" to query that endpoint +instance (ToJSON a, HasClient sublayout) + => HasClient (ReqBody a :> sublayout) where + + type Client (ReqBody a :> sublayout) = + a -> Client sublayout + + clientWithRoute Proxy req body = + clientWithRoute (Proxy :: Proxy sublayout) $ + setRQBody (encode body) req + +-- | Make the querying function append @path@ to the request path. +instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where + type Client (path :> sublayout) = Client sublayout + + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy sublayout) $ + appendToPath p req + + where p = symbolVal (Proxy :: Proxy path) + diff --git a/src/Servant/Common/BaseUrl.hs b/src/Servant/Common/BaseUrl.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Common/BaseUrl.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ViewPatterns #-} +module Servant.Common.BaseUrl where + +import Data.List +import GHC.Generics +import Network.URI +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) + } deriving (Show, Eq, Ord, Generic) + +showBaseUrl :: BaseUrl -> String +showBaseUrl (BaseUrl urlscheme host port) = + schemeString ++ "//" ++ host ++ portString + where + schemeString = case urlscheme of + Http -> "http:" + Https -> "https:" + portString = case (urlscheme, port) of + (Http, 80) -> "" + (Https, 443) -> "" + _ -> ":" ++ show port + +parseBaseUrl :: String -> Either String 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)))) "" "" "") -> + Right (BaseUrl Http host port) + Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") -> + Right (BaseUrl Http host 80) + Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> + Right (BaseUrl Https host port) + Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") -> + Right (BaseUrl Https host 443) + _ -> if "://" `isInfixOf` s + then Left ("invalid base url: " ++ s) + else parseBaseUrl ("http://" ++ s) + where + removeTrailingSlash str = case lastMay str of + Just '/' -> init str + _ -> str diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Common/Req.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Servant.Common.Req where + +import Control.Applicative +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.Catch (MonadThrow) +import Control.Monad.IO.Class +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Aeson.Parser +import Data.Aeson.Types +import Data.Attoparsec.ByteString +import Data.ByteString.Lazy hiding (pack) +import Data.String +import Data.String.Conversions +import Data.Text +import Data.Text.Encoding +import Network.HTTP.Client +import Network.HTTP.Types +import Network.URI +import Servant.Common.BaseUrl +import Servant.Common.Text +import System.IO.Unsafe + +import qualified Network.HTTP.Client as Client + +data Req = Req + { reqPath :: String + , qs :: QueryText + , reqBody :: ByteString + , headers :: [(String, Text)] + } + +defReq :: Req +defReq = Req "" [] "" [] + +appendToPath :: String -> Req -> Req +appendToPath p req = + req { reqPath = reqPath req ++ "/" ++ p } + +appendToQueryString :: Text -- ^ param name + -> Maybe Text -- ^ param value + -> Req + -> Req +appendToQueryString pname pvalue req = + req { qs = qs req ++ [(pname, pvalue)] + } + +addHeader :: ToText a => String -> a -> Req -> Req +addHeader name val req = req { headers = headers req + ++ [(name, toText val)] + } + +setRQBody :: ByteString -> Req -> Req +setRQBody b req = req { reqBody = b } + +reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request +reqToRequest req (BaseUrl reqScheme reqHost reqPort) = + fmap (setheaders . setrqb . setQS ) $ parseUrl url + + where url = show $ nullURI { uriScheme = case reqScheme of + Http -> "http:" + Https -> "https:" + , uriAuthority = Just $ + URIAuth { uriUserInfo = "" + , uriRegName = reqHost + , uriPort = ":" ++ show reqPort + } + , uriPath = reqPath req + } + + setrqb r = r { requestBody = RequestBodyLBS (reqBody req) } + setQS = setQueryString $ queryTextToQuery (qs req) + setheaders r = r { requestHeaders = Prelude.map toProperHeader (headers req) } + + toProperHeader (name, val) = + (fromString name, encodeUtf8 val) + + +-- * performing requests + +{-# NOINLINE __manager #-} +__manager :: MVar Manager +__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar) + +__withGlobalManager :: (Manager -> IO a) -> IO a +__withGlobalManager action = modifyMVar __manager $ \ manager -> do + result <- action manager + return (manager, result) + + +displayHttpRequest :: Method -> String +displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" + + +performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString) +performRequest reqMethod req isWantedStatus reqHost = do + partialRequest <- liftIO $ reqToRequest req reqHost + + let request = partialRequest { Client.method = reqMethod + , checkStatus = \ _status _headers _cookies -> Nothing + } + + eResponse <- liftIO $ __withGlobalManager $ \ manager -> + catchStatusCodeException $ + Client.httpLbs request manager + case eResponse of + Left status -> + left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status) + + Right response -> do + let status = Client.responseStatus response + unless (isWantedStatus (statusCode status)) $ + left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status) + return $ (statusCode status, Client.responseBody response) + where + showStatus (Status code message) = + show code ++ " - " ++ cs message + + +performRequestJSON :: FromJSON result => + Method -> Req -> Int -> BaseUrl -> EitherT String IO result +performRequestJSON reqMethod req wantedStatus reqHost = do + (_status, respBody) <- performRequest reqMethod req (== wantedStatus) reqHost + either + (\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message)) + return + (decodeLenient respBody) + + +catchStatusCodeException :: IO a -> IO (Either Status a) +catchStatusCodeException action = + catch (Right <$> action) $ \e -> + case e of + Client.StatusCodeException status _ _ -> return $ Left status + exc -> throwIO exc + +-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just +-- objects and arrays. +decodeLenient :: FromJSON a => ByteString -> Either String a +decodeLenient input = do + v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input) + parseEither parseJSON v 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 #-}