diff --git a/snaplet-hdbc.cabal b/snaplet-hdbc.cabal --- a/snaplet-hdbc.cabal +++ b/snaplet-hdbc.cabal @@ -1,5 +1,5 @@ name: snaplet-hdbc -version: 0.7.1.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 @@ 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 diff --git a/src/Snap/Snaplet/Hdbc.hs b/src/Snap/Snaplet/Hdbc.hs --- a/src/Snap/Snaplet/Hdbc.hs +++ b/src/Snap/Snaplet/Hdbc.hs @@ -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 @@ 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 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 @@ -- 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 @@ 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 @@ 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 @@ -- 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' :: 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 @@ 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 diff --git a/src/Snap/Snaplet/Hdbc/Types.hs b/src/Snap/Snaplet/Hdbc/Types.hs --- a/src/Snap/Snaplet/Hdbc/Types.hs +++ b/src/Snap/Snaplet/Hdbc/Types.hs @@ -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 @@ { 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 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