diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Network/Wai/Middleware/Approot.hs b/Network/Wai/Middleware/Approot.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/Approot.hs @@ -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 diff --git a/Network/Wai/Middleware/ForceSSL.hs b/Network/Wai/Middleware/ForceSSL.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/ForceSSL.hs @@ -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 diff --git a/Network/Wai/Request.hs b/Network/Wai/Request.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Request.hs @@ -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) diff --git a/Network/Wai/Test.hs b/Network/Wai/Test.hs --- a/Network/Wai/Test.hs +++ b/Network/Wai/Test.hs @@ -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) diff --git a/test/Network/Wai/Middleware/ApprootSpec.hs b/test/Network/Wai/Middleware/ApprootSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/ApprootSpec.hs @@ -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)] "" diff --git a/test/Network/Wai/Middleware/ForceSSLSpec.hs b/test/Network/Wai/Middleware/ForceSSLSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/ForceSSLSpec.hs @@ -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 [] "" diff --git a/test/Network/Wai/RequestSpec.hs b/test/Network/Wai/RequestSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/RequestSpec.hs @@ -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 diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -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