{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Tests
( tests
, testsDbInit) where
------------------------------------------------------------------------------
import Control.Error
import Control.Monad.State as S
import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as BL
import qualified Data.HashMap.Lazy as HM
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import Database.SQLite.Simple
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test, path)
------------------------------------------------------------------------------
import App
import Snap.Snaplet
import Snap.Snaplet.Auth
import qualified Snap.Snaplet.SqliteSimple as SQ
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
-- Create empty db, add user in old schema, then access it, and delete it
, testInitDbSchema0
, testCreateUserGood
, testDeleteUser
-- Create empty db, perform some basic queries
, testInitDbSchema0
, testQueries
-- Login tests, these use some otherwise uncovered DB backend
-- functions.
, testInitDbSchema0WithUser
, testLoginByRememberTokenKO
, testLoginByRememberTokenOK
, testLogoutOK
, testCurrentUserKO
, testCurrentUserOK
]
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 Nothing (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)
assertEqual "roles" [] (userRoles u)
assertEqual "meta" HM.empty (userMeta 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 Nothing (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"
, userRoles = roles
, userMeta = meta })
res <- evalHandler Nothing (ST.get "" M.empty) saveHdl appInit
either (assertFailure . show) checkUpdatedUser res
roles = [Role $ BL.pack "Superman", Role $ BL.pack "Journalist"]
meta = HM.fromList [ (T.pack "email-verified",
A.toJSON $ T.pack "yes")
, (T.pack "suppress-products",
A.toJSON [T.pack "Kryptonite"]) ]
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)
assertEqual "account roles" roles (userRoles u)
assertEqual "account meta data" meta (userMeta u)
let loginHdl = with auth $ loginByUsername "bar" (ClearText "foo") True
res <- evalHandler Nothing (ST.get "" M.empty) loginHdl appInit
either (assertFailure . show) (assertBool "login as 'bar' ok?" . isRight) res
------------------------------------------------------------------------------
-- Test that deleting a user works.
testDeleteUser :: Test
testDeleteUser = testCase "delete a user" assertGoodUser
where
loginHdl = with auth $ loginByUsername "foo" (ClearText "foo") True
assertGoodUser :: Assertion
assertGoodUser = do
res <- evalHandler Nothing (ST.get "" M.empty) loginHdl appInit
either (assertFailure . show) delUser res
delUser (Left _) = assertBool "failed login" False
delUser (Right u) = do
let delHdl = with auth $ destroyUser u
Right res <- evalHandler Nothing (ST.get "" M.empty) delHdl appInit
res <- evalHandler Nothing (ST.get "" M.empty) loginHdl appInit
either (assertFailure . show) (assertBool "login as 'foo' should fail now" . isLeft) res
------------------------------------------------------------------------------
-- Query tests
testQueries :: Test
testQueries = testCase "basic queries" runTest
where
queries = do
SQ.execute_ "CREATE TABLE foo (id INTEGER PRIMARY KEY, t TEXT)"
SQ.execute "INSERT INTO foo (t) VALUES (?)" (Only ("bar" :: String))
[(a :: Int,b :: String)] <- SQ.query_ "SELECT id,t FROM foo"
[Only (s :: String)] <- SQ.query "SELECT t FROM foo WHERE id = ?" (Only (1 :: Int))
withTop db . SQ.withSqlite $ \conn -> do
a @=? 1
b @=? "bar"
s @=? "bar"
[Only (v :: Int)] <- query_ conn "SELECT 1+1"
v @=? 2
runTest :: Assertion
runTest = do
r <- evalHandler Nothing (ST.get "" M.empty) queries appInit
return ()
------------------------------------------------------------------------------
testLoginByRememberTokenKO :: Test
testLoginByRememberTokenKO = testCase "loginByRememberToken no token" assertion
where
assertion :: Assertion
assertion = do
let hdl = with auth loginByRememberToken
res <- evalHandler Nothing (ST.get "" M.empty) hdl appInit
either (assertFailure . show) (assertBool failMsg . isLeft) res
failMsg = "loginByRememberToken: Expected to fail for the " ++
"absence of a token, but didn't."
------------------------------------------------------------------------------
testLoginByRememberTokenOK :: Test
testLoginByRememberTokenOK = testCase "loginByRememberToken token" assertion
where
assertion :: Assertion
assertion = do
res <- evalHandler Nothing (ST.get "" M.empty) hdl appInit
case res of
(Left e) -> assertFailure $ show e
(Right res') -> assertBool failMsg $ isRight res'
hdl :: Handler App App (Either AuthFailure AuthUser)
hdl = with auth $ do
res <- loginByUsername "foo" (ClearText "foo") True
either (\e -> return (Left e)) (\_ -> loginByRememberToken) res
failMsg = "loginByRememberToken: Expected to succeed but didn't."
------------------------------------------------------------------------------
assertLogout :: Handler App App (Maybe AuthUser) -> String -> Assertion
assertLogout hdl failMsg = do
res <- evalHandler Nothing (ST.get "" M.empty) hdl appInit
either (assertFailure . show) (assertBool failMsg . isNothing) res
testLogoutOK :: Test
testLogoutOK = testCase "logout user logged in." $ assertLogout hdl failMsg
where
hdl :: Handler App App (Maybe AuthUser)
hdl = with auth $ do
loginByUsername "foo" (ClearText "foo") True
logout
mgr <- get
return (activeUser mgr)
failMsg = "logout: Expected to get Nothing as the active user, " ++
" but didn't."
------------------------------------------------------------------------------
testCurrentUserKO :: Test
testCurrentUserKO = testCase "currentUser unsuccesful call" assertion
where
assertion :: Assertion
assertion = do
let hdl = with auth currentUser
res <- evalHandler Nothing (ST.get "" M.empty) hdl appInit
either (assertFailure . show) (assertBool failMsg . isNothing) res
failMsg = "currentUser: Expected Nothing as the current user, " ++
" but didn't."
------------------------------------------------------------------------------
testCurrentUserOK :: Test
testCurrentUserOK = testCase "successful currentUser call" assertion
where
assertion :: Assertion
assertion = do
res <- evalHandler Nothing (ST.get "" M.empty) hdl appInit
either (assertFailure . show) (assertBool failMsg . isJust) res
hdl :: Handler App App (Maybe AuthUser)
hdl = with auth $ do
res <- loginByUsername "foo" (ClearText "foo") True
either (\_ -> return Nothing) (\_ -> currentUser) res
failMsg = "currentUser: Expected to get the current user, " ++
" but didn't."