diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index e3cd7a0e..c9052224 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -2,6 +2,7 @@ HEAD ---- * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators +* Added support for `path` on `BaseUrl`. 0.4.1 ----- diff --git a/servant-client/src/Servant/Common/BaseUrl.hs b/servant-client/src/Servant/Common/BaseUrl.hs index 666595d1..03ca21ed 100644 --- a/servant-client/src/Servant/Common/BaseUrl.hs +++ b/servant-client/src/Servant/Common/BaseUrl.hs @@ -15,7 +15,7 @@ import Control.Monad.Catch (Exception, MonadThrow, throwM) import Data.List import Data.Typeable import GHC.Generics -import Network.URI +import Network.URI hiding (path) import Safe import Text.Read @@ -31,11 +31,12 @@ 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, Eq, Ord, Generic) showBaseUrl :: BaseUrl -> String -showBaseUrl (BaseUrl urlscheme host port) = - schemeString ++ "//" ++ host ++ portString +showBaseUrl (BaseUrl urlscheme host port path) = + schemeString ++ "//" ++ host ++ portString ++ path where schemeString = case urlscheme of Http -> "http:" @@ -52,14 +53,14 @@ 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)))) "" "" "") -> - return (BaseUrl Http host port) - Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") -> - return (BaseUrl Http host 80) - Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") -> - return (BaseUrl Https host port) - Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") -> - return (BaseUrl Https host 443) + 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) diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 4a6a63a6..74a36526 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -20,12 +20,12 @@ import Data.Proxy import Data.Text (Text) import Data.Text.Encoding import Data.Typeable -import Network.HTTP.Client hiding (Proxy) +import Network.HTTP.Client hiding (Proxy, path) import Network.HTTP.Client.TLS import Network.HTTP.Media import Network.HTTP.Types import qualified Network.HTTP.Types.Header as HTTP -import Network.URI +import Network.URI hiding (path) import Servant.API.ContentTypes import Servant.Common.BaseUrl import Servant.Common.Text @@ -98,7 +98,7 @@ setRQBody :: ByteString -> MediaType -> Req -> Req setRQBody b t req = req { reqBody = Just (b, t) } reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request -reqToRequest req (BaseUrl reqScheme reqHost reqPort) = +reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = setheaders . setAccept . setrqb . setQS <$> parseUrl url where url = show $ nullURI { uriScheme = case reqScheme of @@ -109,7 +109,7 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) = , uriRegName = reqHost , uriPort = ":" ++ show reqPort } - , uriPath = reqPath req + , uriPath = path ++ reqPath req } setrqb r = case reqBody req of diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 7685a79c..8bf70095 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -287,7 +287,7 @@ failSpec = withFailServer $ \ baseUrl -> do :<|> _ ) = client api baseUrl getGetWrongHost :: EitherT ServantError IO Person - (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872) + (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") hspec $ do context "client returns errors appropriately" $ do @@ -347,7 +347,7 @@ withWaiDaemon mkApplication action = do runSettingsSocket settings socket application) `finally` notifyKilled () krakenPort <- waitForStart - let baseUrl = (BaseUrl Http "localhost" 80){baseUrlPort = krakenPort} + let baseUrl = (BaseUrl Http "localhost" 80 ""){baseUrlPort = krakenPort} return (thread, waitForKilled, baseUrl) free (thread, waitForKilled, _) = do killThread thread diff --git a/servant-examples/hackage/hackage.hs b/servant-examples/hackage/hackage.hs index d656cfd5..f0fdc584 100644 --- a/servant-examples/hackage/hackage.hs +++ b/servant-examples/hackage/hackage.hs @@ -57,7 +57,7 @@ hackageAPI = Proxy getUsers :: EitherT ServantError IO [UserSummary] getUser :: Username -> EitherT ServantError IO UserDetailed getPackages :: EitherT ServantError IO [Package] -getUsers :<|> getUser :<|> getPackages = client hackageAPI $ BaseUrl Http "hackage.haskell.org" 80 +getUsers :<|> getUser :<|> getPackages = client hackageAPI $ BaseUrl Http "hackage.haskell.org" 80 "" main :: IO () main = print =<< uselessNumbers diff --git a/servant-examples/tutorial/T8.hs b/servant-examples/tutorial/T8.hs index 331cb831..b57cc8e1 100644 --- a/servant-examples/tutorial/T8.hs +++ b/servant-examples/tutorial/T8.hs @@ -23,7 +23,7 @@ marketing :: ClientInfo -- ^ value for the request body position :<|> hello :<|> marketing = client api baseUrl baseUrl :: BaseUrl -baseUrl = BaseUrl Http "localhost" 8081 +baseUrl = BaseUrl Http "localhost" 8081 "" queries :: EitherT ServantError IO (Position, HelloMessage, Email) queries = do