4238a58 · typeable/servant

git.iko.soy/typeable/servant

Fix #203; add path to BaseUrl

commit4238a58f926a4b5886e5e245a477795ce3118a44 authorTaylor Fausak <taylor@fausak.me> dateMon 24 Aug 2015, 21:26 (11 years ago) parente5492bf

6 files changed+21−19

compare with master

unifiedsplit

servant-client/CHANGELOG.md+1 servant-client/src/Servant/Common/BaseUrl.hs+12−11 servant-client/src/Servant/Common/Req.hs+4−4 servant-client/test/Servant/ClientSpec.hs+2−2 servant-examples/hackage/hackage.hs+1−1 servant-examples/tutorial/T8.hs+1−1

servant-client/CHANGELOG.md+1

@@ -2,6 +2,7 @@ HEAD

22----

44* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators

5+* Added support for `path` on `BaseUrl`.

670.4.1

78-----

servant-client/src/Servant/Common/BaseUrl.hs+12−11

@@ -15,7 +15,7 @@ import Control.Monad.Catch (Exception, MonadThrow, throwM)

1515import Data.List

1616import Data.Typeable

1717import GHC.Generics

18−import Network.URI

18+import Network.URI hiding (path)

1919import Safe

2020import Text.Read

2121

@@ -31,11 +31,12 @@ data BaseUrl = BaseUrl

3131 { baseUrlScheme :: Scheme -- ^ URI scheme to use

3232 , baseUrlHost :: String -- ^ host (eg "haskell.org")

3333 , baseUrlPort :: Int -- ^ port (eg 80)

34+ , baseUrlPath :: String -- ^ path (eg "/a/b/c")

3435 } deriving (Show, Eq, Ord, Generic)

3536

3637showBaseUrl :: BaseUrl -> String

37−showBaseUrl (BaseUrl urlscheme host port) =

38− schemeString ++ "//" ++ host ++ portString

38+showBaseUrl (BaseUrl urlscheme host port path) =

39+ schemeString ++ "//" ++ host ++ portString ++ path

3940 where

4041 schemeString = case urlscheme of

4142 Http -> "http:"

@@ -52,14 +53,14 @@ parseBaseUrl :: MonadThrow m => String -> m BaseUrl

5253parseBaseUrl s = case parseURI (removeTrailingSlash s) of

5354 -- This is a rather hacky implementation and should be replaced with something

5455 -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).

55− Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->

56− return (BaseUrl Http host port)

57− Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->

58− return (BaseUrl Http host 80)

59− Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->

60− return (BaseUrl Https host port)

61− Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->

62− return (BaseUrl Https host 443)

56+ Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->

57+ return (BaseUrl Http host port path)

58+ Just (URI "http:" (Just (URIAuth "" host "")) path "" "") ->

59+ return (BaseUrl Http host 80 path)

60+ Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->

61+ return (BaseUrl Https host port path)

62+ Just (URI "https:" (Just (URIAuth "" host "")) path "" "") ->

63+ return (BaseUrl Https host 443 path)

6364 _ -> if "://" `isInfixOf` s

6465 then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)

6566 else parseBaseUrl ("http://" ++ s)

servant-client/src/Servant/Common/Req.hs+4−4

@@ -20,12 +20,12 @@ import Data.Proxy

2020import Data.Text (Text)

2121import Data.Text.Encoding

2222import Data.Typeable

23−import Network.HTTP.Client hiding (Proxy)

23+import Network.HTTP.Client hiding (Proxy, path)

2424import Network.HTTP.Client.TLS

2525import Network.HTTP.Media

2626import Network.HTTP.Types

2727import qualified Network.HTTP.Types.Header as HTTP

28−import Network.URI

28+import Network.URI hiding (path)

2929import Servant.API.ContentTypes

3030import Servant.Common.BaseUrl

3131import Servant.Common.Text

@@ -98,7 +98,7 @@ setRQBody :: ByteString -> MediaType -> Req -> Req

9898setRQBody b t req = req { reqBody = Just (b, t) }

9999

100100reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request

101−reqToRequest req (BaseUrl reqScheme reqHost reqPort) =

101+reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =

102102 setheaders . setAccept . setrqb . setQS <$> parseUrl url

103103

104104 where url = show $ nullURI { uriScheme = case reqScheme of

@@ -109,7 +109,7 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) =

109109 , uriRegName = reqHost

110110 , uriPort = ":" ++ show reqPort

111111 }

112− , uriPath = reqPath req

112+ , uriPath = path ++ reqPath req

113113 }

114114

115115 setrqb r = case reqBody req of

servant-client/test/Servant/ClientSpec.hs+2−2

@@ -287,7 +287,7 @@ failSpec = withFailServer $ \ baseUrl -> do

287287 :<|> _ )

288288 = client api baseUrl

289289 getGetWrongHost :: EitherT ServantError IO Person

290− (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872)

290+ (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "")

291291

292292 hspec $ do

293293 context "client returns errors appropriately" $ do

@@ -347,7 +347,7 @@ withWaiDaemon mkApplication action = do

347347 runSettingsSocket settings socket application)

348348 `finally` notifyKilled ()

349349 krakenPort <- waitForStart

350− let baseUrl = (BaseUrl Http "localhost" 80){baseUrlPort = krakenPort}

350+ let baseUrl = (BaseUrl Http "localhost" 80 ""){baseUrlPort = krakenPort}

351351 return (thread, waitForKilled, baseUrl)

352352 free (thread, waitForKilled, _) = do

353353 killThread thread

servant-examples/hackage/hackage.hs+1−1

@@ -57,7 +57,7 @@ hackageAPI = Proxy

5757getUsers :: EitherT ServantError IO [UserSummary]

5858getUser :: Username -> EitherT ServantError IO UserDetailed

5959getPackages :: EitherT ServantError IO [Package]

60−getUsers :<|> getUser :<|> getPackages = client hackageAPI $ BaseUrl Http "hackage.haskell.org" 80

60+getUsers :<|> getUser :<|> getPackages = client hackageAPI $ BaseUrl Http "hackage.haskell.org" 80 ""

6161

6262main :: IO ()

6363main = print =<< uselessNumbers

servant-examples/tutorial/T8.hs+1−1

@@ -23,7 +23,7 @@ marketing :: ClientInfo -- ^ value for the request body

2323position :<|> hello :<|> marketing = client api baseUrl

2424

2525baseUrl :: BaseUrl

26−baseUrl = BaseUrl Http "localhost" 8081

26+baseUrl = BaseUrl Http "localhost" 8081 ""

2727

2828queries :: EitherT ServantError IO (Position, HelloMessage, Email)

2929queries = do