implement BaseUrl to allow https for Clients

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
+getGreet :: Text -> Maybe Bool -> BaseUrl -> EitherT String IO Greet
-postGreet :: Greet -> URIAuth -> EitherT String IO Greet
+postGreet :: Greet -> BaseUrl -> EitherT String IO Greet
-deleteGreet :: Text -> URIAuth -> EitherT String IO ()
+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"

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

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

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
 

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

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

src/Servant/Client.hs

@@ -14,9 +14,16 @@ import System.IO.Unsafe
 
 -- * Accessing APIs as a Client
 
--- | Convenience function for creating 'URIAuth's.
+data Scheme = Http | Https
-mkHost :: String -> Int -> URIAuth
+
-mkHost hostName port = URIAuth "" hostName (":" ++ show port)
+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 :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
-reqToRequest req host = fmap (setrqb . setQS ) $ parseUrl url
+reqToRequest req (BaseUrl scheme host port) = fmap (setrqb . setQS ) $ parseUrl url
 
-  where url = show $ nullURI { uriScheme = "http:"
+  where url = show $ nullURI { uriScheme = case scheme of
-                             , uriAuthority = Just host
+                                  Http  -> "http:"
+                                  Https -> "https:"
+                             , uriAuthority = Just $
+                                 URIAuth { uriUserInfo = ""
+                                         , uriRegName = host
+                                         , uriPort = ":" ++ show port
+                                         }
                              , uriPath = reqPath req
                              }
 

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
 

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 :: (BaseUrl -> IO a) -> IO a
-withServer action = withWaiDaemon (return server) (action . mkHost "localhost")
+withServer action = withWaiDaemon (return server) action
 
-getGet :: URIAuth -> EitherT String IO Person
+getGet :: BaseUrl -> EitherT String IO Person
-getCapture :: String -> URIAuth -> EitherT String IO Person
+getCapture :: String -> BaseUrl -> EitherT String IO Person
-getBody :: Person -> URIAuth -> EitherT String IO Person
+getBody :: Person -> BaseUrl -> EitherT String IO Person
-getQueryParam :: Maybe String -> URIAuth -> EitherT String IO Person
+getQueryParam :: Maybe String -> BaseUrl -> EitherT String IO Person
-getQueryParams :: [String] -> URIAuth -> EitherT String IO [Person]
+getQueryParams :: [String] -> BaseUrl -> EitherT String IO [Person]
-getQueryFlag :: Bool -> URIAuth -> EitherT String IO Bool
+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
+          \ host -> do
-            let getResponse :: URIAuth -> EitherT String IO ()
+            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