Commits

Luke Plant committed f3972c2 Merge

Merge

Comments (0)

Files changed (4)

         network >= 2.1,
         SHA >= 1.0.2,
         old-time >= 1.0.0,
+        unix >= 2.3,
         cgi >= 3001
   Exposed-Modules:
     Ella.Request, Ella.Response, Ella.GenUtils, Ella.Utils, Ella.Framework,

src/Ella/GenUtils.hs

 
 where
 
+import Control.Monad (liftM)
 import Data.ByteString.Lazy.Char8 (ByteString)
+import GHC.Exts( IsString(..) )
+import Random (randomRs, newStdGen)
+import System.Posix.Time (epochTime)
 import qualified Data.ByteString.Lazy.UTF8 as UTF8
 
-import GHC.Exts( IsString(..) )
-
 -- | Takes a String and returns UTF8 ByteString
 utf8 :: String -> ByteString
 utf8 = UTF8.fromString
 nullToNothing :: String -> Maybe String
 nullToNothing "" = Nothing
 nullToNothing x  = Just x
+
+
+-- | Return current time as a UNIX timestamp
+getTimestamp :: IO Int
+getTimestamp = liftM (floor . toRational) epochTime
+
+-- | Returns a randomly generated string of length n
+randomStr :: Int -> IO String
+randomStr n = do
+    g <- newStdGen
+    return $ take n (randomRs chars g)
+  where chars = ('a','z')

src/Ella/Processors/Security.hs

 
 where
 
-import Ella.GenUtils (utf8)
+import Control.Monad (guard)
 import Data.Digest.Pure.SHA (showDigest, sha1)
-import Data.Maybe (isJust, fromJust)
+import Data.Maybe (isJust, fromJust, isNothing)
 import Ella.Framework
-import Control.Monad (guard)
+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
 
 -- | Create view processor for implementing signed cookies.
 -- Pass a secret string (used for hashing), and apply the resulting function
         -- Now modify outgoing response
         Just resp -> return $ Just $ resp { cookies = map addShaHash $ cookies resp }
     where
-      mkHash val = showDigest $ sha1 $ utf8 $ secret ++ val
+      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' -- for the ':'
                                        guard (isJust newval)
                                        return (name, fromJust newval)
                                  in req { allCookies = checked }
+
+-- | CSRF protection
+--
+-- Provides a view processor function and other utility functions for protecting
+-- against CSRF using a cookie.  It sets a cookie to a random value, provides a
+-- function for adding tokens based on the value to outgoing forms, making them
+-- unique to each user, and requires incoming POST requests to have the same
+-- token.
+data CSRFProtection = CSRFProtection {
+      csrfProtectView :: View -> View -- ^ view processor that stops requests
+                                  -- without the CSRF token and sets an outgoing
+                                  -- cookie.
+    , csrfTokenField :: Request -> String -- ^ function that returns a hidden
+                                          -- input field to be inserted into
+                                          -- forms.
+    , csrfTokenName :: String -- ^ name to use for CSRF token in forms
+    , csrfTokenValue :: Request -> String -- ^ Returns the raw CSRF token
+                                          -- for a given request
+}
+
+defaultCSRFRejectView :: View
+defaultCSRFRejectView = undefined -- TODO
+
+-- | Creates a CSRFProtection object for the supplied options.
+mkCSRFProtection :: Cookie -- ^ cookie used for basis of CSRF cookie, must have at least 'name' set, 'value' and 'expires' will be overwritten
+                 -> View -- ^ view to be used for rejects
+                 -> String -- ^ secret string used for hashing
+                 -> CSRFProtection
+mkCSRFProtection baseCookie rejectView secret =
+    let tokenName = "csrfmiddlewaretoken"
+        makeCsrfToken = randomStr 20
+        hashToken val = makeShaHash "csrf" secret val
+        getTokenFromReq req = fromJust $ Map.lookup "csrftoken" $ environment req
+        addTokenToReq req token = req { environment = Map.insert "csrftoken" 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
+          -- Get existing CSRF cookie
+          let incomingCookie = getCookieVal req (cookieName baseCookie)
+          let incomingToken = getPOST req tokenName
+
+          -- normal processing - add token to request environment and
+          -- add outgoing cookie
+          let normalProc = do
+                           -- create token if one doesn't exist
+                           token <- do
+                               case incomingCookie of
+                                 Just val -> return val
+                                 _        -> makeCsrfToken
+                           -- add token to environment in Request object
+                           let req2 = addTokenToReq req (hashToken token)
+                           resp' <- view req2
+                           case resp' of
+                             Nothing -> return Nothing
+                             Just resp -> do
+                                        -- set cookie on all outgoing responses
+                                        cookie <- makeCsrfCookie token
+                                        let resp2 =  resp `with` [ addCookie cookie ]
+                                        return (Just resp2)
+
+          -- if POST request, reject if no cookie or no POST token or
+          -- POST token doesn't match hash of cookie
+          if requestMethod req == "POST"
+            then if isNothing incomingCookie || (fmap hashToken incomingCookie /= incomingToken)
+                   then rejectView req
+                   else normalProc
+            else normalProc
+
+    in CSRFProtection { csrfProtectView = pview
+                      , csrfTokenField = undefined
+                      , csrfTokenName = tokenName
+                      , csrfTokenValue = getTokenFromReq
+                      }

src/Ella/Utils.hs

 
 where
 
+import Ella.GenUtils (utf8)
+import Ella.Response (addContent, Response)
 import Text.XHtml (renderHtml, HTML)
-import Ella.Response (addContent, Response)
-import Ella.GenUtils (utf8)
 
 -- Utility functions