hdbi 1.1.0 → 1.1.1

raw patch · 5 files changed

+144/−88 lines, 5 filesdep +containersdep +stmPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers, stm

API changes (from Hackage documentation)

Files

• Database/HDBI/DriverUtils.hs +41/−30
• Database/HDBI/Parsers.hs +3/−3
• hdbi.cabal +8/−3
• testsrc/dummydriver.hs +86/−45
• testsrc/sqlvalues.hs +6/−7

@@ -12,53 +12,70 @@  module Database.HDBI.DriverUtils ( -- | Utilities for database backend drivers.---   +-- -- Please note: this module is intended for authors of database driver libraries -- only.  Authors of applications using HDBI should use 'Database.HDBI' -- exclusively.-  -  ChildList++  ChildList(..)   , closeAllChildren   , addChild   , newChildList   )  where++import Control.Applicative import Control.Concurrent.MVar-import System.Mem.Weak+import Control.Concurrent.STM.TVar import Control.Monad+import Control.Monad.STM import Database.HDBI.Types (Statement(..))+import System.Mem.Weak+import qualified Data.IntMap as M  -- | List of weak pointers to childs with concurrent access-type ChildList stmt = MVar [Weak stmt]+data ChildList stmt = ChildList+                      { clList ::  TVar (M.IntMap (Weak stmt))+                      , clCounter :: TVar Int -- ^ Little hackish child counter,+                                             -- need to wait all child+                                             -- finalizers in 'closeAllChildren'+                      , clNextKey :: MVar Int+                      }   -- | new empty child list newChildList :: IO (ChildList stmt)-newChildList = newMVar []+newChildList = ChildList+               <$> newTVarIO M.empty+               <*> newTVarIO 0  -- child counter+               <*> newMVar 0  -- next key  {- | Close all children.  Intended to be called by the 'disconnect' function-in 'Connection'. +in 'Connection'.  There may be a potential race condition wherein a call to newSth at the same time as a call to this function may result in the new child not being closed. -} closeAllChildren :: (Statement stmt) => (ChildList stmt) -> IO ()-closeAllChildren mcl = modifyMVar_ mcl $ \ls -> do-  mapM_ closefunc ls-  return ls-    where closefunc child =-              do c <- deRefWeak child-                 case c of-                   Nothing -> return ()-                   Just x -> finish x+closeAllChildren mcl = do+  l <- readTVarIO $ clList mcl+  mapM_ finalize $ map snd $ M.toList l+  atomically $ do               -- wait until counter becomes 0. In other words,+                                -- wait until all finalizers run+    a <- readTVar $ clCounter mcl+    when (a > 0) retry+  return ()  {- | Adds a new child to the existing list.  Also takes care of registering a finalizer for it, to remove it from the list when possible. -} addChild :: (Statement stmt) => (ChildList stmt) -> stmt -> IO ()-addChild mcl stmt = -    do weakptr <- mkWeakPtr stmt (Just (childFinalizer mcl))-       modifyMVar_ mcl (\l -> return (weakptr : l))+addChild mcl stmt = modifyMVar_ (clNextKey mcl) $ \key -> do+  wp <- mkWeakPtr stmt $ Just $ childFinalizer mcl key stmt+  atomically $ do+    modifyTVar' (clList mcl) $ M.insert key wp+    modifyTVar' (clCounter mcl) (+1)+  return $ key + 1  {- | The general finalizer for a child. @@ -66,15 +83,9 @@  If the MVar is locked at the start, does nothing to avoid deadlock.  Future runs would probably catch it anyway. -}-childFinalizer :: ChildList a -> IO ()-childFinalizer mcl = do-  c <- isEmptyMVar mcl-  case c of-    True   -> return ()-    False  -> modifyMVar_ mcl (filterM filterfunc)-    -  where filterfunc c = do-          dc <- deRefWeak c-          case dc of-            Nothing -> return False-            Just _ -> return True+childFinalizer :: (Statement stmt) => ChildList stmt -> Int -> stmt -> IO ()+childFinalizer mcl key stmt = do+  finish stmt                   -- make sure the statement is finished+  atomically $ do+    modifyTVar' (clCounter mcl) $ \x -> x - 1+    modifyTVar' (clList mcl) $ M.delete key 

@@ -27,16 +27,16 @@        ) where  import Control.Applicative ((<$>), (<|>))-import qualified Data.Attoparsec.Text.Lazy as P import Data.Bits import Data.Char (isDigit)+import Data.Monoid (getFirst, First(..), mconcat) import Data.Time import Data.Word-import Data.Monoid (getFirst, First(..), mconcat)+import qualified Data.Attoparsec.Text.Lazy as P import qualified Data.Text as T  spaces :: P.Parser ()-spaces = P.takeWhile (\x -> x == ' ' || x == '\t') >> return ()+spaces = P.skipWhile (\x -> x == ' ' || x == '\t')   -- | Parse bit field literal in format ''b'00101011'''. Takes just last 64 bits

@@ -1,5 +1,5 @@ Name: hdbi-Version: 1.1.0+Version: 1.1.1 License: BSD3 Maintainer: Aleksey Uymanov <s9gf4ult@gmail.com> Author: John Goerzen@@ -31,10 +31,12 @@                , attoparsec                , blaze-builder                , bytestring+               , containers                , deepseq                , old-locale+               , stm                , text-               , time >=1.1.2.4 && <=1.5+               , time >= 1.1.2.4 && <=1.5                , uuid >= 1.0.0    -- Hack for cabal-install weirdness.  cabal-install forces base 3,@@ -65,6 +67,7 @@                   , attoparsec                   , blaze-builder                   , bytestring+                  , containers                   , deepseq                   , old-locale                   , quickcheck-assertions@@ -81,7 +84,7 @@   Main-Is:          testsrc/dummydriver.hs   other-modules: Database.HDBI                , Database.HDBI.DriverUtils-  GHC-Options: -Wall -main-is DummyDriver -fno-warn-orphans+  GHC-Options: -Wall -main-is DummyDriver -fno-warn-orphans -threaded   ghc-prof-options: -fprof-auto   Build-Depends:    base                   , Decimal >= 0.2.1@@ -89,9 +92,11 @@                   , attoparsec                   , blaze-builder                   , bytestring+                  , containers                   , deepseq                   , hspec-expectations                   , old-locale+                  , stm                   , test-framework                   , test-framework-hunit                   , text

@@ -7,24 +7,24 @@  module DummyDriver where -import System.Mem-import System.Mem.Weak--import Test.HUnit (Assertion)-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Hspec.Expectations- import Control.Applicative import Control.Concurrent.MVar+import Control.Concurrent.STM.TVar import Control.Exception import Control.Monad-import Data.Typeable import Data.Maybe-+import Data.Typeable import Database.HDBI import Database.HDBI.DriverUtils+import System.Mem+import System.Mem.Weak+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit (Assertion)+import Test.Hspec.Expectations+import qualified Data.IntMap as M + data TStatus = TIdle | TInTransaction              deriving (Eq, Show, Read, Typeable) @@ -34,8 +34,9 @@                   , dcData :: MVar [[SqlValue]]                   , dcChilds :: ChildList DummyStatement                   , dcTransSupport :: Bool+                  , dcCounter :: MVar Int -- ^ child statements counter                   }-  deriving (Typeable, Eq)+  deriving (Typeable)  data DummyStatement =   DummyStatement { dsConnection :: DummyConnection@@ -43,9 +44,9 @@                  , dsSelecting :: MVar (Maybe Int)                  , dsStatus :: MVar StatementStatus                  }-  deriving (Typeable, Eq)-  +  deriving (Typeable) + newConnection :: Bool -> IO DummyConnection newConnection transSupport = DummyConnection                              <$> newMVar ConnOK@@ -53,6 +54,7 @@                              <*> newMVar []                              <*> newChildList                              <*> return transSupport+                             <*> newMVar 0  withOKConnection :: DummyConnection -> IO a -> IO a withOKConnection conn action = do@@ -65,14 +67,14 @@ withTransactionSupport conn action = case (dcTransSupport conn) of   True -> action   False -> throwIO $ SqlError "10" "Transaction is not supported by this connection"-   + instance Connection DummyConnection where   type ConnStatement DummyConnection = DummyStatement   disconnect conn = modifyMVar_ (dcState conn) $ \_ -> do     closeAllChildren $ dcChilds conn     return ConnDisconnected-  +   begin conn = withOKConnection conn                $ withTransactionSupport conn                $ modifyMVar_ (dcTrans conn)@@ -102,6 +104,7 @@           <*> newMVar Nothing           <*> newMVar StatementNew     addChild (dcChilds conn) st+    modifyMVar_ (dcCounter conn) $ return . (+1)     return st   clone conn = DummyConnection                <$> (newMVar ConnOK)@@ -109,10 +112,11 @@                <*> newMVar []                <*> newChildList                <*> (return $ dcTransSupport conn)+               <*> newMVar 0   hdbiDriverName = const "DummyDriver"   dbTransactionSupport = dcTransSupport -  + instance Statement DummyStatement where   execute stmt params = modifyMVar_ (dsStatus stmt) $ \st -> do     case st of@@ -123,11 +127,21 @@           "select" -> modifyMVar (dsSelecting stmt) $ const $ return (Just 0, StatementExecuted)           _ -> return StatementExecuted       _ -> throwIO $ SqlError "6" $ "Statement has wrong status to execute query " ++ show st-    +   statementStatus = readMVar . dsStatus -  finish stmt = modifyMVar_ (dsStatus stmt) $ const $ return StatementFinished-  reset stmt = modifyMVar_ (dsStatus stmt) $ const $ return StatementNew+  finish stmt = modifyMVar_ (dsStatus stmt) $ \s -> case s of+    r@StatementFinished -> return r+    _ -> do+      modifyMVar_ (dcCounter $ dsConnection stmt) $ return . (\x -> x - 1)+      return StatementFinished++  reset stmt = modifyMVar_ (dsStatus stmt) $ \s -> case s of+    StatementFinished -> do+      modifyMVar_ (dcCounter $ dsConnection stmt) $ return . (+1)+      return StatementNew+    _ -> return StatementNew+   fetchRow stmt = modifyMVar (dsSelecting stmt) $ \slct -> case slct of     Nothing -> return (Nothing, Nothing)     Just sl -> do@@ -135,14 +149,14 @@       if (length dt) > sl         then return (Just $ sl+1, Just $ dt !! sl)         else return (Nothing, Nothing)-    -    ++   getColumnNames = const $ return []   originalQuery = dsQuery --test1 :: Assertion-test1 = do+-- | rollback after exception+inTransactionExceptions :: Assertion+inTransactionExceptions = do   c <- ConnWrapper <$> newConnection True   (withTransaction c $ do       intr <- inTransaction c@@ -153,8 +167,9 @@   intr <- inTransaction c   intr `shouldBe` False         -- after rollback -test2 :: Assertion-test2 = do+-- | commit after no exception+inTransactionCommit :: Assertion+inTransactionCommit = do   c <- ConnWrapper <$> newConnection True   intr1 <- inTransaction c   intr1 `shouldBe` False@@ -166,35 +181,36 @@   intr <- inTransaction c   intr `shouldBe` False         -- after commit -test3 :: Assertion-test3 = do+weakRefsEmpty :: Assertion+weakRefsEmpty = do   c <- ConnWrapper <$> newConnection False   sub c   performGC                     -- after this all refs must be empty   p <- case castConnection c of-    Just cc ->  readMVar $ dcChilds cc-  prts <- filterM (deRefWeak >=> (return . isJust)) p+    Just cc ->  readTVarIO $ clList $ dcChilds cc+  prts <- filterM (deRefWeak >=> (return . isJust)) $ map snd $ M.toList p   (length prts) `shouldBe` 0      where       sub cn = case castConnection cn of-        Just c -> do +        Just c -> do           st1 <- prepare c "query 1"           st2 <- prepare c "query 2"           executeRaw st2-          prts <- readMVar $ dcChilds c-          (length prts) `shouldBe` 2+          prts <- readTVarIO $ clList $ dcChilds c+          (length $ M.toList prts) `shouldBe` 2 -test4 :: Assertion-test4 = do+-- | Childs finished after 'closeAllChildren'+closeAllChildrenFinish :: Assertion+closeAllChildrenFinish = do   c <- ConnWrapper <$> newConnection False   stmt <- prepare c "query 1"   disconnect c   ss <- statementStatus stmt   ss `shouldBe` StatementFinished -test5 :: Assertion-test5 = do+eachConnectionSeparate :: Assertion+eachConnectionSeparate = do   c <- ConnWrapper <$> newConnection True   c2 <- clone c   st1 <- prepare c "query"@@ -232,14 +248,39 @@   executeRaw ss   outdt <- fetchAllRows ss   outdt `shouldBe` indt-  -  -  ++noStatementsAfterDisconnect :: Assertion+noStatementsAfterDisconnect = do+  c <- newConnection True+  sub c+  disconnect c+  readMVar (dcCounter c) >>= (`shouldBe` 0)++  c2 <- newConnection True+  sub c+  performGC                     -- disconnect must wait for finalizers even+                                -- after GC+  disconnect c+  readMVar (dcCounter c2) >>= (`shouldBe` 0)+  where+    sub c = do+      withStatement c "query string" $ \st -> do -- this statement should be+                                                -- finished+        executeRaw st+        _ <- fetchRow st+        return ()+      s <- prepare c "query string" -- but this should not+      executeRaw s+      s2 <- prepare c "query string"+      return ()++ main :: IO ()-main = defaultMain [ testCase "Transaction exception handling" test1-                   , testCase "Transaction commiting" test2-                   , testCase "Child statements" test3-                   , testCase "Childs closed when disconnect" test4-                   , testCase "Each connection has it's own childs" test5+main = defaultMain [ testCase "Transaction exception handling" inTransactionExceptions+                   , testCase "Transaction commiting" inTransactionCommit+                   , testCase "Child statements empty after GC" weakRefsEmpty+                   , testCase "Childs closed when disconnect" closeAllChildrenFinish+                   , testCase "Each connection has it's own childs" eachConnectionSeparate                    , testCase "Fetch all rows preserve order" testFetchAllRows+                   , testCase "No statements after disconnect" noStatementsAfterDisconnect                    ]

@@ -7,6 +7,12 @@ module SqlValues where  import Control.Applicative+import Data.Decimal+import Data.Int+import Data.List (intercalate)+import Data.Time+import Data.UUID+import Data.Word import Database.HDBI (ToSql(..), FromSql(..), BitField(..)) import Database.HDBI.Parsers import Test.Framework@@ -17,18 +23,11 @@ import Test.QuickCheck.Assertions import Test.QuickCheck.Instances () import Test.QuickCheck.Property- import qualified Data.Attoparsec.Text.Lazy as P import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Lazy as TL-import Data.Decimal-import Data.Int-import Data.List (intercalate)-import Data.Time-import Data.UUID-import Data.Word   #if MIN_VERSION_Decimal(0,3,1)