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

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

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

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

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

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

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

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

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

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,
+                                              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 (..),
                                               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

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,
+                                             HttpVersion, IsSecure(..), JSON, MatrixFlag,
-                                             MatrixParams, Patch, PlainText,
+                                             MatrixParam, MatrixParams, Patch, PlainText,
-                                             Post, Put, QueryFlag, QueryParam,
+                                             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

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`

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

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)

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

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

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

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