module Network.Wai.Serve.Middleware
(
MiddlewareStack(..)
, (<#>)
, flatten
, wrap
, loggerMiddleware
, forceSSLMiddleware
, gzipMiddleware
, domainMiddleware
, securityHeadersMiddleware
, stsHeadersMiddleware
, cspHeadersMiddleware
, deindexifyMiddleware
) where
import Data.ByteString (ByteString)
import Data.Monoid ((<>))
import Prelude hiding (unwords)
import Data.Text (Text, intercalate,
unwords)
import qualified Data.Text as T (concat)
import Data.Text.Encoding (encodeUtf8)
import Network.Wai (Application, Middleware,
pathInfo)
import Network.Wai.Middleware.AddHeaders (addHeaders)
import Network.Wai.Middleware.ForceDomain (forceDomain)
import Network.Wai.Middleware.ForceSSL (forceSSL)
import Network.Wai.Middleware.Gzip (GzipFiles (GzipCompress),
def, gzip, gzipFiles)
import Network.Wai.Middleware.RequestLogger (logStdout)
import Network.Wai.Middleware.Vhost (redirectTo)
import Safe (lastMay)
import Network.Wai.Serve.Types
infixl 5 <#>
(<#>) :: MiddlewareStack -> Middleware -> MiddlewareStack
(<#>) (MiddlewareStack s) m = MiddlewareStack (s ++ [m])
flatten :: MiddlewareStack -> Middleware
flatten (MiddlewareStack s) = foldr (.) id s
wrap :: MiddlewareStack -> Application -> Application
wrap = flatten
dt :: Text -> [Text] -> Text
dt prefix [] = prefix
dt prefix xs = unwords (prefix : xs)
showDirective :: Directive -> Text
showDirective (BaseURI xs) = dt "base-uri" xs
showDirective (ChildSrc xs) = dt "child-src" xs
showDirective (ConnectSrc xs) = dt "connect-src" xs
showDirective (DefaultSrc xs) = dt "default-src" xs
showDirective (FontSrc xs) = dt "font-src" xs
showDirective (FormAction xs) = dt "form-action" xs
showDirective (FrameAncestors xs) = dt "frame-ancestors" xs
showDirective (FrameSrc xs) = dt "frame-src" xs
showDirective (ImgSrc xs) = dt "img-src" xs
showDirective (ManifestSrc xs) = dt "manifest-src" xs
showDirective (MediaSrc xs) = dt "media-src" xs
showDirective (ObjectSrc xs) = dt "object-src" xs
showDirective (PluginTypes xs) = dt "plugin-types" xs
showDirective (Referrer x) = dt "referrer" [x]
showDirective (ReflectedXSS x) = dt "reflected-xss" [x]
showDirective (ReportURI x) = dt "report-uri" [x]
showDirective (Sandbox x) = dt "sandbox" [x]
showDirective (ScriptSrc xs) = dt "script-src" xs
showDirective (StyleSrc xs) = dt "style-src" xs
showDirective UpgradeInsecureRequests = dt "upgrade-insecure-requests" []
loggerMiddleware :: Middleware
loggerMiddleware = logStdout
forceSSLMiddleware :: Middleware
forceSSLMiddleware = forceSSL
gzipMiddleware :: Middleware
gzipMiddleware = gzip $ def {gzipFiles = GzipCompress}
domainMiddleware :: Domain -> Middleware
domainMiddleware target = forceDomain
$ \domain -> if domain `elem` [target, "localhost"]
then Nothing
else Just target
securityHeadersMiddleware :: Middleware
securityHeadersMiddleware = addHeaders
[ ("X-Frame-Options", "SAMEORIGIN")
, ("X-XSS-Protection", "1; mode=block")
, ("X-Content-Type-Options", "nosniff")
]
stsHeadersMiddleware :: Middleware
stsHeadersMiddleware = addHeaders
[("Strict-Transport-Security", "max-age=31536000; includeSubdomains")]
cspHeadersMiddleware :: [Directive] -> Middleware
cspHeadersMiddleware directives = addHeaders
[("Content-Security-Policy", encodeUtf8 $ glue directives)]
where
glue :: [Directive] -> Text
glue [] = showDirective $ DefaultSrc ["'none'"]
glue xs = intercalate "; " (map showDirective xs)
deindexifyMiddleware :: Middleware
deindexifyMiddleware app req sendResponse
= if lastMay (pathInfo req) == Just "index.html"
then sendResponse $ redirectTo newPath
else app req sendResponse
where
newPath :: ByteString
newPath = encodeUtf8 $ processPath oldPath
processPath :: [Text] -> Text
processPath xs = case xs of
[] -> "/"
_ -> T.concat $ map prefixSlash xs
oldPath :: [Text]
oldPath = init $ pathInfo req
prefixSlash :: Text -> Text
prefixSlash = (<>) "/"