Add more tests to the core.
This commit is contained in:
Felipe Lessa
parent
b7a063e1ee
commit
26d7aa5e47
@ -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 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
|
||||
cookieName stnull `shouldBe` "JSESSIONID"
|
||||
authKey stnull `shouldBe` "_ID"
|
||||
idleTimeout stnull `shouldBe` Just (60*60*24*7)
|
||||
absoluteTimeout stnull `shouldBe` Just (60*60*24*60)
|
||||
persistentCookies stnull `shouldBe` True
|
||||
httpOnlyCookies stnull `shouldBe` True
|
||||
secureCookies stnull `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
|
||||
cookieName (setCookieName "a" stnull) `shouldBe` "a"
|
||||
authKey (setAuthKey "a" stnull) `shouldBe` "a"
|
||||
idleTimeout (setIdleTimeout (Just 1) stnull) `shouldBe` Just 1
|
||||
absoluteTimeout (setAbsoluteTimeout (Just 1) stnull) `shouldBe` Just 1
|
||||
persistentCookies (setPersistentCookies False stnull) `shouldBe` False
|
||||
httpOnlyCookies (setHttpOnlyCookies False stnull) `shouldBe` False
|
||||
secureCookies (setSecureCookies True stnull) `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 st Nothing
|
||||
ret <- loadSession sttnt 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")
|
||||
ret <- loadSession sttnt (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)
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user