diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Change log + +## 0.1.0.0 + +Initial release diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,30 @@ +Copyright SimSpace (c) 2020 + +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 SimSpace 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. diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,31 @@ +name: postgresql-tx-squeal +version: 0.1.0.0 +github: "simspace/postgresql-tx/squeal" +license: BSD3 +license-file: LICENSE.md +author: "Cary Robbins" +maintainer: "carymrobbins@gmail.com" +copyright: "2020 SimSpace" +synopsis: postgresql-tx interfacing for use with squeal-postgresql. +category: Database +description: Please see the README on GitHub at + +extra-source-files: +- CHANGELOG.md +- LICENSE.md +- package.yaml + +ghc-options: +- -Wall + +dependencies: +- base >= 4.7 && < 5 +- bytestring >= 0.10.10.0 && < 0.11 +- generics-sop >= 0.5.1.0 && < 0.6 +- postgresql-libpq >= 0.9.4.2 && < 0.10 +- postgresql-tx >= 0.1.0.0 && < 0.2 +- records-sop >= 0.1.0.3 && < 0.2 +- squeal-postgresql >= 0.6.0.2 && < 0.7 + +library: + source-dirs: src diff --git a/postgresql-tx-squeal.cabal b/postgresql-tx-squeal.cabal new file mode 100644 --- /dev/null +++ b/postgresql-tx-squeal.cabal @@ -0,0 +1,49 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: ec2093cdd28764a2714fde9b8bb6779e505a1ebb631618e8362b78c63e60d8ab + +name: postgresql-tx-squeal +version: 0.1.0.0 +synopsis: postgresql-tx interfacing for use with squeal-postgresql. +description: Please see the README on GitHub at +category: Database +homepage: https://github.com/simspace/postgresql-tx#readme +bug-reports: https://github.com/simspace/postgresql-tx/issues +author: Cary Robbins +maintainer: carymrobbins@gmail.com +copyright: 2020 SimSpace +license: BSD3 +license-file: LICENSE.md +build-type: Simple +extra-source-files: + CHANGELOG.md + LICENSE.md + package.yaml + +source-repository head + type: git + location: https://github.com/simspace/postgresql-tx + subdir: squeal + +library + exposed-modules: + Database.PostgreSQL.Tx.Squeal + Database.PostgreSQL.Tx.Squeal.Internal.Reexport + other-modules: + Paths_postgresql_tx_squeal + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , bytestring >=0.10.10.0 && <0.11 + , generics-sop >=0.5.1.0 && <0.6 + , postgresql-libpq >=0.9.4.2 && <0.10 + , postgresql-tx >=0.1.0.0 && <0.2 + , records-sop >=0.1.0.3 && <0.2 + , squeal-postgresql >=0.6.0.2 && <0.7 + default-language: Haskell2010 diff --git a/src/Database/PostgreSQL/Tx/Squeal.hs b/src/Database/PostgreSQL/Tx/Squeal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Tx/Squeal.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Database.PostgreSQL.Tx.Squeal + ( module Database.PostgreSQL.Tx.Squeal + , module Database.PostgreSQL.Tx.Squeal.Internal.Reexport + ) where + +import Data.ByteString (ByteString) +import Database.PostgreSQL.Tx (Tx(TxEnv, tx), UnsafeTx(unsafeIOTx), TxM, unsafeRunTxM) +import Database.PostgreSQL.Tx.Squeal.Internal.Reexport +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Generics.SOP as SOP +import qualified Generics.SOP.Record as SOP +import qualified Squeal.PostgreSQL as Squeal + +type SquealM db0 db1 = PQ db0 db1 TxM + +unsafeSquealIOTx :: PQ db0 db1 IO a -> SquealM db0 db1 a +unsafeSquealIOTx = unsafeIOTx + +unsafeSquealIOTx1 + :: (x1 -> PQ db0 db1 IO a) + -> x1 -> SquealM db0 db1 a +unsafeSquealIOTx1 f x1 = unsafeSquealIOTx $ f x1 + +unsafeSquealIOTx2 + :: (x1 -> x2 -> PQ db0 db1 IO a) + -> x1 -> x2 -> SquealM db0 db1 a +unsafeSquealIOTx2 f x1 x2 = unsafeSquealIOTx $ f x1 x2 + +unsafeSquealIOTx3 + :: (x1 -> x2 -> x3 -> PQ db0 db1 IO a) + -> x1 -> x2 -> x3 -> SquealM db0 db1 a +unsafeSquealIOTx3 f x1 x2 x3 = unsafeSquealIOTx $ f x1 x2 x3 + +getRow :: LibPQ.Row -> Result y -> SquealM db db y +getRow = unsafeSquealIOTx2 Squeal.getRow + +firstRow :: Result y -> SquealM db db (Maybe y) +firstRow = unsafeSquealIOTx1 Squeal.firstRow + +getRows :: Result y -> SquealM db db [y] +getRows = unsafeSquealIOTx1 Squeal.getRows + +nextRow :: LibPQ.Row -> Result y -> LibPQ.Row -> SquealM db db (Maybe (LibPQ.Row, y)) +nextRow = unsafeSquealIOTx3 Squeal.nextRow + +ntuples :: Result y -> SquealM db db LibPQ.Row +ntuples = unsafeSquealIOTx1 Squeal.ntuples + +nfields :: Result y -> SquealM db db LibPQ.Column +nfields = unsafeSquealIOTx1 Squeal.nfields + +resultStatus :: Result y -> SquealM db db ExecStatus +resultStatus = unsafeSquealIOTx1 Squeal.resultStatus + +okResult :: K LibPQ.Result row -> SquealM db db () +okResult = unsafeSquealIOTx1 Squeal.okResult + +resultErrorMessage :: Result y -> SquealM db db (Maybe ByteString) +resultErrorMessage = unsafeSquealIOTx1 Squeal.resultErrorMessage + +resultErrorCode :: Result y -> SquealM db db (Maybe ByteString) +resultErrorCode = unsafeSquealIOTx1 Squeal.resultErrorCode + +executeParams :: Statement db x y -> x -> SquealM db db (Result y) +executeParams = unsafeSquealIOTx2 Squeal.executeParams + +executeParams_ :: Statement db x () -> x -> SquealM db db () +executeParams_ = unsafeSquealIOTx2 Squeal.executeParams_ + +execute :: Statement db () y -> SquealM db db (Result y) +execute = unsafeSquealIOTx1 Squeal.execute + +execute_ :: Statement db () () -> SquealM db db () +execute_ = unsafeSquealIOTx1 Squeal.execute_ + +executePrepared + :: (Traversable list) + => Statement db x y -> list x -> SquealM db db (list (Result y)) +executePrepared = unsafeSquealIOTx2 Squeal.executePrepared + +executePrepared_ + :: (Foldable list) + => Statement db x () -> list x -> SquealM db db () +executePrepared_ = unsafeSquealIOTx2 Squeal.executePrepared_ + +manipulateParams + :: ( GenericParams db params x xs + , Squeal.GenericRow row y ys + ) + => Manipulation '[] db params row + -> x + -> SquealM db db (Result y) +manipulateParams = unsafeSquealIOTx2 Squeal.manipulateParams + +manipulateParams_ + :: (GenericParams db params x xs) + => Manipulation '[] db params '[] -> x -> SquealM db db () +manipulateParams_ = unsafeSquealIOTx2 Squeal.manipulateParams_ + +manipulate + :: (Squeal.GenericRow row y ys) + => Manipulation '[] db '[] row -> SquealM db db (Result y) +manipulate = unsafeSquealIOTx1 Squeal.manipulate + +manipulate_ + :: Manipulation '[] db '[] '[] -> SquealM db db () +manipulate_ = unsafeSquealIOTx1 Squeal.manipulate_ + +runQueryParams + :: ( GenericParams db params x xs + , SOP.IsRecord y ys + , SOP.AllZip Squeal.FromField row ys + ) + => Squeal.Query '[] '[] db params row -> x -> SquealM db db (Result y) +runQueryParams = unsafeSquealIOTx2 Squeal.runQueryParams + +runQuery + :: ( SOP.IsRecord y ys + , SOP.AllZip Squeal.FromField row ys + ) + => Squeal.Query '[] '[] db '[] row -> SquealM db db (Result y) +runQuery = unsafeSquealIOTx1 Squeal.runQuery + +traversePrepared + :: ( GenericParams db params x xs + , Traversable list + , SOP.IsRecord y ys + , SOP.AllZip Squeal.FromField row ys + ) + => Manipulation '[] db params row + -> list x + -> SquealM db db (list (Result y)) +traversePrepared = unsafeSquealIOTx2 Squeal.traversePrepared + +forPrepared + :: ( GenericParams db params x xs + , Traversable list + , SOP.IsRecord y ys + , SOP.AllZip Squeal.FromField row ys + ) + => list x + -> Manipulation '[] db params row + -> SquealM db db (list (Result y)) +forPrepared = unsafeSquealIOTx2 Squeal.forPrepared + +traversePrepared_ + :: ( GenericParams db params x xs + , Foldable list + ) + => Manipulation '[] db params '[] + -> list x + -> SquealM db db () +traversePrepared_ = unsafeSquealIOTx2 Squeal.traversePrepared_ + +forPrepared_ + :: ( GenericParams db params x xs + , Foldable list + ) + => list x + -> Manipulation '[] db params '[] + -> SquealM db db () +forPrepared_ = unsafeSquealIOTx2 Squeal.forPrepared_ + +transactionally :: TransactionMode -> Connection -> TxM a -> IO a +transactionally m = unsafeRunSquealTransaction (Squeal.transactionally m) + +transactionally_ :: Connection -> TxM a -> IO a +transactionally_ = unsafeRunSquealTransaction Squeal.transactionally_ + +transactionallyRetry :: TransactionMode -> Connection -> TxM a -> IO a +transactionallyRetry m = unsafeRunSquealTransaction (Squeal.transactionallyRetry m) + +ephemerally :: TransactionMode -> Connection -> TxM a -> IO a +ephemerally m = unsafeRunSquealTransaction (Squeal.ephemerally m) + +ephemerally_ :: Connection -> TxM a -> IO a +ephemerally_ = unsafeRunSquealTransaction Squeal.ephemerally_ + +unsafeRunSquealTransaction + :: (PQ db0 db1 IO a -> PQ db0 db1 IO a) + -> Connection + -> TxM a + -> IO a +unsafeRunSquealTransaction f conn x = + flip Squeal.evalPQ (Squeal.K conn) + $ f + $ PQ \_ -> Squeal.K <$> unsafeRunTxM x + +instance Tx (SquealM db0 db1) where + type TxEnv (SquealM db0 db1) = Connection + tx conn x = evalPQ x (Squeal.K conn) + +instance (UnsafeTx io t) => UnsafeTx (PQ db0 db1 io) (PQ db0 db1 t) where + unsafeIOTx x = PQ \kConn -> unsafeIOTx (Squeal.unPQ x kConn) diff --git a/src/Database/PostgreSQL/Tx/Squeal/Internal/Reexport.hs b/src/Database/PostgreSQL/Tx/Squeal/Internal/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Tx/Squeal/Internal/Reexport.hs @@ -0,0 +1,38 @@ +module Database.PostgreSQL.Tx.Squeal.Internal.Reexport + ( module X + ) where + +-- Don't re-export names that we define in 'Database.PostgreSQL.Tx.Squeal'. +import Squeal.PostgreSQL as X hiding + ( getRow + , firstRow + , getRows + , nextRow + , ntuples + , nfields + , resultStatus + , okResult + , resultErrorMessage + , resultErrorCode + , executeParams + , executeParams_ + , execute + , execute_ + , executePrepared + , executePrepared_ + , manipulateParams + , manipulateParams_ + , manipulate + , manipulate_ + , runQueryParams + , runQuery + , traversePrepared + , forPrepared + , traversePrepared_ + , forPrepared_ + , transactionally + , transactionally_ + , transactionallyRetry + , ephemerally + , ephemerally_ + )