wai-enforce-https (empty) → 0.0.1
raw patch · 11 files changed
+819/−0 lines, 11 filesdep +basedep +bytestringdep +case-insensitivesetup-changed
Dependencies added: base, bytestring, case-insensitive, hspec, http-types, network, text, wai, wai-enforce-https, wai-extra, warp, warp-tls
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Network/HTTP/Forwarded.hs +119/−0
- Network/Wai/Middleware/EnforceHTTPS.hs +239/−0
- Setup.hs +2/−0
- examples/Proxy.hs +19/−0
- examples/TLSApp.hs +29/−0
- test/EnforceHTTPSSpec.hs +234/−0
- test/ForwardedSpec.hs +66/−0
- test/Spec.hs +1/−0
- wai-enforce-https.cabal +75/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for wai-enforce-https++## 0.0.1 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Marek Fajkus++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Marek Fajkus nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/HTTP/Forwarded.hs view
@@ -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
+ Network/Wai/Middleware/EnforceHTTPS.hs view
@@ -0,0 +1,239 @@+{-# 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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Proxy.hs view
@@ -0,0 +1,19 @@+{-# 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
+ examples/TLSApp.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Concurrent (forkIO)+import Network.HTTP.Types (status200)+import Network.Wai (Application, responseLBS)+import Network.Wai.Handler.Warp (defaultSettings, run,+ setPort)+import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)+import Network.Wai.Middleware.EnforceHTTPS (EnforceHTTPSConfig (..))++import qualified Network.Wai.Middleware.EnforceHTTPS as EnforceHTTPS++handler :: Application+handler _ respond =+ respond $ responseLBS status200 [] "Hello over HTTPS"++httpsConf :: EnforceHTTPSConfig+httpsConf = EnforceHTTPS.defaultConfig { httpsPort = 8443 }++app :: Application+app = EnforceHTTPS.withConfig httpsConf handler++main :: IO ()+main = do+ let tls = tlsSettings "examples/cert.pem" "examples/key.pem"+ _ <- forkIO $ run 8080 app+ runTLS tls (setPort (httpsPort httpsConf) defaultSettings) app
+ test/EnforceHTTPSSpec.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE OverloadedStrings #-}++module EnforceHTTPSSpec where++import Network.HTTP.Types+import Network.Wai+import Network.Wai.Middleware.EnforceHTTPS+import Network.Wai.Test+import Test.Hspec+++app :: EnforceHTTPSConfig -> Application+app conf = withConfig conf $+ -- reference to: https://en.wikipedia.org/wiki/Zork+ \_ respond -> respond $ responseLBS status200 [] "Hello, sailor"+++run :: EnforceHTTPSConfig -> Session a -> IO a+run = flip runSession . app+++baseReq :: Request+baseReq =+ defaultRequest { requestHeaderHost = Just "haskell.org" }+++spec :: Spec+spec = do+ describe "Default settings" defaultSettingsSpec+ describe "`httpsHostname` setting" hostnameSpec+ describe "`httpsPort` setting" portSpec+ describe "`httpsIgnoreURL` setting" ignoreURLSpec+ describe "`httpsTemporary` setting" temporarySpec+ describe "`skipDefaultPort` setting" skipDefaultPortSpec+ describe "`httsRedirectMethods` setting" redirectMethodsSpec+ describe "`httpsDisallowStatus` settings" disallowStatusSpec+ describe "resolvers" resolversSpec+++defaultSettingsSpec :: Spec+defaultSettingsSpec = do+ let withApp = run defaultConfig++ it "retuns 301 redirect on GET" $ withApp $ do+ res <- request $ baseReq+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org" res++ it "retuns 301 redirect on HEAD" $ withApp $ do+ res <- request $ baseReq { requestMethod = "HEAD" }+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org" res++ it "retuns 405 disallow on POST" $ withApp $ do+ res <- request $ baseReq { requestMethod = "POST" }+ assertStatus 405 res+ assertNoHeader "Location" res+ assertHeader "Allow" "GET, HEAD" res++ it "should not redirect secure request" $ withApp $ do+ res <- request $ baseReq { isSecure = True }+ assertStatus 200 res+ assertNoHeader "Location" res+ assertBody "Hello, sailor" res++ it "includes url path and params to redirect" $ withApp $ do+ res <- request $ baseReq { rawPathInfo = "/foo", rawQueryString = "?bar=baz" }+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org/foo?bar=baz" res++ it "request without `Host` header fails with 400 (Bad Request)" $ withApp $ do+ res <- request defaultRequest+ assertStatus 400 res+++hostnameSpec :: Spec+hostnameSpec = do+ let withApp = run $ defaultConfig { httpsHostname = Just "foo.com" }++ it "redirects to specified hostname" $ withApp $ do+ res <- request baseReq+ assertStatus 301 res+ assertHeader "Location" "https://foo.com" res++ it "redirects with path and params" $ withApp $ do+ res <- request $ baseReq { rawPathInfo = "/foo", rawQueryString = "?bar=baz" }+ assertStatus 301 res+ assertHeader "Location" "https://foo.com/foo?bar=baz" res+++portSpec :: Spec+portSpec = do+ let withApp = run $ defaultConfig { httpsPort = 8443 }++ it "redirects to specified port" $ withApp $ do+ res <- request baseReq+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org:8443" res++ it "redirects with path and params" $ withApp $ do+ res <- request $ baseReq { rawPathInfo = "/foo", rawQueryString = "?bar=baz" }+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org:8443/foo?bar=baz" res++ it "removes doesn't stack ports" $ withApp $ do+ res <- request $ baseReq { requestHeaderHost = Just "localhost:8080" }+ assertStatus 301 res+ assertHeader "Location" "https://localhost:8443" res+++ignoreURLSpec :: Spec+ignoreURLSpec =+ let withApp = run $ defaultConfig { httpsIgnoreURL = True }+ in+ it "redirect without path" $ withApp $ do+ res <- request $ baseReq { rawPathInfo = "/foo", rawQueryString = "?bar=baz" }+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org" res+++temporarySpec :: Spec+temporarySpec =+ let withApp = run $ defaultConfig { httpsTemporary = True }+ in+ it "redirect without path" $ withApp $ do+ res <- request baseReq+ assertStatus 307 res+++skipDefaultPortSpec :: Spec+skipDefaultPortSpec =+ let withApp = run $ defaultConfig { httpsSkipDefaultPort = False }+ in+ it "redirect without path" $ withApp $ do+ res <- request baseReq+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org:443" res+++redirectMethodsSpec :: Spec+redirectMethodsSpec = do+ let withApp = run $ defaultConfig { httpsRedirectMethods = [ "TRACE" ] }++ it "default settings for GET is overwritten" $ withApp $ do+ res <- request baseReq+ assertStatus 405 res++ it "specified methods is redirected" $ withApp $ do+ res <- request $ baseReq { requestMethod = "TRACE" }+ assertStatus 301 res+++disallowStatusSpec :: Spec+disallowStatusSpec =+ let withApp = run $ defaultConfig { httpsDisallowStatus = status403 }+ in+ it "returns specified status for disallowed method" $ withApp $ do+ res <- request $ baseReq { requestMethod = "POST" }+ assertStatus 403 res+ assertNoHeader "Allow" res+++resolversSpec :: Spec+resolversSpec = do+ describe "x-forwarded-proto resolver" $ do+ let withApp = run $ defaultConfig { httpsIsSecure = xForwardedProto }++ it "retuns 301 redirect on GET without header" $ withApp $ do+ res <- request $ baseReq+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org" res++ it "retuns 301 redirect on GET if header value is http" $ withApp $ do+ res <- request $ baseReq { requestHeaders = [("x-forwarded-proto", "http")]}+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org" res++ it "returns 200 if header value is https" $ withApp $ do+ res <- request $ baseReq { requestHeaders = [("x-forwarded-proto", "https")]}+ assertStatus 200 res+ assertNoHeader "Location" res+ assertBody "Hello, sailor" res++ describe "azure's x-arr-ssl header" $ do+ let withApp = run $ defaultConfig { httpsIsSecure = azure }++ it "retuns 301 redirect on GET without header" $ withApp $ do+ res <- request $ baseReq+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org" res++ it "returns 200 if header is present" $ withApp $ do+ res <- request $ baseReq { requestHeaders = [("x-arr-ssl", "")]}+ assertStatus 200 res+ assertNoHeader "Location" res+ assertBody "Hello, sailor" res++ describe "custom proto header resolver" $ do+ let withApp = run $ defaultConfig { httpsIsSecure = customProtoHeader("x-proto") }++ it "retuns 301 redirect on GET without header" $ withApp $ do+ res <- request $ baseReq+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org" res++ it "retuns 301 redirect on GET if header value is http" $ withApp $ do+ res <- request $ baseReq { requestHeaders = [("x-proto", "http")]}+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org" res++ it "returns 200 if header value is https" $ withApp $ do+ res <- request $ baseReq { requestHeaders = [("x-proto", "https")]}+ assertStatus 200 res+ assertNoHeader "Location" res+ assertBody "Hello, sailor" res++ describe "forwarded header" $ do+ let withApp = run $ defaultConfig { httpsIsSecure = forwarded }++ it "retuns 301 redirect on GET without header" $ withApp $ do+ res <- request $ baseReq+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org" res++ it "retuns 301 redirect on GET if header value is http" $ withApp $ do+ res <- request $ baseReq { requestHeaders = [("forwarded", "proto=http")]}+ assertStatus 301 res+ assertHeader "Location" "https://haskell.org" res++ it "returns 200 if header value is https" $ withApp $ do+ res <- request $ baseReq { requestHeaders = [("forwarded", "proto=https")]}+ assertStatus 200 res+ assertNoHeader "Location" res+ assertBody "Hello, sailor" res
+ test/ForwardedSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++module ForwardedSpec where++import Data.ByteString (ByteString)+import Test.Hspec++import qualified Data.CaseInsensitive as CI+import qualified Network.HTTP.Forwarded as F+++valIs :: Maybe ByteString -> ByteString -> Expectation+valIs a b = shouldBe a (Just b)+++valIsInsensitive :: Maybe (CI.CI ByteString) -> ByteString -> Expectation+valIsInsensitive a b = shouldBe a (Just $ CI.mk b)+++spec :: Spec+spec = do+ describe "parsing" $ do+ context "full header" $ do+ let val = "by=foo; for=bar; host=haskell.org; proto=https"+ let parsed = F.parseForwarded val++ it "parses" $ do+ F.forwardedBy parsed `valIs` "foo"+ F.forwardedFor parsed `valIs` "bar"+ F.forwardedHost parsed `valIs` "haskell.org"+ F.forwardedProto parsed `valIsInsensitive` "https"++ it "should encode" $ do+ F.serializeForwarded parsed `shouldBe` val++ it "parses even without spaces" $ do+ let p = F.parseForwarded "by=foo;for=bar;host=haskell.org;proto=https"+ F.forwardedBy p `valIs` "foo"+ F.forwardedFor p `valIs` "bar"+ F.forwardedHost p `valIs` "haskell.org"+ F.forwardedProto p `valIsInsensitive` "https"+++ context "only proto part" $ do+ let val = "proto=http"+ let parsed = F.parseForwarded val++ it "parses" $ do+ F.forwardedBy parsed `shouldBe` Nothing+ F.forwardedFor parsed `shouldBe` Nothing+ F.forwardedHost parsed `shouldBe` Nothing+ F.forwardedProto parsed `valIsInsensitive` "http"++ it "should serialize" $ do+ F.serializeForwarded parsed `shouldBe` val++ describe "properties" $ do+ it "proto part is case insensitive" $ do+ let val = "proto=HTTP"+ let parsed = F.parseForwarded val+ F.forwardedProto parsed `shouldBe` (Just "http")++ it "for part is case sensitive" $ do+ let val = "by=FOO"+ let parsed = F.parseForwarded val+ F.forwardedBy parsed `shouldNotBe` (Just "foo")
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ wai-enforce-https.cabal view
@@ -0,0 +1,75 @@+-- Initial wai-enforce-https.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: wai-enforce-https+version: 0.0.1+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+license-file: LICENSE+author: Marek Fajkus+maintainer: marek.faj@gmail.com+-- copyright:+category: Web+build-type: Simple+extra-source-files: CHANGELOG.md+cabal-version: >=1.10+homepage: https://github.com/turboMaCk/wai-enforce-https++library+ exposed-modules: Network.Wai.Middleware.EnforceHTTPS+ , Network.HTTP.Forwarded+ -- other-modules:+ -- other-extensions:+ build-depends: base >= 4 && < 5+ , wai+ , network+ , http-types+ , bytestring+ , text+ , case-insensitive+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: EnforceHTTPSSpec+ , ForwardedSpec+ build-depends: base+ , hspec+ , wai-enforce-https+ , wai+ , wai-extra+ , http-types+ , bytestring+ , case-insensitive+ ghc-options: -Wall+ default-language: Haskell2010++executable example-tls+ hs-source-dirs: examples+ main-is: TLSApp.hs+ build-depends: base+ , wai-enforce-https+ , wai+ , warp+ , warp-tls+ , http-types+ ghc-options: -Wall+ default-language: Haskell2010++executable example-proxy+ hs-source-dirs: examples+ main-is: Proxy.hs+ build-depends: base+ , wai-enforce-https+ , wai+ , warp+ , http-types+ ghc-options: -Wall+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/turboMaCk/wai-enforce-https.git