Skip to content

Commit

Permalink
Switch back to resource-pool-catchio for now
Browse files Browse the repository at this point in the history
  • Loading branch information
@norm2782
norm2782 committed Dec 30, 2011
1 parent 568c854 commit f96ca9f
Show file tree
Hide file tree
Showing 3 changed files with 37 additions and 83 deletions.
36 changes: 17 additions & 19 deletions snaplet-hdbc.cabal
View file
Original file line number Original file line Diff line number Diff line change
@@ -1,5 +1,5 @@
name: snaplet-hdbc name: snaplet-hdbc
version: 0.7.1 version: 0.7.2
synopsis: HDBC snaplet for Snap Framework synopsis: HDBC snaplet for Snap Framework
description: This snaplet consists of two parts: an HDBC abstraction snaplet description: This snaplet consists of two parts: an HDBC abstraction snaplet
and an HDBC authentication backend for Snap's authentication and an HDBC authentication backend for Snap's authentication
Expand Down Expand Up @@ -28,24 +28,22 @@ Library
Snap.Snaplet.Hdbc.Types Snap.Snaplet.Hdbc.Types


build-depends: build-depends:
base >= 4 && < 5, base >= 4 && < 5,
bytestring >= 0.9.1 && < 0.10, bytestring >= 0.9.1 && < 0.10,
clientsession >= 0.7.2 && < 0.8, clientsession >= 0.7.2 && < 0.8,
containers >= 0.3 && < 0.5, containers >= 0.3 && < 0.5,
convertible >= 1.0 && < 1.1, convertible >= 1.0 && < 1.1,
data-lens >= 2.0.1 && < 2.1, data-lens >= 2.0.1 && < 2.1,
data-lens-template >= 2.1 && < 2.2, data-lens-template >= 2.1 && < 2.2,
HDBC >= 2.2 && < 2.4, HDBC >= 2.2 && < 2.4,
lifted-base >= 0.1 && < 0.2, MonadCatchIO-transformers >= 0.2.1 && < 0.3,
mtl > 2.0 && < 2.1, mtl > 2.0 && < 2.1,
monad-control >= 0.2 && < 0.4, resource-pool-catchio >= 0.2 && < 0.3,
resource-pool >= 0.2 && < 0.3, snap >= 0.6 && < 0.8,
snap >= 0.6 && < 0.8, text >= 0.11 && < 0.12,
text >= 0.11 && < 0.12, time >= 1.1 && < 1.5,
time >= 1.1 && < 1.5, transformers >= 0.2 && < 0.3,
transformers >= 0.2 && < 0.3, unordered-containers >= 0.1.4 && < 0.2
transformers-base >= 0.2 && < 0.5,
unordered-containers >= 0.1.4 && < 0.2


ghc-options: -Wall -fwarn-tabs -funbox-strict-fields ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
-fno-warn-orphans -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-unused-do-bind
53 changes: 12 additions & 41 deletions src/Snap/Snaplet/Hdbc.hs
View file
Original file line number Original file line Diff line number Diff line change
@@ -1,10 +1,10 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}


-- | This module provides a very thin wrapper around HDBC. It wraps some of the -- | This module provides a very thin wrapper around HDBC. It wraps some of the
-- HDBC functions in more convenient functions and re-exports the rest of the -- HDBC functions in more convenient functions and re-exports the rest of the
Expand Down Expand Up @@ -79,6 +79,9 @@ module Snap.Snaplet.Hdbc (
import Prelude hiding (catch) import Prelude hiding (catch)


import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Exception (SomeException)
import Control.Monad.CatchIO
import Control.Monad.IO.Class
import Data.Map (Map) import Data.Map (Map)
import Data.Pool import Data.Pool
import qualified Database.HDBC as HDBC import qualified Database.HDBC as HDBC
Expand All @@ -87,18 +90,6 @@ import Database.HDBC.ColTypes
import Snap.Snaplet import Snap.Snaplet
import Snap.Snaplet.Hdbc.Types import Snap.Snaplet.Hdbc.Types


#if MIN_VERSION_monad_control(0,3,0)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Base
import Control.Exception.Lifted
#else
import Control.Monad.IO.Control (MonadControlIO(..))
import Control.Monad.IO.Class (liftIO)
import Control.Exception.Control hiding (Handler)
#define control controlIO
#define liftBase liftIO
#endif

-- | A map with the column name as key and the value from the database as value -- | A map with the column name as key and the value from the database as value
type Row = Map String SqlValue type Row = Map String SqlValue


Expand All @@ -107,24 +98,11 @@ type Row = Map String SqlValue
-- can find the connection source. -- can find the connection source.
class ( IConnection c class ( IConnection c
, ConnSrc s , ConnSrc s
#if MIN_VERSION_monad_control(0,3,0) , MonadCatchIO m
, MonadBaseControl IO m
#else
, MonadControlIO m
#endif
) )
=> HasHdbc m c s | m -> c s where => HasHdbc m c s | m -> c s where
getHdbcState :: m (HdbcSnaplet c s) getHdbcState :: m (HdbcSnaplet c s)


-- | This is (hopefully) a temporary instance, which will disppear once the
-- entire snap framework is switched to monad-control.
#if MIN_VERSION_monad_control(0,3,0)

#else
instance MonadControlIO (Handler b v) where
liftControlIO f = liftBase (f return)
#endif

type HdbcIO c = HdbcSnaplet c IO type HdbcIO c = HdbcSnaplet c IO
type HdbcPool c = HdbcSnaplet c Pool type HdbcPool c = HdbcSnaplet c Pool


Expand All @@ -137,14 +115,11 @@ type HdbcPool c = HdbcSnaplet c Pool
hdbcInit hdbcInit
:: ( ConnSrc s :: ( ConnSrc s
, IConnection c , IConnection c
#if MIN_VERSION_monad_control(0,3,0)
, MonadBase IO (Initializer b (HdbcSnaplet c s))
#endif
) )
=> s c => s c
-> SnapletInit b (HdbcSnaplet c s) -> SnapletInit b (HdbcSnaplet c s)
hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ do hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ do
mv <- liftBase newEmptyMVar mv <- liftIO newEmptyMVar
return $ HdbcSnaplet src mv return $ HdbcSnaplet src mv




Expand All @@ -153,7 +128,7 @@ hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ do
withHdbc :: HasHdbc m c s => (c -> IO a) -> m a withHdbc :: HasHdbc m c s => (c -> IO a) -> m a
withHdbc f = do withHdbc f = do
st <- getHdbcState st <- getHdbcState
withConn st (liftBase . f) withConn st (liftIO . f)


-- | Get a new connection from the resource pool, apply the provided function -- | Get a new connection from the resource pool, apply the provided function
-- to it and return the result in of the compution in monad 'm'. -- to it and return the result in of the compution in monad 'm'.
Expand All @@ -173,8 +148,8 @@ query
-- row. Can be the empty list. -- row. Can be the empty list.
query sql bind = do query sql bind = do
stmt <- prepare sql stmt <- prepare sql
liftBase $ HDBC.execute stmt bind liftIO $ HDBC.execute stmt bind
liftBase $ HDBC.fetchAllRowsMap stmt liftIO $ HDBC.fetchAllRowsMap stmt


-- | Similar to 'query', but instead of returning a list of 'Row's, it returns -- | Similar to 'query', but instead of returning a list of 'Row's, it returns
-- an 'Integer' indicating the numbers of affected rows. This is typically used -- an 'Integer' indicating the numbers of affected rows. This is typically used
Expand All @@ -183,13 +158,13 @@ query sql bind = do
query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer
query' sql bind = withTransaction $ \conn -> do query' sql bind = withTransaction $ \conn -> do
stmt <- HDBC.prepare conn sql stmt <- HDBC.prepare conn sql
liftBase $ HDBC.execute stmt bind liftIO $ HDBC.execute stmt bind


-- query' below doesn't work that well, due to withTransaction' -- query' below doesn't work that well, due to withTransaction'
{- query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer-} {- query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer-}
{- query' sql bind = withTransaction' $ do-} {- query' sql bind = withTransaction' $ do-}
{- stmt <- prepare sql-} {- stmt <- prepare sql-}
{- liftBase $ HDBC.execute stmt bind-} {- liftIO $ HDBC.execute stmt bind-}


-- | Run an action inside a transaction. If the action throws an exception, the -- | Run an action inside a transaction. If the action throws an exception, the
-- transaction will be rolled back, and the exception rethrown. -- transaction will be rolled back, and the exception rethrown.
Expand All @@ -212,11 +187,7 @@ withTransaction' action = do
commit commit
return r return r
where doRollback = rollback `catch` doRollbackHandler where doRollback = rollback `catch` doRollbackHandler
#if MIN_VERSION_monad_control(0,3,0) doRollbackHandler :: MonadCatchIO m => SomeException -> m ()
doRollbackHandler :: MonadBaseControl IO m => SomeException -> m ()
#else
doRollbackHandler :: MonadControlIO m => SomeException -> m ()
#endif
doRollbackHandler _ = return () doRollbackHandler _ = return ()


-- | The functions provided below are wrappers around the original HDBC -- | The functions provided below are wrappers around the original HDBC
Expand Down
31 changes: 8 additions & 23 deletions src/Snap/Snaplet/Hdbc/Types.hs
View file
Original file line number Original file line Diff line number Diff line change
@@ -1,24 +1,15 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}


module Snap.Snaplet.Hdbc.Types where module Snap.Snaplet.Hdbc.Types where


import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Monad.CatchIO
import Control.Monad.State import Control.Monad.State
import Database.HDBC (IConnection()) import Database.HDBC (IConnection())
import qualified Database.HDBC as HDBC import qualified Database.HDBC as HDBC
import Data.Pool import Data.Pool


#if MIN_VERSION_monad_control(0,3,0)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Base (liftBase)
#else
import Control.Monad.IO.Control (MonadControlIO)
#define control controlIO
#define liftBase liftIO
#endif

-- | The snaplet state type containing a resource pool, parameterised by a raw -- | The snaplet state type containing a resource pool, parameterised by a raw
-- HDBC connection. -- HDBC connection.
data HdbcSnaplet c s data HdbcSnaplet c s
Expand All @@ -27,15 +18,9 @@ data HdbcSnaplet c s
{ connSrc :: s c { connSrc :: s c
, connVar :: MVar c } , connVar :: MVar c }


#if MIN_VERSION_monad_control(0,3,0)
class ConnSrc s where
withConn :: (MonadBaseControl IO m, IConnection c) => HdbcSnaplet c s -> (c -> m b) -> m b
closeConn :: (MonadBaseControl IO m, IConnection c) => HdbcSnaplet c s -> c -> m ()
#else
class ConnSrc s where class ConnSrc s where
withConn :: (MonadControlIO m, IConnection c) => HdbcSnaplet c s -> (c -> m b) -> m b withConn :: (MonadCatchIO m, IConnection c) => HdbcSnaplet c s -> (c -> m b) -> m b
closeConn :: (MonadControlIO m, IConnection c) => HdbcSnaplet c s -> c -> m () closeConn :: (MonadCatchIO m, IConnection c) => HdbcSnaplet c s -> c -> m ()
#endif


instance ConnSrc Pool where instance ConnSrc Pool where
withConn = withResource . connSrc withConn = withResource . connSrc
Expand All @@ -44,12 +29,12 @@ instance ConnSrc Pool where
instance ConnSrc IO where instance ConnSrc IO where
withConn st fn = do withConn st fn = do
let cv = connVar st let cv = connVar st
emp <- liftBase $ isEmptyMVar cv emp <- liftIO $ isEmptyMVar cv
conn <- if emp conn <- if emp
then do then do
conn <- liftBase $ connSrc st conn <- liftIO $ connSrc st
liftBase $ putMVar cv conn liftIO $ putMVar cv conn
return conn return conn
else liftBase $ readMVar cv else liftIO $ readMVar cv
fn conn fn conn
closeConn _ = liftBase . HDBC.disconnect closeConn _ = liftIO . HDBC.disconnect

0 comments on commit f96ca9f

Please sign in to comment.