diff --git a/resources/db/devel.cfg b/resources/db/devel.cfg --- a/resources/db/devel.cfg +++ b/resources/db/devel.cfg @@ -1,13 +1,1 @@ db = "test.db" - -# Nmuber of distinct connection pools to maintain. The smallest acceptable -# value is 1. -numStripes = 1 - -# Number of seconds an unused resource is kept open. The smallest acceptable -# value is 0.5 seconds. -idleTime = 5 - -# Maximum number of resources to keep open per stripe. The smallest -# acceptable value is 1. -maxResourcesPerStripe = 20 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.3.1 +version: 0.4.0 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 @@ -21,7 +21,7 @@ author: Janne Hellsten, Doug Beardsley maintainer: Janne Hellsten build-type: Simple -cabal-version: >= 1.6 +cabal-version: >= 1.10 homepage: https://github.com/nurpax/snaplet-sqlite-simple category: Web, Snap @@ -36,6 +36,7 @@ location: https://github.com/nurpax/snaplet-sqlite-simple.git Library + default-language: Haskell2010 hs-source-dirs: src exposed-modules: @@ -63,3 +64,40 @@ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-orphans -fno-warn-unused-do-bind + + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: TestSuite.hs + + other-modules: App + , Tests + , SafeCWD + + build-depends: + HUnit >= 1.2 && < 2, + MonadCatchIO-transformers >= 0.2 && < 0.4, + base >= 4 && < 5, + bytestring >= 0.9 && < 0.11, + clientsession, + configurator >= 0.1 && < 0.3, + containers >= 0.3, + directory >= 1.0 && < 1.3, + errors >= 1.3.1 && < 1.4, + lens >= 3.7.0.1 && < 3.8, + mtl >= 2, + snap-core, + snap, + snaplet-sqlite-simple, + sqlite-simple, + stm >= 2.4, + test-framework >= 0.6 && < 0.9, + test-framework-hunit >= 0.2.7 && < 0.4, + text >= 0.11 && < 0.12, + time >= 1.1, + transformers >= 0.2 + + default-extensions: + FlexibleInstances 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 @@ -38,29 +38,29 @@ ) where ------------------------------------------------------------------------------ +import Control.Concurrent import qualified Data.Configurator as C import qualified Data.HashMap.Lazy as HM -import qualified Data.Text as T -import Data.Text (Text) import Data.Maybe -import Data.Pool -import Database.SQLite3 (SQLData(..)) +import Data.Text (Text) +import qualified Data.Text as T import qualified Database.SQLite.Simple as S -import qualified Database.SQLite.Simple.ToField as S import Database.SQLite.Simple.FromField import Database.SQLite.Simple.FromRow +import qualified Database.SQLite.Simple.ToField as S import Database.SQLite.Simple.Types +import Database.SQLite3 (SQLData(..)) +import Paths_snaplet_sqlite_simple import Snap import Snap.Snaplet.Auth -import Snap.Snaplet.SqliteSimple import Snap.Snaplet.Session +import Snap.Snaplet.SqliteSimple import Web.ClientSession -import Paths_snaplet_sqlite_simple data SqliteAuthManager = SqliteAuthManager { pamTable :: AuthTable - , pamConnPool :: Pool S.Connection + , pamConnPool :: MVar S.Connection } @@ -78,7 +78,7 @@ key <- liftIO $ getKey (asSiteKey authSettings) let tableDesc = defAuthTable { tblName = authTable } let manager = SqliteAuthManager tableDesc $ - sqlitePool $ db ^# snapletValue + sqliteConn $ db ^# snapletValue liftIO $ createTableIfMissing manager rng <- liftIO mkRNG return $ AuthManager @@ -162,7 +162,7 @@ -- | Create the user table if it doesn't exist. createTableIfMissing :: SqliteAuthManager -> IO () createTableIfMissing SqliteAuthManager{..} = do - withResource pamConnPool $ \conn -> do + withMVar pamConnPool $ \conn -> do authTblExists <- tableExists conn $ tblName pamTable unless authTblExists $ createInitialSchema conn pamTable upgradeSchema conn pamTable 0 @@ -225,14 +225,14 @@ querySingle :: (ToRow q, FromRow a) - => Pool S.Connection -> Query -> q -> IO (Maybe a) -querySingle pool q ps = withResource pool $ \conn -> return . listToMaybe =<< + => MVar S.Connection -> Query -> q -> IO (Maybe a) +querySingle pool q ps = withMVar pool $ \conn -> return . listToMaybe =<< S.query conn q ps authExecute :: ToRow q - => Pool S.Connection -> Query -> q -> IO () + => MVar S.Connection -> Query -> q -> IO () authExecute pool q ps = do - withResource pool $ \conn -> S.execute conn q ps + withMVar pool $ \conn -> S.execute conn q ps return () instance S.ToField Password where @@ -351,7 +351,7 @@ instance IAuthBackend SqliteAuthManager where save SqliteAuthManager{..} u@AuthUser{..} = do let (qstr, params) = saveQuery pamTable u - withResource pamConnPool $ \conn -> do + withMVar pamConnPool $ \conn -> do -- Note that the user INSERT here expects that duplicate -- login error checking has been done already at the level -- that calls here. diff --git a/src/Snap/Snaplet/SqliteSimple.hs b/src/Snap/Snaplet/SqliteSimple.hs --- a/src/Snap/Snaplet/SqliteSimple.hs +++ b/src/Snap/Snaplet/SqliteSimple.hs @@ -62,6 +62,7 @@ Sqlite(..) , HasSqlite(..) , sqliteInit + , withSqlite -- * Wrappers and re-exports , query @@ -85,6 +86,7 @@ import Prelude hiding (catch) +import Control.Concurrent import Control.Monad.CatchIO hiding (Handler) import Control.Monad.IO.Class import Control.Monad.State @@ -93,7 +95,6 @@ import qualified Data.Configurator as C import Data.List import Data.Maybe -import Data.Pool import Database.SQLite.Simple.ToRow import Database.SQLite.Simple.FromRow import qualified Database.SQLite.Simple as S @@ -106,8 +107,8 @@ -- | The state for the sqlite-simple snaplet. To use it in your app -- include this in your application state and use 'sqliteInit' to initialize it. data Sqlite = Sqlite - { sqlitePool :: Pool S.Connection - -- ^ Function for retrieving the connection pool + { sqliteConn :: MVar S.Connection + -- ^ Function for retrieving the database connection } @@ -131,7 +132,7 @@ -- | A convenience instance to make it easier to use this snaplet in the -- Initializer monad like this: -- --- > d <- nestSnaplet "db" db pgsInit +-- > d <- nestSnaplet "db" db sqliteInit -- > count <- liftIO $ runReaderT (execute "INSERT ..." params) d instance (MonadCatchIO m) => HasSqlite (ReaderT (Snaplet Sqlite) m) where getSqliteState = asks (\sqlsnaplet -> sqlsnaplet ^# snapletValue) @@ -164,12 +165,8 @@ return $ db let ci = fromMaybe (error $ intercalate "\n" errs) mci - stripes <- liftIO $ C.lookupDefault 1 config "numStripes" - idle <- liftIO $ C.lookupDefault 5 config "idleTime" - resources <- liftIO $ C.lookupDefault 20 config "maxResourcesPerStripe" - pool <- liftIO $ createPool (S.open ci) S.close stripes - (realToFrac (idle :: Double)) resources - return $ Sqlite pool + conn <- liftIO $ (S.open ci >>= newMVar) + return $ Sqlite conn where description = "Sqlite abstraction" datadir = Just $ liftM (++"/resources/db") getDataDir @@ -178,29 +175,40 @@ ------------------------------------------------------------------------------ -- | Convenience function for executing a function that needs a database -- connection. +-- +-- /Multi-threading considerations/: The database connection is mutexed +-- such that only a single thread can read or write at any given time. +-- This means we lose database access parallelism. Please see +-- for more +-- information. withSqlite :: (HasSqlite m) => (S.Connection -> IO b) -> m b withSqlite f = do s <- getSqliteState - let pool = sqlitePool s - liftIO $ withResource pool f - + let conn = sqliteConn s + liftIO $ withMVar conn f ------------------------------------------------------------------------------ --- | See 'P.query' +-- | See 'S.query' +-- +-- See also 'withSqlite' for notes on concurrent access. query :: (HasSqlite m, ToRow q, FromRow r) => S.Query -> q -> m [r] query q params = withSqlite (\c -> S.query c q params) ------------------------------------------------------------------------------ --- | See 'P.query_' +-- | See 'S.query_' +-- +-- See also 'withSqlite' for notes on concurrent access. query_ :: (HasSqlite m, FromRow r) => S.Query -> m [r] query_ q = withSqlite (\c -> S.query_ c q) ------------------------------------------------------------------------------ -- | +-- +-- See also 'withSqlite' for notes on concurrent access. execute :: (HasSqlite m, ToRow q, MonadCatchIO m) => S.Query -> q -> m () execute template qs = withSqlite (\c -> S.execute c template qs) @@ -208,6 +216,8 @@ ------------------------------------------------------------------------------ -- | +-- +-- See also 'withSqlite' for notes on concurrent access. execute_ :: (HasSqlite m, MonadCatchIO m) => S.Query -> m () execute_ template = withSqlite (\c -> S.execute_ c template) diff --git a/test/App.hs b/test/App.hs new file mode 100644 --- /dev/null +++ b/test/App.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module App where + +------------------------------------------------------------------------------ +import Control.Lens +import Control.Monad +import Prelude hiding (catch) +------------------------------------------------------------------------------ + +import Snap +import Snap.Snaplet.Auth +import Snap.Snaplet.Session +import Snap.Snaplet.SqliteSimple +import Snap.Snaplet.Auth.Backends.SqliteSimple +import Snap.Snaplet.Session.Backends.CookieSession + +------------------------------------------------------------------------------ +data App = App + { + _sess :: Snaplet SessionManager + , _db :: Snaplet Sqlite + , _auth :: Snaplet (AuthManager App) + } + +makeLenses ''App + +instance HasSqlite (Handler b App) where + getSqliteState = with db get + +------------------------------------------------------------------------------ +appInit :: SnapletInit App App +appInit = makeSnaplet "app" "Test application" Nothing $ do + s <- nestSnaplet "sess" sess $ + initCookieSessionManager "site_key.txt" "sess" (Just 3600) + + -- Initialize auth that's backed by an sqlite database + d <- nestSnaplet "db" db sqliteInit + a <- nestSnaplet "auth" auth $ initSqliteAuth sess d + return $ App s d a + diff --git a/test/SafeCWD.hs b/test/SafeCWD.hs new file mode 100644 --- /dev/null +++ b/test/SafeCWD.hs @@ -0,0 +1,31 @@ +module SafeCWD + ( inDir + , removeDirectoryRecursiveSafe + ) where + +import Control.Concurrent.QSem +import Control.Exception +import Control.Monad +import System.Directory +import System.IO.Unsafe + +sem :: QSem +sem = unsafePerformIO $ newQSem 1 + +inDir :: Bool -> FilePath -> IO a -> IO a +inDir startClean dir action = bracket before after (const action) + where + before = do + waitQSem sem + cwd <- getCurrentDirectory + when startClean $ removeDirectoryRecursiveSafe dir + createDirectoryIfMissing True dir + setCurrentDirectory dir + return cwd + after cwd = do + setCurrentDirectory cwd + signalQSem sem + +removeDirectoryRecursiveSafe :: String -> IO () +removeDirectoryRecursiveSafe p = + doesDirectoryExist p >>= flip when (removeDirectoryRecursive p) diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +------------------------------------------------------------------------------ +import Control.Exception hiding (Handler) +import Control.Monad +import Prelude hiding (catch) +import Test.Framework +------------------------------------------------------------------------------ + +import SafeCWD +import qualified Tests as Tests + + +------------------------------------------------------------------------------ +main :: IO () +main = + inDir True "non-cabal-appdir" runTests + where + runTests = do + defaultMain tests `finally` (return ()) + + tests = + [ mutuallyExclusive $ testGroup "with db migration" [Tests.testsDbInit] + , mutuallyExclusive $ testGroup "from empty db" [Tests.tests] + ] diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,165 @@ +{-# 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