diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for wai-enforce-https -## 0.0.1 -- YYYY-mm-dd +## 0.0.2 -- 2020-03-01 + +* Make Config record field strict +* Add INLINE directive to some functions +* Improve documentation + +## 0.0.1 -- 2019-01-19 * First version. Released on an unsuspecting world. diff --git a/Network/HTTP/Forwarded.hs b/Network/HTTP/Forwarded.hs deleted file mode 100644 --- a/Network/HTTP/Forwarded.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | --- Module : Network.Wai.Middleware.EnforceHTTPS --- Copyright : (c) Marek Fajkus --- License : BSD3 --- --- Maintainer : marek.faj@gmail.com --- --- Parsing and Serialization of [Forwarded](https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Forwarded) --- HTTP header values. - -module Network.HTTP.Forwarded - ( Forwarded(..) - , parseForwarded - , serializeForwarded - ) where - -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import Data.Maybe (catMaybes) -import Data.Monoid ((<>)) -import Data.Word (Word8) - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>)) -#endif - -import qualified Data.ByteString as ByteString -import qualified Data.CaseInsensitive as CaseInsensitive -import qualified Data.Char as Char - - --- | Representation of Forwarded header data --- All field are optional -data Forwarded = Forwarded - { forwardedBy :: Maybe ByteString - , forwardedFor :: Maybe ByteString - , forwardedHost :: Maybe ByteString - , forwardedProto :: Maybe (CI ByteString) - } deriving (Eq, Show) - - -empty :: Forwarded -empty = Forwarded - { forwardedBy = Nothing - , forwardedFor = Nothing - , forwardedHost = Nothing - , forwardedProto = Nothing - } - - --- | Parse @ByteString@ to Forwarded header --- Note that this function works with the values --- of the header only. Extraction of value --- from header depends what representation of headers --- you're using. --- --- In case of Wai you can extract headers as following: --- --- > :set -XOverloadedStrings --- > import Network.Wai --- > import Network.HTTP.Forwarded --- > getForwarded req = parseForwarded <$> "forwarded" `lookup` requestHeaders req --- > :t getForwarded --- > getForwarded :: Request -> Maybe Forwarded -parseForwarded :: ByteString -> Forwarded -parseForwarded = foldr accumulate empty . parseForwarded' - where - accumulate (key, val) acc = - case key of - "by" -> acc { forwardedBy = Just val } - "for" -> acc { forwardedFor = Just val } - "host" -> acc { forwardedHost = Just val } - "proto" -> acc { forwardedProto = Just $ CaseInsensitive.mk val } - _ -> acc - - -parseForwarded' :: ByteString -> [ (ByteString, ByteString) ] -parseForwarded' s - | ByteString.null s = [] - | otherwise = - let (x, y) = breakDiscard 59 s -- semicolon - in parsePart x : parseForwarded' y - - -parsePart :: ByteString -> (ByteString, ByteString) -parsePart s = (key', value) - where - (key, value) = - breakDiscard 61 s -- equals sign - key' = - ByteString.dropWhile (== 32) key -- space - - -breakDiscard :: Word8 -> ByteString -> (ByteString, ByteString) -breakDiscard w s = (x, ByteString.drop 1 y) - where - (x, y) = - ByteString.break (== w) s - - --- | Serialize `Forwarded` data type back --- to ByteString representation. -serializeForwarded :: Forwarded -> ByteString -serializeForwarded Forwarded { .. } = - ByteString.intercalate "; " $ catMaybes xs - where - xs = - [ strVal "by" forwardedBy - , strVal "for" forwardedFor - , strVal "host" forwardedHost - , strVal "proto" $ CaseInsensitive.original <$> forwardedProto - ] - - strVal _ Nothing = Nothing - strVal key (Just val) = Just $ key <> "=" <> val diff --git a/Network/Wai/Middleware/EnforceHTTPS.hs b/Network/Wai/Middleware/EnforceHTTPS.hs deleted file mode 100644 --- a/Network/Wai/Middleware/EnforceHTTPS.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | --- Module : Network.Wai.Middleware.EnforceHTTPS --- Copyright : (c) Marek Fajkus --- License : BSD3 --- --- Maintainer : marek.faj@gmail.com --- --- Wai Middleware for enforcing encrypted HTTPS connection safely. --- --- This module is intended to be imported @qualified@ --- --- > import qualified Network.Wai.Middleware.EnforceHTTPS as EnforceHTTPS - -module Network.Wai.Middleware.EnforceHTTPS - ( def - , withResolver - , xForwardedProto - , azure - , forwarded - , customProtoHeader - , EnforceHTTPSConfig(..) - , defaultConfig - , withConfig - ) where - -import Data.ByteString (ByteString) -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Network.HTTP.Types (Method, Status) -import Network.Wai (Application, Middleware, Request) - -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mempty, mappend) -#endif - -import qualified Data.ByteString as ByteString -import qualified Data.CaseInsensitive as CaseInsensitive -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Network.HTTP.Forwarded as Forwarded -import qualified Network.HTTP.Types as HTTP -import qualified Network.Wai as Wai - - --- | === Configuration --- --- `EnforceHTTPSConfig` does export constructor --- which should not collide with ny other functions --- and therefore can be exposed in import --- --- > import Network.Wai.Middleware.EnforceHTTPS (EnforceHTTPSConfig(..)) --- --- __Default configuration is recommended__ but you're free --- to override any default value if you need to. --- --- Configuration of `httpsIsSecure` can be set using `withResolver` --- function which is preferred way for overwriting default `Resolver` . -data EnforceHTTPSConfig = EnforceHTTPSConfig - { httpsIsSecure :: HTTPSResolver - , httpsHostname :: Maybe ByteString - , httpsPort :: Int - , httpsIgnoreURL :: Bool - , httpsTemporary :: Bool - , httpsSkipDefaultPort :: Bool - , httpsRedirectMethods :: [ Method ] - , httpsDisallowStatus :: Status - } - - --- | Default Configuration --- Default resolver is proxy to @Network.Wai.isSecure@ function --- --- * uses request @Host@ header information to resolve hostname --- * standard HTTPS port @443@ --- * redirect includes path and url params --- * uses permanent redirect (@301@) --- * doesn't include @port@ in @Location@ header id port is @443@ --- * redirects @GET@ and @HEAD@ methods --- * all /other/ methods are resolved with @405@ (Method not Allowed) and with appropriate @Allowed@ header -defaultConfig :: EnforceHTTPSConfig -defaultConfig = EnforceHTTPSConfig - { httpsIsSecure = Wai.isSecure - , httpsHostname = Nothing - , httpsPort = 443 - , httpsIgnoreURL = False - , httpsTemporary = False - , httpsSkipDefaultPort = True - , httpsRedirectMethods = [ "GET", "HEAD" ] - , httpsDisallowStatus = HTTP.methodNotAllowed405 - } - - --- | Construct `Middleware` for specific `EnforceHTTPSConfig` -withConfig :: EnforceHTTPSConfig -> Middleware -withConfig conf@EnforceHTTPSConfig { .. } app req - | httpsIsSecure req = app req - | otherwise = redirect conf req - - -redirect :: EnforceHTTPSConfig -> Application -redirect EnforceHTTPSConfig { .. } req respond = respond $ - case Wai.requestHeaderHost req of - -- A Host header field must be sent in all HTTP/1.1 request messages. - -- A 400 (Bad Request) status code will be sent to any HTTP/1.1 request message - -- that lacks a Host header field or contains more than one. - -- source: https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Host - Nothing -> Wai.responseBuilder HTTP.status400 [] mempty - Just h -> Wai.responseBuilder status (headers $ stripPort h) mempty - - where - ( status, headers ) = - if reqMethod `elem` httpsRedirectMethods then - ( if httpsTemporary then - HTTP.status307 - else - HTTP.status301 - , return . redirectURL - ) - - else - ( httpsDisallowStatus - , const $ - if httpsDisallowStatus == HTTP.methodNotAllowed405 then - [ ("Allow", ByteString.intercalate ", " httpsRedirectMethods) ] - else - [] - ) - - redirectURL h = - ( HTTP.hLocation, "https://" <> fullHost h <> path) - - path = - if httpsIgnoreURL then - mempty - else - Wai.rawPathInfo req <> Wai.rawQueryString req - - port = - if httpsPort == 443 && httpsSkipDefaultPort then - "" - else - Text.encodeUtf8 $ (mappend ":") $ Text.pack $ show httpsPort - - stripPort h = - fst $ ByteString.break (== 58) h -- colon - - fullHost h = fromMaybe h httpsHostname <> port - reqMethod = Wai.requestMethod req - - --- | `Middleware` with /default/ configuration. --- See `defaultConfig` for more details. -def :: Middleware -def = - withConfig defaultConfig - - --- | Construct middleware with provided `Resolver` --- See `Resolver` section for information. -withResolver :: HTTPSResolver -> Middleware -withResolver resolver = - withConfig $ defaultConfig { httpsIsSecure = resolver } - - --- | === RESOLVERS --- --- Resolvers are function used for testing --- if Request is made over secure HTTPS protocol. --- --- if `True` is returned from `Resolver` function --- request is considered as being secure. --- For `False` values redirection logic is called. -type HTTPSResolver = - Request -> Bool - - --- | Resolver checking value of @x-forwarded-proto@ HTTP header. --- This header is for instance used by Heroku or GCP Ingress --- among many others. --- --- Request is secure if value of header is `https` --- otherwise request is considered not being secure. -xForwardedProto :: HTTPSResolver -xForwardedProto req = - maybe False (== "https") maybeHederVal - where - maybeHederVal = - "x-forwarded-proto" `lookup` Wai.requestHeaders req - - --- | Azure is proxying with additional --- `x-arr-ssl` header if original protocol is HTTPS. --- This resolver checks for the presence of this header. -azure :: HTTPSResolver -azure req = - maybe False (const True) maybeHeader - where - maybeHeader = - "x-arr-ssl" `lookup` Wai.requestHeaders req - - --- | Some reverse proxies (Kong) are using --- values similar to @x-forwarded-proto@ --- but are using different headers. --- This resolver allows you to specify name of header --- which should be used for the check. --- Like `xForwardedProto`, request is considered --- as being secure if value of header is @https@. -customProtoHeader :: ByteString -> HTTPSResolver -customProtoHeader header req = - maybe False (== "https") maybeHederVal - where - maybeHederVal = - CaseInsensitive.mk header `lookup` Wai.requestHeaders req - - --- | Forwarded HTTP header is relatively new standard --- which should replaced all @x-*@ adhoc headers by --- standardized one. --- This resolver is using @proto=foo@ part of the header --- and check for equality with @https@ value. --- --- More information can be found on [MDN](https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Forwarded) --- Complete implementation of @Forwarded@ is located in --- @Network.HTTP.Forwarded@ module -forwarded :: HTTPSResolver -forwarded req = - maybe False check maybeHeader - where - check val = - maybe False (== "https") $ - Forwarded.forwardedProto $ Forwarded.parseForwarded val - - maybeHeader = - "forwarded" `lookup` Wai.requestHeaders req diff --git a/examples/cert.pem b/examples/cert.pem new file mode 100644 --- /dev/null +++ b/examples/cert.pem @@ -0,0 +1,21 @@ +-----BEGIN CERTIFICATE----- +MIIDXTCCAkWgAwIBAgIJAKX446gRqkVkMA0GCSqGSIb3DQEBCwUAMEUxCzAJBgNV +BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX +aWRnaXRzIFB0eSBMdGQwHhcNMTkwMTA5MjI0OTE0WhcNMjAwMTA5MjI0OTE0WjBF +MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50 +ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIB +CgKCAQEA3nQFkTV5MbOjmJRRlUTlR4nSQgYP7q8X0bqF4rwhfRq+0WCnlYrzZc/g +Uxr1AzHRRWbEeGxLWx0l+ASMe1g6RAAuxH39lk7cvBfT6TNs5UMyzolb6YQf8Pa9 +RvXHIpz+c7uXGqqK3XFl3JgA3H9YwOtgP4UKuyDTPznJjfp5ezBP9vEuLrvB+odr +oQdgqWemr3Vn/+SiLEbjQQLfQasAgrZW5rNLBj+j2JnnSO1+XVktx2tSJq5gxoGf +MxQhCUPd9N7HxptYERYcw73qeD3PApZyKA7FFoVIfBpkbAfGDbzfKi8c70qHReyX +I4zHJPYpTOJQMCAByTrDuYBzHJihwwIDAQABo1AwTjAdBgNVHQ4EFgQUsNM4DJsF +M9GkukizijgK92GAvqgwHwYDVR0jBBgwFoAUsNM4DJsFM9GkukizijgK92GAvqgw +DAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAQEAtwrIYpD6eio74vccRpvu +0aTWf3ZG3Wauf8XV3/7rUa7f1l34cn9wCynb+3JzIM9AY23Ctaop0FHNgUkzyOYF +NjckgMPEhx353tA91XYUPnIKaKrI3o45Qju86g7Y+MrYcZ1+WSqM+lF8n8qutnMI +O26GBy9BufXo/6mhjXZ0bK8U7W8zvp3xaCejdzEMuZVIIk1gV/2X/qrLD29XS9cB +N5I01Ot9CxjrAQxjs+w6xqkBN8zLmjiDmryNedeCxQBw9BgR+35c07RTQETRbPdj +7Nc97HFkt//dtDM5/OtaDI4f6YbElVSDsdBpht2XhJ7woYDKPhYc6EUCJn0fjIUk +BQ== +-----END CERTIFICATE----- diff --git a/examples/key.pem b/examples/key.pem new file mode 100644 --- /dev/null +++ b/examples/key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQDedAWRNXkxs6OY +lFGVROVHidJCBg/urxfRuoXivCF9Gr7RYKeVivNlz+BTGvUDMdFFZsR4bEtbHSX4 +BIx7WDpEAC7Eff2WTty8F9PpM2zlQzLOiVvphB/w9r1G9ccinP5zu5caqordcWXc +mADcf1jA62A/hQq7INM/OcmN+nl7ME/28S4uu8H6h2uhB2CpZ6avdWf/5KIsRuNB +At9BqwCCtlbms0sGP6PYmedI7X5dWS3Ha1ImrmDGgZ8zFCEJQ9303sfGm1gRFhzD +vep4Pc8ClnIoDsUWhUh8GmRsB8YNvN8qLxzvSodF7JcjjMck9ilM4lAwIAHJOsO5 +gHMcmKHDAgMBAAECggEAc/FozWxfhIYqqGX1t6U3E3hD/GGIgFEGSyu6iJiho8EC +38JO1mSbw976/pW4Sjf26QNNN67J/+1LUt+cENXFWJf3yDYaq/Lina6VpqBFC6Fg +o8F4BFf3BfK0aH3Fksbc4JlPgniM9Coce0NGf6ZoLfUAL1s6YpoTQIrwAG4iTw/A +I828Dh5Qf1ltZoEV3QM6a2eBdeBk50OAgdV4Y0h4hfjgdi6LvIzWP20o2lSd0fDh +kqO4NUXBd7geeKFPbAy+cqgplSmby/EWgtiKUdkhltHZ9+MW9feB5fwchdROtN9v +WdRxWrfbwGJedq07mNH1mkCcIyMx6CEb6QPS3MRdsQKBgQD7d/vj92c6a1yBzKkm +Jvt4Tle1RNsXoxHS9jkqVwj9cBbbpNsW5Mesg8kshIFM0MOeVXGbi9PuJr7j5kfp +57UCtyLLPYw2B9dirrk8iShWOBOXb5QCTLGgxUiPtjOPJDzNtdYEjxXRz/jHl565 +nbjncCZqzOjbA0l2drqEQroOrwKBgQDidjDAxD2Xa5lRZ7zpkTVuFB4BpzkBiZvk +G+q9vVBtauYP7USiyZzg4/s4xSGPtPmKrqgqdrb2fNqfeXeSNcb1BuoTjH9o3QFf +cW8A/GnR8m52lHe2NF3ELrAd0BlH03cSsGlCeL/Cg7YnZ7+RwyeBPB+Z38AdWZ+M +8umytcgDLQKBgBqxwPaRM88ayIYq4KXhK3646kye05ctw12er7DT7mtg87w7Qtqq +TJv+nWNxaXxrCOkM7vNxI307dbYhou6snyV7pWDn1rOBn5alL5rCgJqudz3zJUYd +OBn1917yG4UNdrrrm51+RvWv2xvs93eCy7cdy6Y4vFtLfQfrUJ9rqe6XAoGBANHw +5/mM89xwb8478bJGX9YQ6FB4Ci0WuWKbTt9fpjQJqgaR29NePQVv1PIoLpjfGYgr +qtLTA4M29CZroSH2oN9+7Xn6AhPg7ujgbBvp5OAxc56SvPg5S8QX1EWPKiCgNf8p +dCufbYaSPEgDsmEbHoB8kH9CIwQSlgtBFs4KH8ZxAoGBAM5cSypHMyKXn5Lkwe62 +PuX4nvV8g6+iUUhmNPMOYF+lL5xJlkbPeS2EtRc1Wf38+msBJSbpSyslC5X2jB5M +QzjteJ2x/6bxif2Wwe3XXNjmk5emswhIuBWhorP38DaitXxkP5ewOLElHbq2nZX2 +eUCMNqzpok7OOoi9n2NNT+wa +-----END PRIVATE KEY----- diff --git a/lib/Network/HTTP/Forwarded.hs b/lib/Network/HTTP/Forwarded.hs new file mode 100644 --- /dev/null +++ b/lib/Network/HTTP/Forwarded.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Network.Wai.Middleware.EnforceHTTPS +-- Copyright : (c) Marek Fajkus +-- License : BSD3 +-- +-- Maintainer : marek.faj@gmail.com +-- +-- Parsing and Serialization of [Forwarded](https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Forwarded) +-- HTTP header values. + +module Network.HTTP.Forwarded + ( Forwarded(..) + , parseForwarded + , serializeForwarded + ) where + +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) +import Data.Word (Word8) + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif + +import qualified Data.ByteString as ByteString +import qualified Data.CaseInsensitive as CaseInsensitive +import qualified Data.Char as Char + + +-- | Representation of Forwarded header data +-- All field are optional +data Forwarded = Forwarded + { forwardedBy :: Maybe ByteString + , forwardedFor :: Maybe ByteString + , forwardedHost :: Maybe ByteString + , forwardedProto :: Maybe (CI ByteString) + } deriving (Eq, Show) + + +empty :: Forwarded +empty = Forwarded + { forwardedBy = Nothing + , forwardedFor = Nothing + , forwardedHost = Nothing + , forwardedProto = Nothing + } + + +-- | Parse @ByteString@ to Forwarded header +-- Note that this function works with the values +-- of the header only. Extraction of value +-- from header depends what representation of headers +-- you're using. +-- +-- In case of Wai you can extract headers as following: +-- +-- > :set -XOverloadedStrings +-- > import Network.Wai +-- > import Network.HTTP.Forwarded +-- > getForwarded req = parseForwarded <$> "forwarded" `lookup` requestHeaders req +-- > :t getForwarded +-- > getForwarded :: Request -> Maybe Forwarded +parseForwarded :: ByteString -> Forwarded +parseForwarded = foldr accumulate empty . parseForwarded' + where + accumulate (key, val) acc = + case key of + "by" -> acc { forwardedBy = Just val } + "for" -> acc { forwardedFor = Just val } + "host" -> acc { forwardedHost = Just val } + "proto" -> acc { forwardedProto = Just $ CaseInsensitive.mk val } + _ -> acc + + +parseForwarded' :: ByteString -> [ (ByteString, ByteString) ] +parseForwarded' s + | ByteString.null s = [] + | otherwise = + let (x, y) = breakDiscard 59 s -- semicolon + in parsePart x : parseForwarded' y + + +parsePart :: ByteString -> (ByteString, ByteString) +parsePart s = (key', value) + where + (key, value) = + breakDiscard 61 s -- equals sign + key' = + ByteString.dropWhile (== 32) key -- space + + +breakDiscard :: Word8 -> ByteString -> (ByteString, ByteString) +breakDiscard w s = (x, ByteString.drop 1 y) + where + (x, y) = + ByteString.break (== w) s + + +-- | Serialize `Forwarded` data type back +-- to ByteString representation. +serializeForwarded :: Forwarded -> ByteString +serializeForwarded Forwarded { .. } = + ByteString.intercalate "; " $ catMaybes xs + where + xs = + [ strVal "by" forwardedBy + , strVal "for" forwardedFor + , strVal "host" forwardedHost + , strVal "proto" $ CaseInsensitive.original <$> forwardedProto + ] + + strVal _ Nothing = Nothing + strVal key (Just val) = Just $ key <> "=" <> val diff --git a/lib/Network/Wai/Middleware/EnforceHTTPS.hs b/lib/Network/Wai/Middleware/EnforceHTTPS.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Wai/Middleware/EnforceHTTPS.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Network.Wai.Middleware.EnforceHTTPS +-- Copyright : (c) Marek Fajkus +-- License : BSD3 +-- +-- Maintainer : marek.faj@gmail.com +-- +-- Wai Middleware for enforcing encrypted HTTPS connection safely. +-- +-- This module is intended to be imported @qualified@ +-- +-- > import qualified Network.Wai.Middleware.EnforceHTTPS as EnforceHTTPS +-- +-- = Example Usage +-- +-- Following is the most typical config. +-- That is GCP, AWS and Heroku compatible setting +-- using @x-forwarded-proto@ header check and default configuration. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main where +-- > +-- > import Network.HTTP.Types (status200) +-- > import Network.Wai (Application, responseLBS) +-- > import Network.Wai.Handler.Warp (runEnv) +-- > +-- > import qualified Network.Wai.Middleware.EnforceHTTPS as EnforceHTTPS +-- > +-- > handler :: Application +-- > handler _ respond = respond $ +-- > responseLBS status200 [] "Hello from behind proxy" +-- > +-- > app :: Application +-- > app = EnforceHTTPS.withResolver EnforceHTTPS.xForwardedProto handler +-- > +-- > main :: IO () +-- > main = runEnv 8080 app + +module Network.Wai.Middleware.EnforceHTTPS + ( + -- * Configuration and Initialization + EnforceHTTPSConfig(..) + , defaultConfig + , def + , withResolver + , withConfig + -- * Provided Resolvers + -- | This module provides most common implementation + -- of rrsolvers used by various cloud providers and + -- reverse proxy implemetations. + , HTTPSResolver + , xForwardedProto + , azure + , forwarded + , customProtoHeader + ) where + +import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Network.HTTP.Types (Method, Status) +import Network.Wai (Application, Middleware, Request) + +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid (mappend, mempty) +#endif + +import qualified Data.ByteString as ByteString +import qualified Data.CaseInsensitive as CaseInsensitive +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Network.HTTP.Forwarded as Forwarded +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai + + +-- | === Configuration +-- +-- `EnforceHTTPSConfig` does export constructor +-- which should not collide with any other functions +-- and therefore can be exposed in import +-- +-- > import Network.Wai.Middleware.EnforceHTTPS (EnforceHTTPSConfig(..)) +-- +-- __Default configuration is recommended__ but you're free +-- to override any default value if you need to. +-- +-- Configuration of `httpsIsSecure` can be set using `withResolver` +-- function which is preferred way for overwriting default `Resolver`. +data EnforceHTTPSConfig = EnforceHTTPSConfig + { httpsIsSecure :: !HTTPSResolver + , httpsHostname :: !(Maybe ByteString) + , httpsPort :: !Int + , httpsIgnoreURL :: !Bool + , httpsTemporary :: !Bool + , httpsSkipDefaultPort :: !Bool + , httpsRedirectMethods :: ![Method] + , httpsDisallowStatus :: !Status + } + + +-- | Default Configuration +-- Default resolver is proxy to 'Network.Wai.isSecure' function +-- +-- * uses request @Host@ header information to resolve hostname +-- * standard HTTPS port @443@ +-- * redirect includes path and url params +-- * uses permanent redirect (@301@) +-- * doesn't include @port@ in @Location@ header id port is @443@ +-- * redirects @GET@ and @HEAD@ methods +-- * all /other/ methods are resolved with @405@ (Method not Allowed) and with appropriate @Allowed@ header +defaultConfig :: EnforceHTTPSConfig +defaultConfig = EnforceHTTPSConfig + { httpsIsSecure = Wai.isSecure + , httpsHostname = Nothing + , httpsPort = 443 + , httpsIgnoreURL = False + , httpsTemporary = False + , httpsSkipDefaultPort = True + , httpsRedirectMethods = [ "GET", "HEAD" ] + , httpsDisallowStatus = HTTP.methodNotAllowed405 + } +{-# INLINE defaultConfig #-} + + +-- | Construct `Middleware` for specific `EnforceHTTPSConfig` +withConfig :: EnforceHTTPSConfig -> Middleware +withConfig conf@EnforceHTTPSConfig { .. } app req + | httpsIsSecure req = app req + | otherwise = redirect conf req +{-# INLINE withConfig #-} + + +redirect :: EnforceHTTPSConfig -> Application +redirect EnforceHTTPSConfig { .. } req respond = respond $ + case Wai.requestHeaderHost req of + -- A Host header field must be sent in all HTTP/1.1 request messages. + -- A 400 (Bad Request) status code will be sent to any HTTP/1.1 request message + -- that lacks a Host header field or contains more than one. + -- source: https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Host + Nothing -> Wai.responseBuilder HTTP.status400 [] mempty + Just h -> Wai.responseBuilder status (headers $ stripPort h) mempty + + where + ( status, headers ) = + if reqMethod `elem` httpsRedirectMethods then + ( if httpsTemporary then + HTTP.status307 + else + HTTP.status301 + , return . redirectURL + ) + + else + ( httpsDisallowStatus + , const $ + if httpsDisallowStatus == HTTP.methodNotAllowed405 then + [ ("Allow", ByteString.intercalate ", " httpsRedirectMethods) ] + else + [] + ) + + redirectURL h = + ( HTTP.hLocation, "https://" <> fullHost h <> path) + + path = + if httpsIgnoreURL then + mempty + else + Wai.rawPathInfo req <> Wai.rawQueryString req + + port = + if httpsPort == 443 && httpsSkipDefaultPort then + "" + else + Text.encodeUtf8 $ (mappend ":") $ Text.pack $ show httpsPort + + stripPort h = + fst $ ByteString.break (== 58) h -- colon + + fullHost h = fromMaybe h httpsHostname <> port + reqMethod = Wai.requestMethod req + + +-- | `Middleware` with /default/ configuration. +-- See 'defaultConfig' for more details. +def :: Middleware +def = + withConfig defaultConfig +{-# INLINE def #-} + + +-- | Construct middleware with provided `Resolver` +-- See `Provided Resolvers` section for more information. +withResolver :: HTTPSResolver -> Middleware +withResolver resolver = + withConfig $ defaultConfig { httpsIsSecure = resolver } +{-# INLINE withResolver #-} + + +-- | Resolvers are function used for testing +-- if Request is made over secure HTTPS protocol. +-- +-- if `True` is returned from a `Resolver` function, +-- request is considered to be secure. +-- In case of `False` value, redirect logic is called. +type HTTPSResolver = + Request -> Bool + + +-- | Resolver checking value of @x-forwarded-proto@ HTTP header. +-- This header is for instance used by Heroku or GCP Ingress +-- among many others. +-- +-- Request is secure if value of header is `https` +-- otherwise request is considered not being secure. +xForwardedProto :: HTTPSResolver +xForwardedProto req = + maybe False (== "https") maybeHederVal + where + maybeHederVal = + "x-forwarded-proto" `lookup` Wai.requestHeaders req +{-# INLINE xForwardedProto #-} + + +-- | Azure is proxying with additional +-- `x-arr-ssl` header if original protocol is HTTPS. +-- This resolver checks for the presence of this header. +azure :: HTTPSResolver +azure req = + maybe False (const True) maybeHeader + where + maybeHeader = + "x-arr-ssl" `lookup` Wai.requestHeaders req +{-# INLINE azure #-} + + +-- | Some reverse proxies (Kong) are using +-- values similar to @x-forwarded-proto@ +-- but are using different headers. +-- This resolver allows you to specify name of header +-- which should be used for the check. +-- Like `xForwardedProto`, request is considered +-- as being secure if value of header is @https@. +customProtoHeader :: ByteString -> HTTPSResolver +customProtoHeader header req = + maybe False (== "https") maybeHederVal + where + maybeHederVal = + CaseInsensitive.mk header `lookup` Wai.requestHeaders req +{-# INLINE customProtoHeader #-} + + +-- | Forwarded HTTP header is relatively new standard +-- which should replaced all @x-*@ adhoc headers by +-- standardized one. +-- This resolver is using @proto=foo@ part of the header +-- and check for equality with @https@ value. +-- +-- More information can be found on [MDN](https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Forwarded) +-- Complete implementation of @Forwarded@ is located in +-- @Network.HTTP.Forwarded@ module +forwarded :: HTTPSResolver +forwarded req = + maybe False check maybeHeader + where + check val = + maybe False (== "https") $ + Forwarded.forwardedProto $ Forwarded.parseForwarded val + + maybeHeader = + "forwarded" `lookup` Wai.requestHeaders req +{-# INLINE forwarded #-} diff --git a/wai-enforce-https.cabal b/wai-enforce-https.cabal --- a/wai-enforce-https.cabal +++ b/wai-enforce-https.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: wai-enforce-https -version: 0.0.1 +version: 0.0.2 synopsis: Enforce HTTPS in Wai server app safely. description: Wai middleware enforcing HTTPS protocol on any incoming request. In case of non-encrypted HTTP, traffic is redirected using 301 Permanent Redirect or optionally 307 Temporary Redirect. Middleware has compatibility modes for various reverse proxies (load balancers) and therefore can be used with Heroku, Google Cloud (Ingress), Azure or any other type of PAS or Cloud provider. license: BSD3 @@ -15,8 +15,21 @@ extra-source-files: CHANGELOG.md cabal-version: >=1.10 homepage: https://github.com/turboMaCk/wai-enforce-https +tested-with: GHC == 7.10.3 + , GHC == 7.8.4 + , GHC == 7.6.3 + , GHC == 8.4.4 + , GHC == 8.6.5 +data-files: examples/cert.pem + , examples/key.pem + +Flag examples + Description: Build example projects + Default: False + library + hs-source-dirs: lib exposed-modules: Network.Wai.Middleware.EnforceHTTPS , Network.HTTP.Forwarded -- other-modules: @@ -48,6 +61,10 @@ default-language: Haskell2010 executable example-tls + if flag(examples) + buildable: True + else + buildable: False hs-source-dirs: examples main-is: TLSApp.hs build-depends: base @@ -60,6 +77,10 @@ default-language: Haskell2010 executable example-proxy + if flag(examples) + buildable: True + else + buildable: False hs-source-dirs: examples main-is: Proxy.hs build-depends: base