Skip to content
Browse files

Support both monad-control-0.2.x and monad-control-0.3.x

  • Loading branch information...
1 parent e5cffc0 commit 3db7b8c12d260519cc82924f24882c64c20ffd9d @norm2782 committed Dec 21, 2011
Showing with 71 additions and 22 deletions.
  1. +5 −2 snaplet-hdbc.cabal
  2. +43 −13 src/Snap/Snaplet/Hdbc.hs
  3. +23 −7 src/Snap/Snaplet/Hdbc/Types.hs
View
7 snaplet-hdbc.cabal
@@ -1,5 +1,5 @@
name: snaplet-hdbc
-version: 0.7
+version: 0.7.1
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
@@ -36,12 +36,15 @@ Library
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.3,
+ 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
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
View
56 src/Snap/Snaplet/Hdbc.hs
@@ -1,8 +1,10 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleContexts #-}
-- | 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
@@ -77,9 +79,6 @@ module Snap.Snaplet.Hdbc (
import Prelude hiding (catch)
import Control.Concurrent.MVar
-import Control.Exception.Control hiding (Handler)
-import Control.Monad.IO.Control
-import Control.Monad.State
import Data.Map (Map)
import Data.Pool
import qualified Database.HDBC as HDBC
@@ -88,21 +87,43 @@ 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
-- | Instantiate this typeclass on 'Handler b YourSnapletState' so this snaplet
-- can find the connection source.
-class (IConnection c, ConnSrc s, MonadControlIO m)
+class ( IConnection c
+ , ConnSrc s
+#if MIN_VERSION_monad_control(0,3,0)
+ , MonadBaseControl IO m
+#else
+ , MonadControlIO m
+#endif
+ )
=> 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 'MonadControlIO'.
+-- 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 = liftIO (f return)
+ liftControlIO f = liftBase (f return)
+#endif
type HdbcIO c = HdbcSnaplet c IO
type HdbcPool c = HdbcSnaplet c Pool
@@ -114,11 +135,16 @@ type HdbcPool c = HdbcSnaplet c Pool
-- unloaded, the 'disconnect' function is called to close any remaining
-- connections.
hdbcInit
- :: (ConnSrc s, IConnection c)
+ :: ( 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 <- liftIO newEmptyMVar
+ mv <- liftBase newEmptyMVar
return $ HdbcSnaplet src mv
@@ -127,7 +153,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 (liftIO . f)
+ withConn st (liftBase . 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'.
@@ -147,8 +173,8 @@ query
-- row. Can be the empty list.
query sql bind = do
stmt <- prepare sql
- liftIO $ HDBC.execute stmt bind
- liftIO $ HDBC.fetchAllRowsMap stmt
+ liftBase $ HDBC.execute stmt bind
+ liftBase $ 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
@@ -157,13 +183,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
- liftIO $ HDBC.execute stmt bind
+ liftBase $ 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-}
- {- liftIO $ HDBC.execute stmt bind-}
+ {- liftBase $ 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.
@@ -186,7 +212,11 @@ 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 _ = return ()
-- | The functions provided below are wrappers around the original HDBC
View
30 src/Snap/Snaplet/Hdbc/Types.hs
@@ -1,14 +1,24 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
module Snap.Snaplet.Hdbc.Types where
import Control.Concurrent.MVar
-import Control.Monad.IO.Control
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
@@ -17,23 +27,29 @@ 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
instance ConnSrc Pool where
- withConn = withResource . connSrc
+ withConn = undefined --withResource . connSrc
closeConn _ _ = return ()
instance ConnSrc IO where
withConn st fn = do
let cv = connVar st
- emp <- liftIO $ isEmptyMVar cv
+ emp <- liftBase $ isEmptyMVar cv
conn <- if emp
then do
- conn <- liftIO $ connSrc st
- liftIO $ putMVar cv conn
+ conn <- liftBase $ connSrc st
+ liftBase $ putMVar cv conn
return conn
- else liftIO $ readMVar cv
+ else liftBase $ readMVar cv
fn conn
- closeConn _ = liftIO . HDBC.disconnect
+ closeConn _ = liftBase . HDBC.disconnect

0 comments on commit 3db7b8c

Please sign in to comment.
Something went wrong with that request. Please try again.