put BaseUrl in it's own module
This commit is contained in:
parent
85aceadc60
commit
93195abed6
12 changed files with 134 additions and 16 deletions
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
51
src/Servant/Client/BaseUrl.hs
Normal file
51
src/Servant/Client/BaseUrl.hs
Normal file
|
@ -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
|
|
@ -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
|
||||
|
||||
|
|
69
test/Servant/Client/BaseUrlSpec.hs
Normal file
69
test/Servant/Client/BaseUrlSpec.hs
Normal file
|
@ -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)
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue