Commits

Luke Plant committed caf8006

Signed cookies processors now checks for expired cookies.

Comments (0)

Files changed (4)

         network >= 2.1,
         SHA >= 1.0.2,
         old-time >= 1.0.0,
+        old-locale >= 1.0.0,
         unix >= 2.3,
         cgi >= 3001
   Exposed-Modules:

src/Ella/GenUtils.hs

     g <- newStdGen
     return $ take n (randomRs chars g)
   where chars = ('a','z')
+
+-- | Split string on a separator
+splitOn :: (a -> Bool) -> [a] -> [[a]]
+splitOn f xs = split xs
+  where split xs = case break f xs of
+          (chunk,[])     -> chunk : []
+          (chunk,_:rest) -> chunk : split rest

src/Ella/Processors/Security.hs

 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.GenUtils (utf8, getTimestamp, randomStr, with, splitOn, exactParse)
 import Ella.Request
 import Ella.Response
-import System.Time (ClockTime(..), toUTCTime)
+import System.Locale (defaultTimeLocale)
+import System.Time (ClockTime(..), toUTCTime, formatCalendarTime, CalendarTime)
 import qualified Data.Map as Map
 
-makeShaHash prefix secret val = showDigest $ sha1 $ utf8 $ prefix ++ secret ++ val
+makeShaHash val = showDigest $ sha1 $ utf8 $ val
 
 -- | Create view processor for implementing signed cookies.
 -- Pass a secret string (used for hashing), and apply the resulting function
 signedCookiesProcessor secret view req =
     do
       -- modify the request to strip invalid cookies
-      let req2 = removeInvalidCookies req
+      cur_timestamp <- getTimestamp
+      let req2 = removeInvalidCookies req cur_timestamp
       -- get the normal response
       resp' <- view req2
       case resp' of
         -- Now modify outgoing response
         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' -- for the ':'
-                                  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 }
+      removeInvalidCookies req timestamp =
+          let checked = do
+                (name, val) <- allCookies req
+                let newval = retrieveCookieVal val timestamp
+                guard (isJust newval)
+                return (name, fromJust newval)
+          in req { allCookies = checked }
+
+      retrieveCookieVal fullval timestamp =
+          let hash:expires:val:_ = splitOn (== ':') fullval ++ repeat ""
+              hashMatch = mkHash val expires == hash
+              expiresOK = if expires == ""
+                            then True
+                            else case exactParse expires of
+                                   Nothing -> False
+                                   Just expires' -> expires' > timestamp
+          in if hashMatch && expiresOK
+             then Just val
+             else Nothing
+
+      addShaHash cookie =
+          let val = cookieValue cookie
+              ts = showExpires $ cookieExpires cookie
+          in cookie {
+                   cookieValue = mkHash val ts ++ ":" ++ ts ++ ":" ++ val
+                 }
+
+      mkHash :: String -> String -> String
+      mkHash val expires = makeShaHash ("signedcookies:" ++ secret ++ ":" ++ expires ++ ":" ++ val)
+
+      showExpires :: Maybe CalendarTime -> String
+      showExpires (Just x) = formatCalendarTime defaultTimeLocale "%s" x
+      showExpires Nothing = ""
 
 -- | CSRF protection
 --

testsuite/Tests/Ella/Processors/Security.hs

 where
 
 import Data.Digest.Pure.SHA (showDigest, sha1)
-import Ella.GenUtils (utf8, with)
+import Ella.GenUtils (utf8, with, getTimestamp)
 import Ella.Processors.Security
 import Ella.Request
 import Ella.Response
 import Ella.TestUtils (mkGetReq, mkPostReq, addCookieValues)
+import System.Locale (defaultTimeLocale)
+import System.Time (toUTCTime, ClockTime(..), formatCalendarTime, CalendarTime)
 import Test.HUnit
 import qualified Data.ByteString.Lazy as BS
 import qualified Data.Map as Map
 
 -- This mirrors how signedCookiesProcessors does it.  Duplication
 -- is allowed to ensure test actually does the right thing!
-signCookieVal val = (showDigest $ sha1 $ utf8 ("signedcookies" ++ scp_secret ++ val)) ++ ":" ++ val
+signCookieVal :: String -> Maybe CalendarTime -> String
+signCookieVal val expires = (showDigest $ sha1 $ utf8 ("signedcookies:" ++ scp_secret ++ ":" ++ showExpires expires ++ ":" ++ val)) ++ ":" ++ showExpires expires ++ ":" ++ val
+
+showExpires :: Maybe CalendarTime -> String
+showExpires (Just x) = formatCalendarTime defaultTimeLocale "%s" x
+showExpires Nothing = ""
 
 testSignedCookiesProcessor1 =
     (do
 testSignedCookiesProcessor3 =
     (do
       Just resp <- scp viewReturningCookie (mkGetReq "/foo/")
-      return ((cookieValue $ head $ cookies resp) == signCookieVal "bar")
+      return ((cookieValue $ head $ cookies resp) == signCookieVal "bar" Nothing)
     ) ~? "signedCookiesProcessor adds sha1 hash to beginning of values"
 
 
              [("REQUEST_METHOD", "GET")
              ,("PATH_INFO", "/posts")
              ,("HTTP_COOKIE",
-               "name1=" ++ signCookieVal "val1" ++
-               ";name2=val2;name3=" ++ signCookieVal "val3")]
+               "name1=" ++ signCookieVal "val1" Nothing ++
+               ";name2=val2;name3=" ++ signCookieVal "val3" Nothing)]
              "" utf8Encoding)
 
 testSignedCookiesProcessor4 =
       return (content resp == "name1=val1\nname3=val3\n")
     ) ~? "signedCookiesProcessor removes cookies that don't have correct hashes"
 
+cookieReq2 :: Int -> Request
+cookieReq2 ts = (mkRequest
+                 [("REQUEST_METHOD", "GET")
+                 ,("PATH_INFO", "/posts")
+                 ,("HTTP_COOKIE",
+                   "name1=" ++ signCookieVal "val1" (mkExpires $ ts + 100) ++
+                   ";name2=" ++ signCookieVal "val2" (mkExpires $ ts - 100))]
+                 "" utf8Encoding)
+    where mkExpires timestamp = Just $ toUTCTime $ TOD (toInteger timestamp) 0
+
+
+testSignedCookiesProcessorTimestamp =
+    (do
+      ts <- getTimestamp
+      let req = cookieReq2 ts
+      Just resp <- scp viewDisplayingCookies req
+      return (content resp == "name1=val1\n")
+    ) ~? "signedCookiesProcessor removes cookies which have expired"
 
 -- CSRF view processor
 
              , testSignedCookiesProcessor2
              , testSignedCookiesProcessor3
              , testSignedCookiesProcessor4
+             , testSignedCookiesProcessorTimestamp
              , testCsrfGETAllowAll
              , testCsrfRejectMissingCookie
              , testCsrfRejectMissingToken