Merge pull request #204 from tfausak/gh-203-base-url-paths

Fix #203; add path to BaseUrl

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

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)

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

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

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

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