Add more tests to the core.

serversession/tests/Main.hs

@@ -1,25 +1,41 @@
 module Main (main) where
 
+import Control.Arrow
 import Control.Monad
 import Data.Maybe
 import Data.Typeable (Typeable)
 import Test.Hspec
 import Test.Hspec.QuickCheck
-import Test.QuickCheck.Property (ioProperty, (===))
 import Web.PathPieces
 import Web.ServerSession.Core.Internal
 
 import qualified Control.Exception as E
 import qualified Crypto.Nonce as N
+import qualified Data.ByteString.Char8 as B8
 import qualified Data.IORef as I
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Data.Text as T
 import qualified Data.Time as TI
+import qualified Test.QuickCheck.Property as Q
 
 
 main :: IO ()
 main = hspec $ parallel $ do
+  -- State using () as storage.  As () is not a Storage instance,
+  -- this is the state to be used when testing functions that
+  -- should not touch the storage in any code path.
+  stnull <- runIO $ createState ()
+
+  -- State using TNTStorage.  This state should be used for
+  -- functions that normally need to access the storage but on
+  -- the test code path should not do so.
+  sttnt <- runIO $ createState TNTStorage
+
+  -- Some functions take a time argument meaning "now".  We don't
+  -- gain anything using real "now", so here's a fake "now".
+  let fakenow = read "2015-05-27 17:55:41 UTC" :: TI.UTCTime
+
   describe "SessionId" $ do
     gen <- runIO N.new
     it "is generated with 24 bytes from letters, numbers, dashes and underscores" $ do
@@ -36,9 +52,9 @@ main = hspec $ parallel $ do
       observed `shouldBe` expected
 
     prop "accepts as valid the session IDs generated by ourselves" $
-      ioProperty $ do
+      Q.ioProperty $ do
         sid <- generateSessionId gen
-        return $ fromPathPiece (toPathPiece sid) === Just sid
+        return $ fromPathPiece (toPathPiece sid) Q.=== Just sid
 
     it "does not accept as valid some example invalid session IDs" $ do
       let parse = fromPathPiece :: T.Text -> Maybe SessionId
@@ -53,27 +69,27 @@ main = hspec $ parallel $ do
   describe "State" $ do
     it "has the expected default values" $ do
       -- A silly test to avoid unintended change of default values.
-      st <- createState ()
+      cookieName stnull        `shouldBe` "JSESSIONID"
-      cookieName st        `shouldBe` "JSESSIONID"
+      authKey stnull           `shouldBe` "_ID"
-      authKey st           `shouldBe` "_ID"
+      idleTimeout stnull       `shouldBe` Just (60*60*24*7)
-      idleTimeout st       `shouldBe` Just (60*60*24*7)
+      absoluteTimeout stnull   `shouldBe` Just (60*60*24*60)
-      absoluteTimeout st   `shouldBe` Just (60*60*24*60)
+      persistentCookies stnull `shouldBe` True
-      persistentCookies st `shouldBe` True
+      httpOnlyCookies stnull   `shouldBe` True
-      httpOnlyCookies st   `shouldBe` True
+      secureCookies stnull     `shouldBe` False
-      secureCookies st     `shouldBe` False
 
     it "has sane setters of ambiguous types" $ do
-      st <- createState ()
+      cookieName        (setCookieName        "a"      stnull) `shouldBe` "a"
-      cookieName        (setCookieName        "a"      st) `shouldBe` "a"
+      authKey           (setAuthKey           "a"      stnull) `shouldBe` "a"
-      authKey           (setAuthKey           "a"      st) `shouldBe` "a"
+      idleTimeout       (setIdleTimeout       (Just 1) stnull) `shouldBe` Just 1
-      idleTimeout       (setIdleTimeout       (Just 1) st) `shouldBe` Just 1
+      absoluteTimeout   (setAbsoluteTimeout   (Just 1) stnull) `shouldBe` Just 1
-      absoluteTimeout   (setAbsoluteTimeout   (Just 1) st) `shouldBe` Just 1
+      persistentCookies (setPersistentCookies False    stnull) `shouldBe` False
-      persistentCookies (setPersistentCookies False    st) `shouldBe` False
+      httpOnlyCookies   (setHttpOnlyCookies   False    stnull) `shouldBe` False
-      httpOnlyCookies   (setHttpOnlyCookies   False    st) `shouldBe` False
+      secureCookies     (setSecureCookies     True     stnull) `shouldBe` True
-      secureCookies     (setSecureCookies     True     st) `shouldBe` True
 
   describe "loadSession" $ do
     let checkEmptySession (sessionMap, SaveSessionToken msession time) = do
+          -- Saved time is close to now, session map is empty,
+          -- there's no reference to an existing session.
           let point1 = 0.1 {- second -} :: Double
           now <- TI.getCurrentTime
           abs (realToFrac $ TI.diffUTCTime now time) `shouldSatisfy` (< point1)
@@ -81,13 +97,11 @@ main = hspec $ parallel $ do
           msession `shouldSatisfy` isNothing
 
     it "returns empty session and token when the session ID cookie is not present" $ do
-      st  <- createState TNTStorage
+      ret <- loadSession sttnt Nothing
-      ret <- loadSession st Nothing
       checkEmptySession ret
 
     it "does not need the storage if session ID cookie has invalid data" $ do
-      st  <- createState TNTStorage
+      ret <- loadSession sttnt (Just "123456789-123456789-123")
-      ret <- loadSession st (Just "123456789-123456789-123")
       checkEmptySession ret
 
     it "returns empty session and token when the session ID cookie refers to inexistent session" $ do
@@ -99,16 +113,79 @@ main = hspec $ parallel $ do
       ret <- loadSession st (Just "123456789-123456789-1234")
       checkEmptySession ret
 
-    it "should have more tests" pending
+    it "returns the session from the storage when the session ID refers to an existing session" $ do
+      let session = Session
+            { sessionKey        = S "123456789-123456789-1234"
+            , sessionAuthId     = Just authId
+            , sessionData       = M.fromList [("a", "b"), ("c", "d")]
+            , sessionCreatedAt  = TI.addUTCTime (-10) fakenow
+            , sessionAccessedAt = TI.addUTCTime (-5)  fakenow
+            }
+          authId = "auth-id"
+      st  <- createState =<< prepareMockStorage [session]
+      (retSessionMap, SaveSessionToken msession _now) <-
+          loadSession st (Just $ B8.pack $ T.unpack $ unS $ sessionKey session)
+      retSessionMap `shouldBe` M.insert (authKey st) authId (sessionData session)
+      msession      `shouldBe` Just session
 
   describe "checkExpired" $ do
-    it "should have more tests" pending
+    prop "agrees with nextExpires" $
+      \idleSecs absSecs ->
+        let idleDiff  = realToFrac $ max 1 $ abs (idleSecs :: Int)
+            absDiff   = realToFrac $ max 1 $ abs (absSecs  :: Int)
+            st'       = setIdleTimeout     (Just idleDiff) $
+                        setAbsoluteTimeout (Just absDiff) stnull
+            sessTimes = do
+              diff <- [0, idleDiff, absDiff]
+              off <- [1, 0, -1]
+              return $ TI.addUTCTime (negate $ diff + off) fakenow
+            sessions  = do
+              createdAt  <- sessTimes
+              accessedAt <- sessTimes
+              return $ Session
+                { sessionKey        = error "irrelevant 1"
+                , sessionAuthId     = error "irrelevant 2"
+                , sessionData       = error "irrelevant 3"
+                , sessionCreatedAt  = createdAt
+                , sessionAccessedAt = accessedAt
+                }
+            test s =
+              Q.counterexample
+                (unlines
+                   [ "fakenow    = " ++ show fakenow
+                   , "createdAt  = " ++ show (sessionCreatedAt s)
+                   , "accessedAt = " ++ show (sessionAccessedAt s)
+                   , "checkRet   ~ " ++ show (() <$ checkRet)
+                   , "nextRet    = " ++ show nextRet ])
+                (isJust checkRet == (nextRet >= Just fakenow))
+              where checkRet = checkExpired fakenow st' s
+                    nextRet  = nextExpires st' s
+        in Q.conjoin (test <$> sessions)
 
   describe "nextExpires" $ do
-    it "should have more tests" pending
+    it "should have unit tests" pending
 
   describe "cookieExpires" $ do
-    it "should have more tests" pending
+    prop "is Nothing for non-persistent cookies regardless of session" $
+      \midleSecs mabsSecs ->
+        let idleDiff  = realToFrac . max 1 . abs <$> (midleSecs :: Maybe Int)
+            absDiff   = realToFrac . max 1 . abs <$> (mabsSecs  :: Maybe Int)
+            st'       = setIdleTimeout       idleDiff $
+                        setAbsoluteTimeout   absDiff  $
+                        setPersistentCookies False stnull
+        in cookieExpires st' (error "irrelevant") Q.=== Nothing
+    it "is a long time for persistent cookies without timeouts regardless of session" $
+      let st' = setIdleTimeout     Nothing $
+                setAbsoluteTimeout Nothing stnull
+          session = Session
+            { sessionKey        = error "irrelevant 1"
+            , sessionAuthId     = error "irrelevant 2"
+            , sessionData       = error "irrelevant 3"
+            , sessionCreatedAt  = error "irrelevant 4"
+            , sessionAccessedAt = fakenow
+            }
+          distantFuture = TI.addUTCTime (60*60*24*365*10) fakenow
+      in cookieExpires st' session `shouldSatisfy` maybe False (>= distantFuture)
 
   describe "saveSession" $ do
     it "should have more tests" pending
@@ -116,19 +193,56 @@ main = hspec $ parallel $ do
   describe "invalidateIfNeeded" $ do
     it "should have more tests" pending
 
-  describe "decomposeSession" $ do
-    it "should have more tests" pending
-
   describe "saveSessionOnDb" $ do
     it "should have more tests" pending
 
-  describe "toSessionMap" $ do
+  describe "decomposeSession" $ do
+    prop "it is sane when not finding auth key or force invalidate key" $
+      \data_ ->
+        let sessionMap = mkSessionMap $ filter (notSpecial . fst) $ data_
+            notSpecial = flip notElem [authKey stnull, forceInvalidateKey] . T.pack
+        in decomposeSession stnull sessionMap `shouldBe`
+           DecomposedSession Nothing DoNotForceInvalidate sessionMap
+
+    prop "parses the force invalidate key" $
+      \data_  ->
+        let sessionMap v = M.insert forceInvalidateKey (B8.pack $ show v) $ mkSessionMap data_
+            allForces    = [minBound..maxBound] :: [ForceInvalidate]
+            test v       = dsForceInvalidate (decomposeSession stnull $ sessionMap v) Q.=== v
+        in Q.conjoin (test <$> allForces)
+
     it "should have more tests" pending
 
+  describe "toSessionMap" $ do
+    let mkSession authId data_ = Session
+          { sessionKey        = error "irrelevant 1"
+          , sessionAuthId     = authId
+          , sessionData       = mkSessionMap data_
+          , sessionCreatedAt  = error "irrelevant 2"
+          , sessionAccessedAt = error "irrelevant 3"
+          }
+
+    prop "does not change session data for sessions without auth ID" $
+      \data_ ->
+        let s = mkSession Nothing data_
+        in toSessionMap stnull s Q.=== sessionData s
+
+    prop "adds (overwriting) the auth ID to the session data" $
+      \authId_ data_ ->
+        let s = mkSession (Just authId) ((T.unpack k, "foo") : data_)
+            k = authKey stnull
+            authId = B8.pack authId_
+        in toSessionMap stnull s Q.=== M.adjust (const authId) k (sessionData s)
+
   describe "MockStorage" $ do
     it "passes the storage test" pending
 
 
+-- | Used to generate session maps on QuickCheck properties.
+mkSessionMap :: [(String, String)] -> SessionMap
+mkSessionMap = M.fromList . map (T.pack *** B8.pack)
+
+
 ----------------------------------------------------------------------