hasql 0.6.0 → 0.7.0

raw patch · 7 files changed

+168/−138 lines, 7 filesdep ~hasql-backendPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hasql-backend

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• demo/Main.hs +8/−8
• hasql.cabal +4/−4
• hspec-postgres/Main.hs +16/−16
• library/Hasql.hs +71/−46
• library/Hasql/CxRow.hs +64/−0
• library/Hasql/RowParser.hs +0/−64

@@ -1,3 +1,8 @@+# 0.7.0 - Refinements and minor updates+* Streaming now is parameterized by the size of a chunk+* Introduced a new type `Ex`+* Changed the suffix of statement execution functions to `Ex`+ # 0.6.0 - Major API overhaul * The connection pool acquisition is now explicit and is no longer handled by the `Session` monad. This should provide for a simpler integration with other libraries. * The `Session` monad is now merely a convenience thing for providing a context to multiple transactions. One can run it as many times as he wants - it won't reestablish any resources any more.

@@ -36,11 +36,11 @@      -- Execute a group of statements without any locking and ACID guarantees:     H.tx Nothing $ do-      H.unitTx [H.stmt|DROP TABLE IF EXISTS a|]-      H.unitTx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, balance INT8, PRIMARY KEY (id))|]+      H.unitEx [H.stmt|DROP TABLE IF EXISTS a|]+      H.unitEx [H.stmt|CREATE TABLE a (id SERIAL NOT NULL, balance INT8, PRIMARY KEY (id))|]       -- Insert three rows:       replicateM_ 3 $ do -        H.unitTx [H.stmt|INSERT INTO a (balance) VALUES (0)|]+        H.unitEx [H.stmt|INSERT INTO a (balance) VALUES (0)|]      -- Declare a list of transfer settings, which we'll later use.     -- The tuple structure is: @@ -56,16 +56,16 @@         runMaybeT $ do           -- To distinguish results rows containing just one column,            -- we use 'Identity' as a sort of a single element tuple.-          Identity balance1 <- MaybeT $ H.maybeTx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id1-          Identity balance2 <- MaybeT $ H.maybeTx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id2-          lift $ H.unitTx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance1 - amount) id1-          lift $ H.unitTx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance2 + amount) id2+          Identity balance1 <- MaybeT $ H.maybeEx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id1+          Identity balance2 <- MaybeT $ H.maybeEx $ [H.stmt|SELECT balance FROM a WHERE id=?|] id2+          lift $ H.unitEx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance1 - amount) id1+          lift $ H.unitEx $ [H.stmt|UPDATE a SET balance=? WHERE id=?|] (balance2 + amount) id2      -- Output all the updated rows:     do       -- Unfortunately in this case there's no way to infer the type of the results,       -- so we need to specify it explicitly:-      rows <- H.tx Nothing $ H.vectorTx $ [H.stmt|SELECT * FROM a|]+      rows <- H.tx Nothing $ H.vectorEx $ [H.stmt|SELECT * FROM a|]       forM_ rows $ \(id :: Int, amount :: Int) -> do         liftIO $ putStrLn $ "ID: " ++ show id ++ ", Amount: " ++ show amount 

@@ -1,7 +1,7 @@ name:   hasql version:-  0.6.0+  0.7.0 synopsis:   A minimalistic general high level API for relational databases description:@@ -10,7 +10,7 @@   .   Features:   .-  * Concise and crisp API. Just a few functions and one monad doing all the+  * Concise and crisp API. Just a few functions and two monads doing all the   boilerplate job for you.   .   * A powerful transaction abstraction, which provides @@ -89,14 +89,14 @@   other-modules:     Hasql.Prelude     Hasql.QParser-    Hasql.RowParser+    Hasql.CxRow     Hasql.TH   exposed-modules:     Hasql   build-depends:     --      resource-pool == 0.2.*,-    hasql-backend == 0.3.*,+    hasql-backend == 0.4.*,     --      template-haskell >= 2.8 && < 2.10,     -- 

@@ -18,18 +18,18 @@         flip shouldBe (Right (Nothing :: Maybe (Identity Int))) =<< do           session $ do             H.tx Nothing $ do-              H.unitTx $ [H.stmt|DROP TABLE IF EXISTS a|]-              H.unitTx $ [H.stmt|CREATE TABLE a (x INT8 NOT NULL, PRIMARY KEY (x))|]+              H.unitEx $ [H.stmt|DROP TABLE IF EXISTS a|]+              H.unitEx $ [H.stmt|CREATE TABLE a (x INT8 NOT NULL, PRIMARY KEY (x))|]             H.tx (Just (H.Serializable, Just False)) $ do-              H.unitTx $ [H.stmt|INSERT INTO a (x) VALUES (2)|]+              H.unitEx $ [H.stmt|INSERT INTO a (x) VALUES (2)|]             H.tx Nothing $ do-              H.maybeTx $ [H.stmt|SELECT x FROM a WHERE x = 2|]+              H.maybeEx $ [H.stmt|SELECT x FROM a WHERE x = 2|]      context "UTF-8 templates" $ do        it "encode properly" $ do         flip shouldBe (Right (Just (Identity ("Ёжик" :: Text)))) =<< do-          session $ H.tx Nothing $ H.maybeTx $ [H.stmt| SELECT 'Ёжик' |]+          session $ H.tx Nothing $ H.maybeEx $ [H.stmt| SELECT 'Ёжик' |]      context "Bug" $ do @@ -37,16 +37,16 @@          it "should not be" $ do           session $ H.tx Nothing $ do-            H.unitTx [H.stmt|DROP TABLE IF EXISTS artist|]-            H.unitTx [H.stmt|DROP TABLE IF EXISTS artist_union|]-            H.unitTx $+            H.unitEx [H.stmt|DROP TABLE IF EXISTS artist|]+            H.unitEx [H.stmt|DROP TABLE IF EXISTS artist_union|]+            H.unitEx $               [H.stmt|                 CREATE TABLE "artist_union" (                   "id" BIGSERIAL,                   PRIMARY KEY ("id")                 )               |]-            H.unitTx $+            H.unitEx $               [H.stmt|                 CREATE TABLE "artist" (                   "id" BIGSERIAL,@@ -60,13 +60,13 @@           let              insertArtistUnion :: H.Tx HP.Postgres s Int64             insertArtistUnion =-              fmap (runIdentity . fromJust) $ H.maybeTx $+              fmap (runIdentity . fromJust) $ H.maybeEx $               [H.stmt|                  INSERT INTO artist_union DEFAULT VALUES RETURNING id               |]             insertArtist :: Int64 -> [Text] -> H.Tx HP.Postgres s Int64             insertArtist unionID artistNames = -              fmap (runIdentity . fromJust) $ H.maybeTx $+              fmap (runIdentity . fromJust) $ H.maybeEx $               [H.stmt|                  INSERT INTO artist                   (artist_union_id, @@ -86,22 +86,22 @@           replicateM_ 6 process           block -    context "RowParser" $ do+    context "CxRow" $ do        it "should fail on incorrect arity" $ do         flip shouldSatisfy (\case Left (H.ResultError _) -> True; _ -> False) =<< do           session $ do             H.tx Nothing $ do-              H.unitTx [H.stmt|DROP TABLE IF EXISTS data|]-              H.unitTx [H.stmt|CREATE TABLE data (+              H.unitEx [H.stmt|DROP TABLE IF EXISTS data|]+              H.unitEx [H.stmt|CREATE TABLE data (                                    field1    DECIMAL NOT NULL,                                    field2    BIGINT  NOT NULL,                                    PRIMARY KEY (field1)                                )|]-              H.unitTx [H.stmt|INSERT INTO data (field1, field2) VALUES (0, 0)|]+              H.unitEx [H.stmt|INSERT INTO data (field1, field2) VALUES (0, 0)|]             mrow :: Maybe (Double, Int64, String) <-                H.tx Nothing $  -                H.maybeTx $ [H.stmt|SELECT * FROM data|]+                H.maybeEx $ [H.stmt|SELECT * FROM data|]             return ()  

@@ -30,14 +30,15 @@   Bknd.Stmt,   stmt, -  -- ** Statement Execution-  unitTx,-  countTx,-  singleTx,-  maybeTx,-  listTx,-  vectorTx,-  streamTx,+  -- * Statement Execution+  Ex,+  unitEx,+  countEx,+  singleEx,+  maybeEx,+  listEx,+  vectorEx,+  streamEx,    -- * Transaction   Tx,@@ -49,16 +50,17 @@   Bknd.TxWriteMode(..),    -- ** Result Stream-  TxListT,+  TxStream,+  TxStreamListT,    -- * Row Parser-  RowParser.RowParser,+  CxRow.CxRow, ) where  import Hasql.Prelude import qualified Hasql.Backend as Bknd-import qualified Hasql.RowParser as RowParser+import qualified Hasql.CxRow as CxRow import qualified Hasql.QParser as QParser import qualified ListT import qualified Data.Pool as Pool@@ -67,6 +69,7 @@ import qualified Data.Vector.Mutable as MVector import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH+import qualified Language.Haskell.TH.Syntax as TH import qualified Hasql.TH as THUtil  @@ -115,7 +118,13 @@ -- Settings of a pool. data PoolSettings =   PoolSettings !Int !Int+  deriving (Show) +instance TH.Lift PoolSettings where+  lift (PoolSettings a b) = +    [|PoolSettings a b|]+    + -- |  -- A smart constructor for pool settings. poolSettings :: @@ -225,7 +234,7 @@ -- Execute a transaction in a session. --  -- This function ensures on the type level, --- that it's impossible to return @'TxListT' s m r@ from it.+-- that it's impossible to return @'TxStreamListT' s m r@ from it. tx :: (Bknd.CxTx c, MonadBaseControl IO m) => Bknd.TxMode -> (forall s. Tx c s r) -> Session c m r tx mode (Tx m) =   Session $ ReaderT $ \(Pool pool) ->@@ -244,16 +253,23 @@ -------------------------  -- |+-- Statement executor.+-- +-- Just an alias to a function, which executes a statement in 'Tx'.+type Ex c s r =+  Bknd.Stmt c -> Tx c s r++-- | -- Execute a statement without processing the result.-unitTx :: Bknd.Stmt c -> Tx c s ()-unitTx = +unitEx :: Ex c s ()+unitEx =    Tx . lift . Bknd.unitTx  -- | -- Execute a statement and count the amount of affected rows. -- Useful for resolving how many rows were updated or deleted.-countTx :: Bknd.CxValue c Word64 => Bknd.Stmt c -> Tx c s Word64-countTx =+countEx :: Bknd.CxValue c Word64 => Ex c s Word64+countEx =   Tx . lift . Bknd.countTx  -- |@@ -264,53 +280,58 @@ --  -- Please note that using this executor for selecting rows is conceptually wrong,  -- since in that case the results are always optional. --- Use 'maybeTx', 'listTx' or 'vectorTx' instead.+-- Use 'maybeEx', 'listEx' or 'vectorEx' instead. --  -- If the result is empty this executor will raise 'ResultError'.-singleTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s r-singleTx =-  join . fmap (maybe (Tx $ left $ ResultError "No rows on 'singleTx'") return) .-  maybeTx+singleEx :: CxRow.CxRow c r => Ex c s r+singleEx =+  join . fmap (maybe (Tx $ left $ ResultError "No rows on 'singleEx'") return) .+  maybeEx  -- | -- Execute a statement, -- which optionally produces a single result row.-maybeTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s (Maybe r)-maybeTx =-  fmap (fmap Vector.unsafeHead . mfilter (not . Vector.null) . Just) . vectorTx+maybeEx :: CxRow.CxRow c r => Ex c s (Maybe r)+maybeEx =+  fmap (fmap Vector.unsafeHead . mfilter (not . Vector.null) . Just) . vectorEx  -- | -- Execute a statement, -- and produce a list of results.-listTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s [r]-listTx =-  fmap toList . vectorTx+listEx :: CxRow.CxRow c r => Ex c s [r]+listEx =+  fmap toList . vectorEx  -- | -- Execute a statement, -- and produce a vector of results.-vectorTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s (Vector r)-vectorTx s =+vectorEx :: CxRow.CxRow c r => Ex c s (Vector r)+vectorEx s =   Tx $ do     r <- lift $ Bknd.vectorTx s-    EitherT $ return $ traverse ((mapLeft ResultError) . RowParser.parseRow) $ r+    EitherT $ return $ traverse ((mapLeft ResultError) . CxRow.parseRow) $ r  -- |--- Execute a @SELECT@ statement with a cursor,+-- Given a batch size, execute a statement with a cursor, -- and produce a result stream. -- --- Cursor allows you to fetch virtually limitless results in a constant memory+-- The cursor allows you to fetch virtually limitless results in a constant memory -- at a cost of a small overhead.+-- +-- The batch size parameter controls how many rows will be fetched +-- during every roundtrip to the database. +-- A minimum value of 256 seems to be sane.+--  -- Note that in most databases cursors require establishing a database transaction, -- so depending on a backend the transaction may result in an error, -- if you run it improperly.-streamTx :: RowParser.RowParser c r => Bknd.Stmt c -> Tx c s (TxListT s (Tx c s) r)-streamTx s =+streamEx :: CxRow.CxRow c r => Int -> Ex c s (TxStream c s r)+streamEx n s =   Tx $ do-    r <- lift $ Bknd.streamTx s-    return $ TxListT $ do+    r <- lift $ Bknd.streamTx n s+    return $ TxStreamListT $ do       row <- hoist (Tx . lift) r-      lift $ Tx $ EitherT $ return $ mapLeft ResultError $ RowParser.parseRow $ row+      lift $ Tx $ EitherT $ return $ mapLeft ResultError $ CxRow.parseRow $ row   -- * Result Stream@@ -318,26 +339,30 @@  -- | -- A stream of results, --- which fetches only those that you reach.--- --- It's a wrapper around 'ListT.ListT', +-- which fetches approximately only those that you reach.+type TxStream c s =+  TxStreamListT s (Tx c s)++-- |+-- A wrapper around 'ListT.ListT',  -- which uses the same trick as the 'ST' monad to associate with the--- context transaction and become impossible to be used outside of it.+-- context monad and become impossible to be returned from it,+-- using the anonymous type parameter @s@. -- This lets the library ensure that it is safe to automatically -- release all the connections associated with this stream. --  -- All the functions of the \"list-t\" library are applicable to this type, -- amongst which are 'ListT.head', 'ListT.toList', 'ListT.fold', 'ListT.traverse_'.-newtype TxListT s m r =-  TxListT (ListT.ListT m r)+newtype TxStreamListT s m r =+  TxStreamListT (ListT.ListT m r)   deriving (Functor, Applicative, Alternative, Monad, MonadTrans, MonadPlus,              Monoid, ListT.MonadCons) -instance ListT.MonadTransUncons (TxListT s) where+instance ListT.MonadTransUncons (TxStreamListT s) where   uncons = -    (liftM . fmap . fmap) (unsafeCoerce :: ListT.ListT m r -> TxListT s m r) .+    (liftM . fmap . fmap) (unsafeCoerce :: ListT.ListT m r -> TxStreamListT s m r) .     ListT.uncons . -    (unsafeCoerce :: TxListT s m r -> ListT.ListT m r)+    (unsafeCoerce :: TxStreamListT s m r -> ListT.ListT m r)   -- * Statements quasi-quotation

@@ -0,0 +1,64 @@+module Hasql.CxRow where++import Hasql.Prelude+import Language.Haskell.TH+import qualified Hasql.Backend as Bknd+import qualified Data.Vector as Vector+import qualified Hasql.TH as THUtil+++-- |+-- This class is only intended to be used with the supplied instances,+-- which should be enough to cover all use cases.+class CxRow c r where+  parseRow :: Bknd.ResultRow c -> Either Text r++instance CxRow c () where+  parseRow row = +    if Vector.null row+      then Right ()+      else Left "Not an empty row"++instance Bknd.CxValue c v => CxRow c (Identity v) where+  parseRow row = do+    Identity <$> Bknd.decodeValue (Vector.unsafeHead row)++-- Generate tuple instaces using Template Haskell:+return $ flip map [2 .. 24] $ \arity ->+  let +    varNames =+      [1 .. arity] >>= \i -> return (mkName ('v' : show i))+    varTypes =+      map VarT varNames+    connectionType =+      VarT (mkName "c")+    constraints =+      map (\t -> ClassP ''Bknd.CxValue [connectionType, t]) varTypes+    head =+      AppT (AppT (ConT ''CxRow) connectionType) (foldl AppT (TupleT arity) varTypes)+    parseRowDec =+      FunD 'parseRow [Clause [VarP rowVarName] (NormalB e) []]+      where+        rowVarName = mkName "row"+        e =+          THUtil.purify $+            [|+              let actualLength = Vector.length $(varE rowVarName)+                  expectedLength = $(litE (IntegerL $ fromIntegral arity))+                  in if actualLength == expectedLength+                    then $(pure $ THUtil.applicativeE (ConE (tupleDataName arity)) lookups)+                    else Left $ fromString $ ($ "") $+                           showString "Inappropriate row length: " . shows actualLength .+                           showString ", expecting: " . shows expectedLength . +                           showString " instead"+            |]+          where+            lookups = do+              i <- [0 .. pred arity]+              return $ THUtil.purify $+                [|+                  Bknd.decodeValue+                    (Vector.unsafeIndex $(varE rowVarName) $(litE (IntegerL $ fromIntegral i)) )+                |]+    in InstanceD constraints head [parseRowDec]+

@@ -1,64 +0,0 @@-module Hasql.RowParser where--import Hasql.Prelude-import Language.Haskell.TH-import qualified Hasql.Backend as Bknd-import qualified Data.Vector as Vector-import qualified Hasql.TH as THUtil----- |--- This class is only intended to be used with the supplied instances,--- which should be enough to cover all use cases.-class RowParser c r where-  parseRow :: Bknd.ResultRow c -> Either Text r--instance RowParser c () where-  parseRow row = -    if Vector.null row-      then Right ()-      else Left "Not an empty row"--instance Bknd.CxValue c v => RowParser c (Identity v) where-  parseRow row = do-    Identity <$> Bknd.decodeValue (Vector.unsafeHead row)---- Generate tuple instaces using Template Haskell:-return $ flip map [2 .. 24] $ \arity ->-  let -    varNames =-      [1 .. arity] >>= \i -> return (mkName ('v' : show i))-    varTypes =-      map VarT varNames-    connectionType =-      VarT (mkName "c")-    constraints =-      map (\t -> ClassP ''Bknd.CxValue [connectionType, t]) varTypes-    head =-      AppT (AppT (ConT ''RowParser) connectionType) (foldl AppT (TupleT arity) varTypes)-    parseRowDec =-      FunD 'parseRow [Clause [VarP rowVarName] (NormalB e) []]-      where-        rowVarName = mkName "row"-        e =-          THUtil.purify $-            [|-              let actualLength = Vector.length $(varE rowVarName)-                  expectedLength = $(litE (IntegerL $ fromIntegral arity))-                  in if actualLength == expectedLength-                    then $(pure $ THUtil.applicativeE (ConE (tupleDataName arity)) lookups)-                    else Left $ fromString $ ($ "") $-                           showString "Inappropriate row length: " . shows actualLength .-                           showString ", expecting: " . shows expectedLength . -                           showString " instead"-            |]-          where-            lookups = do-              i <- [0 .. pred arity]-              return $ THUtil.purify $-                [|-                  Bknd.decodeValue-                    (Vector.unsafeIndex $(varE rowVarName) $(litE (IntegerL $ fromIntegral i)) )-                |]-    in InstanceD constraints head [parseRowDec]-