snaplet-sqlite-simple 0.3.1 → 0.4.0
raw patch · 8 files changed
+347/−44 lines, 8 filesdep +HUnitdep +containersdep +directorydep ~MonadCatchIO-transformersdep ~bytestringdep ~clientsession
Dependencies added: HUnit, containers, directory, errors, lens, snap-core, snaplet-sqlite-simple, stm, test-framework, test-framework-hunit, time
Dependency ranges changed: MonadCatchIO-transformers, bytestring, clientsession, configurator, mtl, snap, sqlite-simple, transformers
Files
- resources/db/devel.cfg +0/−12
- snaplet-sqlite-simple.cabal +40/−2
- src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs +15/−15
- src/Snap/Snaplet/SqliteSimple.hs +25/−15
- test/App.hs +43/−0
- test/SafeCWD.hs +31/−0
- test/TestSuite.hs +28/−0
- test/Tests.hs +165/−0
resources/db/devel.cfg view
@@ -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
snaplet-sqlite-simple.cabal view
@@ -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 <jjhellst@gmail.com> 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
src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs view
@@ -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.
src/Snap/Snaplet/SqliteSimple.hs view
@@ -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+-- <https://github.com/nurpax/snaplet-sqlite-simple/issues/5> 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)
+ test/App.hs view
@@ -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+
+ test/SafeCWD.hs view
@@ -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)
+ test/TestSuite.hs view
@@ -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]+ ]
+ test/Tests.hs view
@@ -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