multipool-persistent-postgresql (empty) → 0.1.0.0

raw patch · 7 files changed

+177/−0 lines, 7 filesdep +basedep +monad-loggerdep +mtlsetup-changed

Dependencies added: base, monad-logger, mtl, multipool, multipool-persistent, multipool-persistent-postgresql, persistent, persistent-postgresql, postgresql-common-persistent, unliftio-core, unordered-containers

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
multipool-persistent-postgresql.cabal +68/−0
src/Data/MultiPool/Persist/Postgresql.hs +71/−0
test/Spec.hs +2/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for multipool-persistent-postgresql++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Ian Duncan (c) 2018++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 Ian Duncan 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,1 @@+# multipool-persistent-postgresql

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ multipool-persistent-postgresql.cabal view

@@ -0,0 +1,68 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 2b2ee99431ace4a6256156fe6335848b4ce04856b60c4fb1e4d61cde709eace0++name:           multipool-persistent-postgresql+version:        0.1.0.0+synopsis:       Read and write appropriately from both master and replicated postgresql instances.+description:    Please see the README on GitHub at <https://github.com/iand675/multipool-persistent-postgresql#readme>+homepage:       https://github.com/iand675/multipool-persistent-postgresql#readme+bug-reports:    https://github.com/iand675/multipool-persistent-postgresql/issues+author:         Ian Duncan+maintainer:     ian@iankduncan.com+copyright:      Ian Duncan+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/iand675/multipool-persistent-postgresql++library+  exposed-modules:+      Data.MultiPool.Persist.Postgresql+  other-modules:+      Paths_multipool_persistent_postgresql+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , monad-logger+    , mtl+    , multipool+    , multipool-persistent+    , persistent+    , persistent-postgresql+    , postgresql-common-persistent+    , unliftio-core+    , unordered-containers+  default-language: Haskell2010++test-suite multipool-persistent-postgresql-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_multipool_persistent_postgresql+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , monad-logger+    , mtl+    , multipool+    , multipool-persistent+    , multipool-persistent-postgresql+    , persistent+    , persistent-postgresql+    , postgresql-common-persistent+    , unliftio-core+    , unordered-containers+  default-language: Haskell2010

+ src/Data/MultiPool/Persist/Postgresql.hs view

@@ -0,0 +1,71 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+module Data.MultiPool.Persist.Postgresql+    ( initMultiPool+    , initMultiPool'+    , runReadCurrent+    , getLastLSN+    , gatherLSNs+    ) where+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Reader+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.MultiPool+import Data.MultiPool.Persist.Sql+import Database.Persist.Postgresql+import Database.Persist.Postgresql.Common++initMultiPool ::+     (MonadLogger m, MonadUnliftIO m)+  => ConnectionString+  -> Int+  -> [(InstanceName SqlReadBackend, ConnectionString, Int)]+  -> m (MultiPool SqlBackend)+initMultiPool mc mn rl = do+  rr <- roundRobin $ map (\(i, _, _) -> i) rl+  initMultiPool' rr mc mn rl++initMultiPool' ::+     (MonadLogger m, MonadUnliftIO m)+  => (MultiPool SqlBackend -> IO (Maybe (InstanceName SqlReadBackend))) -- Strategy for selectin the replica instance when calling 'runReadAny'. 'roundRobin' is the current default.+  -> ConnectionString -- ^ Master connection string+  -> Int -- ^ Max number of connections to master instance+  -> [(InstanceName SqlReadBackend, ConnectionString, Int)] -- ^ Replica connection details+  -> m (MultiPool SqlBackend)+initMultiPool' multiPoolAnyReplicaSelector str n is = do+  multiPoolMaster <- createPostgresqlPool str n+  replicas <- mapM (\(inst, connStr, numConns) -> (,) <$> pure inst <*> createPostgresqlPool connStr numConns) is+  let multiPoolReplica = HM.fromList replicas+      multiPoolAnyMasterSelector = const $ pure ()+  return $ MultiPool {..}++-- | Performs a read on the first replica found that sufficiently up-to-date with the given LSN. This function can be combined with 'gatherLSNs' and some sort of caching mechanism to provide a simple way to scale out reads. An great article on this concept can be found [here](https://brandur.org/postgres-reads)+--+-- If no replica is up-to-date with the given LSN, the master instance will be used to run the query.+runReadCurrent ::+     MonadUnliftIO m+  => MultiPool SqlBackend+  -> HashMap (InstanceName SqlReadBackend) LSN+  -> LSN+  -> ReaderT SqlReadBackend m a+  -> m a+runReadCurrent b lsnMap lsn m =+  case validLsnPools of+    [] -> runReadAnyMaster b m+    (pool:_) -> runSqlPool m $ snd pool+  where+    validLsnPools =+      HM.toList $+      HM.intersectionWith+        (\pool _ -> pool)+        (multiPoolReplica b)+        (HM.filter (>= lsn) lsnMap)++-- TODO 9.6 support?+getLastLSN :: MonadIO m => ReaderT SqlReadBackend m LSN+getLastLSN = (unSingle . head) <$> unsafeRead [sqlQQ|SELECT pg_last_wal_replay_lsn() AS lsn|]++gatherLSNs :: MonadUnliftIO m => MultiPool SqlBackend -> m (HashMap (InstanceName SqlReadBackend) LSN)+gatherLSNs p = fmap HM.fromList $ forReplicas p $ \ident pool -> runSqlPool ((,) <$> pure ident <*> getLastLSN) pool

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"