diff --git a/snaplet-sqlite-simple.cabal b/snaplet-sqlite-simple.cabal --- a/snaplet-sqlite-simple.cabal +++ b/snaplet-sqlite-simple.cabal @@ -1,5 +1,5 @@ name: snaplet-sqlite-simple -version: 0.4.6 +version: 0.4.7 synopsis: sqlite-simple snaplet for the Snap Framework description: This snaplet provides support for using the SQLite database with a Snap Framework application via the @@ -58,7 +58,7 @@ direct-sqlite >= 2.3.3 && < 2.4, snap >= 0.13 && < 0.14, text >= 0.11 && < 1.2, - transformers >= 0.3 && < 0.4, + transformers >= 0.3 && < 0.5, unordered-containers >= 0.2 && < 0.3 @@ -89,6 +89,7 @@ errors >= 1.3.1 && < 1.5, lens, mtl >= 2, + SafeSemaphore, snap-core, snap, snaplet-sqlite-simple, @@ -98,7 +99,7 @@ test-framework-hunit >= 0.2.7 && < 0.4, text >= 0.11 && < 1.2, time >= 1.1, - transformers >= 0.3 && < 0.4, + transformers, unordered-containers >= 0.2 && < 0.3 default-extensions: diff --git a/src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs b/src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs --- a/src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs +++ b/src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs @@ -404,10 +404,10 @@ , fst (colLogin pamTable) , " = ?" ] - res <- S.query conn q2 [userLogin] - case res of - [savedUser] -> return $ Right savedUser - _ -> return . Left $ AuthError "snaplet-sqlite-simple: Failed user save" + -- TODO S.query may throw an exception, ideally we would + -- catch it and turn it into an AuthError. + [savedUser] <- S.query conn q2 [userLogin] + return $ Right savedUser lookupByUserId SqliteAuthManager{..} uid = do let q = Query $ T.concat diff --git a/test/SafeCWD.hs b/test/SafeCWD.hs --- a/test/SafeCWD.hs +++ b/test/SafeCWD.hs @@ -3,20 +3,20 @@ , removeDirectoryRecursiveSafe ) where -import Control.Concurrent.QSem +import Control.Concurrent.SSem import Control.Exception import Control.Monad import System.Directory import System.IO.Unsafe -sem :: QSem -sem = unsafePerformIO $ newQSem 1 +sem :: SSem +sem = unsafePerformIO $ new 1 inDir :: Bool -> FilePath -> IO a -> IO a inDir startClean dir action = bracket before after (const action) where before = do - waitQSem sem + wait sem cwd <- getCurrentDirectory when startClean $ removeDirectoryRecursiveSafe dir createDirectoryIfMissing True dir @@ -24,7 +24,7 @@ return cwd after cwd = do setCurrentDirectory cwd - signalQSem sem + signal sem removeDirectoryRecursiveSafe :: String -> IO () removeDirectoryRecursiveSafe p = diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} module Tests ( tests @@ -6,25 +6,27 @@ ------------------------------------------------------------------------------ +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 Database.SQLite.Simple - ------------------------------------------------------------------------------ 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" @@ -47,12 +49,23 @@ -- 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 ] -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" @@ -178,3 +191,127 @@ 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."