├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── Vagrantfile ├── benchmarks └── Main.hs ├── developer_notes.md ├── flamecharts └── baseline.svg ├── package.yaml ├── s └── test-time ├── src └── Database │ └── PostgreSQL │ └── Simple │ ├── Queue.hs │ └── Queue │ └── Migrate.hs ├── stack.yaml ├── stack.yaml.lock └── test ├── Database └── PostgreSQL │ └── Simple │ └── QueueSpec.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | # Compiled source # 2 | ################### 3 | *.com 4 | *.class 5 | *.dll 6 | *.exe 7 | *.o 8 | *.so 9 | *.hi 10 | *.lib 11 | 12 | *.aes 13 | *.pem 14 | # Packages # 15 | ############ 16 | # it's better to unpack these files and commit the raw source 17 | # git has its own built in compression methods 18 | *.7z 19 | *.dmg 20 | *.gz 21 | *.iso 22 | *.jar 23 | *.rar 24 | *.tar 25 | *.zip 26 | 27 | # Logs and databases # 28 | ###################### 29 | *.log 30 | *.sql 31 | *.sqlite 32 | 33 | #keys 34 | *.pem 35 | *.cer 36 | *.pem~ 37 | *.p12 38 | 39 | # OS generated files # 40 | ###################### 41 | .DS_Store* 42 | ehthumbs.db 43 | Icon? 44 | Thumbs.db 45 | 46 | *.p_o 47 | *.hi 48 | *.*~ 49 | dist 50 | tags 51 | *.prof 52 | 53 | .cabal-sandbox 54 | .stack-work 55 | .vagrant 56 | bin/ 57 | core/ 58 | *.s 59 | 60 | .test-cache 61 | /postgresql-simple-queue.cabal 62 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Copy these contents into the root directory of your Github project in a file 2 | # named .travis.yml 3 | 4 | # Use new container infrastructure to enable caching 5 | sudo: false 6 | 7 | # Choose a lightweight base image; we provide our own build tools. 8 | language: c 9 | 10 | # Caching so the next build will be fast too. 11 | cache: 12 | directories: 13 | - $HOME/.ghc 14 | - $HOME/.cabal 15 | - $HOME/.stack 16 | 17 | # The different configurations we want to test. We have BUILD=cabal which uses 18 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 19 | # of those below. 20 | # 21 | # We set the compiler values here to tell Travis to use a different 22 | # cache file per set of arguments. 23 | # 24 | # If you need to have different apt packages for each combination in the 25 | # matrix, you can use a line such as: 26 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 27 | matrix: 28 | include: 29 | # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: 30 | # https://github.com/hvr/multi-ghc-travis 31 | #- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 32 | # compiler: ": #GHC 7.0.4" 33 | # addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 34 | #- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 35 | # compiler: ": #GHC 7.2.2" 36 | # addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 37 | #- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 38 | # compiler: ": #GHC 7.4.2" 39 | # addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 40 | - env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 41 | compiler: ": #GHC 7.6.3" 42 | addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 43 | - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7 44 | compiler: ": #GHC 7.8.4" 45 | addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 46 | - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 47 | compiler: ": #GHC 7.10.3" 48 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 49 | - env: BUILD=cabal GHCVER=8.0.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 50 | compiler: ": #GHC 8.0.1" 51 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 52 | 53 | # Build with the newest GHC and cabal-install. This is an accepted failure, 54 | # see below. 55 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 56 | compiler: ": #GHC HEAD" 57 | addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 58 | 59 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 60 | # variable, such as using --stack-yaml to point to a different file. 61 | - env: BUILD=stack ARGS="" 62 | compiler: ": #stack default" 63 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 64 | 65 | # Nightly builds are allowed to fail 66 | - env: BUILD=stack ARGS="--resolver nightly" 67 | compiler: ": #stack nightly" 68 | addons: {apt: {packages: [libgmp,libgmp-dev]}} 69 | 70 | # Build on OS X in addition to Linux 71 | - env: BUILD=stack ARGS="" 72 | compiler: ": #stack default osx" 73 | os: osx 74 | 75 | - env: BUILD=stack ARGS="--resolver lts-2" 76 | compiler: ": #stack 7.8.4 osx" 77 | os: osx 78 | 79 | - env: BUILD=stack ARGS="--resolver lts-3" 80 | compiler: ": #stack 7.10.2 osx" 81 | os: osx 82 | 83 | - env: BUILD=stack ARGS="--resolver lts-6" 84 | compiler: ": #stack 7.10.3 osx" 85 | os: osx 86 | 87 | - env: BUILD=stack ARGS="--resolver nightly" 88 | compiler: ": #stack nightly osx" 89 | os: osx 90 | 91 | allow_failures: 92 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 93 | - env: BUILD=stack ARGS="--resolver nightly" 94 | 95 | before_install: 96 | # Using compiler above sets CC to an invalid value, so unset it 97 | - unset CC 98 | 99 | # We want to always allow newer versions of packages when building on GHC HEAD 100 | - CABALARGS="" 101 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 102 | 103 | # Download and unpack the stack executable 104 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 105 | - mkdir -p ~/.local/bin 106 | - | 107 | if [ `uname` = "Darwin" ] 108 | then 109 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 110 | else 111 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 112 | fi 113 | 114 | # Use the more reliable S3 mirror of Hackage 115 | mkdir -p $HOME/.cabal 116 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 117 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 118 | 119 | if [ "$CABALVER" != "1.16" ] 120 | then 121 | echo 'jobs: $ncpus' >> $HOME/.cabal/config 122 | fi 123 | 124 | # Get the list of packages from the stack.yaml file 125 | - PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 126 | 127 | install: 128 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 129 | - if [ -f configure.ac ]; then autoreconf -i; fi 130 | - | 131 | set -ex 132 | case "$BUILD" in 133 | stack) 134 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 135 | ;; 136 | cabal) 137 | cabal --version 138 | travis_retry cabal update 139 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 140 | ;; 141 | esac 142 | set +ex 143 | 144 | script: 145 | - | 146 | set -ex 147 | case "$BUILD" in 148 | stack) 149 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 150 | ;; 151 | cabal) 152 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 153 | 154 | ORIGDIR=$(pwd) 155 | for dir in $PACKAGES 156 | do 157 | cd $dir 158 | cabal check || [ "$CABALVER" == "1.16" ] 159 | cabal sdist 160 | PKGVER=$(cabal info . | awk '{print $2;exit}') 161 | SRC_TGZ=$PKGVER.tar.gz 162 | cd dist 163 | tar zxfv "$SRC_TGZ" 164 | cd "$PKGVER" 165 | cabal configure --enable-tests 166 | cabal build 167 | cd $ORIGDIR 168 | done 169 | ;; 170 | esac 171 | set +ex 172 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # postgresql-simple-queue 2 | 3 | This module utilizes PostgreSQL to implement a durable queue for efficently processing arbitrary payloads which can be represented as JSON. 4 | 5 | Typically a producer would enqueue a new payload as part of larger database transaction 6 | 7 | ```haskell 8 | createAccount userRecord = do 9 | runDBTSerializable $ do 10 | createUserDB userRecord 11 | enqueueDB $ makeVerificationEmail userRecord 12 | ``` 13 | 14 | In another thread or process, the consumer would drain the queue. 15 | 16 | ```haskell 17 | forever $ do 18 | -- Attempt get a payload or block until one is available 19 | payload <- lock conn 20 | 21 | -- Perform application specifc parsing of the payload value 22 | case fromJSON $ pValue payload of 23 | Success x -> sendEmail x -- Perform application specific processing 24 | Error err -> logErr err 25 | 26 | -- Remove the payload from future processing 27 | dequeue conn $ pId payload 28 | ``` 29 | 30 | ## Installation 31 | 32 | ```bash 33 | stack install postgresql-simple-queue 34 | ``` 35 | 36 | ## Blog 37 | This package was discussed in the blog [Testing PostgreSQL for Fun](https://medium.com/@jonathangfischoff/testing-postgresql-for-fun-af891047e5fc) 38 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Vagrantfile: -------------------------------------------------------------------------------- 1 | # -*- mode: ruby -*- 2 | # vi: set ft=ruby : 3 | 4 | # All Vagrant configuration is done below. The "2" in Vagrant.configure 5 | # configures the configuration version (we support older styles for 6 | # backwards compatibility). Please don't change it unless you know what 7 | # you're doing. 8 | Vagrant.configure("2") do |config| 9 | # The most common configuration options are documented and commented below. 10 | # For a complete reference, please see the online documentation at 11 | # https://docs.vagrantup.com. 12 | 13 | # Every Vagrant development environment requires a box. You can search for 14 | # boxes at https://vagrantcloud.com/search. 15 | config.vm.box = "debian/buster64" 16 | 17 | # Disable automatic box update checking. If you disable this, then 18 | # boxes will only be checked for updates when the user runs 19 | # `vagrant box outdated`. This is not recommended. 20 | # config.vm.box_check_update = false 21 | 22 | # Create a forwarded port mapping which allows access to a specific port 23 | # within the machine from a port on the host machine. In the example below, 24 | # accessing "localhost:8080" will access port 80 on the guest machine. 25 | # NOTE: This will enable public access to the opened port 26 | # config.vm.network "forwarded_port", guest: 80, host: 8080 27 | 28 | # Create a forwarded port mapping which allows access to a specific port 29 | # within the machine from a port on the host machine and only allow access 30 | # via 127.0.0.1 to disable public access 31 | # config.vm.network "forwarded_port", guest: 80, host: 8080, host_ip: "127.0.0.1" 32 | 33 | # Create a private network, which allows host-only access to the machine 34 | # using a specific IP. 35 | # config.vm.network "private_network", ip: "192.168.33.10" 36 | 37 | # Create a public network, which generally matched to bridged network. 38 | # Bridged networks make the machine appear as another physical device on 39 | # your network. 40 | # config.vm.network "public_network" 41 | 42 | # Share an additional folder to the guest VM. The first argument is 43 | # the path on the host to the actual folder. The second argument is 44 | # the path on the guest to mount the folder. And the optional third 45 | # argument is a set of non-required options. 46 | # config.vm.synced_folder "../data", "/vagrant_data" 47 | 48 | # Provider-specific configuration so you can fine-tune various 49 | # backing providers for Vagrant. These expose provider-specific options. 50 | # Example for VirtualBox: 51 | # 52 | config.vm.provider "virtualbox" do |vb| 53 | # # Display the VirtualBox GUI when booting the machine 54 | # vb.gui = true 55 | # 56 | # # Customize the amount of memory on the VM: 57 | vb.memory = "4096" 58 | end 59 | # 60 | # View the documentation for the provider you are using for more 61 | # information on available options. 62 | 63 | # Enable provisioning with a shell script. Additional provisioners such as 64 | # Puppet, Chef, Ansible, Salt, and Docker are also available. Please see the 65 | # documentation for more information about their specific syntax and use. 66 | # config.vm.provision "shell", inline: <<-SHELL 67 | # apt-get update 68 | # apt-get install -y apache2 69 | # SHELL 70 | end 71 | -------------------------------------------------------------------------------- /benchmarks/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import System.Environment 3 | import Database.PostgreSQL.Simple.Queue 4 | import Database.PostgreSQL.Simple.Queue.Migrate 5 | import Control.Concurrent.Async 6 | import Data.Aeson 7 | import Data.IORef 8 | import Control.Exception 9 | import Crypto.Hash.SHA1 (hash) 10 | import qualified Data.ByteString.Base64.URL as Base64 11 | import qualified Data.ByteString.Char8 as BSC 12 | import Data.Pool 13 | import Database.Postgres.Temp 14 | import Database.PostgreSQL.Simple 15 | import Control.Concurrent 16 | import Control.Monad (replicateM, forever, void) 17 | 18 | 19 | -- TODO need to make sure the number of producers and consumers does not go over the number of connections 20 | 21 | 22 | withConn :: DB -> (Connection -> IO a) -> IO a 23 | withConn db f = do 24 | let connStr = toConnectionString db 25 | bracket (connectPostgreSQL connStr) close f 26 | 27 | withSetup :: (Pool Connection -> IO ()) -> IO () 28 | withSetup f = do 29 | -- Helper to throw exceptions 30 | let throwE x = either throwIO pure =<< x 31 | 32 | throwE $ withDbCache $ \dbCache -> do 33 | --let combinedConfig = autoExplainConfig 15 <> cacheConfig dbCache 34 | let combinedConfig = defaultConfig <> cacheConfig dbCache 35 | migratedConfig <- throwE $ cacheAction (("~/.tmp-postgres/" <>) . BSC.unpack . Base64.encode . hash 36 | $ BSC.pack migrationQueryString) (flip withConn migrate) combinedConfig 37 | withConfig migratedConfig $ \db -> do 38 | print $ toConnectionString db 39 | 40 | f =<< createPool 41 | (do 42 | c <- connectPostgreSQL $ toConnectionString db 43 | setup c 44 | pure c 45 | ) close 2 60 49 46 | 47 | payload :: Value 48 | payload = toJSON 'a' 49 | 50 | main :: IO () 51 | main = do 52 | [producerCount, consumerCount, time, initialDequeueCount, initialEnqueueCount] <- map read <$> getArgs 53 | -- create a temporary database 54 | enqueueCounter <- newIORef (0 :: Int) 55 | dequeueCounter <- newIORef (0 :: Int) 56 | 57 | let printCounters = do 58 | finalEnqueueCount <- readIORef enqueueCounter 59 | finalDequeueCount <- readIORef dequeueCounter 60 | putStrLn $ "Time " <> show time <> " secs" 61 | putStrLn $ "Enqueue Count: " <> show finalEnqueueCount 62 | putStrLn $ "Dequeue Count: " <> show finalDequeueCount 63 | 64 | flip finally printCounters $ withSetup $ \pool -> do 65 | -- enqueue the enqueueCount + dequeueCount 66 | let totalEnqueueCount = initialDequeueCount + initialEnqueueCount 67 | enqueueAction = void $ withResource pool $ \conn -> enqueue conn payload 68 | dequeueAction = void $ withResource pool $ dequeue 69 | 70 | replicateConcurrently_ totalEnqueueCount enqueueAction 71 | replicateConcurrently_ initialDequeueCount dequeueAction 72 | 73 | withResource pool $ \conn -> void $ execute_ conn "VACUUM FULL ANALYZE" 74 | 75 | -- forever $ threadDelay 1000000000 76 | 77 | let enqueueLoop = forever $ do 78 | enqueueAction 79 | atomicModifyIORef' enqueueCounter $ \x -> (x+1, ()) 80 | 81 | dequeueLoop = forever $ do 82 | dequeueAction 83 | atomicModifyIORef' dequeueCounter $ \x -> (x+1, ()) 84 | 85 | -- Need better exception behavior ... idk ... I'll deal with this later 86 | _enqueueThreads <- replicateM producerCount $ async enqueueLoop 87 | _dequeueThreads <- replicateM consumerCount $ async dequeueLoop 88 | 89 | threadDelay $ time * 1000000 90 | throwIO $ userError "Finished" 91 | -------------------------------------------------------------------------------- /developer_notes.md: -------------------------------------------------------------------------------- 1 | # 1/21/20 2 | - According to the flamecharts preparing the statements takes a third of the time. Also setting the schema takes some time. 3 | - Going to remove the schema setting first to simplify the code. Then I'll use prepared statements. 4 | - The reason I need the schema is for a prefix for the notify 5 | - One option is to remove it and the figure out how to add it back. 6 | - Yeah I'm going to do that. I would like to keep things simple as I improve perf 7 | - I think it needs to make a record of function based on the string 8 | 9 | # 1/13/20 10 | - Initial benchmark setup ... not sure what else to do with it at the moment 11 | - There are two types of slow queries 12 | - Update on public.payloads (cost=4.01..12.04 rows=1 width=102) (actual time=21.069..21.070 rows=1 loops=1) 13 | Output: payloads.id, payloads.value, payloads.state, payloads.attempts, payloads.created_at, payloads.modified_at 14 | Buffers: shared hit=69 15 | -> Nested Loop (cost=4.01..12.04 rows=1 width=102) (actual time=2.849..2.850 rows=1 loops=1) 16 | Output: payloads.id, payloads.value, payloads.attempts, 'dequeued'::state_t, payloads.created_at, payloads.modified_at, payloads.ctid, "ANY_subquery".* 17 | Inner Unique: true 18 | Buffers: shared hit=43 19 | -> HashAggregate (cost=3.73..3.74 rows=1 width=40) (actual time=2.835..2.836 rows=1 loops=1) 20 | Output: "ANY_subquery".*, "ANY_subquery".id 21 | Group Key: "ANY_subquery".id 22 | Buffers: shared hit=40 23 | -> Subquery Scan on "ANY_subquery" (cost=0.28..3.72 rows=1 width=40) (actual time=2.821..2.823 rows=1 loops=1) 24 | Output: "ANY_subquery".*, "ANY_subquery".id 25 | Buffers: shared hit=40 26 | -> Limit (cost=0.28..3.71 rows=1 width=22) (actual time=2.799..2.800 rows=1 loops=1) 27 | Output: payloads_1.id, payloads_1.modified_at, payloads_1.ctid 28 | Buffers: shared hit=40 29 | -> LockRows (cost=0.28..161.58 rows=47 width=22) (actual time=2.798..2.798 rows=1 loops=1) 30 | Output: payloads_1.id, payloads_1.modified_at, payloads_1.ctid 31 | Buffers: shared hit=40 32 | -> Index Scan using active_modified_at_idx on public.payloads payloads_1 (cost=0.28..161.11 rows=47 width=22) (actual time=1.262..1.296 rows=21 loops=1) 33 | Output: payloads_1.id, payloads_1.modified_at, payloads_1.ctid 34 | Filter: (payloads_1.state = 'enqueued'::state_t) 35 | Buffers: shared hit=19 36 | -> Index Scan using payloads_pkey on public.payloads (cost=0.29..8.30 rows=1 width=66) (actual time=0.011..0.011 rows=1 loops=1) 37 | Output: payloads.id, payloads.value, payloads.attempts, payloads.created_at, payloads.modified_at, payloads.ctid 38 | Index Cond: (payloads.id = "ANY_subquery".id) 39 | Buffers: shared hit=3 40 | Trigger payloads_modified: time=0.299 calls=1 41 | 42 | Where the time is attributed to nothing in particular and where it is attributed to the lock 43 | 44 | - Update on public.payloads (cost=6.54..14.56 rows=1 width=80) (actual time=23.427..23.428 rows=1 loops=1) 45 | Output: payloads.id, payloads.value, payloads.state, payloads.attempts, payloads.created_at, payloads.modified_at 46 | Buffers: shared hit=371 47 | -> Nested Loop (cost=6.54..14.56 rows=1 width=80) (actual time=23.388..23.389 rows=1 loops=1) 48 | Output: payloads.id, payloads.value, payloads.attempts, 'dequeued'::state_t, payloads.created_at, payloads.modified_at, payloads.ctid, "ANY_subquery".* 49 | Inner Unique: true 50 | Buffers: shared hit=363 51 | -> HashAggregate (cost=6.25..6.26 rows=1 width=40) (actual time=23.378..23.378 rows=1 loops=1) 52 | Output: "ANY_subquery".*, "ANY_subquery".id 53 | Group Key: "ANY_subquery".id 54 | Buffers: shared hit=360 55 | -> Subquery Scan on "ANY_subquery" (cost=0.28..6.25 rows=1 width=40) (actual time=23.374..23.375 rows=1 loops=1) 56 | Output: "ANY_subquery".*, "ANY_subquery".id 57 | Buffers: shared hit=360 58 | -> Limit (cost=0.28..6.24 rows=1 width=22) (actual time=23.370..23.370 rows=1 loops=1) 59 | Output: payloads_1.id, payloads_1.modified_at, payloads_1.ctid 60 | Buffers: shared hit=360 61 | -> LockRows (cost=0.28..6.24 rows=1 width=22) (actual time=23.369..23.369 rows=1 loops=1) 62 | Output: payloads_1.id, payloads_1.modified_at, payloads_1.ctid 63 | Buffers: shared hit=360 64 | -> Index Scan using active_modified_at_idx on public.payloads payloads_1 (cost=0.28..6.23 rows=1 width=22) (actual time=0.068..0.191 rows=86 loops=1) 65 | Output: payloads_1.id, payloads_1.modified_at, payloads_1.ctid 66 | Filter: (payloads_1.state = 'enqueued'::state_t) 67 | Buffers: shared hit=141 68 | -> Index Scan using payloads_pkey on public.payloads (cost=0.29..8.30 rows=1 width=44) (actual time=0.007..0.007 rows=1 loops=1) 69 | Output: payloads.id, payloads.value, payloads.attempts, payloads.created_at, payloads.modified_at, payloads.ctid 70 | Index Cond: (payloads.id = "ANY_subquery".id) 71 | Buffers: shared hit=3 72 | Trigger payloads_modified: time=0.013 calls=1 73 | 74 | # 1/12/20 75 | 76 | - I wish there were actual benchmarks already setup. 77 | - I want to see if the `pg_wait_sampling` provides any insight. 78 | - Not really about to see any perf issues just looking at the tests. 79 | - I need to make actual benchmarks to stress the system. 80 | - Some thoughts about benchmarks 81 | - I need to warm the caches when setting up 82 | - I should run vacuum analyze full and reindex before running. 83 | - I would like to be able to `pg_wait_sampling` as well. 84 | - I feel like I am going to want to be able replay what happens when there is contention. 85 | - I should map out what happens as the consumers and producers numbers are adjusted. 86 | - I don't think I should write a criterion benchmark for this. I think I should have a 87 | exe that that could how many queues/enqueues in some amount of time. 88 | - It should take args for 89 | - number of producers 90 | - number of consumers 91 | - number of time 92 | - initial number dequeued payloads 93 | - initial number of enqueued payloads 94 | # Decemeber 27th 2019 95 | 96 | The result of removing a postgres instance. 97 | 98 | The old times are on the left and the new (removed instance) are on the right. 99 | 100 | 1.6324 1.4624 R 101 | 1.6689 1.6946 L 102 | 1.7416 1.3665 R 103 | 1.8576 1.5354 R 104 | 1.8035 1.5383 R 105 | 1.7434 1.4234 R 106 | 1.9321 1.4897 R 107 | 1.7444 1.4729 R 108 | 1.6803 1.4600 R 109 | 1.6598 1.6410 R 110 | 111 | Removing an instance wins. 112 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: postgresql-simple-queue 2 | version: '1.0.1' 3 | synopsis: A PostgreSQL backed queue 4 | description: ! 'This module utilize PostgreSQL to implement a durable queue for efficently 5 | processing arbitrary payloads which can be represented as JSON. 6 | 7 | 8 | Typically a producer would enqueue a new payload as part of larger database 9 | 10 | transaction 11 | 12 | 13 | > createAccount userRecord = do 14 | 15 | > ''runDBTSerializable'' $ do 16 | 17 | > createUserDB userRecord 18 | 19 | > ''enqueueDB'' "queue_schema" $ makeVerificationEmail userRecord 20 | 21 | 22 | In another thread or process, the consumer would drain the queue. 23 | 24 | 25 | > forever $ do 26 | 27 | > -- Attempt get a payload or block until one is available 28 | 29 | > payload <- lock "queue" conn 30 | 31 | > 32 | 33 | > -- Perform application specifc parsing of the payload value 34 | 35 | > case fromJSON $ pValue payload of 36 | 37 | > Success x -> sendEmail x -- Perform application specific processing 38 | 39 | > Error err -> logErr err 40 | 41 | > 42 | 43 | > -- Remove the payload from future processing 44 | 45 | > dequeue "queue" conn $ pId payload 46 | 47 | > 48 | 49 | > To support multiple queues in the same database, the API expects a table name 50 | string 51 | 52 | > to determine which queue tables to use.' 53 | category: Web 54 | author: Jonathan Fischoff 55 | maintainer: jonathangfischoff@gmail.com 56 | copyright: 2017 Jonathan Fischoff 57 | license: BSD3 58 | github: jfischoff/postgresql-queue 59 | extra-source-files: 60 | - README.md 61 | ghc-options: 62 | - -Wall 63 | - -Wno-unused-do-bind 64 | 65 | default-extensions: 66 | - OverloadedStrings 67 | 68 | dependencies: 69 | - base >=4.7 && <5 70 | - time 71 | - transformers 72 | - random 73 | - text 74 | - monad-control 75 | - exceptions 76 | - postgresql-simple 77 | - pg-transact 78 | - aeson 79 | - bytestring 80 | - stm 81 | - here 82 | 83 | library: 84 | source-dirs: src 85 | exposed-modules: 86 | - Database.PostgreSQL.Simple.Queue 87 | - Database.PostgreSQL.Simple.Queue.Migrate 88 | 89 | tests: 90 | unit-tests: 91 | main: Spec.hs 92 | source-dirs: test 93 | ghc-options: 94 | - -O2 95 | - -threaded 96 | - -rtsopts 97 | - -with-rtsopts=-N 98 | dependencies: 99 | - base64-bytestring 100 | - cryptohash-sha1 101 | - postgresql-simple-queue 102 | - hspec 103 | - hspec-core 104 | - hspec-discover 105 | - hspec-expectations-lifted 106 | - async 107 | - split 108 | - tmp-postgres 109 | - resource-pool 110 | 111 | executables: 112 | benchmark: 113 | main: Main.hs 114 | source-dirs: benchmarks 115 | ghc-options: 116 | - -O2 117 | - -Wall 118 | - -threaded 119 | - -rtsopts 120 | - -with-rtsopts=-N 121 | dependencies: 122 | - base64-bytestring 123 | - cryptohash-sha1 124 | - postgresql-simple-queue 125 | - async 126 | - tmp-postgres 127 | - resource-pool 128 | -------------------------------------------------------------------------------- /s/test-time: -------------------------------------------------------------------------------- 1 | stack test 2>&1 | grep Fini 2 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Queue.hs: -------------------------------------------------------------------------------- 1 | {-| This module utilize PostgreSQL to implement a durable queue for efficently processing 2 | arbitrary payloads which can be represented as JSON. 3 | 4 | Typically a producer would enqueue a new payload as part of larger database 5 | transaction 6 | 7 | @ 8 | createAccount userRecord = do 9 | 'runDBTSerializable' $ do 10 | createUserDB userRecord 11 | 'enqueueDB' $ makeVerificationEmail userRecord 12 | @ 13 | 14 | In another thread or process, the consumer would drain the queue. 15 | 16 | @ 17 | forever $ do 18 | -- Attempt get a payload or block until one is available 19 | payload <- 'lock' conn 20 | 21 | -- Perform application specifc parsing of the payload value 22 | case fromJSON $ 'pValue' payload of 23 | Success x -> sendEmail x -- Perform application specific processing 24 | Error err -> logErr err 25 | 26 | -- Remove the payload from future processing 27 | 'dequeue' conn $ 'pId' payload 28 | @ 29 | 30 | For a more complete example or a consumer, utilizing the provided 31 | 'Database.PostgreSQL.Simple.Queue.Main.defaultMain', see 32 | 'Database.PostgreSQL.Simple.Queue.Examples.EmailQueue.EmailQueue'. 33 | 34 | This modules provides two flavors of functions, a DB API and an IO API. 35 | Most operations are provided in both flavors, with the exception of 'lock'. 36 | 'lock' blocks and would not be that useful as part of a larger transaction 37 | since it would keep the transaction open for a potentially long time. Although 38 | both flavors are provided, in general one versions is more useful for typical 39 | use cases. 40 | 41 | -} 42 | {-# LANGUAGE FlexibleContexts #-} 43 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 44 | {-# LANGUAGE LambdaCase #-} 45 | {-# LANGUAGE OverloadedStrings #-} 46 | {-# LANGUAGE QuasiQuotes #-} 47 | {-# LANGUAGE RecordWildCards #-} 48 | {-# LANGUAGE ScopedTypeVariables #-} 49 | {-# LANGUAGE OverloadedStrings #-} 50 | module Database.PostgreSQL.Simple.Queue 51 | ( -- * Types 52 | PayloadId (..) 53 | , State (..) 54 | , Payload (..) 55 | -- * DB API 56 | , setup 57 | , enqueueDB 58 | , dequeueDB 59 | , withPayloadDB 60 | , getCountDB 61 | -- * IO API 62 | , enqueue 63 | , tryDequeue 64 | , dequeue 65 | , withPayload 66 | , getCount 67 | ) where 68 | import Control.Monad 69 | import Control.Monad.Catch 70 | import Data.Aeson 71 | import Data.Function 72 | import Data.Int 73 | import Data.Text (Text) 74 | import Data.Time 75 | import Database.PostgreSQL.Simple (Connection, Only (..)) 76 | import qualified Database.PostgreSQL.Simple as Simple 77 | import Database.PostgreSQL.Simple.FromField 78 | import Database.PostgreSQL.Simple.FromRow 79 | import Database.PostgreSQL.Simple.Notification 80 | import Database.PostgreSQL.Simple.SqlQQ 81 | import Database.PostgreSQL.Simple.ToField 82 | import Database.PostgreSQL.Simple.ToRow 83 | import Database.PostgreSQL.Simple.Transaction 84 | import Database.PostgreSQL.Transact 85 | import Data.String 86 | import Control.Monad.IO.Class 87 | import Data.Maybe 88 | 89 | ------------------------------------------------------------------------------- 90 | --- Types 91 | ------------------------------------------------------------------------------- 92 | newtype PayloadId = PayloadId { unPayloadId :: Int64 } 93 | deriving (Eq, Show, FromField, ToField) 94 | 95 | instance FromRow PayloadId where 96 | fromRow = fromOnly <$> fromRow 97 | 98 | instance ToRow PayloadId where 99 | toRow = toRow . Only 100 | 101 | -- The fundemental record stored in the queue. The queue is a single table 102 | -- and each row consists of a 'Payload' 103 | data Payload = Payload 104 | { pId :: PayloadId 105 | , pValue :: Value 106 | -- ^ The JSON value of a payload 107 | , pState :: State 108 | , pAttempts :: Int 109 | , pCreatedAt :: UTCTime 110 | , pModifiedAt :: UTCTime 111 | } deriving (Show, Eq) 112 | 113 | instance FromRow Payload where 114 | fromRow = Payload <$> field <*> field <*> field <*> field <*> field <*> field 115 | 116 | -- | A 'Payload' can exist in three states in the queue, 'Enqueued', 117 | -- and 'Dequeued'. A 'Payload' starts in the 'Enqueued' state and is locked 118 | -- so some sort of process can occur with it, usually something in 'IO'. 119 | -- Once the processing is complete, the `Payload' is moved the 'Dequeued' 120 | -- state, which is the terminal state. 121 | data State = Enqueued | Dequeued 122 | deriving (Show, Eq, Ord, Enum, Bounded) 123 | 124 | instance ToField State where 125 | toField = toField . \case 126 | Enqueued -> "enqueued" :: Text 127 | Dequeued -> "dequeued" 128 | 129 | -- Converting from enumerations is annoying :( 130 | instance FromField State where 131 | fromField f y = do 132 | n <- typename f 133 | if n == "state_t" then case y of 134 | Nothing -> returnError UnexpectedNull f "state can't be NULL" 135 | Just y' -> case y' of 136 | "enqueued" -> return Enqueued 137 | "dequeued" -> return Dequeued 138 | x -> returnError ConversionFailed f (show x) 139 | else 140 | returnError Incompatible f $ 141 | "Expect type name to be state but it was " ++ show n 142 | 143 | ------------------------------------------------------------------------------- 144 | --- DB API 145 | ------------------------------------------------------------------------------- 146 | notifyName :: IsString s => s 147 | notifyName = fromString "postgresql_simple_enqueue" 148 | 149 | {-| 150 | Prepare all the statements. 151 | -} 152 | setupDB :: DB () 153 | setupDB = void $ execute_ 154 | [sql| 155 | PREPARE enqueue (int, jsonb) AS 156 | INSERT INTO payloads (attempts, value) 157 | VALUES ($1, $2) 158 | RETURNING id; 159 | 160 | PREPARE dequeue AS 161 | UPDATE payloads 162 | SET state='dequeued' 163 | WHERE id in 164 | ( SELECT p1.id 165 | FROM payloads AS p1 166 | WHERE p1.state='enqueued' 167 | ORDER BY p1.modified_at ASC 168 | FOR UPDATE SKIP LOCKED 169 | LIMIT 1 170 | ) 171 | RETURNING id, value, state, attempts, created_at, modified_at; 172 | 173 | PREPARE get_enqueue AS 174 | SELECT id, value, state, attempts, created_at, modified_at 175 | FROM payloads 176 | WHERE state='enqueued' 177 | ORDER BY modified_at ASC 178 | FOR UPDATE SKIP LOCKED 179 | LIMIT 1; 180 | 181 | PREPARE update_state (int8) AS 182 | UPDATE payloads SET state='dequeued' WHERE id = $1; 183 | 184 | PREPARE get_count AS 185 | SELECT count(*) 186 | FROM payloads 187 | WHERE state='enqueued'; 188 | |] 189 | 190 | {-| Enqueue a new JSON value into the queue. This particularly function 191 | can be composed as part of a larger database transaction. For instance, 192 | a single transaction could create a user and enqueue a email message. 193 | 194 | @ 195 | createAccount userRecord = do 196 | 'runDBTSerializable' $ do 197 | createUserDB userRecord 198 | 'enqueueDB' $ makeVerificationEmail userRecord 199 | @ 200 | -} 201 | enqueueDB :: Value -> DB PayloadId 202 | enqueueDB value = enqueueWithDB value 0 203 | 204 | enqueueWithDB :: Value -> Int -> DB PayloadId 205 | enqueueWithDB value attempts = 206 | fmap head $ query "NOTIFY postgresql_simple_enqueue; EXECUTE enqueue(?, ?)" (attempts, value) 207 | 208 | retryDB :: Value -> Int -> DB PayloadId 209 | retryDB value attempts = enqueueWithDB value $ attempts + 1 210 | 211 | -- | Transition a 'Payload' to the 'Dequeued' state. 212 | dequeueDB :: DB (Maybe Payload) 213 | dequeueDB = fmap listToMaybe $ query_ "EXECUTE dequeue" 214 | 215 | {-| 216 | 217 | Attempt to get a payload and process it. If the function passed in throws an exception 218 | return it on the left side of the `Either`. Re-add the payload up to some passed in 219 | maximum. Return `Nothing` is the `payloads` table is empty otherwise the result is an `a` 220 | from the payload ingesting function. 221 | 222 | -} 223 | withPayloadDB :: Int 224 | -- ^ retry count 225 | -> (Payload -> IO a) 226 | -- ^ payload processing function 227 | -> DB (Either SomeException (Maybe a)) 228 | withPayloadDB retryCount f 229 | = query_ "EXECUTE get_enqueue" 230 | >>= \case 231 | [] -> return $ return Nothing 232 | [payload@Payload {..}] -> do 233 | execute "EXECUTE update_state(?)" pId 234 | 235 | -- Retry on failure up to retryCount 236 | handle (\e -> when (pAttempts < retryCount) 237 | (void $ retryDB pValue pAttempts) 238 | >> return (Left e) 239 | ) 240 | $ Right . Just <$> liftIO (f payload) 241 | xs -> return 242 | $ Left 243 | $ toException 244 | $ userError 245 | $ "LIMIT is 1 but got more than one row: " 246 | ++ show xs 247 | 248 | -- | Get the number of rows in the 'Enqueued' state. 249 | getCountDB :: DB Int64 250 | getCountDB = fmap (fromOnly . head) $ query_ "EXECUTE get_count" 251 | ------------------------------------------------------------------------------- 252 | --- IO API 253 | ------------------------------------------------------------------------------- 254 | {-| 255 | Prepare all the statements. 256 | -} 257 | setup :: Connection -> IO () 258 | setup conn = runDBT setupDB ReadCommitted conn 259 | 260 | {-| Enqueue a new JSON value into the queue. See 'enqueueDB' for a version 261 | which can be composed with other queries in a single transaction. 262 | -} 263 | enqueue :: Connection -> Value -> IO PayloadId 264 | enqueue conn value = runDBT (enqueueDB value) ReadCommitted conn 265 | 266 | -- Block until a payload notification is fired. Fired during insertion. 267 | notifyPayload :: Connection -> IO () 268 | notifyPayload conn = do 269 | Notification {..} <- getNotification conn 270 | unless (notificationChannel == notifyName) $ notifyPayload conn 271 | 272 | {-| Return a the oldest 'Payload' in the 'Enqueued' state or 'Nothing' 273 | if there are no payloads. For a blocking version utilizing PostgreSQL's 274 | NOTIFY and LISTEN, see 'dequeue'. This functions runs 'dequeueDb' as a 275 | 'ReadCommitted' transaction. 276 | 277 | See `withPayload' for an alternative interface that will automatically return 278 | the payload to the 'Enqueued' state if an exception occurs. 279 | -} 280 | tryDequeue :: Connection -> IO (Maybe Payload) 281 | tryDequeue conn = runDBT dequeueDB ReadCommitted conn 282 | 283 | -- | Transition a 'Payload' to the 'Dequeued' state. his functions runs 284 | -- 'dequeueDB' as a 'Serializable' transaction. 285 | dequeue :: Connection -> IO Payload 286 | dequeue conn = bracket_ 287 | (Simple.execute_ conn $ "LISTEN " <> notifyName) 288 | (Simple.execute_ conn $ "UNLISTEN " <> notifyName) 289 | $ fix $ \continue -> do 290 | m <- tryDequeue conn 291 | case m of 292 | Nothing -> do 293 | notifyPayload conn 294 | continue 295 | Just x -> return x 296 | 297 | {-| Return the oldest 'Payload' in the 'Enqueued' state or block until a 298 | payload arrives. This function utilizes PostgreSQL's LISTEN and NOTIFY 299 | functionality to avoid excessively polling of the DB while 300 | waiting for new payloads, without scarficing promptness. 301 | -} 302 | withPayload :: Connection 303 | -> Int 304 | -- ^ retry count 305 | -> (Payload -> IO a) 306 | -> IO (Either SomeException a) 307 | withPayload conn retryCount f = bracket_ 308 | (Simple.execute_ conn $ "LISTEN " <> notifyName) 309 | (Simple.execute_ conn $ "UNLISTEN " <> notifyName) 310 | $ fix 311 | $ \continue -> runDBT (withPayloadDB retryCount f) ReadCommitted conn 312 | >>= \case 313 | Left x -> return $ Left x 314 | Right Nothing -> do 315 | notifyPayload conn 316 | continue 317 | Right (Just x) -> return $ Right x 318 | 319 | {-| Get the number of rows in the 'Enqueued' state. This function runs 320 | 'getCountDB' in a 'ReadCommitted' transaction. 321 | -} 322 | getCount :: Connection -> IO Int64 323 | getCount = runDBT getCountDB ReadCommitted 324 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Queue/Migrate.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK prune #-} 2 | {-# LANGUAGE QuasiQuotes, OverloadedStrings #-} 3 | module Database.PostgreSQL.Simple.Queue.Migrate where 4 | import Control.Monad 5 | import Database.PostgreSQL.Simple 6 | import Data.String 7 | import Data.String.Here.Uninterpolated 8 | 9 | migrationQueryString :: String 10 | migrationQueryString = [here| 11 | DO $$ 12 | BEGIN 13 | IF NOT EXISTS (SELECT 1 FROM pg_type WHERE typname = 'state_t') THEN 14 | CREATE TYPE state_t AS ENUM ('enqueued', 'dequeued'); 15 | END IF; 16 | END$$; 17 | 18 | CREATE OR REPLACE FUNCTION update_row_modified_function() 19 | RETURNS TRIGGER AS 20 | $$ 21 | BEGIN 22 | NEW.modified_at = clock_timestamp(); 23 | RETURN NEW; 24 | END; 25 | $$ 26 | language 'plpgsql'; 27 | 28 | CREATE TABLE IF NOT EXISTS payloads 29 | ( id BIGSERIAL PRIMARY KEY 30 | , value jsonb NOT NULL 31 | , attempts int NOT NULL DEFAULT 0 32 | , state state_t NOT NULL DEFAULT 'enqueued' 33 | , created_at TIMESTAMP WITH TIME ZONE NOT NULL DEFAULT clock_timestamp() 34 | , modified_at TIMESTAMP WITH TIME ZONE NOT NULL DEFAULT clock_timestamp() 35 | ) WITH (fillfactor = 50); 36 | 37 | CREATE INDEX IF NOT EXISTS active_modified_at_idx ON payloads USING btree (modified_at) 38 | WHERE (state = 'enqueued'); 39 | 40 | CREATE INDEX IF NOT EXISTS active_created_at_idx ON payloads (created_at) 41 | WHERE (state = 'enqueued'); 42 | 43 | DROP TRIGGER IF EXISTS payloads_modified ON payloads; 44 | CREATE TRIGGER payloads_modified 45 | BEFORE UPDATE ON payloads 46 | FOR EACH ROW EXECUTE PROCEDURE update_row_modified_function(); 47 | 48 | 49 | |] 50 | 51 | 52 | {-| This function creates a table and enumeration type that is 53 | appriopiate for the queue. The following sql is used. 54 | 55 | @ 56 | CREATE TYPE state_t AS ENUM ('enqueued', 'locked', 'dequeued'); 57 | 58 | CREATE TABLE payloads 59 | ( id uuid PRIMARY KEY 60 | , value jsonb NOT NULL 61 | , state state_t NOT NULL DEFAULT 'enqueued' 62 | , created_at TIMESTAMP WITH TIME ZONE NOT NULL DEFAULT clock_timestamp() 63 | , modified_at TIMESTAMP WITH TIME ZONE NOT NULL DEFAULT clock_timestamp() 64 | ); 65 | 66 | CREATE INDEX state_idx ON payloads (state); 67 | 68 | CREATE OR REPLACE FUNCTION update_row_modified_function_() 69 | RETURNS TRIGGER 70 | AS 71 | $$ 72 | BEGIN 73 | -- ASSUMES the table has a column named exactly "modified_at". 74 | -- Fetch date-time of actual current moment from clock, 75 | -- rather than start of statement or start of transaction. 76 | NEW.modified_at = clock_timestamp(); 77 | RETURN NEW; 78 | END; 79 | $$ 80 | language 'plpgsql'; 81 | @ 82 | 83 | -} 84 | migrate :: Connection -> IO () 85 | migrate conn = void $ execute_ conn $ 86 | fromString migrationQueryString 87 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: nightly-2020-01-21 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | 41 | # Dependency packages to be pulled from upstream that are not in the resolver 42 | # (e.g., acme-missiles-0.3) 43 | extra-deps: 44 | # - 'hspec-expectations-lifted-0.10.0' 45 | # - 'optparse-generic-1.2.2' 46 | # - 'pg-transact-0.3.1.0' 47 | # - 'postgresql-simple-opts-0.2.0.2' 48 | # - 'generic-monoid-0.1.0.0' 49 | # - 'tmp-postgres-1.34.1.0' 50 | 51 | # Override default flag values for local packages and extra-deps 52 | flags: {} 53 | 54 | # Extra package databases containing global packages 55 | extra-package-dbs: [] 56 | 57 | # Control whether we use the GHC we find on the path 58 | # system-ghc: true 59 | # 60 | # Require a specific version of stack, using version ranges 61 | # require-stack-version: -any # Default 62 | # require-stack-version: ">=1.4" 63 | # 64 | # Override the architecture used by stack, especially useful on Windows 65 | # arch: i386 66 | # arch: x86_64 67 | # 68 | # Extra directories used by stack for building 69 | # extra-include-dirs: [/path/to/dir] 70 | # extra-lib-dirs: [/path/to/dir] 71 | # 72 | # Allow a newer minor version of GHC than the snapshot specifies 73 | # compiler-check: newer-minor 74 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 458669 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/1/21.yaml 11 | sha256: 3162cd7b6d9a0f8f033a1a2eebb5e5c7f353514a790938cb71690cf8c0a87a28 12 | original: nightly-2020-01-21 13 | -------------------------------------------------------------------------------- /test/Database/PostgreSQL/Simple/QueueSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | module Database.PostgreSQL.Simple.QueueSpec where 5 | import Control.Concurrent 6 | import Control.Concurrent.STM 7 | import Control.Concurrent.Async 8 | import Control.Exception as E 9 | import Control.Monad 10 | import Data.Aeson 11 | import Data.Function 12 | import Data.IORef 13 | import Data.List 14 | import Database.PostgreSQL.Simple 15 | import Database.PostgreSQL.Simple.Transaction 16 | import Database.PostgreSQL.Simple.Queue 17 | import Database.PostgreSQL.Simple.Queue.Migrate 18 | import Database.PostgreSQL.Transact as T 19 | import Test.Hspec (SpecWith, Spec, describe, parallel, it, afterAll, beforeAll, runIO) 20 | import Test.Hspec.Expectations.Lifted 21 | import Control.Monad.Catch 22 | import Control.Monad.IO.Class 23 | import Data.List.Split 24 | import Data.Either 25 | import Database.Postgres.Temp as Temp 26 | import Data.Pool 27 | import Data.Foldable 28 | import Test.Hspec.Core.Spec (sequential) 29 | import Crypto.Hash.SHA1 (hash) 30 | import qualified Data.ByteString.Base64.URL as Base64 31 | import qualified Data.ByteString.Char8 as BSC 32 | 33 | aroundAll :: forall a. ((a -> IO ()) -> IO ()) -> SpecWith a -> Spec 34 | aroundAll withFunc specWith = do 35 | (var, stopper, asyncer) <- runIO $ 36 | (,,) <$> newEmptyMVar <*> newEmptyMVar <*> newIORef Nothing 37 | let theStart :: IO a 38 | theStart = do 39 | 40 | thread <- async $ do 41 | withFunc $ \x -> do 42 | putMVar var x 43 | takeMVar stopper 44 | pure $ error "Don't evaluate this" 45 | 46 | writeIORef asyncer $ Just thread 47 | 48 | either pure pure =<< (wait thread `race` takeMVar var) 49 | 50 | theStop :: a -> IO () 51 | theStop _ = do 52 | putMVar stopper () 53 | traverse_ cancel =<< readIORef asyncer 54 | 55 | beforeAll theStart $ afterAll theStop $ specWith 56 | 57 | withConn :: Temp.DB -> (Connection -> IO a) -> IO a 58 | withConn db f = do 59 | let connStr = toConnectionString db 60 | E.bracket (connectPostgreSQL connStr) close f 61 | 62 | withSetup :: (Pool Connection -> IO ()) -> IO () 63 | withSetup f = either throwIO pure <=< withDbCache $ \dbCache -> do 64 | migratedConfig <- either throwIO pure =<< 65 | cacheAction 66 | (("~/.tmp-postgres/" <>) . BSC.unpack . Base64.encode . hash 67 | $ BSC.pack migrationQueryString) 68 | (flip withConn migrate) 69 | (verboseConfig <> cacheConfig dbCache) 70 | withConfig migratedConfig $ \db -> do 71 | f =<< createPool 72 | (do 73 | c <- connectPostgreSQL $ toConnectionString db 74 | setup c 75 | pure c 76 | ) 77 | close 78 | 2 79 | 60 80 | 50 81 | 82 | withConnection :: (Connection -> IO ()) -> Pool Connection -> IO () 83 | withConnection = flip withResource 84 | 85 | withReadCommitted :: T.DB () -> Pool Connection -> IO () 86 | withReadCommitted action pool = E.handle (\T.Abort -> pure ()) $ withResource pool $ 87 | T.runDBT (T.abort action) ReadCommitted 88 | 89 | runDB :: Connection -> T.DB a -> IO a 90 | runDB conn action = T.runDBT action ReadCommitted conn 91 | 92 | spec :: Spec 93 | spec = describe "Database.Queue" $ parallel $ do 94 | sequential $ aroundAll withSetup $ describe "basic" $ do 95 | it "is okay to migrate multiple times" $ withConnection $ 96 | liftIO . migrate 97 | 98 | it "empty locks nothing" $ withReadCommitted $ 99 | (either throwM return =<< (withPayloadDB 8 return)) 100 | `shouldReturn` Nothing 101 | it "empty gives count 0" $ withReadCommitted $ 102 | getCountDB `shouldReturn` 0 103 | it "enqueuesDB/withPayloadDB" $ withReadCommitted $ do 104 | payloadId <- enqueueDB $ String "Hello" 105 | getCountDB `shouldReturn` 1 106 | 107 | either throwM return =<< withPayloadDB 8 (\(Payload {..}) -> do 108 | pId `shouldBe` payloadId 109 | pValue `shouldBe` String "Hello" 110 | ) 111 | 112 | getCountDB `shouldReturn` 0 113 | 114 | it "enqueuesDB/withPayloadDB/retries" $ withReadCommitted $ do 115 | void $ enqueueDB $ String "Hello" 116 | getCountDB `shouldReturn` 1 117 | 118 | xs <- replicateM 7 $ withPayloadDB 8 (\(Payload {..}) -> 119 | throwM $ userError "not enough tries" 120 | ) 121 | 122 | all isLeft xs `shouldBe` True 123 | 124 | either throwM (const $ pure ()) =<< withPayloadDB 8 (\(Payload {..}) -> do 125 | pAttempts `shouldBe` 7 126 | pValue `shouldBe` String "Hello" 127 | ) 128 | it "enqueuesDB/withPayloadDB/timesout" $ withReadCommitted $ do 129 | void $ enqueueDB $ String "Hello" 130 | getCountDB `shouldReturn` 1 131 | 132 | xs <- replicateM 2 $ withPayloadDB 1 (\(Payload {..}) -> 133 | throwM $ userError "not enough tries" 134 | ) 135 | 136 | all isLeft xs `shouldBe` True 137 | 138 | getCountDB `shouldReturn` 0 139 | 140 | it "selects the oldest first" $ withReadCommitted $ do 141 | payloadId0 <- enqueueDB $ String "Hello" 142 | liftIO $ threadDelay 100 143 | 144 | payloadId1 <- enqueueDB $ String "Hi" 145 | 146 | getCountDB `shouldReturn` 2 147 | 148 | either throwM return =<< withPayloadDB 8 (\(Payload {..}) -> do 149 | pId `shouldBe` payloadId0 150 | pValue `shouldBe` String "Hello" 151 | ) 152 | 153 | either throwM return =<< withPayloadDB 8 (\(Payload {..}) -> do 154 | pId `shouldBe` payloadId1 155 | pValue `shouldBe` String "Hi" 156 | ) 157 | 158 | getCountDB `shouldReturn` 0 159 | 160 | it "enqueues and dequeues concurrently withPayload" $ \testDB -> do 161 | let withPool' = flip withConnection testDB 162 | elementCount = 1000 :: Int 163 | expected = [0 .. elementCount - 1] 164 | 165 | ref <- newTVarIO [] 166 | 167 | loopThreads <- replicateM 35 $ async $ withPool' $ \c -> fix $ \next -> do 168 | lastCount <- either throwM return <=< withPayload c 0 $ \(Payload {..}) -> do 169 | atomically $ do 170 | xs <- readTVar ref 171 | writeTVar ref $ pValue : xs 172 | return $ length xs + 1 173 | 174 | when (lastCount < elementCount) next 175 | 176 | forM_ (chunksOf (elementCount `div` 11) expected) $ \xs -> forkIO $ void $ withPool' $ \c -> 177 | forM_ xs $ \i -> enqueue c $ toJSON i 178 | 179 | waitAnyCancel loopThreads 180 | xs <- atomically $ readTVar ref 181 | let Just decoded = mapM (decode . encode) xs 182 | sort decoded `shouldBe` sort expected 183 | 184 | aroundAll withSetup $ describe "basic" $ do 185 | it "enqueues and dequeues concurrently dequeue" $ \testDB -> do 186 | let withPool' = flip withConnection testDB 187 | elementCount = 1000 :: Int 188 | expected = [0 .. elementCount - 1] 189 | 190 | ref <- newTVarIO [] 191 | 192 | loopThreads <- replicateM 35 $ async $ withPool' $ \c -> fix $ \next -> do 193 | Payload {..} <- dequeue c 194 | lastCount <- atomically $ do 195 | xs <- readTVar ref 196 | writeTVar ref $ pValue : xs 197 | return $ length xs + 1 198 | 199 | when (lastCount < elementCount) next 200 | 201 | forM_ (chunksOf (elementCount `div` 11) expected) $ \xs -> forkIO $ void $ withPool' $ \c -> 202 | forM_ xs $ \i -> enqueue c $ toJSON i 203 | 204 | waitAnyCancel loopThreads 205 | xs <- atomically $ readTVar ref 206 | let Just decoded = mapM (decode . encode) xs 207 | sort decoded `shouldBe` sort expected 208 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} --------------------------------------------------------------------------------