packages feed

hdbi-conduit (empty) → 1.2.0

raw patch · 5 files changed

+352/−0 lines, 5 filesdep +QuickCheckdep +basedep +conduitsetup-changed

Dependencies added: QuickCheck, base, conduit, hdbi, hdbi-sqlite, quickcheck-assertions, resourcet, test-framework, test-framework-quickcheck2, transformers

Files

+ Data/Conduit/HDBI.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE+  BangPatterns+, TypeFamilies+  #-}++module Data.Conduit.HDBI+       (+         -- * Conduit functions+         selectAll+       , selectAllRows+       , selectRawAll+       , selectRawAllRows+       , insertAll+       , insertAllRows+       , insertAllCount+       , insertAllRowsCount+         -- * Auxiliary conduit functions+       , statementSource+       , statementSink+       , statementSinkCount+         -- * ResourceT functions+       , allocConnection+       , allocStmt+       , executeStmt+       , executeStmtRow+       , executeStmtRaw+       ) where++import Control.Monad.IO.Class+import Control.Monad.Trans.Resource+import Data.Conduit+import Database.HDBI++allocConnection :: (Connection con, MonadResource m) => IO con -> m (ReleaseKey, con)+allocConnection con = allocate con disconnect++allocStmt :: (Statement stmt, MonadResource m) => IO stmt -> m (ReleaseKey, stmt)+allocStmt stmt = allocate stmt finish++executeStmt :: (Connection con, (ConnStatement con) ~ stmt, MonadResource m) => con -> Query -> [SqlValue] -> m (ReleaseKey, stmt)+executeStmt con query vals = do+  (key, stmt) <- allocStmt $ prepare con query+  liftIO $ execute stmt vals+  return (key, stmt)++executeStmtRow :: (Connection con, (ConnStatement con) ~ stmt, ToRow row, MonadResource m) => con -> Query -> row -> m (ReleaseKey, stmt)+executeStmtRow con query row = do+  (key, stmt) <- allocStmt $ prepare con query+  liftIO $ executeRow stmt row+  return (key, stmt)++executeStmtRaw :: (Connection con, (ConnStatement con) ~ stmt, MonadResource m) => con -> Query -> m (ReleaseKey, stmt)+executeStmtRaw con query = do+  (key, stmt) <- allocStmt $ prepare con query+  liftIO $ executeRaw stmt+  return (key, stmt)++-- | fetch all results of query+selectAll :: (Connection con, MonadResource m)+             => con+             -> Query            -- query to execute+             -> [SqlValue]       -- query parameters+             -> Source m [SqlValue]+selectAll con query params = statementSource fetch $ do+  st <- prepare con query+  execute st params+  return st++-- | same as `selectAll` but reburn stream of `FromRow` instances+selectAllRows :: (Connection con, MonadResource m, FromRow a)+                 => con+                 -> Query+                 -> [SqlValue]+                 -> Source m a+selectAllRows con query params = statementSource fetchRow $ do+  st <- prepare con query+  execute st params+  return st++-- | same as `selectAll` but without query parameters+selectRawAll :: (Connection con, MonadResource m)+                => con+                -> Query+                -> Source m [SqlValue]+selectRawAll con query = statementSource fetch $ do+  st <- prepare con query+  executeRaw st+  return st++-- | same as `selectRawAll` but return stream of `FromRow` instances+selectRawAllRows :: (Connection con, MonadResource m, FromRow a) => con -> Query -> Source m a+selectRawAllRows con query = statementSource fetchRow $ do+  st <- prepare con query+  executeRaw st+  return st++-- | same as `insertAll` but also count executed rows+insertAllCount :: (Connection con, MonadResource m, Num count) => con -> Query -> Sink [SqlValue] m count+insertAllCount con query = statementSinkCount execute $ prepare con query++-- | same as `insertAllRows` but also count executed rows+insertAllRowsCount :: (Connection con, MonadResource m, Num count, ToRow a) => con -> Query -> Sink a m count+insertAllRowsCount con query = statementSinkCount executeRow $ prepare con query++-- | perform `execute` for each bunch of values+insertAll :: (Connection con, MonadResource m)+             => con+             -> Query+             -> Sink [SqlValue] m ()+insertAll con query = statementSink execute $ prepare con query++-- | perfor `executeRow` for each input row+insertAllRows :: (Connection con, MonadResource m, ToRow a)+                 => con+                 -> Query+                 -> Sink a m ()+insertAllRows con query = statementSink executeRow $ prepare con query+++-- | Get all values from the statement until action return ''Just a''+statementSource :: (Statement stmt, MonadResource m)+                   => (stmt -> IO (Maybe a))  -- action to execute until it return+                                             -- Nothing+                   -> IO stmt               -- statement constructor+                   -> Source m a+statementSource getter stmt = bracketP+                              stmt+                              finish+                              statementSource'+  where+    statementSource' st = do+      row <- liftIO $ getter st+      case row of+        Nothing -> return ()+        Just r -> do+          yield r+          statementSource' st++-- | Execute action many times with given thread of values, return the count+-- of executions+statementSinkCount :: (Statement stmt, MonadResource m, Num count)+                      => (stmt -> a -> IO ()) -- action to execute each time+                      -> IO stmt            -- statement constructor+                      -> Sink a m count+statementSinkCount putter stmt = bracketP+                                 stmt+                                 finish+                                 $ statementSinkCount' 0+  where+    statementSinkCount' !ac st = do+      next <- await+      case next of+        Nothing -> return ac+        Just n -> do+          liftIO $ do+            reset st+            putter st n+          statementSinkCount' (ac+1) st++-- | Same as `statementSinkCount` but without counting, just return ()+statementSink :: (Statement stmt, MonadResource m)+                 => (stmt -> a -> IO ())+                 -> IO stmt+                 -> Sink a m ()+statementSink putter stmt = bracketP+                            stmt+                            finish+                            statementSink'+  where+    statementSink' st = do+      next <- await+      case next of+        Nothing -> return ()+        Just n -> do+          liftIO $ do+            reset st+            putter st n+          statementSink' st
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Aleksey Uymanov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Aleksey Uymanov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hdbi-conduit.cabal view
@@ -0,0 +1,52 @@+-- Initial hdbi-conduit.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                hdbi-conduit+version:             1.2.0+synopsis:            Conduit glue for HDBI+-- description:+license:             BSD3+license-file:        LICENSE+author:              Aleksey Uymanov+maintainer:          s9gf4ult@gmail.com+homepage:            https://github.com/s9gf4ult/hdbi-conduit++-- copyright:+category:            Database+stability:           experimental+build-type:          Simple+cabal-version:       >=1.8++source-repository head+  type:            git+  location:        https://github.com/s9gf4ult/hdbi-conduit.git+++library+  exposed-modules:     Data.Conduit.HDBI+  -- other-modules:+  ghc-options: -Wall+  ghc-prof-options: -fprof-auto+  build-depends:       base < 5+                     , conduit+                     , hdbi >= 1.2.0+                     , resourcet+                     , transformers++test-suite runtests++  type: exitcode-stdio-1.0+  main-is: testsrc/runtests.hs+  other-modules: Data.Conduit.HDBI+  ghc-options: -Wall -main-is RunTests+  ghc-prof-options: -fprof-auto+  build-depends:       base < 5+                     , QuickCheck+                     , conduit+                     , hdbi >= 1.2.0+                     , hdbi-sqlite >= 1.2.0+                     , quickcheck-assertions+                     , resourcet+                     , test-framework+                     , test-framework-quickcheck2+                     , transformers
+ testsrc/runtests.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE+  OverloadedStrings+, BangPatterns+, ScopedTypeVariables+  #-}++module RunTests where++import Control.Exception+import Data.Conduit+import Data.List (foldl')+import Data.Monoid ((<>))+import Data.Conduit.HDBI+import Database.HDBI+import Database.HDBI.SQlite+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.QuickCheck.Assertions+import qualified Data.Conduit.List as L+import qualified Data.Conduit.Util as U+import qualified Test.QuickCheck.Monadic as M++createTables :: SQliteConnection -> IO ()+createTables c = do+  runRaw c "create table values1(val1 integer, val2 integer)"+  runRaw c "create table values2(val1 integer, val2 integer)"+  runRaw c "create table values3(val1 integer, val2 integer)"+++allTests :: SQliteConnection -> Test+allTests c = testGroup "All tests"+             [ testProperty "Insert + fold" $ insertFold c+             , testProperty "Insert + copy" $ insertCopy c+             , testProperty "Insert + copy + sum" $ insertCopySum c]++sumPairs :: (Num a, Num b) => (a, b) -> (a, b) -> (a, b)+sumPairs (!a, !b) (!x, !y) = (a+x, b+y)++insertFold :: SQliteConnection -> [(Integer, Integer)] -> Property+insertFold c vals = M.monadicIO $ do+  res <- M.run $ withTransaction c $ do+    runRaw c "delete from values1"+    runManyRows c "insert into values1(val1, val2) values (?,?)" vals+    runResourceT+      $ selectRawAllRows c "select val1, val2 from values1"+      $$ L.fold sumPairs (0 :: Integer, 0 :: Integer)+  M.stop $ res ?== (foldl' sumPairs (0, 0) vals)++insertCopy :: SQliteConnection -> [(Integer, Integer)] -> Property+insertCopy c vals = M.monadicIO $ do+  res <- M.run $ withTransaction c $ do+    runRaw c "delete from values1"+    runRaw c "delete from values2"+    runResourceT+      $ L.sourceList vals+      $$ insertAllRows c "insert into values1(val1, val2) values (?,?)"+    runResourceT+      $ selectRawAll c "select val1, val2 from values1"+      $$ insertAllCount c "insert into values2(val1, val2) values (?,?)"+  M.stop $ res == (length vals)++insertCopySum :: SQliteConnection -> [(Integer, Integer)] -> Property+insertCopySum c vals = M.monadicIO $ do+  res <- M.run $ withTransaction c $ do+    mapM_ (runRaw c . ("delete from " <>)) ["values1",+                                            "values2",+                                            "values3"]+    runResourceT+      $ L.sourceList (map (\(a, b) -> [toSql a, toSql b]) vals)+      $$ insertAll c "insert into values1(val1, val2) values (?,?)"+    runResourceT+      $ selectRawAll c "select val1, val2 from values1"+      $$ insertAll c "insert into values2(val1, val2) values (?,?)"+    runResourceT+      $ (U.zip+         (selectRawAllRows c "select val1, val2 from values1")+         (selectRawAllRows c "select val1, val2 from values2"))+      $= L.map (\(a, b :: (Integer, Integer)) -> sumPairs a b)+      $$ insertAllRows c "insert into values3(val1, val2) values (?,?)"+    runResourceT+      $ selectRawAllRows c "select val1, val2 from values3"+      $$ L.fold sumPairs (0 :: Integer, 0 :: Integer)+  let (a, b) = foldl' sumPairs (0, 0) vals+  M.stop $ (a*2, b*2) ==? res++main :: IO ()+main = bracket (connectSqlite3 ":memory:") disconnect $ \c -> do+  createTables c+  defaultMain [allTests c]