diff --git a/serversession/serversession.cabal b/serversession/serversession.cabal index ed9a460..d30d16b 100644 --- a/serversession/serversession.cabal +++ b/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 diff --git a/serversession/tests/Main.hs b/serversession/tests/Main.hs new file mode 100644 index 0000000..7fcab05 --- /dev/null +++ b/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. + -- + 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