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