put BaseUrl in it's own module

example/greet.hs

@@ -20,6 +20,7 @@ import Network.Wai.Handler.Warp
 
 import Servant.API
 import Servant.Client
+import Servant.Client.BaseUrl
 import Servant.Docs
 import Servant.Server
 

servant.cabal

@@ -15,6 +15,7 @@ library
   exposed-modules:
     Servant
     Servant.Client
+    Servant.Client.BaseUrl
     Servant.Docs
     Servant.Server
     Servant.API
@@ -82,6 +83,7 @@ test-suite spec
       base == 4.*
     , aeson
     , bytestring
+    , deepseq
     , either
     , exceptions
     , hspec2

src/Servant.hs

@@ -7,6 +7,7 @@ module Servant (
   module Servant.Server,
   -- | For accessing servant APIs as API clients.
   module Servant.Client,
+  module Servant.Client.BaseUrl,
   -- | For generating documentation for servant APIs.
   module Servant.Docs,
   -- | Helper module
@@ -15,6 +16,7 @@ module Servant (
 
 import Servant.API
 import Servant.Client
+import Servant.Client.BaseUrl
 import Servant.Docs
 import Servant.Server
 import Servant.Utils.Text

src/Servant/API/Delete.hs

@@ -11,6 +11,7 @@ import Data.Typeable
 import Network.HTTP.Types
 import Network.Wai
 import Servant.Client
+import Servant.Client.BaseUrl
 import Servant.Docs
 import Servant.Server
 import Servant.Utils.Client

src/Servant/API/Get.hs

@@ -12,6 +12,7 @@ import Data.Typeable
 import Network.HTTP.Types
 import Network.Wai
 import Servant.Client
+import Servant.Client.BaseUrl
 import Servant.Docs
 import Servant.Server
 import Servant.Utils.Client

src/Servant/API/Post.hs

@@ -12,6 +12,7 @@ import Data.Typeable
 import Network.HTTP.Types
 import Network.Wai
 import Servant.Client
+import Servant.Client.BaseUrl
 import Servant.Docs
 import Servant.Server
 import Servant.Utils.Client

src/Servant/API/Put.hs

@@ -12,6 +12,7 @@ import Data.Typeable
 import Network.HTTP.Types
 import Network.Wai
 import Servant.Client
+import Servant.Client.BaseUrl
 import Servant.Docs
 import Servant.Server
 import Servant.Utils.Client

src/Servant/Client.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric #-}
 module Servant.Client where
 
 import Control.Concurrent
@@ -8,27 +7,15 @@ import Control.Monad.Catch
 import Data.ByteString.Lazy
 import Data.Proxy
 import Data.Text
-import GHC.Generics
 import Network.HTTP.Client hiding (Proxy)
 import Network.HTTP.Types
 import Network.URI
 import System.IO.Unsafe
 
+import Servant.Client.BaseUrl
+
 -- * Accessing APIs as a Client
 
-data Scheme = Http | Https
-  deriving (Show, Eq, Ord, Generic)
-
-data BaseUrl = BaseUrl {
-  baseUrlScheme :: Scheme,
-  baseUrlHost :: String,
-  baseUrlPort :: Int
- }
-  deriving (Show, Eq, Ord, Generic)
-
-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
 client p = clientWithRoute p defReq

src/Servant/Client/BaseUrl.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE ViewPatterns #-}
+module Servant.Client.BaseUrl where
+
+import Data.List
+import GHC.Generics
+import Network.URI
+import Safe
+import Text.Read
+
+data Scheme = Http | Https
+  deriving (Show, Eq, Ord, Generic)
+
+data BaseUrl = BaseUrl {
+  baseUrlScheme :: Scheme,
+  baseUrlHost :: String,
+  baseUrlPort :: Int
+ }
+  deriving (Show, Eq, Ord, Generic)
+
+showBaseUrl :: BaseUrl -> String
+showBaseUrl (BaseUrl scheme host port) =
+  schemeString ++ "//" ++ host ++ portString
+    where
+      schemeString = case scheme of
+        Http  -> "http:"
+        Https -> "https:"
+      portString = case (scheme, port) of
+        (Http, 80) -> ""
+        (Https, 443) -> ""
+        _ -> ":" ++ show port
+
+parseBaseUrl :: String -> Either String 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)))) "" "" "") ->
+    Right (BaseUrl Http host port)
+  Just (URI "http:" (Just (URIAuth "" host "")) "" "" "") ->
+    Right (BaseUrl Http host 80)
+  Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) "" "" "") ->
+    Right (BaseUrl Https host port)
+  Just (URI "https:" (Just (URIAuth "" host "")) "" "" "") ->
+    Right (BaseUrl Https host 443)
+  _ -> if "://" `isInfixOf` s
+    then Left ("invalid base url: " ++ s)
+    else parseBaseUrl ("http://" ++ s)
+ where
+  removeTrailingSlash s = case lastMay s of
+    Just '/' -> init s
+    _ -> s

src/Servant/Utils/Client.hs

@@ -14,6 +14,7 @@ import Data.ByteString.Lazy
 import Data.String.Conversions
 import Network.HTTP.Types
 import Servant.Client
+import Servant.Client.BaseUrl
 
 import qualified Network.HTTP.Client as Client
 

test/Servant/Client/BaseUrlSpec.hs

@@ -0,0 +1,69 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Servant.Client.BaseUrlSpec where
+
+import Control.Applicative
+import Control.DeepSeq
+import Test.Hspec
+import Test.QuickCheck
+
+import Servant.Client.BaseUrl
+
+spec :: Spec
+spec = do
+  describe "showBaseUrl" $ do
+    it "shows a BaseUrl" $ do
+      showBaseUrl (BaseUrl Http "foo.com" 80) `shouldBe` "http://foo.com"
+
+    it "shows a https BaseUrl" $ do
+      showBaseUrl (BaseUrl Https "foo.com" 443) `shouldBe` "https://foo.com"
+
+  describe "httpBaseUrl" $ do
+    it "allows to construct default http BaseUrls" $ do
+      BaseUrl Http "bar" 80 `shouldBe` BaseUrl Http "bar" 80
+
+  describe "parseBaseUrl" $ do
+    it "is total" $ do
+      property $ \ string ->
+        deepseq (fmap show (parseBaseUrl string)) True
+
+    it "is the inverse of showBaseUrl" $ do
+      property $ \ baseUrl ->
+        counterexample (showBaseUrl baseUrl) $
+        parseBaseUrl (showBaseUrl baseUrl) ===
+          Right baseUrl
+
+    it "allows trailing slashes" $ do
+      parseBaseUrl "foo.com/" `shouldBe` Right (BaseUrl Http "foo.com" 80)
+
+    context "urls without scheme" $ do
+      it "assumes http" $ do
+        parseBaseUrl "foo.com" `shouldBe` Right (BaseUrl Http "foo.com" 80)
+
+      it "allows port numbers" $ do
+        parseBaseUrl "foo.com:8080" `shouldBe` Right (BaseUrl Http "foo.com" 8080)
+
+    it "rejects ftp urls" $ do
+      parseBaseUrl "ftp://foo.com" `shouldSatisfy` isLeft
+
+instance Arbitrary BaseUrl where
+  arbitrary = BaseUrl <$>
+    elements [Http, Https] <*>
+    hostNameGen <*>
+    portGen
+   where
+    -- this does not perfectly mirror the url standard, but I hope it's good
+    -- enough.
+    hostNameGen = do
+      let letters = ['a' .. 'z'] ++ ['A' .. 'Z']
+      first <- elements letters
+      middle <- listOf1 $ elements (letters ++ ['0' .. '9'] ++ ['.', '-'])
+      last <- elements letters
+      return (first : middle ++ [last])
+    portGen = frequency $
+      (1, return 80) :
+      (1, return 443) :
+      (1, choose (1, 20000)) :
+      []
+
+isLeft :: Either a b -> Bool
+isLeft = either (const True) (const False)

test/Servant/ClientSpec.hs

@@ -21,6 +21,7 @@ import Test.QuickCheck
 
 import Servant.API
 import Servant.Client
+import Servant.Client.BaseUrl
 import Servant.Server
 
 import Servant.ServerSpec
@@ -157,7 +158,7 @@ withWaiDaemon mkApplication action = do
       runSettingsSocket settings socket application)
             `finally` notifyKilled ()
     krakenPort <- waitForStart
-    let baseUrl = (httpBaseUrl "localhost"){baseUrlPort = krakenPort}
+    let baseUrl = (BaseUrl Http "localhost" 80){baseUrlPort = krakenPort}
     return (thread, waitForKilled, baseUrl)
   free (thread, waitForKilled, _) = do
     killThread thread