Permalink
Browse files

Switch back to resource-pool-catchio for now

  • Loading branch information...
1 parent 568c854 commit f96ca9f7871885e6e5908f48c96b06f426ce1fef @norm2782 committed Dec 30, 2011
Showing with 37 additions and 83 deletions.
  1. +17 −19 snaplet-hdbc.cabal
  2. +12 −41 src/Snap/Snaplet/Hdbc.hs
  3. +8 −23 src/Snap/Snaplet/Hdbc/Types.hs
View
@@ -1,5 +1,5 @@
name: snaplet-hdbc
-version: 0.7.1
+version: 0.7.2
synopsis: HDBC snaplet for Snap Framework
description: This snaplet consists of two parts: an HDBC abstraction snaplet
and an HDBC authentication backend for Snap's authentication
@@ -28,24 +28,22 @@ Library
Snap.Snaplet.Hdbc.Types
build-depends:
- base >= 4 && < 5,
- bytestring >= 0.9.1 && < 0.10,
- clientsession >= 0.7.2 && < 0.8,
- containers >= 0.3 && < 0.5,
- convertible >= 1.0 && < 1.1,
- data-lens >= 2.0.1 && < 2.1,
- data-lens-template >= 2.1 && < 2.2,
- HDBC >= 2.2 && < 2.4,
- lifted-base >= 0.1 && < 0.2,
- mtl > 2.0 && < 2.1,
- monad-control >= 0.2 && < 0.4,
- resource-pool >= 0.2 && < 0.3,
- snap >= 0.6 && < 0.8,
- text >= 0.11 && < 0.12,
- time >= 1.1 && < 1.5,
- transformers >= 0.2 && < 0.3,
- transformers-base >= 0.2 && < 0.5,
- unordered-containers >= 0.1.4 && < 0.2
+ base >= 4 && < 5,
+ bytestring >= 0.9.1 && < 0.10,
+ clientsession >= 0.7.2 && < 0.8,
+ containers >= 0.3 && < 0.5,
+ convertible >= 1.0 && < 1.1,
+ data-lens >= 2.0.1 && < 2.1,
+ data-lens-template >= 2.1 && < 2.2,
+ HDBC >= 2.2 && < 2.4,
+ MonadCatchIO-transformers >= 0.2.1 && < 0.3,
+ mtl > 2.0 && < 2.1,
+ resource-pool-catchio >= 0.2 && < 0.3,
+ snap >= 0.6 && < 0.8,
+ text >= 0.11 && < 0.12,
+ time >= 1.1 && < 1.5,
+ transformers >= 0.2 && < 0.3,
+ unordered-containers >= 0.1.4 && < 0.2
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
-fno-warn-orphans -fno-warn-unused-do-bind
View
@@ -1,10 +1,10 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
-- | 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
@@ -79,6 +79,9 @@ module Snap.Snaplet.Hdbc (
import Prelude hiding (catch)
import Control.Concurrent.MVar
+import Control.Exception (SomeException)
+import Control.Monad.CatchIO
+import Control.Monad.IO.Class
import Data.Map (Map)
import Data.Pool
import qualified Database.HDBC as HDBC
@@ -87,18 +90,6 @@ import Database.HDBC.ColTypes
import Snap.Snaplet
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
type Row = Map String SqlValue
@@ -107,24 +98,11 @@ type Row = Map String SqlValue
-- can find the connection source.
class ( IConnection c
, ConnSrc s
-#if MIN_VERSION_monad_control(0,3,0)
- , MonadBaseControl IO m
-#else
- , MonadControlIO m
-#endif
+ , MonadCatchIO m
)
=> HasHdbc m c s | m -> c s where
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 HdbcPool c = HdbcSnaplet c Pool
@@ -137,14 +115,11 @@ type HdbcPool c = HdbcSnaplet c Pool
hdbcInit
:: ( ConnSrc s
, IConnection c
-#if MIN_VERSION_monad_control(0,3,0)
- , MonadBase IO (Initializer b (HdbcSnaplet c s))
-#endif
)
=> s c
-> SnapletInit b (HdbcSnaplet c s)
hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ do
- mv <- liftBase newEmptyMVar
+ mv <- liftIO newEmptyMVar
return $ HdbcSnaplet src mv
@@ -153,7 +128,7 @@ hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ do
withHdbc :: HasHdbc m c s => (c -> IO a) -> m a
withHdbc f = do
st <- getHdbcState
- withConn st (liftBase . f)
+ withConn st (liftIO . f)
-- | 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'.
@@ -173,8 +148,8 @@ query
-- row. Can be the empty list.
query sql bind = do
stmt <- prepare sql
- liftBase $ HDBC.execute stmt bind
- liftBase $ HDBC.fetchAllRowsMap stmt
+ liftIO $ HDBC.execute stmt bind
+ liftIO $ HDBC.fetchAllRowsMap stmt
-- | 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
@@ -183,13 +158,13 @@ query sql bind = do
query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer
query' sql bind = withTransaction $ \conn -> do
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' :: HasHdbc m c s => String -> [SqlValue] -> m Integer-}
{- query' sql bind = withTransaction' $ do-}
{- 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
-- transaction will be rolled back, and the exception rethrown.
@@ -212,11 +187,7 @@ withTransaction' action = do
commit
return r
where doRollback = rollback `catch` doRollbackHandler
-#if MIN_VERSION_monad_control(0,3,0)
- doRollbackHandler :: MonadBaseControl IO m => SomeException -> m ()
-#else
- doRollbackHandler :: MonadControlIO m => SomeException -> m ()
-#endif
+ doRollbackHandler :: MonadCatchIO m => SomeException -> m ()
doRollbackHandler _ = return ()
-- | The functions provided below are wrappers around the original HDBC
@@ -1,24 +1,15 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
module Snap.Snaplet.Hdbc.Types where
import Control.Concurrent.MVar
+import Control.Monad.CatchIO
import Control.Monad.State
import Database.HDBC (IConnection())
import qualified Database.HDBC as HDBC
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
-- HDBC connection.
data HdbcSnaplet c s
@@ -27,15 +18,9 @@ data HdbcSnaplet c s
{ connSrc :: s 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
- withConn :: (MonadControlIO m, IConnection c) => HdbcSnaplet c s -> (c -> m b) -> m b
- closeConn :: (MonadControlIO m, IConnection c) => HdbcSnaplet c s -> c -> m ()
-#endif
+ withConn :: (MonadCatchIO m, IConnection c) => HdbcSnaplet c s -> (c -> m b) -> m b
+ closeConn :: (MonadCatchIO m, IConnection c) => HdbcSnaplet c s -> c -> m ()
instance ConnSrc Pool where
withConn = withResource . connSrc
@@ -44,12 +29,12 @@ instance ConnSrc Pool where
instance ConnSrc IO where
withConn st fn = do
let cv = connVar st
- emp <- liftBase $ isEmptyMVar cv
+ emp <- liftIO $ isEmptyMVar cv
conn <- if emp
then do
- conn <- liftBase $ connSrc st
- liftBase $ putMVar cv conn
+ conn <- liftIO $ connSrc st
+ liftIO $ putMVar cv conn
return conn
- else liftBase $ readMVar cv
+ else liftIO $ readMVar cv
fn conn
- closeConn _ = liftBase . HDBC.disconnect
+ closeConn _ = liftIO . HDBC.disconnect

0 comments on commit f96ca9f

Please sign in to comment.