add HttpVersion, IsSecure, RemoteHost and Vault combinators with instances for all interpretations (all but the server ones being 'ignore that combinator')

tighter version bounds for network

cleanup

document the new combinators

servant-server: add some tests for HttpVersion, IsSecure, RemoteHost and Vault

update changelogs

address Julian's feedback

remove vault test in servant-server

servant-server tests: -Werror friendly
This commit is contained in:
Alp Mestanogullari 2015-06-23 10:34:20 +02:00
parent 490a84cda1
commit f39d57c6b3
17 changed files with 271 additions and 12 deletions

View file

@ -1,3 +1,8 @@
HEAD
----
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
0.4.1 0.4.1
----- -----
* The `HasClient` instance for `Delete cts ()` now does not care at all about content types provided. * The `HasClient` instance for `Delete cts ()` now does not care at all about content types provided.

View file

@ -669,3 +669,20 @@ instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout
where p = symbolVal (Proxy :: Proxy path) where p = symbolVal (Proxy :: Proxy path)
instance HasClient api => HasClient (Vault :> api) where
type Client (Vault :> api) = Client api
clientWithRoute Proxy req baseurl =
clientWithRoute (Proxy :: Proxy api) req baseurl
instance HasClient api => HasClient (RemoteHost :> api) where
type Client (RemoteHost :> api) = Client api
clientWithRoute Proxy req baseurl =
clientWithRoute (Proxy :: Proxy api) req baseurl
instance HasClient api => HasClient (IsSecure :> api) where
type Client (IsSecure :> api) = Client api
clientWithRoute Proxy req baseurl =
clientWithRoute (Proxy :: Proxy api) req baseurl

View file

@ -1,3 +1,8 @@
HEAD
----
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
0.4 0.4
--- ---
* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

View file

@ -900,3 +900,18 @@ instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) wh
endpoint' = endpoint & path <>~ [symbolVal pa] endpoint' = endpoint & path <>~ [symbolVal pa]
pa = Proxy :: Proxy path pa = Proxy :: Proxy path
instance HasDocs sublayout => HasDocs (RemoteHost :> sublayout) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
instance HasDocs sublayout => HasDocs (IsSecure :> sublayout) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
instance HasDocs sublayout => HasDocs (HttpVersion :> sublayout) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep
instance HasDocs sublayout => HasDocs (Vault :> sublayout) where
docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep

View file

@ -1,3 +1,8 @@
HEAD
----
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
0.4 0.4
--- ---
* `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body

View file

@ -338,3 +338,27 @@ instance (KnownSymbol path, HasJQ sublayout)
& funcName %~ (str <>) & funcName %~ (str <>)
where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path) where str = map (\c -> if c == '.' then '_' else c) $ symbolVal (Proxy :: Proxy path)
instance HasJQ sublayout => HasJQ (RemoteHost :> sublayout) where
type JQ (RemoteHost :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) req
instance HasJQ sublayout => HasJQ (IsSecure :> sublayout) where
type JQ (IsSecure :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) req
instance HasJQ sublayout => HasJQ (Vault :> sublayout) where
type JQ (Vault :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) req
instance HasJQ sublayout => HasJQ (HttpVersion :> sublayout) where
type JQ (HttpVersion :> sublayout) = JQ sublayout
jqueryFor Proxy req =
jqueryFor (Proxy :: Proxy sublayout) req

View file

@ -1,3 +1,8 @@
HEAD
----
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
0.4.1 0.4.1
----- -----
* Bump attoparsec upper bound to < 0.14 * Bump attoparsec upper bound to < 0.14

View file

@ -52,6 +52,7 @@ library
, network-uri >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7
, mtl >= 2 && < 3 , mtl >= 2 && < 3
, mmorph >= 1 , mmorph >= 1
, network >= 2.6 && < 2.7
, safe >= 0.3 && < 0.4 , safe >= 0.3 && < 0.4
, servant == 0.4.* , servant == 0.4.*
, split >= 0.2 && < 0.3 , split >= 0.2 && < 0.3
@ -63,6 +64,7 @@ library
, wai >= 3.0 && < 3.1 , wai >= 3.0 && < 3.1
, wai-app-static >= 3.0 && < 3.2 , wai-app-static >= 3.0 && < 3.2
, warp >= 3.0 && < 3.1 , warp >= 3.0 && < 3.1
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

View file

@ -35,15 +35,17 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Typeable import Data.Typeable
import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.TypeLits (KnownSymbol, symbolVal)
import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.HTTP.Types hiding (Header, ResponseHeaders)
import Network.Socket (SockAddr)
import Network.Wai (Application, lazyRequestBody, import Network.Wai (Application, lazyRequestBody,
rawQueryString, requestHeaders, rawQueryString, requestHeaders,
requestMethod, responseLBS) requestMethod, responseLBS, remoteHost,
isSecure, vault, httpVersion)
import Servant.API ((:<|>) (..), (:>), Capture, import Servant.API ((:<|>) (..), (:>), Capture,
Delete, Get, Header, Delete, Get, Header,
MatrixFlag, MatrixParam, MatrixParams, IsSecure(..), MatrixFlag, MatrixParam,
Patch, Post, Put, QueryFlag, MatrixParams, Patch, Post, Put,
QueryParam, QueryParams, Raw, QueryFlag, QueryParam, QueryParams,
ReqBody) Raw, RemoteHost, ReqBody, Vault)
import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..), AllCTRender (..),
AllCTUnrender (..)) AllCTUnrender (..))
@ -721,5 +723,31 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout
(route (Proxy :: Proxy sublayout) subserver) (route (Proxy :: Proxy sublayout) subserver)
where proxyPath = Proxy :: Proxy path where proxyPath = Proxy :: Proxy path
instance HasServer api => HasServer (RemoteHost :> api) where
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
route Proxy subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (feedTo subserver $ remoteHost req)
instance HasServer api => HasServer (IsSecure :> api) where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
route Proxy subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (feedTo subserver $ secure req)
where secure req = if isSecure req then Secure else NotSecure
instance HasServer api => HasServer (Vault :> api) where
type ServerT (Vault :> api) m = Vault -> ServerT api m
route Proxy subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (feedTo subserver $ vault req)
instance HasServer api => HasServer (HttpVersion :> api) where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
route Proxy subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) (feedTo subserver $ httpVersion req)
ct_wildcard :: B.ByteString ct_wildcard :: B.ByteString
ct_wildcard = "*" <> "/" <> "*" -- Because CPP ct_wildcard = "*" <> "/" <> "*" -- Because CPP

View file

@ -37,9 +37,9 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders,
import Servant.API ((:<|>) (..), (:>), import Servant.API ((:<|>) (..), (:>),
addHeader, Capture, addHeader, Capture,
Delete, Get, Header (..), Headers, Delete, Get, Header (..), Headers,
JSON, MatrixFlag, MatrixParam, HttpVersion, IsSecure(..), JSON, MatrixFlag,
MatrixParams, Patch, PlainText, MatrixParam, MatrixParams, Patch, PlainText,
Post, Put, QueryFlag, QueryParam, Post, Put, RemoteHost, QueryFlag, QueryParam,
QueryParams, Raw, ReqBody) QueryParams, Raw, ReqBody)
import Servant.Server (Server, serve, ServantErr(..), err404) import Servant.Server (Server, serve, ServantErr(..), err404)
import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.RoutingApplication
@ -93,6 +93,7 @@ spec = do
prioErrorsSpec prioErrorsSpec
errorsSpec errorsSpec
responseHeadersSpec responseHeadersSpec
miscReqCombinatorsSpec
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
@ -667,3 +668,35 @@ errorsSpec = do
nf <> he `shouldBe` he nf <> he `shouldBe` he
nf <> ib `shouldBe` ib nf <> ib `shouldBe` ib
nf <> wm `shouldBe` wm nf <> wm `shouldBe` wm
type MiscCombinatorsAPI
= "version" :> HttpVersion :> Get '[JSON] String
:<|> "secure" :> IsSecure :> Get '[JSON] String
:<|> "host" :> RemoteHost :> Get '[JSON] String
miscApi :: Proxy MiscCombinatorsAPI
miscApi = Proxy
miscServ :: Server MiscCombinatorsAPI
miscServ = versionHandler
:<|> secureHandler
:<|> hostHandler
where versionHandler = return . show
secureHandler Secure = return "secure"
secureHandler NotSecure = return "not secure"
hostHandler = return . show
miscReqCombinatorsSpec :: Spec
miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $
describe "Misc. combinators for request inspection" $ do
it "Successfully gets the HTTP version specified in the request" $
go "/version" "\"HTTP/1.0\""
it "Checks that hspec-wai uses HTTP, not HTTPS" $
go "/secure" "\"not secure\""
it "Checks that hspec-wai issues request from 0.0.0.0" $
go "/host" "\"0.0.0.0:0\""
where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res

View file

@ -1,3 +1,8 @@
HEAD
----
* Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
0.4.2 0.4.2
----- -----
* Fix missing cases for `Patch` in `safeLink` * Fix missing cases for `Patch` in `safeLink`

View file

@ -34,15 +34,19 @@ library
Servant.API.Delete Servant.API.Delete
Servant.API.Get Servant.API.Get
Servant.API.Header Servant.API.Header
Servant.API.HttpVersion
Servant.API.IsSecure
Servant.API.Patch Servant.API.Patch
Servant.API.Post Servant.API.Post
Servant.API.Put Servant.API.Put
Servant.API.QueryParam Servant.API.QueryParam
Servant.API.MatrixParam Servant.API.MatrixParam
Servant.API.Raw Servant.API.Raw
Servant.API.RemoteHost
Servant.API.ReqBody Servant.API.ReqBody
Servant.API.ResponseHeaders Servant.API.ResponseHeaders
Servant.API.Sub Servant.API.Sub
Servant.API.Vault
Servant.Common.Text Servant.Common.Text
Servant.Utils.Links Servant.Utils.Links
build-depends: build-depends:
@ -57,6 +61,7 @@ library
, text >= 1 && < 2 , text >= 1 && < 2
, string-conversions >= 0.3 && < 0.5 , string-conversions >= 0.3 && < 0.5
, network-uri >= 2.6 , network-uri >= 2.6
, vault >= 0.3 && <0.4
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
other-extensions: CPP other-extensions: CPP

View file

@ -1,6 +1,3 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.API ( module Servant.API (
-- * Combinators -- * Combinators
@ -14,12 +11,20 @@ module Servant.API (
-- | Capturing parts of the url path as parsed values: @'Capture'@ -- | Capturing parts of the url path as parsed values: @'Capture'@
module Servant.API.Header, module Servant.API.Header,
-- | Retrieving specific headers from the request -- | Retrieving specific headers from the request
module Servant.API.HttpVersion,
-- | Retrieving the HTTP version of the request
module Servant.API.QueryParam, module Servant.API.QueryParam,
-- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@ -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@
module Servant.API.ReqBody, module Servant.API.ReqBody,
-- | Accessing the request body as a JSON-encoded type: @'ReqBody'@ -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@
module Servant.API.MatrixParam, module Servant.API.MatrixParam,
-- | Retrieving matrix parameters from the 'URI' segment: @'MatrixParam'@ -- | Retrieving matrix parameters from the 'URI' segment: @'MatrixParam'@
module Servant.API.RemoteHost,
-- | Retrieving the IP of the client
module Servant.API.IsSecure,
-- | Is the request made through HTTPS?
module Servant.API.Vault,
-- | Access the location for arbitrary data to be shared by applications and middleware
-- * Actual endpoints, distinguished by HTTP method -- * Actual endpoints, distinguished by HTTP method
module Servant.API.Get, module Servant.API.Get,
@ -64,6 +69,8 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
import Servant.API.Delete (Delete) import Servant.API.Delete (Delete)
import Servant.API.Get (Get) import Servant.API.Get (Get)
import Servant.API.Header (Header (..)) import Servant.API.Header (Header (..))
import Servant.API.HttpVersion (HttpVersion(..))
import Servant.API.IsSecure (IsSecure(..))
import Servant.API.MatrixParam (MatrixFlag, MatrixParam, import Servant.API.MatrixParam (MatrixFlag, MatrixParam,
MatrixParams) MatrixParams)
import Servant.API.Patch (Patch) import Servant.API.Patch (Patch)
@ -72,6 +79,7 @@ import Servant.API.Put (Put)
import Servant.API.QueryParam (QueryFlag, QueryParam, import Servant.API.QueryParam (QueryFlag, QueryParam,
QueryParams) QueryParams)
import Servant.API.Raw (Raw) import Servant.API.Raw (Raw)
import Servant.API.RemoteHost (RemoteHost)
import Servant.API.ReqBody (ReqBody) import Servant.API.ReqBody (ReqBody)
import Servant.API.ResponseHeaders (AddHeader (addHeader), import Servant.API.ResponseHeaders (AddHeader (addHeader),
BuildHeadersTo (buildHeadersTo), BuildHeadersTo (buildHeadersTo),
@ -79,6 +87,7 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader),
HList (..), Headers (..), HList (..), Headers (..),
getHeadersHList, getResponse) getHeadersHList, getResponse)
import Servant.API.Sub ((:>)) import Servant.API.Sub ((:>))
import Servant.API.Vault (Vault)
import Servant.Common.Text (FromText (..), ToText (..)) import Servant.Common.Text (FromText (..), ToText (..))
import Servant.Utils.Links (HasLink (..), IsElem, IsElem', import Servant.Utils.Links (HasLink (..), IsElem, IsElem',
URI (..), safeLink) URI (..), safeLink)

View file

@ -0,0 +1,19 @@
module Servant.API.HttpVersion
( -- $httpversion
HttpVersion(..)
) where
import Network.HTTP.Types (HttpVersion(..))
-- $httpversion
--
-- | You can directly use the 'HttpVersion' type from @Network.HTTP.Types@
-- if your request handlers need it to compute a response. This would
-- make the request handlers take an argument of type 'HttpVersion'.
--
-- Example:
--
-- >>> type API = HttpVersion :> Get '[JSON] String
-- $setup
-- >>> import Servant.API

View file

@ -0,0 +1,37 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Servant.API.IsSecure
( -- $issecure
IsSecure(..)
) where
import Data.Typeable
-- | Was this request made over an SSL connection?
--
-- Note that this value will not tell you if the client originally
-- made this request over SSL, but rather whether the current
-- connection is SSL. The distinction lies with reverse proxies.
-- In many cases, the client will connect to a load balancer over SSL,
-- but connect to the WAI handler without SSL. In such a case,
-- the handlers would get 'NotSecure', but from a user perspective,
-- there is a secure connection.
data IsSecure = Secure -- ^ the connection to the server
-- is secure (HTTPS)
| NotSecure -- ^ the connection to the server
-- is not secure (HTTP)
deriving Typeable
-- $issecure
--
-- | Use 'IsSecure' whenever your request handlers need to know whether
-- the connection to the server is secure or not.
-- This would make the request handlers receive an argument of type 'IsSecure',
-- whose value can be one of 'Secure' (HTTPS) or 'NotSecure' (HTTP).
--
-- Example:
--
-- >>> type API = "sensitive-data" :> IsSecure :> Get '[JSON] NationSecrets
-- $setup
-- >>> import Servant.API
-- >>> data NationSecrets

View file

@ -0,0 +1,25 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Servant.API.RemoteHost
( -- $remotehost
RemoteHost
) where
import Data.Typeable
-- | Provides access to the host or IP address
-- from which the HTTP request was sent.
data RemoteHost deriving Typeable
-- $remotehost
--
-- | Use 'RemoteHost' whenever your request handlers need the host or IP address
-- from which the client issued the HTTP request. The corresponding handlers
-- receive arguments of type @SockAddr@ (from @Network.Socket@).
--
-- Example:
--
-- >>> -- POST /record-ip
-- >>> type API = "record-ip" :> RemoteHost :> Post '[] ()
-- $setup
-- >>> import Servant.API

View file

@ -0,0 +1,20 @@
module Servant.API.Vault
( -- $vault
Vault
) where
import Data.Vault.Lazy (Vault)
-- $vault
--
-- | Use 'Vault' in your API types to provide access to the 'Vault'
-- of the request, which is a location shared by middlewares and applications
-- to store arbitrary data. See 'Vault' for more details on how to actually
-- use the vault in your handlers
--
-- Example:
--
-- >>> type API = Vault :> Get '[JSON] String
-- $setup
-- >>> import Servant.API