From f39d57c6b3a964de34a3a51eefb7ae93e7279651 Mon Sep 17 00:00:00 2001 From: Alp Mestanogullari Date: Tue, 23 Jun 2015 10:34:20 +0200 Subject: [PATCH] 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 --- servant-client/CHANGELOG.md | 5 +++ servant-client/src/Servant/Client.hs | 17 ++++++++ servant-docs/CHANGELOG.md | 5 +++ servant-docs/src/Servant/Docs/Internal.hs | 15 +++++++ servant-jquery/CHANGELOG.md | 5 +++ servant-jquery/src/Servant/JQuery/Internal.hs | 24 +++++++++++ servant-server/CHANGELOG.md | 5 +++ servant-server/servant-server.cabal | 2 + servant-server/src/Servant/Server/Internal.hs | 40 ++++++++++++++++--- servant-server/test/Servant/ServerSpec.hs | 39 ++++++++++++++++-- servant/CHANGELOG.md | 5 +++ servant/servant.cabal | 5 +++ servant/src/Servant/API.hs | 15 +++++-- servant/src/Servant/API/HttpVersion.hs | 19 +++++++++ servant/src/Servant/API/IsSecure.hs | 37 +++++++++++++++++ servant/src/Servant/API/RemoteHost.hs | 25 ++++++++++++ servant/src/Servant/API/Vault.hs | 20 ++++++++++ 17 files changed, 271 insertions(+), 12 deletions(-) create mode 100644 servant/src/Servant/API/HttpVersion.hs create mode 100644 servant/src/Servant/API/IsSecure.hs create mode 100644 servant/src/Servant/API/RemoteHost.hs create mode 100644 servant/src/Servant/API/Vault.hs diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index b68a1e0c..e3cd7a0e 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -1,3 +1,8 @@ +HEAD +---- + +* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators + 0.4.1 ----- * The `HasClient` instance for `Delete cts ()` now does not care at all about content types provided. diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 0106318a..729d7a19 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -669,3 +669,20 @@ instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout 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 diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index 2d87a8bf..afaa18a3 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -1,3 +1,8 @@ +HEAD +---- + +* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators + 0.4 --- * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 09bf8b40..5b590752 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -900,3 +900,18 @@ instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) wh endpoint' = endpoint & path <>~ [symbolVal pa] 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 diff --git a/servant-jquery/CHANGELOG.md b/servant-jquery/CHANGELOG.md index 09b241cc..3ef30bef 100644 --- a/servant-jquery/CHANGELOG.md +++ b/servant-jquery/CHANGELOG.md @@ -1,3 +1,8 @@ +HEAD +---- + +* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators + 0.4 --- * `Delete` now is like `Get`, `Post`, `Put`, and `Patch` and returns a response body diff --git a/servant-jquery/src/Servant/JQuery/Internal.hs b/servant-jquery/src/Servant/JQuery/Internal.hs index 15810a2f..859c1b1b 100644 --- a/servant-jquery/src/Servant/JQuery/Internal.hs +++ b/servant-jquery/src/Servant/JQuery/Internal.hs @@ -338,3 +338,27 @@ instance (KnownSymbol path, HasJQ sublayout) & funcName %~ (str <>) 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 diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 99c329d8..f6122e63 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,3 +1,8 @@ +HEAD +---- + +* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators + 0.4.1 ----- * Bump attoparsec upper bound to < 0.14 diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 277f6050..4f4ebef0 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -52,6 +52,7 @@ library , network-uri >= 2.6 && < 2.7 , mtl >= 2 && < 3 , mmorph >= 1 + , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 , servant == 0.4.* , split >= 0.2 && < 0.3 @@ -63,6 +64,7 @@ library , wai >= 3.0 && < 3.1 , wai-app-static >= 3.0 && < 3.2 , warp >= 3.0 && < 3.1 + hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 02c729f3..20edad8e 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -35,15 +35,17 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Typeable import GHC.TypeLits (KnownSymbol, symbolVal) import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Socket (SockAddr) import Network.Wai (Application, lazyRequestBody, rawQueryString, requestHeaders, - requestMethod, responseLBS) + requestMethod, responseLBS, remoteHost, + isSecure, vault, httpVersion) import Servant.API ((:<|>) (..), (:>), Capture, - Delete, Get, Header, - MatrixFlag, MatrixParam, MatrixParams, - Patch, Post, Put, QueryFlag, - QueryParam, QueryParams, Raw, - ReqBody) + Delete, Get, Header, + IsSecure(..), MatrixFlag, MatrixParam, + MatrixParams, Patch, Post, Put, + QueryFlag, QueryParam, QueryParams, + Raw, RemoteHost, ReqBody, Vault) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..)) @@ -721,5 +723,31 @@ instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout (route (Proxy :: Proxy sublayout) subserver) 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 = "*" <> "/" <> "*" -- Because CPP diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 00087d93..cbde1c94 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -37,9 +37,9 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders, import Servant.API ((:<|>) (..), (:>), addHeader, Capture, Delete, Get, Header (..), Headers, - JSON, MatrixFlag, MatrixParam, - MatrixParams, Patch, PlainText, - Post, Put, QueryFlag, QueryParam, + HttpVersion, IsSecure(..), JSON, MatrixFlag, + MatrixParam, MatrixParams, Patch, PlainText, + Post, Put, RemoteHost, QueryFlag, QueryParam, QueryParams, Raw, ReqBody) import Servant.Server (Server, serve, ServantErr(..), err404) import Servant.Server.Internal.RoutingApplication @@ -93,6 +93,7 @@ spec = do prioErrorsSpec errorsSpec responseHeadersSpec + miscReqCombinatorsSpec type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal @@ -667,3 +668,35 @@ errorsSpec = do nf <> he `shouldBe` he nf <> ib `shouldBe` ib 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 diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index a640d629..9ae7547e 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,3 +1,8 @@ +HEAD +---- + +* Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators + 0.4.2 ----- * Fix missing cases for `Patch` in `safeLink` diff --git a/servant/servant.cabal b/servant/servant.cabal index fb605e11..0e3e6e6e 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -34,15 +34,19 @@ library Servant.API.Delete Servant.API.Get Servant.API.Header + Servant.API.HttpVersion + Servant.API.IsSecure Servant.API.Patch Servant.API.Post Servant.API.Put Servant.API.QueryParam Servant.API.MatrixParam Servant.API.Raw + Servant.API.RemoteHost Servant.API.ReqBody Servant.API.ResponseHeaders Servant.API.Sub + Servant.API.Vault Servant.Common.Text Servant.Utils.Links build-depends: @@ -57,6 +61,7 @@ library , text >= 1 && < 2 , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6 + , vault >= 0.3 && <0.4 hs-source-dirs: src default-language: Haskell2010 other-extensions: CPP diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 034be7a2..9aba6322 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} module Servant.API ( -- * Combinators @@ -14,12 +11,20 @@ module Servant.API ( -- | Capturing parts of the url path as parsed values: @'Capture'@ module Servant.API.Header, -- | Retrieving specific headers from the request + module Servant.API.HttpVersion, + -- | Retrieving the HTTP version of the request module Servant.API.QueryParam, -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@ module Servant.API.ReqBody, -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@ module Servant.API.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 module Servant.API.Get, @@ -64,6 +69,8 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, import Servant.API.Delete (Delete) import Servant.API.Get (Get) import Servant.API.Header (Header (..)) +import Servant.API.HttpVersion (HttpVersion(..)) +import Servant.API.IsSecure (IsSecure(..)) import Servant.API.MatrixParam (MatrixFlag, MatrixParam, MatrixParams) import Servant.API.Patch (Patch) @@ -72,6 +79,7 @@ import Servant.API.Put (Put) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.Raw (Raw) +import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody (ReqBody) import Servant.API.ResponseHeaders (AddHeader (addHeader), BuildHeadersTo (buildHeadersTo), @@ -79,6 +87,7 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader), HList (..), Headers (..), getHeadersHList, getResponse) import Servant.API.Sub ((:>)) +import Servant.API.Vault (Vault) import Servant.Common.Text (FromText (..), ToText (..)) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) diff --git a/servant/src/Servant/API/HttpVersion.hs b/servant/src/Servant/API/HttpVersion.hs new file mode 100644 index 00000000..407ae2db --- /dev/null +++ b/servant/src/Servant/API/HttpVersion.hs @@ -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 diff --git a/servant/src/Servant/API/IsSecure.hs b/servant/src/Servant/API/IsSecure.hs new file mode 100644 index 00000000..a2829200 --- /dev/null +++ b/servant/src/Servant/API/IsSecure.hs @@ -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 diff --git a/servant/src/Servant/API/RemoteHost.hs b/servant/src/Servant/API/RemoteHost.hs new file mode 100644 index 00000000..961c3113 --- /dev/null +++ b/servant/src/Servant/API/RemoteHost.hs @@ -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 diff --git a/servant/src/Servant/API/Vault.hs b/servant/src/Servant/API/Vault.hs new file mode 100644 index 00000000..3acdcf65 --- /dev/null +++ b/servant/src/Servant/API/Vault.hs @@ -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