{-# LANGUAGE OverloadedStrings #-}
module Tests
( tests
, testsDbInit) where
------------------------------------------------------------------------------
import qualified Data.Map as M
import qualified Data.Text as T
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test, path)
import Database.SQLite.Simple
------------------------------------------------------------------------------
import App
import Snap.Snaplet
import Snap.Snaplet.Auth
import qualified Snap.Test as ST
import Snap.Snaplet.Test
------------------------------------------------------------------------------
tests :: Test
tests = mutuallyExclusive $ testGroup "Snap.Snaplet.SqliteSimple"
[ testInitDbEmpty
, testCreateUserGood
, testUpdateUser
]
------------------------------------------------------------------------------
testsDbInit :: Test
testsDbInit = mutuallyExclusive $ testGroup "Snap.Snaplet.SqliteSimple"
[ -- Empty db
testInitDbEmpty
, testCreateUserGood
, testUpdateUser
-- Create empty db with old schema + one user
, testInitDbSchema0
, testCreateUserGood
, testUpdateUser
-- Create empty db, add user in old schema, then access it
, testInitDbSchema0WithUser
, testUpdateUser
]
isRight :: Either a b -> Bool
isRight (Left _) = False
isRight (Right _) = True
dropTables :: Connection -> IO ()
dropTables conn = do
execute_ conn "DROP TABLE IF EXISTS snap_auth_user"
execute_ conn "DROP TABLE IF EXISTS snap_auth_user_version"
-- Must be the first on the test list for basic database
-- initialization (schema creation for snap_auth_user, etc.)
testInitDbEmpty :: Test
testInitDbEmpty = testCase "snaplet database init" go
where
go = do
conn <- open "test.db"
dropTables conn
close conn
(_, _handler, _doCleanup) <- runSnaplet Nothing appInit
assertBool "init ok" True
initSchema0 :: Query
initSchema0 = Query $ T.concat
[ "CREATE TABLE snap_auth_user (uid INTEGER PRIMARY KEY,"
, "login text UNIQUE NOT NULL,"
, "password text,"
, "activated_at timestamp,suspended_at timestamp,remember_token text,"
, "login_count INTEGER NOT NULL,failed_login_count INTEGER NOT NULL,"
, "locked_out_until timestamp,current_login_at timestamp,"
, "last_login_at timestamp,current_login_ip text,"
, "last_login_ip text,created_at timestamp,updated_at timestamp);"
]
addFooUserSchema0 :: Query
addFooUserSchema0 =
"INSERT INTO snap_auth_user VALUES(1,'foo',X'7368613235367C31327C39426E5255534356444B4E6A3553716345774E756E513D3D7C633534506C69614A42314E483562677143494651616732454C75444B684F37745A78655479456C4F6F356F3D',NULL,NULL,'2cc0caf41bd7387150cc1416ac38bccc36e64c11a8945f72298ea366ffa8fc97',0,0,NULL,'2012-11-28 21:59:15.150153','2012-11-28 21:59:15.109848',NULL, NULL, '2012-11-28 21:59:15.052817','2012-11-28 21:59:15.052817');"
-- Must be the first on the test list for basic database
-- initialization (schema creation for snap_auth_user, etc.)
testInitDbSchema0 :: Test
testInitDbSchema0 = testCase "init db with schema0" $ do
conn <- open "test.db"
dropTables conn
execute_ conn initSchema0
close conn
(_, _handler, _doCleanup) <- runSnaplet Nothing appInit
assertBool "init ok" True
-- Initialize db schema to an empty schema0 and add a user 'foo'. The
-- expectation is that snaplet initialization needs to do schema
-- migration for the tables and rows.
testInitDbSchema0WithUser :: Test
testInitDbSchema0WithUser = testCase "init + add foo user directly" $ do
conn <- open "test.db"
dropTables conn
execute_ conn initSchema0
execute_ conn addFooUserSchema0
close conn
(_, _handler, _doCleanup) <- runSnaplet Nothing appInit
assertBool "init ok" True
------------------------------------------------------------------------------
testCreateUserGood :: Test
testCreateUserGood = testCase "createUser good params" assertGoodUser
where
assertGoodUser :: Assertion
assertGoodUser = do
let hdl = with auth $ createUser "foo" "foo"
res <- evalHandler (ST.get "" M.empty) hdl appInit
either (assertFailure . show) checkUserFields res
checkUserFields (Left _) =
assertBool "createUser failed: Couldn't create a new user." False
checkUserFields (Right u) = do
assertEqual "login match" "foo" (userLogin u)
assertEqual "login count" 0 (userLoginCount u)
assertEqual "fail count" 0 (userFailedLoginCount u)
assertEqual "local host ip" Nothing (userCurrentLoginIp u)
assertEqual "local host ip" Nothing (userLastLoginIp u)
assertEqual "locked until" Nothing (userLockedOutUntil u)
assertEqual "empty email" Nothing (userEmail u)
------------------------------------------------------------------------------
-- Create a user, modify it, persist it and load again, check fields ok.
-- Must run after testCreateUserGood
testUpdateUser :: Test
testUpdateUser = testCase "createUser + update good params" assertGoodUser
where
assertGoodUser :: Assertion
assertGoodUser = do
let loginHdl = with auth $ loginByUsername "foo" (ClearText "foo") True
res <- evalHandler (ST.get "" M.empty) loginHdl appInit
either (assertFailure . show) checkLoggedInUser res
checkLoggedInUser (Left _) = assertBool "failed login" False
checkLoggedInUser (Right u) = do
assertEqual "login count" 1 (userLoginCount u)
assertEqual "fail count" 0 (userFailedLoginCount u)
assertEqual "locked until" Nothing (userLockedOutUntil u)
assertEqual "local host ip" (Just "127.0.0.1") (userCurrentLoginIp u)
assertEqual "no previous login" Nothing (userLastLoginIp u)
let saveHdl = with auth $ saveUser (u { userLogin = "bar" })
res <- evalHandler (ST.get "" M.empty) saveHdl appInit
either (assertFailure . show) checkUpdatedUser res
checkUpdatedUser (Left _) = assertBool "failed saveUser" False
checkUpdatedUser (Right u) = do
assertEqual "login rename ok?" "bar" (userLogin u)
assertEqual "login count" 1 (userLoginCount u)
assertEqual "local host ip" (Just "127.0.0.1") (userCurrentLoginIp u)
assertEqual "local host ip" Nothing (userLastLoginIp u)
let loginHdl = with auth $ loginByUsername "bar" (ClearText "foo") True
res <- evalHandler (ST.get "" M.empty) loginHdl appInit
either (assertFailure . show) (assertBool "login as 'bar' ok?" . isRight) res