snaplet-hdbc 0.7 → 0.7.1

raw patch · 3 files changed

+71/−22 lines, 3 filesdep +lifted-basedep +transformersdep +transformers-basedep ~monad-controlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: lifted-base, transformers, transformers-base

Dependency ranges changed: monad-control

API changes (from Hackage documentation)

Files

• snaplet-hdbc.cabal +5/−2
• src/Snap/Snaplet/Hdbc.hs +43/−13
• src/Snap/Snaplet/Hdbc/Types.hs +23/−7

@@ -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 @@     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

@@ -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 @@ 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,6 +87,17 @@ 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@@ -95,14 +105,25 @@  -- | 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 @@ -- 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 @@ 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 @@                  --   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' :: 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 @@   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

@@ -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 @@   {   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