module Ella.Processors.Security ( signedCookiesProcessor
, CSRFProtection(..)
, mkCSRFProtection
, defaultCSRFRejectView
)
where
import Control.Monad (guard)
import Data.ByteString.Search.KnuthMorrisPratt (matchLL)
import Data.Digest.Pure.SHA (showDigest, sha1)
import Data.Maybe (isJust, fromJust, isNothing)
import Ella.Framework
import Ella.GenUtils (utf8, getTimestamp, randomStr, with)
import Ella.Request
import Ella.Response
import System.Time (ClockTime(..), toUTCTime)
import qualified Data.Map as Map
makeShaHash prefix secret val = showDigest $ sha1 $ utf8 $ prefix ++ secret ++ val
signedCookiesProcessor :: String -> (View -> View)
signedCookiesProcessor secret view req =
do
let req2 = removeInvalidCookies req
resp' <- view req2
case resp' of
Nothing -> return Nothing
Just resp -> return $ Just $ resp { cookies = map addShaHash $ cookies resp }
where
mkHash val = makeShaHash "signedcookies" secret val
addShaHash cookie = cookie { cookieValue = (mkHash $ cookieValue cookie) ++ ":" ++ cookieValue cookie }
retrieveCookieVal fullval = let (hash, val') = span (/= ':') fullval
val = drop 1 val'
in if mkHash val == hash
then Just val
else Nothing
removeInvalidCookies req = let checked = do
(name, val) <- allCookies req
let newval = retrieveCookieVal val
guard (isJust newval)
return (name, fromJust newval)
in req { allCookies = checked }
data CSRFProtection = CSRFProtection {
csrfViewProcessor :: View -> View
, csrfTokenField :: Request -> String
, csrfTokenName :: String
, csrfTokenValue :: Request -> String
}
defaultCSRFRejectView :: View
defaultCSRFRejectView req = return $ Just $ buildResponse [ addContent $ utf8 "<h1>403 Forbidden</h1>"
, addContent $ utf8 "<p>CSRF protection triggered, request aborted"
, setStatus 403
] utf8HtmlResponse
mkCSRFProtection :: Cookie
-> View
-> String
-> CSRFProtection
mkCSRFProtection baseCookie rejectView secret =
let tokenName = "csrftoken"
requestEnvName = "csrftoken"
makeCsrfToken = randomStr 20
getTokenFromReq req = fromJust $ Map.lookup requestEnvName $ environment req
mkTokenField req = "<div style=\"display:none\"><input type=\"hidden\" name=\"" ++ tokenName ++ "\" value=\"" ++ getTokenFromReq req ++ "\" ></div>"
addTokenToReq req token = req { environment = Map.insert requestEnvName token $ environment req }
makeCsrfCookie token = do
timestamp <- getTimestamp
let expires = Just $ toUTCTime $ TOD (toInteger timestamp + 3600*24*365*5) 0
return baseCookie { cookieExpires = expires
, cookieValue = token
}
pview view = \req -> do
let incomingCookie = getCookieVal req (cookieName baseCookie)
let incomingToken = getPOST req tokenName
let normalProc = do
token <- do
case incomingCookie of
Just val -> return val
_ -> makeCsrfToken
let req2 = addTokenToReq req token
resp' <- view req2
case resp' of
Nothing -> return Nothing
Just resp -> do
if null $ matchLL (utf8 token) (content resp)
then return (Just resp)
else do
cookie <- makeCsrfCookie token
let resp2 = resp `with` [ addCookie cookie ]
return (Just resp2)
if requestMethod req == "POST"
then if Map.member "HTTP_X_REQUESTED_WITH" $ environment req
then normalProc
else if isNothing incomingCookie || (incomingCookie /= incomingToken)
then rejectView req
else normalProc
else normalProc
in CSRFProtection { csrfViewProcessor = pview
, csrfTokenField = mkTokenField
, csrfTokenName = tokenName
, csrfTokenValue = getTokenFromReq
}