snaplet-sqlite-simple 0.4.6 → 0.4.7
raw patch · 4 files changed
+158/−20 lines, 4 filesdep +SafeSemaphoredep ~transformers
Dependencies added: SafeSemaphore
Dependency ranges changed: transformers
Files
- snaplet-sqlite-simple.cabal +4/−3
- src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs +4/−4
- test/SafeCWD.hs +5/−5
- test/Tests.hs +145/−8
snaplet-sqlite-simple.cabal view
@@ -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:
src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs view
@@ -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
test/SafeCWD.hs view
@@ -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 =
test/Tests.hs view
@@ -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."