diff --git a/example/greet.hs b/example/greet.hs index 42fab2a0..8855806a 100644 --- a/example/greet.hs +++ b/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 diff --git a/servant.cabal b/servant.cabal index cd05c2e7..017a57e8 100644 --- a/servant.cabal +++ b/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 diff --git a/src/Servant.hs b/src/Servant.hs index 3ee1907e..26d2b5c8 100644 --- a/src/Servant.hs +++ b/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 diff --git a/src/Servant/API/Delete.hs b/src/Servant/API/Delete.hs index f5db3b17..ae7a4239 100644 --- a/src/Servant/API/Delete.hs +++ b/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 diff --git a/src/Servant/API/Get.hs b/src/Servant/API/Get.hs index c7faedc4..c9494427 100644 --- a/src/Servant/API/Get.hs +++ b/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 diff --git a/src/Servant/API/Post.hs b/src/Servant/API/Post.hs index 1290f4e2..96314c98 100644 --- a/src/Servant/API/Post.hs +++ b/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 diff --git a/src/Servant/API/Put.hs b/src/Servant/API/Put.hs index 2ffe59ae..e5cb73b1 100644 --- a/src/Servant/API/Put.hs +++ b/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 diff --git a/src/Servant/Client.hs b/src/Servant/Client.hs index 8fd12a88..8c432504 100644 --- a/src/Servant/Client.hs +++ b/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 diff --git a/src/Servant/Client/BaseUrl.hs b/src/Servant/Client/BaseUrl.hs new file mode 100644 index 00000000..fc5b72eb --- /dev/null +++ b/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 diff --git a/src/Servant/Utils/Client.hs b/src/Servant/Utils/Client.hs index 2214e54d..62a391e2 100644 --- a/src/Servant/Utils/Client.hs +++ b/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 diff --git a/test/Servant/Client/BaseUrlSpec.hs b/test/Servant/Client/BaseUrlSpec.hs new file mode 100644 index 00000000..1f75b697 --- /dev/null +++ b/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) diff --git a/test/Servant/ClientSpec.hs b/test/Servant/ClientSpec.hs index a90f0601..f0c11760 100644 --- a/test/Servant/ClientSpec.hs +++ b/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