Permalink
Browse files

Make db connection a singleton

  • Loading branch information...
nurpax committed Dec 30, 2012
1 parent 87ccd6d commit 3957f722cce6abf7e1059f481668379e05b62286
Showing with 19 additions and 24 deletions.
  1. +14 −14 src/Snap/Snaplet/Auth/Backends/SqliteSimple.hs
  2. +5 −10 src/Snap/Snaplet/SqliteSimple.hs
@@ -38,29 +38,29 @@ module Snap.Snaplet.Auth.Backends.SqliteSimple
) 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
}
@@ -162,7 +162,7 @@ upgradeSchema conn pam fromVersion = do
-- | 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 @@ instance FromRow AuthUser where
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 @@ saveQuery at u@AuthUser{..} = maybe insertQuery updateQuery userId
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.
@@ -86,6 +86,7 @@ module Snap.Snaplet.SqliteSimple (
import Prelude hiding (catch)
+import Control.Concurrent
import Control.Monad.CatchIO hiding (Handler)
import Control.Monad.IO.Class
import Control.Monad.State
@@ -94,7 +95,6 @@ import Control.Monad.Trans.Writer
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
@@ -107,7 +107,7 @@ import Paths_snaplet_sqlite_simple
-- | 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
+ { sqlitePool :: MVar S.Connection
-- ^ Function for retrieving the connection pool
}
@@ -165,12 +165,8 @@ sqliteInit = makeSnaplet "sqlite-simple" description datadir $ do
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
@@ -184,8 +180,7 @@ withSqlite :: (HasSqlite m)
withSqlite f = do
s <- getSqliteState
let pool = sqlitePool s
- liftIO $ withResource pool f
-
+ liftIO $ withMVar pool f
------------------------------------------------------------------------------
-- | See 'P.query'

0 comments on commit 3957f72

Please sign in to comment.