put BaseUrl in it's own module

This commit is contained in:
Sönke Hahn 2014-11-07 11:09:54 +08:00
parent 85aceadc60
commit 93195abed6
12 changed files with 134 additions and 16 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View 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

View file

@ -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

View 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)

View file

@ -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