Source

ella / testsuite / Tests / Ella / Processors / Security.hs

Diff from to

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