wai-extra 3.0.6.1 → 3.0.7

raw patch · 9 files changed

+394/−3 lines, 9 filesdep +vaultPVP ok

version bump matches the API change (PVP)

Dependencies added: vault

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• Network/Wai/Middleware/Approot.hs +123/−0
• Network/Wai/Middleware/ForceSSL.hs +44/−0
• Network/Wai/Request.hs +51/−0
• Network/Wai/Test.hs +5/−2
• test/Network/Wai/Middleware/ApprootSpec.hs +37/−0
• test/Network/Wai/Middleware/ForceSSLSpec.hs +56/−0
• test/Network/Wai/RequestSpec.hs +63/−0
• wai-extra.cabal +8/−1

@@ -1,3 +1,10 @@+## 3.0.7++* Add appearsSecure: check if a request appears to be using SSL even in the+  presence of reverse proxies [#362](https://github.com/yesodweb/wai/pull/362)+* Add ForceSSL middleware [#363](https://github.com/yesodweb/wai/pull/363)+* Add Approot middleware+ ## 3.0.6.1  * Test code: only include a Cookie header if there are cookies. Without this

@@ -0,0 +1,123 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Middleware for establishing the root of the application.+--+-- Many application need the ability to create URLs referring back to the+-- application itself. For example: generate RSS feeds or sitemaps, giving+-- users copy-paste links, or sending emails. In many cases, the approot can be+-- determined correctly from the request headers. However, some things can+-- prevent this, especially reverse proxies. This module provides multiple ways+-- of configuring approot discovery, and functions for applications to get that+-- approot.+--+-- Approots are structured such that they can be prepended to a string such as+-- @/foo/bar?baz=bin@. For example, if your application is hosted on+-- example.com using HTTPS, the approot would be @https://example.com@. Note+-- the lack of a trailing slash.+module Network.Wai.Middleware.Approot+    ( -- * Middleware+      approotMiddleware+      -- * Common providers+    , envFallback+    , envFallbackNamed+    , hardcoded+    , fromRequest+      -- * Functions for applications+    , getApproot+    , getApprootMay+    ) where++import           Control.Exception     (Exception, throw)+import           Data.ByteString       (ByteString)+import qualified Data.ByteString       as S+import qualified Data.ByteString.Char8 as S8+import           Data.Maybe            (fromMaybe)+import           Data.Typeable         (Typeable)+import qualified Data.Vault.Lazy       as V+import           Network.Wai (Request, vault, Middleware, requestHeaderHost)+import           Network.Wai.Request   (appearsSecure, guessApproot)+import           System.Environment    (getEnvironment)+import           System.IO.Unsafe      (unsafePerformIO)++approotKey :: V.Key ByteString+approotKey = unsafePerformIO V.newKey+{-# NOINLINE approotKey #-}++-- | The most generic version of the middleware, allowing you to provide a+-- function to get the approot for each request. For many use cases, one of the+-- helper functions provided by this module will give the necessary+-- functionality more conveniently.+--+-- Since 3.0.7+approotMiddleware :: (Request -> IO ByteString) -- ^ get the approot+                  -> Middleware+approotMiddleware getRoot app req respond = do+    ar <- getRoot req+    let req' = req { vault = V.insert approotKey ar $ vault req }+    app req' respond++-- | Same as @'envFallbackNamed' "APPROOT"@.+--+-- The environment variable @APPROOT@ is used by Keter, School of Haskell, and yesod-devel.+--+-- Since 3.0.7+envFallback :: IO Middleware+envFallback = envFallbackNamed "APPROOT"++-- | Produce a middleware that takes the approot from the given environment+-- variable, falling back to the behavior of 'fromRequest' if the variable is+-- not set.+--+-- Since 3.0.7+envFallbackNamed :: String -> IO Middleware+envFallbackNamed name = do+    env <- getEnvironment+    case lookup name env of+        Just s -> return $ hardcoded $ S8.pack s+        Nothing -> return fromRequest++-- | Hard-code the given value as the approot.+--+-- Since 3.0.7+hardcoded :: ByteString -> Middleware+hardcoded ar = approotMiddleware (const $ return ar)++-- | Get the approot by analyzing the request. This is not a full-proof+-- approach, but in many common cases will work. Situations that can break this+-- are:+--+-- * Requests which spoof headers and imply the connection is over HTTPS+--+-- * Reverse proxies that change ports in surprising ways+--+-- * Invalid Host headers+--+-- * Reverse proxies which modify the path info+--+-- Normally trusting headers in this way is insecure, however in the case of+-- approot, the worst that can happen is that the client will get an incorrect+-- URL. If you are relying on the approot for some security-sensitive purpose,+-- it is highly recommended to use @hardcoded@, which cannot be spoofed.+--+-- Since 3.0.7+fromRequest :: Middleware+fromRequest = approotMiddleware (return . guessApproot)++data ApprootMiddlewareNotSetup = ApprootMiddlewareNotSetup+    deriving (Show, Typeable)+instance Exception ApprootMiddlewareNotSetup++-- | Get the approot set by the middleware. If the middleware is not in use,+-- then this function will return an exception. For a total version of the+-- function, see 'getApprootMay'.+--+-- Since 3.0.7+getApproot :: Request -> ByteString+getApproot = fromMaybe (throw ApprootMiddlewareNotSetup) . getApprootMay++-- | A total version of 'getApproot', which returns 'Nothing' if the middleware+-- is not in use.+--+-- Since 3.0.7+getApprootMay :: Request -> Maybe ByteString+getApprootMay req = V.lookup approotKey $ vault req

@@ -0,0 +1,44 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Redirect non-SSL requests to https+--+-- Since 3.0.7+module  Network.Wai.Middleware.ForceSSL+    ( forceSSL+    ) where++import Network.Wai+import Network.Wai.Request++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+import Data.Monoid (mempty)+#endif++import Data.Monoid ((<>))+import Network.HTTP.Types (hLocation, methodGet, status301, status307)++import qualified Data.ByteString as S+import Data.Word8 (_colon)++-- | For requests that don't appear secure, redirect to https+--+-- Since 3.0.7+forceSSL :: Middleware+forceSSL app req sendResponse =+    case (appearsSecure req, redirectResponse req) of+        (False, Just resp) -> sendResponse resp+        _                  -> app req sendResponse++redirectResponse :: Request -> Maybe Response+redirectResponse req = do+    (host, _) <- S.break (== _colon) <$> requestHeaderHost req++    return $ responseBuilder status [(hLocation, location host)] mempty++  where+    location h = "https://" <> h <> rawPathInfo req <> rawQueryString req++    status+        | requestMethod req == methodGet = status301+        | otherwise = status307

@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Some helpers for interrogating a WAI 'Request'.++module Network.Wai.Request+    ( appearsSecure+    , guessApproot+    ) where++import Data.ByteString (ByteString)+import Data.Maybe (fromMaybe)+import Network.HTTP.Types (HeaderName)+import Network.Wai (Request, isSecure, requestHeaders, requestHeaderHost)++import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as C++-- | Does this request appear to have been made over an SSL connection?+--+-- This function first checks @'isSecure'@, but also checks for headers that may+-- indicate a secure connection even in the presence of reverse proxies.+--+-- Note: these headers can be easily spoofed, so decisions which require a true+-- SSL connection (i.e. sending sensitive information) should only use+-- @'isSecure'@. This is not always the case though: for example, deciding to+-- force a non-SSL request to SSL by redirect. One can safely choose not to+-- redirect when the request /appears/ secure, even if it's actually not.+--+-- Since 3.0.7+appearsSecure :: Request -> Bool+appearsSecure request = isSecure request || any (uncurry matchHeader)+    [ ("HTTPS"                  , (== "on"))+    , ("HTTP_X_FORWARDED_SSL"   , (== "on"))+    , ("HTTP_X_FORWARDED_SCHEME", (== "https"))+    , ("HTTP_X_FORWARDED_PROTO" , ((== ["https"]) . take 1 . C.split ','))+    ]++  where+    matchHeader :: HeaderName -> (ByteString -> Bool) -> Bool+    matchHeader h f = maybe False f $ lookup h $ requestHeaders request++-- | Guess the \"application root\" based on the given request.+--+-- The application root is the basis for forming URLs pointing at the current+-- application. For more information and relevant caveats, please see+-- "Network.Wai.Middleware.Approot".+--+-- Since 3.0.7+guessApproot :: Request -> ByteString+guessApproot req =+    (if appearsSecure req then "https://" else "http://") `S.append`+    (fromMaybe "localhost" $ requestHeaderHost req)

@@ -32,9 +32,13 @@     , WaiTestFailure (..)     ) where +#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+import Data.Monoid (mempty, mappend)+#endif+ import Network.Wai import Network.Wai.Internal (ResponseReceived (ResponseReceived))-import Control.Applicative ((<$>)) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import qualified Control.Monad.Trans.State as ST@@ -58,7 +62,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.IORef-import Data.Monoid (mempty, mappend) import Data.Time.Clock (getCurrentTime)  type Session = ReaderT Application (ST.StateT ClientState IO)

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Wai.Middleware.ApprootSpec+    ( main+    , spec+    ) where++import Test.Hspec++import Network.Wai.Middleware.Approot+import Network.Wai.Test+import Network.Wai+import Network.HTTP.Types+import Data.ByteString (ByteString)++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+    let test name host secure headers expected = it name $ do+            resp <- runApp host secure headers+            simpleHeaders resp `shouldBe` [("Approot", expected)]+    test "respects host header" "foobar" False [] "http://foobar"+    test "respects isSecure" "foobar" True [] "https://foobar"+    test "respects SSL headers" "foobar" False+        [("HTTP_X_FORWARDED_SSL", "on")] "https://foobar"++runApp :: ByteString -> Bool -> RequestHeaders -> IO SResponse+runApp host secure headers = runSession+    (request defaultRequest+        { requestHeaderHost = Just host+        , isSecure = secure+        , requestHeaders = headers+        }) $ fromRequest app++  where+    app req respond = respond $ responseLBS status200 [("Approot", getApproot req)] ""

@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Wai.Middleware.ForceSSLSpec+    ( main+    , spec+    ) where++import Test.Hspec++import Network.Wai.Middleware.ForceSSL++import Data.ByteString (ByteString)+import Data.Monoid ((<>))+import Network.HTTP.Types (methodPost, status200, status301, status307)+import Network.Wai+import Network.Wai.Test++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "forceSSL" $ do+    let host = "example.com"++    it "redirects non-https requests to https" $ do+        resp <- runApp host forceSSL defaultRequest++        simpleStatus resp `shouldBe` status301+        simpleHeaders resp `shouldBe` [("Location", "https://" <> host)]++    it "redirects with 307 in the case of a non-GET request" $ do+        resp <- runApp host forceSSL defaultRequest+            { requestMethod = methodPost }++        simpleStatus resp `shouldBe` status307+        simpleHeaders resp `shouldBe` [("Location", "https://" <> host)]++    it "does not redirect already-secure requests" $ do+        resp <- runApp host forceSSL defaultRequest { isSecure = True }++        simpleStatus resp `shouldBe` status200++    it "preserves the original path and query string" $ do+        resp <- runApp host forceSSL defaultRequest+            { rawPathInfo = "/foo/bar"+            , rawQueryString = "?baz=bat"+            }++        simpleHeaders resp `shouldBe`+            [("Location", "https://" <> host <> "/foo/bar?baz=bat")]++runApp :: ByteString -> Middleware -> Request -> IO SResponse+runApp host mw req = runSession+    (request req { requestHeaderHost = Just $ host <> ":80" }) $ mw app++  where+    app _ respond = respond $ responseLBS status200 [] ""

@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Wai.RequestSpec+    ( main+    , spec+    ) where++import Test.Hspec++import Data.ByteString (ByteString)+import Network.HTTP.Types (HeaderName)+import Network.Wai (Request(..), defaultRequest)++import Network.Wai.Request++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "appearsSecure" $ do+    let insecureRequest = defaultRequest+            { isSecure = False+            , requestHeaders =+                [ ("HTTPS", "off")+                , ("HTTP_X_FORWARDED_SSL", "off")+                , ("HTTP_X_FORWARDED_SCHEME", "http")+                , ("HTTP_X_FORWARDED_PROTO", "http,xyz")+                ]+            }++    it "returns False for an insecure request" $+        insecureRequest `shouldSatisfy` not . appearsSecure++    it "checks if the Request is actually secure" $ do+        let req = insecureRequest { isSecure = True }++        req `shouldSatisfy` appearsSecure++    it "checks for HTTP: on" $ do+        let req = addHeader "HTTPS" "on" insecureRequest++        req `shouldSatisfy` appearsSecure++    it "checks for HTTP_X_FORWARDED_SSL: on" $ do+        let req = addHeader "HTTP_X_FORWARDED_SSL" "on" insecureRequest++        req `shouldSatisfy` appearsSecure++    it "checks for HTTP_X_FORWARDED_SCHEME: https" $ do+        let req = addHeader "HTTP_X_FORWARDED_SCHEME" "https" insecureRequest++        req `shouldSatisfy` appearsSecure++    it "checks for HTTP_X_FORWARDED_PROTO: https,..." $ do+        let req = addHeader "HTTP_X_FORWARDED_PROTO" "https,xyz" insecureRequest++        req `shouldSatisfy` appearsSecure++addHeader :: HeaderName -> ByteString -> Request -> Request+addHeader name value req = req+    { requestHeaders = (name, value) : otherHeaders }++  where+    otherHeaders = filter ((/= name) . fst) $ requestHeaders req

@@ -1,5 +1,5 @@ Name:                wai-extra-Version:             3.0.6.1+Version:             3.0.7 Synopsis:            Provides some basic WAI handlers and middleware. description:   Provides basic WAI handler and middleware functionality:@@ -109,6 +109,7 @@                    , streaming-commons                    , unix-compat                    , cookie+                   , vault    if os(windows)       cpp-options:   -DWINDOWS@@ -119,6 +120,7 @@                      Network.Wai.Handler.SCGI                      Network.Wai.Middleware.AcceptOverride                      Network.Wai.Middleware.AddHeaders+                     Network.Wai.Middleware.Approot                      Network.Wai.Middleware.Autohead                      Network.Wai.Middleware.CleanPath                      Network.Wai.Middleware.Local@@ -131,7 +133,9 @@                      Network.Wai.Middleware.Vhost                      Network.Wai.Middleware.HttpAuth                      Network.Wai.Middleware.StreamFile+                     Network.Wai.Middleware.ForceSSL                      Network.Wai.Parse+                     Network.Wai.Request                      Network.Wai.UrlMap                      Network.Wai.Test                      Network.Wai.EventSource@@ -145,6 +149,9 @@     main-is:         Spec.hs     other-modules:   Network.Wai.TestSpec                      Network.Wai.ParseSpec+                     Network.Wai.RequestSpec+                     Network.Wai.Middleware.ApprootSpec+                     Network.Wai.Middleware.ForceSSLSpec                      WaiExtraSpec     build-depends:   base                      >= 4        && < 5                    , wai-extra