packages feed

fused-effects-squeal (empty) → 0.1.0.0

raw patch · 8 files changed

+484/−0 lines, 8 filesdep +basedep +fused-effectsdep +squeal-postgresqlsetup-changed

Dependencies added: base, fused-effects, squeal-postgresql, unliftio, unliftio-core, unliftio-pool

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## 0.1.0.0++Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Ilya Kostyuchenko (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 Ilya Kostyuchenko 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.
+ README.md view
@@ -0,0 +1,13 @@+# fused-effects-squeal++This is an overview of the way this library works. If you would like to learn how Squeal itself works you should head to the [morphismtech/squeal repository](https://github.com/morphismtech/squeal).++## Usage++There are two sepaeate effects with corresponding carriers: `Squeal` (with `SquealC`) and `SquealPool` (with `SquealPoolC`).++`Squeal` mimics the functions from `MonadPQ` (from `squeal-postgresql`) and represnts the "inside a transaction" effect.++You can run it directly with `runSquealWithConn` family of functions, but you probably want to use a connection pool.++`SquealPool` allows you to call `runSqueal` function, which picks a connection from the connection pool and runs the `Squeal` effect.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fused-effects-squeal.cabal view
@@ -0,0 +1,40 @@+cabal-version: 1.12+name: fused-effects-squeal+version: 0.1.0.0+license: BSD3+license-file: LICENSE+copyright: Ilya Kostyuchenko+maintainer: ilyakooo0@gmail.com+author: Ilya Kostyuchenko+homepage: https://github.com/ilyakooo0/fused-effects-squeal#readme+synopsis: A fused-effects adapter for squeal-postgresql.+description:+    A fused-effects adapter for squeal-postgresql. It allows you to conjure `MonadPQ` instances and manage connection pools in a `fused-effects` stack.+category: Control+build-type: Simple+extra-source-files:+    README.md+    CHANGELOG.md++library+    exposed-modules:+        Control.Carrier.Squeal+        Control.Effect.Squeal+    hs-source-dirs: src+    other-modules:+        Control.Carrier.Orphans+        Paths_fused_effects_squeal+    default-language: Haskell2010+    default-extensions: DataKinds DeriveFunctor DeriveGeneric+                        FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving+                        MultiParamTypeClasses OverloadedLabels OverloadedStrings+                        TypeApplications TypeOperators UndecidableInstances+                        ScopedTypeVariables PolyKinds DerivingStrategies StandaloneDeriving+                        LambdaCase+    build-depends:+        base >=4.7 && <5,+        fused-effects >=1.0.0.0 && <1.1,+        squeal-postgresql >=0.5.2.0 && <0.6,+        unliftio >=0.2.12 && <0.3,+        unliftio-core >=0.1.2.0 && <0.2,+        unliftio-pool >=0.2.1.0 && <0.3
+ src/Control/Carrier/Orphans.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Control.Carrier.Orphans+  (+  )+where++import Control.Carrier.Interpret+import Control.Carrier.Lift+import Control.Carrier.Reader+import qualified Control.Carrier.Trace.Ignoring as TI+import qualified Control.Carrier.Trace.Printing as TP+import Control.Monad.IO.Unlift++instance MonadUnliftIO m => MonadUnliftIO (LiftC m) where+  askUnliftIO = LiftC $ withUnliftIO $ \u -> return (UnliftIO (unliftIO u . runM))+  {-# INLINE askUnliftIO #-}++  withRunInIO inner = LiftC $ withRunInIO $ \run' -> inner (run' . runM)+  {-# INLINE withRunInIO #-}++instance MonadUnliftIO m => MonadUnliftIO (ReaderC r m) where+  askUnliftIO = ReaderC $ \r -> withUnliftIO $ \u -> pure (UnliftIO (\(ReaderC x) -> unliftIO u (x r)))+  {-# INLINE askUnliftIO #-}++  withRunInIO inner = ReaderC $ \r -> withRunInIO $ \go -> inner (go . runReader r)+  {-# INLINE withRunInIO #-}++instance MonadUnliftIO m => MonadUnliftIO (InterpretC s sig m) where+  askUnliftIO = InterpretC $ withUnliftIO $ \u -> return (UnliftIO (\(InterpretC m) -> unliftIO u m))+  {-# INLINE askUnliftIO #-}+  withRunInIO inner = InterpretC $ withRunInIO $ \run' -> inner (\(InterpretC m) -> run' m)+  {-# INLINE withRunInIO #-}++instance MonadUnliftIO m => MonadUnliftIO (TI.TraceC m) where+  askUnliftIO = TI.TraceC $ withUnliftIO $ \u -> return (UnliftIO (unliftIO u . TI.runTrace))+  {-# INLINE askUnliftIO #-}+  withRunInIO inner = TI.TraceC $ withRunInIO $ \run' -> inner (run' . TI.runTrace)+  {-# INLINE withRunInIO #-}++instance MonadUnliftIO m => MonadUnliftIO (TP.TraceC m) where+  askUnliftIO = TP.TraceC $ withUnliftIO $ \u -> return (UnliftIO (unliftIO u . TP.runTrace))+  {-# INLINE askUnliftIO #-}+  withRunInIO inner = TP.TraceC $ withRunInIO $ \run' -> inner (run' . TP.runTrace)+  {-# INLINE withRunInIO #-}
+ src/Control/Carrier/Squeal.hs view
@@ -0,0 +1,175 @@+module Control.Carrier.Squeal+  ( DBConnection,+    runSquealWithConn,+    runSquealWithConnRethrow,+    runSquealWithConn',+    SquealC (..),+    getSquealPool,+    runSqueal',+    runSqueal,+    runSquealPool,+    runSquealRethrow,+    module Control.Algebra,+  )+where++import Control.Algebra+import Control.Carrier.Orphans ()+import Control.Effect.Squeal+import Control.Monad.IO.Unlift+import qualified Squeal.PostgreSQL as Sq+import UnliftIO+import UnliftIO.Pool++newtype SquealC schemas m k = SquealC {unSquealC :: DBConnection schemas -> m k}++instance Functor m => Functor (SquealC schemas m) where+  fmap f (SquealC mk) = SquealC $ (fmap . fmap) f mk+  {-# INLINE fmap #-}++instance Applicative m => Applicative (SquealC schemas m) where+  pure x = SquealC $ \_ -> pure x+  {-# INLINE pure #-}+  (SquealC mklhs) <*> (SquealC mkrhs) = SquealC $ \r -> mklhs r <*> mkrhs r+  {-# INLINE (<*>) #-}++instance Monad m => Monad (SquealC schemas m) where+  (SquealC mk) >>= f = SquealC $ \r -> mk r >>= (runSquealWithConn' r . f)+  {-# INLINE (>>=) #-}++instance MonadIO m => MonadIO (SquealC schemas m) where+  liftIO = SquealC . const . liftIO+  {-# INLINE liftIO #-}++instance MonadUnliftIO m => MonadUnliftIO (SquealC schemas m) where+  withRunInIO inner = SquealC $ \r -> withRunInIO (\f -> inner (f . runSquealWithConn' r))+  {-# INLINE withRunInIO #-}++instance (MonadUnliftIO m, Algebra sig m) => Algebra (Squeal schemas :+: sig) (SquealC schemas m) where+  alg (L (ManipulateParams man x mk)) = SquealC $ \r -> do+    res <- flip evalPQ r $ Sq.manipulateParams man x+    runSquealWithConn' r $ mk res+  alg (L (TraversePrepared man x mk)) = SquealC $ \r -> do+    res <- flip evalPQ r $ Sq.traversePrepared man x+    runSquealWithConn' r $ mk res+  alg (L (TraversePrepared_ man x mk)) = SquealC $ \r -> do+    flip evalPQ r $ Sq.traversePrepared_ man x+    runSquealWithConn' r mk+  alg (R other) = SquealC $ \r -> alg . hmap (runSquealWithConn' r) $ other+  {-# INLINE alg #-}++-- | Run a squeal session using the given database connection without a transaction and without any error handling. You probably shouldn't use this.+runSquealWithConn' :: DBConnection schemas -> SquealC schemas m k -> m k+runSquealWithConn' r (SquealC mk) = mk r+{-# INLINE runSquealWithConn' #-}++-- | Run a squeal session using the given database connection, transaction mode and error handler.+runSquealWithConn ::+  MonadUnliftIO m =>+  DBConnection schemas ->+  Maybe TransactionMode ->+  (SquealException -> m k) ->+  SquealC schemas m k ->+  m k+runSquealWithConn db tr er mk =+  handleSqueal er $ maybe id (transactionallyRetry' db) tr (runSquealWithConn' db mk)+  where+    transactionallyRetry' ::+      (MonadUnliftIO m) =>+      DBConnection schemas ->+      TransactionMode ->+      m x ->+      m x+    transactionallyRetry' conn mode tx = mask $ \restore ->+      loop . try $ do+        x <- restore tx+        flip evalPQ conn $ Sq.manipulate_ commit+        return x+      where+        loop attempt = do+          flip evalPQ conn $ Sq.manipulate_ $ begin mode+          attempt >>= \case+            Left (PQException (PQState _ (Just "40001") _)) -> do+              flip evalPQ conn $ Sq.manipulate_ rollback+              loop attempt+            Left err -> do+              flip evalPQ conn $ Sq.manipulate_ rollback+              throwIO err+            Right x -> return x+{-# INLINE runSquealWithConn #-}++-- | Run a squeal session using the given database connection and transaction mode. Errors will not be handled.+runSquealWithConnRethrow ::+  MonadUnliftIO m =>+  DBConnection schemas ->+  Maybe TransactionMode ->+  SquealC schemas m k ->+  m k+runSquealWithConnRethrow db tr = runSquealWithConn db tr throwIO+{-# INLINE runSquealWithConnRethrow #-}++newtype SquealPoolC schemas m k = SquealPoolC {unSquealPoolC :: Pool (DBConnection schemas) -> m k}++instance Functor m => Functor (SquealPoolC schemas m) where+  fmap f (SquealPoolC mk) = SquealPoolC $ (fmap . fmap) f mk+  {-# INLINE fmap #-}++instance Applicative m => Applicative (SquealPoolC schemas m) where+  pure x = SquealPoolC $ const $ pure x+  {-# INLINE pure #-}+  (SquealPoolC mklhs) <*> (SquealPoolC mkrhs) = SquealPoolC $ \r -> mklhs r <*> mkrhs r+  {-# INLINE (<*>) #-}++instance Monad m => Monad (SquealPoolC schemas m) where+  (SquealPoolC mk) >>= f = SquealPoolC $ \r -> mk r >>= (($ r) . unSquealPoolC . f)+  {-# INLINE (>>=) #-}++instance MonadIO m => MonadIO (SquealPoolC schemas m) where+  liftIO = SquealPoolC . const . liftIO+  {-# INLINE liftIO #-}++instance MonadUnliftIO m => MonadUnliftIO (SquealPoolC schemas m) where+  withRunInIO inner = SquealPoolC $ \r -> withRunInIO (\f -> inner (f . ($ r) . unSquealPoolC))+  {-# INLINE withRunInIO #-}++runSquealPool :: Pool (DBConnection schemas) -> SquealPoolC schemas m k -> m k+runSquealPool conn (SquealPoolC f) = f conn+{-# INLINE runSquealPool #-}++instance Algebra sig m => Algebra (SquealPool schemas :+: sig) (SquealPoolC schemas m) where+  alg (L (GetSquealPool mk)) = SquealPoolC $ \r -> runSquealPool r $ mk r+  alg (R other) = SquealPoolC $ \r -> alg . hmap (runSquealPool r) $ other+  {-# INLINE alg #-}++-- | Run a squeal session picking a database connection from the connection pool without a transaction and without any error handling. You probably shouldn't use this.+runSqueal' ::+  (MonadUnliftIO m, Has (SquealPool schemas) sig m) =>+  SquealC schemas m k ->+  m k+runSqueal' = runSqueal Nothing throwIO+{-# INLINE runSqueal' #-}++-- | Run a squeal session picking a database connection from the connection pool with the given transaction mode and error handler.+runSqueal ::+  (MonadUnliftIO m, Has (SquealPool schemas) sig m) =>+  Maybe TransactionMode ->+  (SquealException -> m k) ->+  SquealC schemas m k ->+  m k+runSqueal tr er mk = do+  pool <- getSquealPool+  withResource pool $ \db ->+    runSquealWithConn db tr er mk+{-# INLINE runSqueal #-}++-- | Run a squeal session picking a database connection from the connection pool with the given transaction mode. Errors will not be handled.+runSquealRethrow ::+  (MonadUnliftIO m, Has (SquealPool schemas) sig m) =>+  Maybe TransactionMode ->+  SquealC schemas m k ->+  m k+runSquealRethrow tr mk = do+  pool <- getSquealPool+  withResource pool $ \db ->+    runSquealWithConn db tr throwIO mk+{-# INLINE runSquealRethrow #-}
+ src/Control/Effect/Squeal.hs view
@@ -0,0 +1,174 @@+module Control.Effect.Squeal+  ( Squeal (..),+    manipulateParams,+    manipulateParams_,+    manipulate,+    manipulate_,+    runQueryParams,+    runQuery,+    traversePrepared,+    forPrepared,+    traversePrepared_,+    forPrepared_,++    -- * Pool+    DBConnection,+    SquealPool (..),+    getSquealPool,++    -- * Reexports+    module Sq,+    module Control.Algebra,+  )+where++import Control.Algebra+import Control.Carrier.Orphans ()+import Data.Functor+import Squeal.PostgreSQL as Sq hiding+  ( Has,+    forPrepared,+    forPrepared_,+    manipulate,+    manipulateParams,+    manipulateParams_,+    manipulate_,+    runQuery,+    runQueryParams,+    traversePrepared,+    traversePrepared_,+  )++type DBConnection (schemas :: SchemasType) = K Connection schemas++data Squeal (schemas :: SchemasType) m k where+  ManipulateParams ::+    Sq.ToParams x params =>+    Sq.Manipulation '[] schemas params ys ->+    x ->+    (Sq.K Sq.Result ys -> m k) ->+    Squeal schemas m k+  TraversePrepared ::+    (Sq.ToParams x params, Traversable list) =>+    Sq.Manipulation '[] schemas params ys ->+    list x ->+    (list (Sq.K Sq.Result ys) -> m k) ->+    Squeal schemas m k+  TraversePrepared_ ::+    (Sq.ToParams x params, Foldable list) =>+    Sq.Manipulation '[] schemas params '[] ->+    list x ->+    m k ->+    Squeal schemas m k++instance Functor m => Functor (Squeal schemas m) where+  fmap f (ManipulateParams man x mk) = ManipulateParams man x ((fmap . fmap) f mk)+  fmap f (TraversePrepared man x mk) = TraversePrepared man x ((fmap . fmap) f mk)+  fmap f (TraversePrepared_ man x mk) = TraversePrepared_ man x (fmap f mk)+  {-# INLINE fmap #-}++instance HFunctor (Squeal schemas) where+  hmap f (ManipulateParams man x mk) = ManipulateParams man x (fmap f mk)+  hmap f (TraversePrepared man x mk) = TraversePrepared man x (fmap f mk)+  hmap f (TraversePrepared_ man x mk) = TraversePrepared_ man x (f mk)+  {-# INLINE hmap #-}++instance Effect (Squeal schemas) where+  thread ctx f (ManipulateParams man x mk) = ManipulateParams man x $ \y -> f (ctx $> mk y)+  thread ctx f (TraversePrepared man x mk) = TraversePrepared man x $ \y -> f (ctx $> mk y)+  thread ctx f (TraversePrepared_ man x mk) = TraversePrepared_ man x $ f (ctx $> mk)+  {-# INLINE thread #-}++-- | See 'Sq.manipulateParams' from @squeal-postgresql@.+manipulateParams ::+  (Has (Squeal schemas) sig m, Sq.ToParams x params) =>+  Sq.Manipulation '[] schemas params ys ->+  x ->+  m (Sq.K Sq.Result ys)+manipulateParams man x = send $ ManipulateParams man x pure++-- | See 'Sq.manipulateParams_' from @squeal-postgresql@.+manipulateParams_ ::+  (Has (Squeal schemas) sig m, Sq.ToParams x params) =>+  Sq.Manipulation '[] schemas params ys ->+  x ->+  m ()+manipulateParams_ man x = manipulateParams man x $> ()++-- | See 'Sq.manipulate' from @squeal-postgresql@.+manipulate ::+  Has (Squeal schemas) sig m =>+  Sq.Manipulation '[] schemas '[] ys ->+  m (Sq.K Sq.Result ys)+manipulate man = manipulateParams man ()++-- | See 'Sq.manipulate_' from @squeal-postgresql@.+manipulate_ ::+  Has (Squeal schemas) sig m =>+  Sq.Manipulation '[] schemas '[] ys ->+  m ()+manipulate_ man = manipulate_ man $> ()++-- | See 'Sq.runQueryParams' from @squeal-postgresql@.+runQueryParams ::+  (Has (Squeal schemas) sig m, Sq.ToParams x params) =>+  Sq.Query '[] '[] schemas params ys ->+  x ->+  m (Sq.K Sq.Result ys)+runQueryParams = manipulateParams . Sq.queryStatement++-- | See 'Sq.runQuery' from @squeal-postgresql@.+runQuery ::+  Has (Squeal schemas) sig m =>+  Sq.Query '[] '[] schemas '[] ys ->+  m (Sq.K Sq.Result ys)+runQuery q = runQueryParams q ()++-- | See 'Sq.traversePrepared' from @squeal-postgresql@.+traversePrepared ::+  (Sq.ToParams x params, Traversable list, Has (Squeal schemas) sig m) =>+  Sq.Manipulation '[] schemas params ys ->+  list x ->+  m (list (Sq.K Sq.Result ys))+traversePrepared man l = send $ TraversePrepared man l pure++-- | See 'Sq.forPrepared' from @squeal-postgresql@.+forPrepared ::+  (Sq.ToParams x params, Traversable list, Has (Squeal schemas) sig m) =>+  list x ->+  Sq.Manipulation '[] schemas params ys ->+  m (list (Sq.K Sq.Result ys))+forPrepared = flip traversePrepared++-- | See 'Sq.traversePrepared_' from @squeal-postgresql@.+traversePrepared_ ::+  (Sq.ToParams x params, Foldable list, Has (Squeal schemas) sig m) =>+  Sq.Manipulation '[] schemas params '[] ->+  list x ->+  m ()+traversePrepared_ man l = send $ TraversePrepared_ man l (pure ())++-- | See 'Sq.forPrepared_' from @squeal-postgresql@.+forPrepared_ ::+  (Sq.ToParams x params, Foldable list, Has (Squeal schemas) sig m) =>+  list x ->+  Sq.Manipulation '[] schemas params '[] ->+  m ()+forPrepared_ = flip traversePrepared_++newtype SquealPool schemas m k = GetSquealPool (Pool (DBConnection schemas) -> m k)++instance Functor m => Functor (SquealPool schemas m) where+  fmap f (GetSquealPool mk) = GetSquealPool ((fmap . fmap) f mk)+  {-# INLINE fmap #-}++instance HFunctor (SquealPool schemas) where+  hmap f (GetSquealPool mk) = GetSquealPool (fmap f mk)+  {-# INLINE hmap #-}++instance Effect (SquealPool schemas) where+  thread ctx f (GetSquealPool mk) = GetSquealPool $ \y -> f (ctx $> mk y)+  {-# INLINE thread #-}++getSquealPool :: Has (SquealPool schemas) sig m => m (Pool (DBConnection schemas))+getSquealPool = send $ GetSquealPool pure