Initial work on test suites.

Bug fix from 9385651 was already a result of it.

serversession/serversession.cabal

@@ -38,6 +38,25 @@ library
     TypeFamilies
   ghc-options:     -Wall
 
+
+test-suite tests
+  type: exitcode-stdio-1.0
+  hs-source-dirs:  tests
+  build-depends:
+      base, aeson, base64-bytestring, bytestring, containers,
+      data-default, nonce, path-pieces, text, time, transformers
+
+    , hspec                     >= 2.1 && < 3
+    , QuickCheck
+    , serversession
+  extensions:
+    DeriveDataTypeable
+    OverloadedStrings
+    TypeFamilies
+  main-is:         Main.hs
+  ghc-options:     -Wall -threaded -with-rtsopts=-N
+
+
 source-repository head
   type:     git
   location: https://github.com/yesodweb/serversession

serversession/tests/Main.hs

@@ -0,0 +1,197 @@
+module Main (main) where
+
+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.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
+
+
+main :: IO ()
+main = hspec $ parallel $ do
+  describe "SessionId" $ do
+    gen <- runIO N.new
+    it "is generated with 24 bytes from letters, numbers, dashes and underscores" $ do
+      let reps = 10000
+      sids <- replicateM reps (generateSessionId gen)
+      -- Test length to be 24 bytes.
+      map (T.length . unS) sids `shouldBe` replicate reps 24
+      -- Test that we see all chars, and only the expected ones.
+      -- The probability of a given character not appearing on
+      -- this test is (63/64)^(24*reps), so it's extremely
+      -- unlikely for this test to fail on correct code.
+      let observed = S.fromList $ concat $ T.unpack . unS <$> sids
+          expected = S.fromList $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_"
+      observed `shouldBe` expected
+
+    prop "accepts as valid the session IDs generated by ourselves" $
+      ioProperty $ do
+        sid <- generateSessionId gen
+        return $ fromPathPiece (toPathPiece sid) === Just sid
+
+    it "does not accept as valid some example invalid session IDs" $ do
+      let parse = fromPathPiece :: T.Text -> Maybe SessionId
+      parse ""                          `shouldBe` Nothing
+      parse "123456789-123456789-123"   `shouldBe` Nothing
+      parse "123456789-123456789-12345" `shouldBe` Nothing
+      parse "aaaaaaaaaaaaaaaaaa*aaaaa"  `shouldBe` Nothing
+      -- sanity check
+      parse "123456789-123456789-1234"  `shouldSatisfy` isJust
+      parse "aaaaaaaaaaaaaaaaaaaaaaaa"  `shouldSatisfy` isJust
+
+  describe "State" $ do
+    it "has the expected default values" $ do
+      -- A silly test to avoid unintended change of default values.
+      st <- createState ()
+      cookieName st        `shouldBe` "JSESSIONID"
+      authKey st           `shouldBe` "_ID"
+      idleTimeout st       `shouldBe` Just (60*60*24*7)
+      absoluteTimeout st   `shouldBe` Just (60*60*24*60)
+      persistentCookies st `shouldBe` True
+      httpOnlyCookies st   `shouldBe` True
+      secureCookies st     `shouldBe` False
+
+    it "has sane setters of ambiguous types" $ do
+      st <- createState ()
+      cookieName        (setCookieName        "a"      st) `shouldBe` "a"
+      authKey           (setAuthKey           "a"      st) `shouldBe` "a"
+      idleTimeout       (setIdleTimeout       (Just 1) st) `shouldBe` Just 1
+      absoluteTimeout   (setAbsoluteTimeout   (Just 1) st) `shouldBe` Just 1
+      persistentCookies (setPersistentCookies False    st) `shouldBe` False
+      httpOnlyCookies   (setHttpOnlyCookies   False    st) `shouldBe` False
+      secureCookies     (setSecureCookies     True     st) `shouldBe` True
+
+  describe "loadSession" $ do
+    let checkEmptySession (sessionMap, SaveSessionToken msession time) = do
+          let point1 = 0.1 {- second -} :: Double
+          now <- TI.getCurrentTime
+          abs (realToFrac $ TI.diffUTCTime now time) `shouldSatisfy` (< point1)
+          sessionMap `shouldBe` M.empty
+          msession `shouldSatisfy` isNothing
+
+    it "returns empty session and token when the session ID cookie is not present" $ do
+      st  <- createState TNTStorage
+      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 st (Just "123456789-123456789-123")
+      checkEmptySession ret
+
+    it "returns empty session and token when the session ID cookie refers to inexistent session" $ do
+      -- In particular, the save token should *not* refer to the
+      -- session ID that was given.  We're a strict session
+      -- management system.
+      -- <https://www.owasp.org/index.php/Session_Management_Cheat_Sheet#Session_ID_Generation_and_Verification:_Permissive_and_Strict_Session_Management>
+      st  <- createState =<< emptyMockStorage
+      ret <- loadSession st (Just "123456789-123456789-1234")
+      checkEmptySession ret
+
+    it "should have more tests" pending
+
+  describe "checkExpired" $ do
+    it "should have more tests" pending
+
+  describe "nextExpires" $ do
+    it "should have more tests" pending
+
+  describe "cookieExpires" $ do
+    it "should have more tests" pending
+
+  describe "saveSession" $ do
+    it "should have more tests" pending
+
+  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
+    it "should have more tests" pending
+
+  describe "MockStorage" $ do
+    it "passes the storage test" pending
+
+
+----------------------------------------------------------------------
+
+
+-- | A storage that explodes if it's used.  Useful for checking
+-- that the storage is irrelevant on a code path.
+data TNTStorage = TNTStorage deriving (Typeable)
+
+instance Storage TNTStorage where
+  type TransactionM TNTStorage = IO
+  runTransactionM _         = id
+  getSession                = explode "getSession"
+  deleteSession             = explode "deleteSession"
+  deleteAllSessionsOfAuthId = explode "deleteAllSessionsOfAuthId"
+  insertSession             = explode "insertSession"
+  replaceSession            = explode "replaceSession"
+
+
+-- | Implementation of all 'Storage' methods of 'TNTStorage'
+-- (except for runTransactionM).
+explode :: Show a => String -> TNTStorage -> a -> TransactionM TNTStorage b
+explode fun _ = E.throwIO . TNTExplosion fun . show
+
+
+-- | Exception thrown by 'explode'.
+data TNTExplosion = TNTExplosion String String deriving (Show, Typeable)
+
+instance E.Exception TNTExplosion where
+
+
+----------------------------------------------------------------------
+
+
+-- | A mock storage used just for testing.
+data MockStorage =
+  MockStorage
+    { mockSessions :: I.IORef (M.Map SessionId Session)
+    }
+  deriving (Typeable)
+
+instance Storage MockStorage where
+  type TransactionM MockStorage = IO
+  runTransactionM _ = id
+  getSession sto sid =
+    M.lookup sid <$> I.readIORef (mockSessions sto)
+  deleteSession sto sid =
+    I.modifyIORef (mockSessions sto) (M.delete sid)
+  deleteAllSessionsOfAuthId sto authId =
+    I.modifyIORef (mockSessions sto) (M.filter (\s -> sessionAuthId s == Just authId))
+  insertSession sto session =
+    I.modifyIORef (mockSessions sto) (M.insert (sessionKey session) session)
+  replaceSession = insertSession
+
+
+-- | Creates empty mock storage.
+emptyMockStorage :: IO MockStorage
+emptyMockStorage =
+  MockStorage
+    <$> I.newIORef M.empty
+
+
+-- | Creates mock storage with the given sessions already existing.
+prepareMockStorage :: [Session] -> IO MockStorage
+prepareMockStorage sessions = do
+  sto <- emptyMockStorage
+  I.writeIORef (mockSessions sto) (M.fromList [(sessionKey s, s) | s <- sessions])
+  return sto