diff --git a/example/greet.hs b/example/greet.hs index 43a13fec..42fab2a0 100644 --- a/example/greet.hs +++ b/example/greet.hs @@ -15,7 +15,6 @@ import Data.Monoid import Data.Proxy import Data.Text import GHC.Generics -import Network.URI import Network.Wai import Network.Wai.Handler.Warp @@ -75,9 +74,9 @@ server = hello :<|> greet :<|> delete clientApi :: Client TestApi clientApi = client testApi -getGreet :: Text -> Maybe Bool -> URIAuth -> EitherT String IO Greet -postGreet :: Greet -> URIAuth -> EitherT String IO Greet -deleteGreet :: Text -> URIAuth -> EitherT String IO () +getGreet :: Text -> Maybe Bool -> BaseUrl -> EitherT String IO Greet +postGreet :: Greet -> BaseUrl -> EitherT String IO Greet +deleteGreet :: Text -> BaseUrl -> EitherT String IO () getGreet :<|> postGreet :<|> deleteGreet = clientApi -- Turn the server into a WAI app @@ -96,7 +95,7 @@ runTestServer port = run port test main :: IO () main = do tid <- forkIO $ runTestServer 8001 - let uri = mkHost "localhost" 8001 + let uri = BaseUrl Http "localhost" 8001 print =<< runEitherT (getGreet "alp" (Just True) uri) print =<< runEitherT (getGreet "alp" (Just False) uri) let g = Greet "yo" diff --git a/servant.cabal b/servant.cabal index d433ce8b..cd05c2e7 100644 --- a/servant.cabal +++ b/servant.cabal @@ -43,7 +43,7 @@ library , split , http-client , http-types - , network-uri + , network-uri >= 2.6 , wai , warp , safe @@ -70,7 +70,6 @@ executable greet , wai , either , text - , network-uri test-suite spec type: exitcode-stdio-1.0 @@ -90,7 +89,6 @@ test-suite spec , http-client , http-types , network >= 2.6 - , network-uri >= 2.6 , QuickCheck , servant , string-conversions diff --git a/src/Servant/API/Delete.hs b/src/Servant/API/Delete.hs index c43e4cde..f5db3b17 100644 --- a/src/Servant/API/Delete.hs +++ b/src/Servant/API/Delete.hs @@ -9,7 +9,6 @@ import Data.Proxy import Data.String.Conversions import Data.Typeable import Network.HTTP.Types -import Network.URI import Network.Wai import Servant.Client import Servant.Docs @@ -36,7 +35,7 @@ instance HasServer Delete where | otherwise = respond $ failWith NotFound instance HasClient Delete where - type Client Delete = URIAuth -> EitherT String IO () + type Client Delete = BaseUrl -> EitherT String IO () clientWithRoute Proxy req host = performRequest methodDelete req 204 host diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs index 84f15e57..c7faedc4 100644 --- a/src/Servant/API/Get.hs +++ b/src/Servant/API/Get.hs @@ -10,7 +10,6 @@ import Data.Proxy import Data.String.Conversions import Data.Typeable import Network.HTTP.Types -import Network.URI import Network.Wai import Servant.Client import Servant.Docs @@ -37,7 +36,7 @@ instance ToJSON result => HasServer (Get result) where | otherwise = respond $ failWith NotFound instance FromJSON result => HasClient (Get result) where - type Client (Get result) = URIAuth -> EitherT String IO result + type Client (Get result) = BaseUrl -> EitherT String IO result clientWithRoute Proxy req host = performRequest methodGet req 200 host diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs index b67c05d6..1290f4e2 100644 --- a/src/Servant/API/Post.hs +++ b/src/Servant/API/Post.hs @@ -10,7 +10,6 @@ import Data.Proxy import Data.String.Conversions import Data.Typeable import Network.HTTP.Types -import Network.URI import Network.Wai import Servant.Client import Servant.Docs @@ -39,7 +38,7 @@ instance ToJSON a => HasServer (Post a) where | otherwise = respond $ failWith NotFound instance FromJSON a => HasClient (Post a) where - type Client (Post a) = URIAuth -> EitherT String IO a + type Client (Post a) = BaseUrl -> EitherT String IO a clientWithRoute Proxy req uri = performRequest methodPost req 201 uri diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs index 54e8fdae..2ffe59ae 100644 --- a/src/Servant/API/Put.hs +++ b/src/Servant/API/Put.hs @@ -10,7 +10,6 @@ import Data.Proxy import Data.String.Conversions import Data.Typeable import Network.HTTP.Types -import Network.URI import Network.Wai import Servant.Client import Servant.Docs @@ -38,7 +37,7 @@ instance ToJSON a => HasServer (Put a) where | otherwise = respond $ failWith NotFound instance FromJSON a => HasClient (Put a) where - type Client (Put a) = URIAuth -> EitherT String IO a + type Client (Put a) = BaseUrl -> EitherT String IO a clientWithRoute Proxy req host = performRequest methodPut req 200 host diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs index efcfa4c4..f786352b 100644 --- a/src/Servant/Client.hs +++ b/src/Servant/Client.hs @@ -14,9 +14,16 @@ import System.IO.Unsafe -- * Accessing APIs as a Client --- | Convenience function for creating 'URIAuth's. -mkHost :: String -> Int -> URIAuth -mkHost hostName port = URIAuth "" hostName (":" ++ show port) +data Scheme = Http | Https + +data BaseUrl = BaseUrl { + baseUrlScheme :: Scheme, + baseUrlHost :: String, + baseUrlPort :: Int + } + +httpBaseUrl :: String -> BaseUrl +httpBaseUrl host = BaseUrl Http host 80 -- | 'client' allows you to produce operations to query an API from a client. client :: HasClient layout => Proxy layout -> Client layout @@ -50,11 +57,17 @@ appendToQueryString pname pvalue req = setRQBody :: ByteString -> Req -> Req setRQBody b req = req { reqBody = b } -reqToRequest :: (Functor m, MonadThrow m) => Req -> URIAuth -> m Request -reqToRequest req host = fmap (setrqb . setQS ) $ parseUrl url +reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request +reqToRequest req (BaseUrl scheme host port) = fmap (setrqb . setQS ) $ parseUrl url - where url = show $ nullURI { uriScheme = "http:" - , uriAuthority = Just host + where url = show $ nullURI { uriScheme = case scheme of + Http -> "http:" + Https -> "https:" + , uriAuthority = Just $ + URIAuth { uriUserInfo = "" + , uriRegName = host + , uriPort = ":" ++ show port + } , uriPath = reqPath req } diff --git a/src/Servant/Utils/Client.hs b/src/Servant/Utils/Client.hs index b1c769f0..2214e54d 100644 --- a/src/Servant/Utils/Client.hs +++ b/src/Servant/Utils/Client.hs @@ -13,13 +13,12 @@ import Data.Attoparsec.ByteString import Data.ByteString.Lazy import Data.String.Conversions import Network.HTTP.Types -import Network.URI import Servant.Client import qualified Network.HTTP.Client as Client performRequest :: FromJSON result => - Method -> Req -> Int -> URIAuth -> EitherT String IO result + Method -> Req -> Int -> BaseUrl -> EitherT String IO result performRequest method req wantedStatus host = do partialRequest <- liftIO $ reqToRequest req host diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index de46acb8..a90f0601 100644 --- a/test/Servant/ClientSpec.hs +++ b/test/Servant/ClientSpec.hs @@ -13,7 +13,6 @@ import Data.Foldable (forM_) import Data.Proxy import Data.Typeable import Network.Socket -import Network.URI import Network.Wai import Network.Wai.Handler.Warp import Test.Hspec @@ -56,17 +55,17 @@ server = serve api ( :<|> \ a b c d -> return (a, b, c, d) ) -withServer :: (URIAuth -> IO a) -> IO a -withServer action = withWaiDaemon (return server) (action . mkHost "localhost") +withServer :: (BaseUrl -> IO a) -> IO a +withServer action = withWaiDaemon (return server) action -getGet :: URIAuth -> EitherT String IO Person -getCapture :: String -> URIAuth -> EitherT String IO Person -getBody :: Person -> URIAuth -> EitherT String IO Person -getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person -getQueryParams :: [String] -> URIAuth -> EitherT String IO [Person] -getQueryFlag :: Bool -> URIAuth -> EitherT String IO Bool +getGet :: BaseUrl -> EitherT String IO Person +getCapture :: String -> BaseUrl -> EitherT String IO Person +getBody :: Person -> BaseUrl -> EitherT String IO Person +getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person +getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person] +getQueryFlag :: Bool -> BaseUrl -> EitherT String IO Bool getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] - -> URIAuth + -> BaseUrl -> EitherT String IO (String, Maybe Int, Bool, [(String, [Rational])]) ( getGet :<|> getCapture @@ -119,8 +118,8 @@ spec = do test (WrappedApi api) = it (show (typeOf api)) $ withWaiDaemon (return (serve api (left (500, "error message")))) $ - \ (mkHost "localhost" -> host) -> do - let getResponse :: URIAuth -> EitherT String IO () + \ host -> do + let getResponse :: BaseUrl -> EitherT String IO () getResponse = client api Left result <- runEitherT (getResponse host) result `shouldContain` "error message" @@ -133,17 +132,17 @@ spec = do data WrappedApi where WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a, - HasClient api, Client api ~ (URIAuth -> EitherT String IO ()), + HasClient api, Client api ~ (BaseUrl -> EitherT String IO ()), Typeable api) => Proxy api -> WrappedApi -- * utils -withWaiDaemon :: IO Application -> (Port -> IO a) -> IO a +withWaiDaemon :: IO Application -> (BaseUrl -> IO a) -> IO a withWaiDaemon mkApplication action = do application <- mkApplication - bracket (acquire application) free (\ (_, _, port) -> action port) + bracket (acquire application) free (\ (_, _, baseUrl) -> action baseUrl) where acquire application = do (notifyStart, waitForStart) <- lvar @@ -158,7 +157,8 @@ withWaiDaemon mkApplication action = do runSettingsSocket settings socket application) `finally` notifyKilled () krakenPort <- waitForStart - return (thread, waitForKilled, krakenPort) + let baseUrl = (httpBaseUrl "localhost"){baseUrlPort = krakenPort} + return (thread, waitForKilled, baseUrl) free (thread, waitForKilled, _) = do killThread thread waitForKilled