Skip to content
This repository
Browse code

Switch back to resource-pool-catchio for now

  • Loading branch information...
commit f96ca9f7871885e6e5908f48c96b06f426ce1fef 1 parent 568c854
Jurriën Stutterheim authored
36 snaplet-hdbc.cabal
... ... @@ -1,5 +1,5 @@
1 1 name: snaplet-hdbc
2   -version: 0.7.1
  2 +version: 0.7.2
3 3 synopsis: HDBC snaplet for Snap Framework
4 4 description: This snaplet consists of two parts: an HDBC abstraction snaplet
5 5 and an HDBC authentication backend for Snap's authentication
@@ -28,24 +28,22 @@ Library
28 28 Snap.Snaplet.Hdbc.Types
29 29
30 30 build-depends:
31   - base >= 4 && < 5,
32   - bytestring >= 0.9.1 && < 0.10,
33   - clientsession >= 0.7.2 && < 0.8,
34   - containers >= 0.3 && < 0.5,
35   - convertible >= 1.0 && < 1.1,
36   - data-lens >= 2.0.1 && < 2.1,
37   - data-lens-template >= 2.1 && < 2.2,
38   - HDBC >= 2.2 && < 2.4,
39   - lifted-base >= 0.1 && < 0.2,
40   - mtl > 2.0 && < 2.1,
41   - monad-control >= 0.2 && < 0.4,
42   - resource-pool >= 0.2 && < 0.3,
43   - snap >= 0.6 && < 0.8,
44   - text >= 0.11 && < 0.12,
45   - time >= 1.1 && < 1.5,
46   - transformers >= 0.2 && < 0.3,
47   - transformers-base >= 0.2 && < 0.5,
48   - unordered-containers >= 0.1.4 && < 0.2
  31 + base >= 4 && < 5,
  32 + bytestring >= 0.9.1 && < 0.10,
  33 + clientsession >= 0.7.2 && < 0.8,
  34 + containers >= 0.3 && < 0.5,
  35 + convertible >= 1.0 && < 1.1,
  36 + data-lens >= 2.0.1 && < 2.1,
  37 + data-lens-template >= 2.1 && < 2.2,
  38 + HDBC >= 2.2 && < 2.4,
  39 + MonadCatchIO-transformers >= 0.2.1 && < 0.3,
  40 + mtl > 2.0 && < 2.1,
  41 + resource-pool-catchio >= 0.2 && < 0.3,
  42 + snap >= 0.6 && < 0.8,
  43 + text >= 0.11 && < 0.12,
  44 + time >= 1.1 && < 1.5,
  45 + transformers >= 0.2 && < 0.3,
  46 + unordered-containers >= 0.1.4 && < 0.2
49 47
50 48 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
51 49 -fno-warn-orphans -fno-warn-unused-do-bind
53 src/Snap/Snaplet/Hdbc.hs
... ... @@ -1,10 +1,10 @@
1   -{-# LANGUAGE CPP #-}
2 1 {-# LANGUAGE OverloadedStrings #-}
3 2 {-# LANGUAGE FlexibleInstances #-}
4 3 {-# LANGUAGE ExistentialQuantification #-}
5 4 {-# LANGUAGE MultiParamTypeClasses #-}
6 5 {-# LANGUAGE FunctionalDependencies #-}
7 6 {-# LANGUAGE FlexibleContexts #-}
  7 +{-# LANGUAGE TypeFamilies #-}
8 8
9 9 -- | This module provides a very thin wrapper around HDBC. It wraps some of the
10 10 -- HDBC functions in more convenient functions and re-exports the rest of the
@@ -79,6 +79,9 @@ module Snap.Snaplet.Hdbc (
79 79 import Prelude hiding (catch)
80 80
81 81 import Control.Concurrent.MVar
  82 +import Control.Exception (SomeException)
  83 +import Control.Monad.CatchIO
  84 +import Control.Monad.IO.Class
82 85 import Data.Map (Map)
83 86 import Data.Pool
84 87 import qualified Database.HDBC as HDBC
@@ -87,18 +90,6 @@ import Database.HDBC.ColTypes
87 90 import Snap.Snaplet
88 91 import Snap.Snaplet.Hdbc.Types
89 92
90   -#if MIN_VERSION_monad_control(0,3,0)
91   -import Control.Monad.Trans.Control (MonadBaseControl)
92   -import Control.Monad.Base
93   -import Control.Exception.Lifted
94   -#else
95   -import Control.Monad.IO.Control (MonadControlIO(..))
96   -import Control.Monad.IO.Class (liftIO)
97   -import Control.Exception.Control hiding (Handler)
98   -#define control controlIO
99   -#define liftBase liftIO
100   -#endif
101   -
102 93 -- | A map with the column name as key and the value from the database as value
103 94 type Row = Map String SqlValue
104 95
@@ -107,24 +98,11 @@ type Row = Map String SqlValue
107 98 -- can find the connection source.
108 99 class ( IConnection c
109 100 , ConnSrc s
110   -#if MIN_VERSION_monad_control(0,3,0)
111   - , MonadBaseControl IO m
112   -#else
113   - , MonadControlIO m
114   -#endif
  101 + , MonadCatchIO m
115 102 )
116 103 => HasHdbc m c s | m -> c s where
117 104 getHdbcState :: m (HdbcSnaplet c s)
118 105
119   --- | This is (hopefully) a temporary instance, which will disppear once the
120   --- entire snap framework is switched to monad-control.
121   -#if MIN_VERSION_monad_control(0,3,0)
122   -
123   -#else
124   -instance MonadControlIO (Handler b v) where
125   - liftControlIO f = liftBase (f return)
126   -#endif
127   -
128 106 type HdbcIO c = HdbcSnaplet c IO
129 107 type HdbcPool c = HdbcSnaplet c Pool
130 108
@@ -137,14 +115,11 @@ type HdbcPool c = HdbcSnaplet c Pool
137 115 hdbcInit
138 116 :: ( ConnSrc s
139 117 , IConnection c
140   -#if MIN_VERSION_monad_control(0,3,0)
141   - , MonadBase IO (Initializer b (HdbcSnaplet c s))
142   -#endif
143 118 )
144 119 => s c
145 120 -> SnapletInit b (HdbcSnaplet c s)
146 121 hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ do
147   - mv <- liftBase newEmptyMVar
  122 + mv <- liftIO newEmptyMVar
148 123 return $ HdbcSnaplet src mv
149 124
150 125
@@ -153,7 +128,7 @@ hdbcInit src = makeSnaplet "hdbc" "HDBC abstraction" Nothing $ do
153 128 withHdbc :: HasHdbc m c s => (c -> IO a) -> m a
154 129 withHdbc f = do
155 130 st <- getHdbcState
156   - withConn st (liftBase . f)
  131 + withConn st (liftIO . f)
157 132
158 133 -- | Get a new connection from the resource pool, apply the provided function
159 134 -- to it and return the result in of the compution in monad 'm'.
@@ -173,8 +148,8 @@ query
173 148 -- row. Can be the empty list.
174 149 query sql bind = do
175 150 stmt <- prepare sql
176   - liftBase $ HDBC.execute stmt bind
177   - liftBase $ HDBC.fetchAllRowsMap stmt
  151 + liftIO $ HDBC.execute stmt bind
  152 + liftIO $ HDBC.fetchAllRowsMap stmt
178 153
179 154 -- | Similar to 'query', but instead of returning a list of 'Row's, it returns
180 155 -- an 'Integer' indicating the numbers of affected rows. This is typically used
@@ -183,13 +158,13 @@ query sql bind = do
183 158 query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer
184 159 query' sql bind = withTransaction $ \conn -> do
185 160 stmt <- HDBC.prepare conn sql
186   - liftBase $ HDBC.execute stmt bind
  161 + liftIO $ HDBC.execute stmt bind
187 162
188 163 -- query' below doesn't work that well, due to withTransaction'
189 164 {- query' :: HasHdbc m c s => String -> [SqlValue] -> m Integer-}
190 165 {- query' sql bind = withTransaction' $ do-}
191 166 {- stmt <- prepare sql-}
192   - {- liftBase $ HDBC.execute stmt bind-}
  167 + {- liftIO $ HDBC.execute stmt bind-}
193 168
194 169 -- | Run an action inside a transaction. If the action throws an exception, the
195 170 -- transaction will be rolled back, and the exception rethrown.
@@ -212,11 +187,7 @@ withTransaction' action = do
212 187 commit
213 188 return r
214 189 where doRollback = rollback `catch` doRollbackHandler
215   -#if MIN_VERSION_monad_control(0,3,0)
216   - doRollbackHandler :: MonadBaseControl IO m => SomeException -> m ()
217   -#else
218   - doRollbackHandler :: MonadControlIO m => SomeException -> m ()
219   -#endif
  190 + doRollbackHandler :: MonadCatchIO m => SomeException -> m ()
220 191 doRollbackHandler _ = return ()
221 192
222 193 -- | The functions provided below are wrappers around the original HDBC
31 src/Snap/Snaplet/Hdbc/Types.hs
... ... @@ -1,24 +1,15 @@
1   -{-# LANGUAGE CPP #-}
2 1 {-# LANGUAGE ExistentialQuantification #-}
3 2 {-# LANGUAGE FlexibleContexts #-}
4 3
5 4 module Snap.Snaplet.Hdbc.Types where
6 5
7 6 import Control.Concurrent.MVar
  7 +import Control.Monad.CatchIO
8 8 import Control.Monad.State
9 9 import Database.HDBC (IConnection())
10 10 import qualified Database.HDBC as HDBC
11 11 import Data.Pool
12 12
13   -#if MIN_VERSION_monad_control(0,3,0)
14   -import Control.Monad.Trans.Control (MonadBaseControl)
15   -import Control.Monad.Base (liftBase)
16   -#else
17   -import Control.Monad.IO.Control (MonadControlIO)
18   -#define control controlIO
19   -#define liftBase liftIO
20   -#endif
21   -
22 13 -- | The snaplet state type containing a resource pool, parameterised by a raw
23 14 -- HDBC connection.
24 15 data HdbcSnaplet c s
@@ -27,15 +18,9 @@ data HdbcSnaplet c s
27 18 { connSrc :: s c
28 19 , connVar :: MVar c }
29 20
30   -#if MIN_VERSION_monad_control(0,3,0)
31   -class ConnSrc s where
32   - withConn :: (MonadBaseControl IO m, IConnection c) => HdbcSnaplet c s -> (c -> m b) -> m b
33   - closeConn :: (MonadBaseControl IO m, IConnection c) => HdbcSnaplet c s -> c -> m ()
34   -#else
35 21 class ConnSrc s where
36   - withConn :: (MonadControlIO m, IConnection c) => HdbcSnaplet c s -> (c -> m b) -> m b
37   - closeConn :: (MonadControlIO m, IConnection c) => HdbcSnaplet c s -> c -> m ()
38   -#endif
  22 + withConn :: (MonadCatchIO m, IConnection c) => HdbcSnaplet c s -> (c -> m b) -> m b
  23 + closeConn :: (MonadCatchIO m, IConnection c) => HdbcSnaplet c s -> c -> m ()
39 24
40 25 instance ConnSrc Pool where
41 26 withConn = withResource . connSrc
@@ -44,12 +29,12 @@ instance ConnSrc Pool where
44 29 instance ConnSrc IO where
45 30 withConn st fn = do
46 31 let cv = connVar st
47   - emp <- liftBase $ isEmptyMVar cv
  32 + emp <- liftIO $ isEmptyMVar cv
48 33 conn <- if emp
49 34 then do
50   - conn <- liftBase $ connSrc st
51   - liftBase $ putMVar cv conn
  35 + conn <- liftIO $ connSrc st
  36 + liftIO $ putMVar cv conn
52 37 return conn
53   - else liftBase $ readMVar cv
  38 + else liftIO $ readMVar cv
54 39 fn conn
55   - closeConn _ = liftBase . HDBC.disconnect
  40 + closeConn _ = liftIO . HDBC.disconnect

0 comments on commit f96ca9f

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