├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .travis.yml ├── Dockerfile ├── Makefile ├── README.markdown ├── cl-dbi-connection-pool.asd ├── dbi-cp-test.asd ├── dbi-cp.asd ├── docker-compose.test-runner.yml ├── docker-compose.yml ├── src ├── connectionpool.lisp ├── dbi-cp.lisp ├── error.lisp └── proxy.lisp └── t ├── dbi-cp.lisp └── proxy ├── mysql.lisp ├── postgres.lisp └── sqlite3.lisp /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: ci 2 | 3 | on: 4 | push: 5 | branches: 6 | - '**' 7 | 8 | jobs: 9 | ci: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - name: Checkout 13 | uses: actions/checkout@v4 14 | 15 | - name: Build 16 | run: docker compose up -d 17 | 18 | - name: Test 19 | run: docker compose -f docker-compose.test-runner.yml run --rm --entrypoint rove dbi-cp-test dbi-cp-test.asd 20 | 21 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.FASL 2 | *.fasl 3 | *.lisp-temp 4 | *.dfsl 5 | *.pfsl 6 | *.d64fsl 7 | *.p64fsl 8 | *.lx64fsl 9 | *.lx32fsl 10 | *.dx64fsl 11 | *.dx32fsl 12 | *.fx64fsl 13 | *.fx32fsl 14 | *.sx64fsl 15 | *.sx32fsl 16 | *.wx64fsl 17 | *.wx32fsl 18 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | addons: 5 | postgresql: "9.4" 6 | 7 | services: 8 | - postgresql 9 | 10 | env: 11 | global: 12 | - PATH=$HOME/.roswell/bin:$PATH 13 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 14 | matrix: 15 | - LISP=sbcl-bin 16 | - LISP=ccl-bin 17 | 18 | install: 19 | # Install Roswell 20 | - curl -L https://raw.githubusercontent.com/roswell/roswell/release/scripts/install-for-ci.sh | sh 21 | - ros install prove 22 | 23 | before_script: 24 | - mysql -uroot -e 'GRANT ALL ON *.* TO nobody@"localhost" IDENTIFIED BY "nobody"' 25 | - mysql -e 'CREATE DATABASE `dbi-cp`' 26 | - psql -c 'create database "dbi-cp";' -U postgres 27 | - psql -c "CREATE USER nobody WITH PASSWORD 'nobody';" -U postgres 28 | 29 | script: 30 | - run-prove dbi-cp-test.asd 31 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM fukamachi/sbcl 2 | 3 | RUN apt-get update && apt-get install -y \ 4 | default-libmysqlclient-dev \ 5 | libpq-dev \ 6 | libsqlite3-dev \ 7 | default-mysql-client \ 8 | postgresql-client 9 | 10 | RUN ros run -e "(ql-dist:install-dist \"http://dist.shirakumo.org/shirakumo.txt\" :prompt nil)" 11 | RUN ros install qlot rove 12 | 13 | 14 | ENV PATH=${PATH}:/root/.roswell/bin 15 | ENV CL_SOURCE_REGISTRY=/app 16 | 17 | RUN mkdir /app 18 | WORKDIR /app 19 | 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | .DEFAULT_GOAL := test 3 | 4 | .PHONY: setup test.prev test test.down test.console test.swank 5 | setup: 6 | docker build -t dbi-cp-test . 7 | 8 | test.prev: 9 | docker-compose down || true 10 | rm -rf ./volumes 11 | mkdir ./volumes 12 | mkdir ./volumes/mysql 13 | mkdir ./volumes/postgresql 14 | mkdir ./volumes/postgresql/data 15 | mkdir ./volumes/postgresql/log 16 | sleep 1 17 | docker-compose up -d 18 | echo wait... 19 | sleep 10 20 | 21 | test: test.prev 22 | @echo "Running tests..." 23 | docker-compose -f docker-compose.test-runner.yml run --rm --entrypoint rove dbi-cp-test dbi-cp-test.asd 24 | 25 | test.down: 26 | docker-compose down 27 | 28 | 29 | test.console: 30 | docker-compose -f docker-compose.test-runner.yml run -it -p 4005:4005 --rm --entrypoint /bin/bash dbi-cp-test 31 | 32 | test.swank: 33 | docker-compose -f docker-compose.test-runner.yml run -it -p 4005:4005 --rm --entrypoint ros dbi-cp-test run -e "(ql:quickload :swank)" -e "(setf swank::*loopback-interface* \"0.0.0.0\")" -e "(swank:create-server :dont-close t :style :spawn)" 34 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # CL-DBI-Connection-Pool - connection pool for CL-DBI 2 | 3 | ![ci workflow](https://github.com/tamurashingo/cl-dbi-connection-pool/actions/workflows/ci.yml/badge.svg) 4 | 5 | This library provides connection pool for CL-DBI. 6 | 7 | 8 | ## Usage 9 | 10 | ### Create connection pool 11 | 12 | make connection pool. 13 | 14 | ```common-lisp 15 | (dbi-cp:make-db-connection-pool driver-name &key database-name username password (initial-size 10) (max-size 10)) ;; => dbi-cp: 16 | ``` 17 | 18 | - driver-name 19 | - `:sqlite`, `:mysql`, `:postgresql` (same as `CL-DBI`) 20 | - database-name 21 | - database name (same as `CL-DBI`) 22 | - username 23 | - username (same as `CL-DBI`) 24 | - password 25 | - password (same as `CL-DBI`) 26 | - initial-size 27 | - initial number of connections that are created when the pool is started 28 | - max-size 29 | - maximum number of connections 30 | 31 | 32 | Additionally, it accepts parameters used in cl-dbi. 33 | 34 | 35 | ```common-lisp 36 | (defparameter *CONNECTION-POOL* 37 | (dbi-cp:make-dbi-connection-pool :mysql :database-name "dbi-cp" :username "root" :password "password")) 38 | ``` 39 | 40 | ### Get connection 41 | 42 | get database connection from connection pool. 43 | 44 | ```common-lisp 45 | (dbi-cp:get-connection connection-pool) ;; => dbi-cp.proxy: 46 | ``` 47 | 48 | - connection-pool (dbi-cp:<dbi-connection-pool>) 49 | - connection pool 50 | 51 | ```common-lisp 52 | (setf conn (dbi-cp:get-connection *CONNECTION-POOL*)) 53 | ``` 54 | 55 | ### prepare, execute, fetch ... 56 | 57 | #### Prepare 58 | 59 | prepare SQL statement. 60 | 61 | ```common-lisp 62 | (dbi-cp:prepare connection sql) ;; => dbi.driver: 63 | ``` 64 | 65 | - connection (dbi-cp.proxy:<dbi-connection-proxy>) 66 | - database connection 67 | - sql 68 | - SQL statement 69 | 70 | this function is based on `CL-DBI` 71 | 72 | #### Execute 73 | 74 | execute SQL. 75 | 76 | ```common-lisp 77 | (dbi-cp:execute query &optional params) ;; => dbi.driver: 78 | ``` 79 | 80 | - query (dbi.driver:<dbi-query>) 81 | - precompiled query (returned by `prepare`) 82 | - params 83 | - SQL parameters 84 | 85 | this function is based on `CL-DBI` 86 | 87 | #### Fetch 88 | 89 | fetch first row from `query` which is returned by `execute`. 90 | 91 | ```common-lisp 92 | (dbi-cp:fetch query) ;; => result 93 | ``` 94 | 95 | - query (dbi.driver:<dbi-query>) 96 | - returned by `execute` 97 | 98 | this function is based on `CL-DBI` 99 | 100 | ### Fetch all 101 | 102 | fetch all ret row from `query`. 103 | 104 | ```common-lisp 105 | (dbi-cp:fetch-all query) ;; => result 106 | ``` 107 | 108 | - query (dbi.driver:<dbi-query>) 109 | - returned by `execute` 110 | 111 | this function is based on `CL-DBI` 112 | 113 | #### row count 114 | 115 | return the number of counts modified by last execute INSERT/UPDATE/DELETE query. 116 | 117 | ```common-lisp 118 | (dbi-cp:row-count connection) ;; => number 119 | ``` 120 | 121 | - connection (dbi-cp.proxy:<dbi-connection-proxy>) 122 | - database connection 123 | 124 | this function is based on `CL-DBI` 125 | 126 | #### do sql 127 | 128 | do preparation and execution at once for INSERT, UPDATE, DELETE or DDL. 129 | 130 | 131 | ```common-lisp 132 | (dbi-cp:do-sql connection sql &optional params) 133 | ``` 134 | 135 | - connection (dbi-cp.proxy:<dbi-connection-proxy>) 136 | - database connection 137 | - sql 138 | - SQL statement 139 | - params 140 | - SQL parameters 141 | 142 | this function is based on `CL-DBI` 143 | 144 | 145 | ### Transaction 146 | 147 | #### create transaction block 148 | 149 | start a transaction and commit at the end of this block. 150 | if the evaluation `body` is interrupted, the transaction is rolled back automatically. 151 | 152 | ```common-lisp 153 | (dbi-cp:with-transaction connection &body body) 154 | ``` 155 | 156 | - connection (dbi-cp.proxy:<dbi-connection-proxy>) 157 | - database connection 158 | - body 159 | - body 160 | 161 | this function is based on `CL-DBI` 162 | 163 | #### commit 164 | 165 | Within `with-transaction`, you can use `commit`. 166 | Outside of `with-transaction`, `commit` does nothing. 167 | 168 | 169 | ```common-lisp 170 | (dbi-cp:commit connection) 171 | ``` 172 | 173 | - connection (dbi-cp.proxy:<dbi-connection-proxy>) 174 | - database connection 175 | 176 | this function is based on `CL-DBI` 177 | 178 | #### rollback 179 | 180 | Like `commit`, `rollback` is also executed within `with-transaction`. 181 | 182 | 183 | ```common-lisp 184 | (dbi-cp:rollback connection) 185 | ``` 186 | 187 | - connection (dbi-cp.proxy:<dbi-connection-proxy>) 188 | - database connection 189 | 190 | this function is based on `CL-DBI` 191 | 192 | #### savepoint 193 | 194 | set a named transaction savepoint with a name of `identifier`. 195 | 196 | ```common-lisp 197 | (dbi-cp:savepoint connection identifier) 198 | ``` 199 | 200 | - connection (dbi-cp.proxy:<dbi-connection-proxy>) 201 | - database connection 202 | - identifier 203 | - name of transaction savepoint 204 | 205 | this function is based on `CL-DBI` 206 | 207 | #### rollback savepoint 208 | 209 | rollback a transaction to the named savepoint. 210 | 211 | ```common-lisp 212 | (dbi-cp:rollback-savepoint connection &optional identifier) 213 | ``` 214 | 215 | - connection (dbi-cp.proxy:<dbi-connection-proxy>) 216 | - database connection 217 | - identifier 218 | - name of transaction savepoint 219 | 220 | this function is based on `CL-DBI` 221 | 222 | 223 | #### release savepoint 224 | 225 | remove the named savepoint. no commit or rollback occurs. 226 | 227 | ```common-lisp 228 | (dbi-cp:release-savepoint connection &optional identifier) 229 | ``` 230 | 231 | - connection (dbi-cp.proxy:<dbi-connection-proxy>) 232 | - database connection 233 | - identifier 234 | - name of transaction savepoint 235 | 236 | this function is based on `CL-DBI` 237 | 238 | 239 | ## Example 240 | 241 | ```common-lisp 242 | ;;; 243 | ;;; create connection pool 244 | ;;; 245 | CL-USER> (defparameter *pool* 246 | (dbi-cp:make-dbi-connection-pool :mysql 247 | :database-name "test" 248 | :username "root" 249 | :password "password")) 250 | *POOL* 251 | 252 | ;;; 253 | ;;; get database connection 254 | ;;; 255 | CL-USER> (defparameter connection (dbi-cp:get-connection *pool*)) 256 | CONNECTION 257 | CL-USER> connection 258 | # {1002E23973}> 259 | 260 | ;;; 261 | ;;; execute DDL 262 | ;;; 263 | CL-USER> (dbi-cp:do-sql connection "create table person (id integer primary key, name varchar(24) not null)") 264 | ; No value 265 | 266 | ;;; 267 | ;;; select 268 | ;;; 269 | CL-USER> (let* ((query (dbi-cp:prepare connection "select count(*) from person")) 270 | (result (dbi-cp:execute query))) 271 | (format T "~A" (dbi-cp:fetch result))) 272 | (count(*) 0) 273 | NIL 274 | 275 | ;;; 276 | ;;; insert 277 | ;;; 278 | CL-USER> (dbi-cp:with-transaction connection 279 | (let* ((query (dbi-cp:prepare connection "insert into person (id, name) values (?, ?)"))) 280 | (dbi-cp:execute query (list 1 "user1")) 281 | (dbi-cp:execute query (list 2 "user2")) 282 | (dbi-cp:execute query (list 3 "user3")))) 283 | # {1004B671F3}> 284 | 285 | ;;; 286 | ;;; select 287 | ;;; 288 | CL-USER> (let* ((query (dbi-cp:prepare connection "select * from person")) 289 | (result (dbi-cp:execute query))) 290 | (dbi-cp:fetch-all result)) 291 | ((:|id| 1 :|name| "user1") (:|id| 2 :|name| "user2") (:|id| 3 :|name| "user3")) 292 | 293 | ;;; 294 | ;;; rollback 295 | ;;; 296 | CL-USER> (dbi-cp:with-transaction connection 297 | (dbi-cp:execute (dbi-cp:prepare connection "delete from person")) 298 | (rollback connection)) 299 | 0 300 | CL-USER> (dbi-cp:rollback connection) 301 | ; No value 302 | CL-USER> (let* ((query (dbi-cp:prepare connection "select count(*) from person")) 303 | (result (dbi-cp:execute query))) 304 | (format T "~A" (dbi-cp:fetch result))) 305 | (count(*) 3) 306 | NIL 307 | 308 | ;;; 309 | ;;; release connection 310 | ;;; 311 | CL-USER> (dbi-cp:disconnect connection) 312 | NIL 313 | 314 | ;;; 315 | ;;; shutdown connection pool 316 | ;;; 317 | CL-USER> (dbi-cp:shutdown *pool*) 318 | NIL 319 | ``` 320 | 321 | 322 | ## Installation 323 | 324 | This library is available on Quicklisp. 325 | 326 | ```commonlisp 327 | (ql:quickload :cl-dbi-connection-pool) 328 | ``` 329 | 330 | 331 | ## how to develop 332 | 333 | require 334 | 335 | - make 336 | - docker 337 | 338 | ### test 339 | 340 | #### prepare 341 | 342 | To prepare, create a docker image for testing. 343 | 344 | ```sh 345 | make setup 346 | ``` 347 | 348 | #### run test 349 | 350 | ```sh 351 | make test 352 | ``` 353 | 354 | #### swank server 355 | 356 | Start the swank server. 357 | 358 | ```sh 359 | make test.swank 360 | ``` 361 | 362 | connect with SLIME. 363 | 364 | ``` 365 | M-x slime-connect 127.0.0.1 4005 366 | ``` 367 | 368 | create connection pool 369 | 370 | ```common-lisp 371 | (ql:quickload :cl-dbi-connection-pool) 372 | 373 | (defvar *pool-sqlite3* (dbi-cp:make-dbi-connection-pool :sqlite3 374 | :database-name "/app/volumes/sqlite3-test.db")) 375 | 376 | (defvar *pool-mysql* (dbi-cp:make-dbi-connection-pool :mysql 377 | :database-name "test" 378 | :username "root" 379 | :password "password" 380 | :host "mysql-test" 381 | :port 3306)) 382 | 383 | (defvar *pool-postgres* (dbi-cp:make-dbi-connection-pool :postgres 384 | :database-name "test" 385 | :username "dbicp" 386 | :password "password" 387 | :host "postgresql-test" 388 | :port 5432)) 389 | ``` 390 | 391 | 392 | #### stop test containers 393 | 394 | ```sh 395 | make test.down 396 | ``` 397 | 398 | ## Author 399 | 400 | * tamura shingo (tamura.shingo@gmail.com) 401 | 402 | ## Copyright 403 | 404 | Copyright (c) 2017 tamura shingo (tamura.shingo@gmail.com) 405 | 406 | ## License 407 | 408 | Licensed under the LLGPL License. 409 | -------------------------------------------------------------------------------- /cl-dbi-connection-pool.asd: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage cl-dbi-connection-pool-asd 3 | (:use :cl :asdf)) 4 | (in-package :cl-dbi-connection-pool-asd) 5 | 6 | (defsystem cl-dbi-connection-pool 7 | :version "0.1" 8 | :author "tamura shingo" 9 | :license "LLGPL" 10 | :depends-on (:dbi-cp)) 11 | -------------------------------------------------------------------------------- /dbi-cp-test.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of CL-DBI-CONNECTION-POOL project. 3 | Copyright (c) 2017 tamura shingo (tamura.shingo@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage dbi-cp-test-asd 8 | (:use :cl :asdf)) 9 | (in-package :dbi-cp-test-asd) 10 | 11 | (defsystem dbi-cp-test 12 | :author "tamura shingo" 13 | :license "LLGPL" 14 | :depends-on (:dbi-cp 15 | :rove) 16 | :components ((:module "t" 17 | :components 18 | ((:file "dbi-cp") 19 | (:module "proxy" 20 | :components 21 | ((:file "sqlite3") 22 | (:file "mysql") 23 | (:file "postgres")))))) 24 | :description "Test system for CL-DBI-CONNECTION-POOL" 25 | 26 | :perform (test-op (op c) 27 | (uiop:symbol-call :rove :run c))) 28 | -------------------------------------------------------------------------------- /dbi-cp.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of CL-DBI-CONNECTION-POOL project. 3 | Copyright (c) 2017 tamura shingo (tamura.shingo@gmail.com) 4 | |# 5 | 6 | #| 7 | connection pool for CL-DBI 8 | 9 | Author: tamura shingo (tamura.shingo@gmail.com) 10 | |# 11 | 12 | (in-package :cl-user) 13 | (defpackage dbi-cp-asd 14 | (:use :cl :asdf)) 15 | (in-package :dbi-cp-asd) 16 | 17 | (defsystem dbi-cp 18 | :version "0.1" 19 | :author "tamura shingo" 20 | :license "LLGPL" 21 | :depends-on (:cl-syntax 22 | :cl-syntax-annot 23 | :cl-dbi 24 | :bt-semaphore) 25 | :components ((:module "src" 26 | :components 27 | ((:file "dbi-cp" :depends-on ("connectionpool")) 28 | (:file "connectionpool" :depends-on ("proxy" "error")) 29 | (:file "proxy") 30 | (:file "error")))) 31 | :description "connection pool for CL-DBI" 32 | :long-description 33 | #.(with-open-file (stream (merge-pathnames 34 | #p"README.markdown" 35 | (or *load-pathname* *compile-file-pathname*)) 36 | :if-does-not-exist nil 37 | :direction :input) 38 | (when stream 39 | (let ((seq (make-array (file-length stream) 40 | :element-type 'character 41 | :fill-pointer t))) 42 | (setf (fill-pointer seq) (read-sequence seq stream)) 43 | seq))) 44 | :in-order-to ((test-op (test-op dbi-cp-test)))) 45 | -------------------------------------------------------------------------------- /docker-compose.test-runner.yml: -------------------------------------------------------------------------------- 1 | services: 2 | dbi-cp-test: 3 | image: dbi-cp-test 4 | build: 5 | context: . 6 | dockerfile: ./Dockerfile 7 | container_name: dbi_cp_test 8 | volumes: 9 | - ./:/app 10 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | services: 2 | mysql-test: 3 | image: mysql:8.0 4 | container_name: dbi-cp_test_mysql 5 | environment: 6 | MYSQL_ROOT_PASSWORD: password 7 | MYSQL_DATABASE: test 8 | volumes: 9 | - ./volumes/mysql:/var/lib/mysql 10 | postgresql-test: 11 | image: postgres:16 12 | container_name: dbi-cp_test_postgresql 13 | environment: 14 | POSTGRES_USER: dbicp 15 | POSTGRES_PASSWORD: password 16 | POSTGRES_DB: test 17 | PGDATA: /var/lib/postgresql/data/pgdata 18 | volumes: 19 | - ./volumes/postgresql/data:/var/lib/postgresql/data 20 | - ./volumes/postgresql/log:/var/log 21 | -------------------------------------------------------------------------------- /src/connectionpool.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dbi-cp.connectionpool 3 | (:use :cl) 4 | (:import-from :dbi-cp.proxy 5 | : 6 | :dbi-connection 7 | :disconnect-fn 8 | :disconnect 9 | :prepare 10 | :do-sql) 11 | (:import-from :dbi-cp.error 12 | :)) 13 | (in-package :dbi-cp.connectionpool) 14 | 15 | (cl-syntax:use-syntax :annot) 16 | 17 | 18 | @export 19 | (defclass () 20 | ((pool :type array 21 | :initarg :pool 22 | :documentation "array of ") 23 | (connect-fn :type function 24 | :initarg :connect-fn 25 | :documentation "function what connecto to database "))) 26 | 27 | (defclass () 28 | ((connect-p :type boolean 29 | :accessor connect-p 30 | :initform NIL 31 | :documentation "T when already connected database") 32 | (semaphore :accessor semaphore 33 | :initform (bt-sem:make-semaphore :count 1)) 34 | (dbi-connection-proxy :type (or null ) 35 | :initarg :dbi-connection-proxy 36 | :accessor dbi-connection-proxy 37 | :initform NIL))) 38 | 39 | @export 40 | (defun make-dbi-connection-pool (driver-name &rest params &key database-name username password (initial-size 10) (max-size 10) &allow-other-keys) 41 | "make connection pool 42 | 43 | Example 44 | (make-dbi-connection-pool :mysql :database-name \"dbicp\" :username \"root\" :password \"password\")" 45 | ;; remove addtional parameter for original dbi:connect argument 46 | (remf params :initial-size) 47 | (remf params :max-size) 48 | 49 | (let* ((pool (make-array max-size :initial-element NIL)) 50 | (dbi-connection-pool 51 | (make-instance ' 52 | :pool pool 53 | :connect-fn (lambda () 54 | (apply #'dbi:connect driver-name params))))) 55 | ;; create instance 56 | (%make-pooledconnection-array! pool max-size) 57 | ;; connect initial-size connection 58 | (%make-connection-array! dbi-connection-pool initial-size) 59 | dbi-connection-pool)) 60 | 61 | 62 | (defun %make-pooledconnection-array! (cp-array array-size) 63 | "create instance" 64 | (loop for idx from 0 below array-size 65 | do (let* ((dbi-cp (make-instance ')) 66 | (pooled-connection (make-instance ' 67 | :dbi-connection-proxy dbi-cp))) 68 | (setf (aref cp-array idx) pooled-connection)))) 69 | 70 | (defun %make-connection-array! (dbi-connection-pool connection-count) 71 | "create connection array" 72 | (let ((connect-fn (slot-value dbi-connection-pool 'connect-fn)) 73 | (pool (slot-value dbi-connection-pool 'pool))) 74 | (loop for idx from 0 below connection-count 75 | do (let ((pooled-connection (aref pool idx))) 76 | (%make-connection! pooled-connection connect-fn))))) 77 | 78 | (defun %make-connection! (pooled-connection connect-fn) 79 | "connect database and set parameters" 80 | (let ((semaphore (semaphore pooled-connection)) 81 | (dbi-proxy (dbi-connection-proxy pooled-connection))) 82 | ;; connected 83 | (setf (connect-p pooled-connection) T) 84 | ;; make connection 85 | (setf (dbi-connection dbi-proxy) (funcall connect-fn)) 86 | ;; make disconnect callback 87 | (setf (disconnect-fn dbi-proxy) 88 | (lambda () 89 | (bt-sem:signal-semaphore semaphore))))) 90 | 91 | @export 92 | (defmethod shutdown ((conn )) 93 | "disconnect all connections" 94 | (loop for pool across (slot-value conn 'pool) 95 | when (connect-p pool) 96 | do (let* ((dbi-connection-proxy (dbi-connection-proxy pool)) 97 | (dbi-connection (dbi-connection dbi-connection-proxy))) 98 | (disconnect dbi-connection)))) 99 | 100 | @export 101 | (defmethod get-connection ((conn )) 102 | "get from connection pool" 103 | (loop for pool across (slot-value conn 'pool) 104 | if (connect-p pool) 105 | do (let ((semaphore (semaphore pool))) 106 | (when (bt-sem:try-semaphore semaphore) 107 | (return (dbi-connection-proxy pool)))) 108 | else 109 | do (let ((semaphore (semaphore pool))) 110 | (when (bt-sem:try-semaphore semaphore) 111 | (%make-connection! pool (slot-value conn 'connect-fn)) 112 | (return (dbi-connection-proxy pool)))) 113 | end 114 | finally (return (error ')))) 115 | -------------------------------------------------------------------------------- /src/dbi-cp.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dbi-cp 3 | (:use :cl) 4 | (:nicknames :cl-dbi-connection-pool) 5 | (:import-from :dbi-cp.connectionpool 6 | :make-dbi-connection-pool 7 | :shutdown 8 | :get-connection) 9 | (:import-from :dbi-cp.proxy 10 | :disconnect 11 | :prepare 12 | :do-sql 13 | :row-count 14 | :begin-transaction 15 | :commit 16 | :rollback 17 | :with-transaction) 18 | (:import-from :dbi-cp.error 19 | :) 20 | (:import-from :dbi 21 | :execute 22 | :fetch 23 | :fetch-all 24 | :savepoint 25 | :rollback-savepoint 26 | :release-savepoint 27 | :ping 28 | 29 | : 30 | : 31 | : 32 | : 33 | : 34 | : 35 | : 36 | : 37 | : 38 | :) 39 | (:export :make-dbi-connection-pool 40 | :get-connection 41 | :do-sql 42 | :prepare 43 | :execute 44 | :fetch 45 | :fetch-all 46 | :begin-transaction 47 | :commit 48 | :rollback 49 | :savepoint 50 | :rollback-savepoint 51 | :release-savepoint 52 | :ping 53 | :row-count 54 | :with-transaction 55 | :disconnect 56 | :shutdown 57 | 58 | : 59 | 60 | : 61 | : 62 | : 63 | : 64 | : 65 | : 66 | : 67 | : 68 | : 69 | :)) 70 | (in-package :dbi-cp) 71 | 72 | 73 | (defun show-connection-pool (connection-pool) 74 | "for debug" 75 | (loop for pool across (slot-value connection-pool 'dbi-cp.connectionpool::pool) 76 | for counter = 0 then (1+ counter) 77 | do (progn 78 | (format T "~A:~%" counter) 79 | (format T " connected :~A~%" (slot-value pool 'dbi-cp.connectionpool::connect-p)) 80 | (format T " available : ~A~%" (= (bt-sem:semaphore-count (slot-value pool 'dbi-cp.connectionpool::semaphore)) 0))))) 81 | 82 | -------------------------------------------------------------------------------- /src/error.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dbi-cp.error 3 | (:use cl)) 4 | (in-package :dbi-cp.error) 5 | 6 | (cl-syntax:use-syntax :annot) 7 | 8 | @export 9 | (define-condition (simple-error) () 10 | (:documentation "Exception raised when no connection found on connection pool") 11 | (:report 12 | (lambda (condition stream) 13 | (format stream 14 | "no database connection found")))) 15 | -------------------------------------------------------------------------------- /src/proxy.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dbi-cp.proxy 3 | (:use :cl 4 | :cl-annot 5 | :annot.class) 6 | (:import-from #:cl-dbi 7 | #:disconnect 8 | #:prepare 9 | #:do-sql 10 | #:row-count 11 | #:begin-transaction 12 | #:commit 13 | #:rollback)) 14 | 15 | (in-package :dbi-cp.proxy) 16 | 17 | (cl-syntax:use-syntax :annot) 18 | 19 | 20 | (defannotation proxy (def-form) 21 | (:arity 1) 22 | "just a mark" 23 | def-form) 24 | 25 | @export 26 | @export-accessors 27 | (defclass () 28 | ((dbi-connection :type 29 | :initarg :dbi-connection 30 | :accessor dbi-connection) 31 | (in-transaction :initform 0) 32 | (disconnect-fn :type function 33 | :initarg :disconnect-fn 34 | :accessor disconnect-fn))) 35 | 36 | @proxy 37 | (defmethod disconnect ((conn )) 38 | (let ((in-transaction (slot-value conn 'in-transaction)) 39 | (disconnect-fn (disconnect-fn conn))) 40 | (when (not (= in-transaction 0)) 41 | (rollback conn)) 42 | (funcall disconnect-fn))) 43 | 44 | @proxy 45 | (defmethod prepare ((conn ) (sql string) &rest rest &key &allow-other-keys) 46 | (let ((dbi-connection (dbi-connection conn))) 47 | (apply #'prepare dbi-connection sql rest))) 48 | 49 | @proxy 50 | (defmethod do-sql ((conn ) (sql string) &optional params) 51 | (let ((dbi-connection (dbi-connection conn))) 52 | (do-sql dbi-connection sql params))) 53 | 54 | @export 55 | (defmacro with-transaction (conn &body body) 56 | (let ((conn-var (gensym "CONN-VAR"))) 57 | `(let ((,conn-var (dbi-cp.proxy::dbi-connection ,conn))) 58 | (dbi:with-transaction ,conn-var 59 | ,@body)))) 60 | 61 | @proxy 62 | (defmethod row-count ((conn )) 63 | (let ((dbi-connection (dbi-connection conn))) 64 | (row-count dbi-connection))) 65 | 66 | 67 | @proxy 68 | (defmethod begin-transaction ((conn )) 69 | (incf (slot-value conn 'in-transaction)) 70 | (let ((dbi-connection (dbi-connection conn))) 71 | (begin-transaction dbi-connection))) 72 | 73 | 74 | @proxy 75 | (defmethod commit ((conn )) 76 | (decf (slot-value conn 'in-transaction)) 77 | (let ((dbi-connection (dbi-connection conn))) 78 | (commit dbi-connection))) 79 | 80 | @proxy 81 | (defmethod rollback ((conn )) 82 | (decf (slot-value conn 'in-transaction)) 83 | (let ((dbi-connection (dbi-connection conn))) 84 | (rollback dbi-connection))) 85 | -------------------------------------------------------------------------------- /t/dbi-cp.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dbi-cp-test 3 | (:use :cl 4 | :dbi-cp 5 | :rove)) 6 | (in-package :dbi-cp-test) 7 | 8 | ;; NOTE: To run this test file, execute `(asdf:test-system :dbi-cp)' in your Lisp. 9 | 10 | (defun connected (connection-pool) 11 | "sum of connected" 12 | (loop for pool across (slot-value connection-pool 'dbi-cp.connectionpool::pool) 13 | count (slot-value pool 'dbi-cp.connectionpool::connect-p))) 14 | 15 | (defun available (connection-pool) 16 | "sum of available connection" 17 | (loop for pool across (slot-value connection-pool 'dbi-cp.connectionpool::pool) 18 | count (= (bt-sem:semaphore-count (slot-value pool 'dbi-cp.connectionpool::semaphore)) 19 | 1))) 20 | 21 | (defparameter *connection-pool-sqlite3* nil) 22 | (defparameter *conn1* NIL) 23 | (defparameter *conn2* NIL) 24 | (defparameter *conn3* NIL) 25 | 26 | 27 | (setup 28 | (setf *connection-pool-sqlite3* 29 | (make-dbi-connection-pool :sqlite3 30 | :database-name ":memory:" 31 | :initial-size 2 32 | :max-size 3))) 33 | 34 | (teardown 35 | (shutdown *connection-pool-sqlite3*)) 36 | 37 | 38 | (deftest check-connection 39 | (ok (eq (connected *connection-pool-sqlite3*) 2) 40 | "check initial connection size is 2") 41 | 42 | (ok (eq (available *connection-pool-sqlite3*) 3) 43 | "check initial avaiable connection size is 3")) 44 | 45 | (deftest connection 46 | (setf *conn1* (get-connection *connection-pool-sqlite3*)) 47 | 48 | (ok (eq (connected *connection-pool-sqlite3*) 2)) 49 | (ok (eq (available *connection-pool-sqlite3*) 2)) 50 | 51 | 52 | ;; get connection 53 | (setf *conn2* (get-connection *connection-pool-sqlite3*)) 54 | 55 | (ok (eq (connected *connection-pool-sqlite3*) 2)) 56 | (ok (eq (available *connection-pool-sqlite3*) 1)) 57 | 58 | 59 | ;; new connection 60 | (setf *conn3* (get-connection *connection-pool-sqlite3*)) 61 | 62 | (ok (eq (connected *connection-pool-sqlite3*) 3)) 63 | (ok (eq (available *connection-pool-sqlite3*) 0)) 64 | 65 | 66 | ;; no connection available 67 | (ok (signals (get-connection *connection-pool-sqlite3*) ')) 68 | 69 | 70 | ;; return connection 71 | ;; not disconnect database, connection continues 72 | (disconnect *conn1*) 73 | (ok (eq (connected *connection-pool-sqlite3*) 3)) 74 | (ok (eq (available *connection-pool-sqlite3*) 1))) 75 | 76 | 77 | 78 | -------------------------------------------------------------------------------- /t/proxy/mysql.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dbi-cp-proxy-mysql-test 3 | (:use :cl 4 | :dbi-cp 5 | :rove)) 6 | (in-package :dbi-cp-proxy-mysql-test) 7 | 8 | (defvar *connection-pool* nil) 9 | 10 | (setup 11 | (setf *connection-pool* (make-dbi-connection-pool :mysql 12 | :database-name "test" 13 | :username "root" 14 | :password "password" 15 | :host "mysql-test" 16 | :port 3306 17 | :initial-size 2 18 | :max-size 2))) 19 | 20 | (teardown 21 | (shutdown *connection-pool*)) 22 | 23 | 24 | (deftest mysql-do-sql 25 | (let ((conn (get-connection *connection-pool*))) 26 | (do-sql conn "DROP TABLE IF EXISTS person") 27 | (do-sql conn "CREATE TABLE person (id INTEGER PRIMARY KEY, name VARCHAR(255) NOT NULL)") 28 | 29 | (ok (eq (do-sql conn "INSERT INTO person (id, name) values (1, 'fukamachi')") 30 | 1)) 31 | (ok (eq (do-sql conn "INSERT INTO person (id, name) values (2, 'matsuyama')") 32 | 1)) 33 | (disconnect conn))) 34 | 35 | 36 | (deftest mysql-prepare-execute-fetch 37 | (let ((conn (get-connection *connection-pool*))) 38 | 39 | (let (query result) 40 | (setf query (prepare conn "SELECT * FROM person")) 41 | (setf result (execute query)) 42 | (ok (equal (fetch-all result) 43 | '((:|id| 1 :|name| "fukamachi") 44 | (:|id| 2 :|name| "matsuyama")))) 45 | 46 | (setf result (execute query)) 47 | (let ((result (fetch result))) 48 | (ok (string= (getf result :|name|) "fukamachi"))) 49 | (let ((result (fetch result))) 50 | (ok (string= (getf result :|name|) "matsuyama"))) 51 | (ok (null (fetch result)))) 52 | 53 | (let* ((query (prepare conn "SELECT * FROM person WHERE name = ?")) 54 | (result (execute query (list "")))) 55 | (ok (null (fetch result)))) 56 | 57 | (execute (prepare conn "INSERT INTO person (id, name) VALUES (3, 'snmsts')")) 58 | 59 | (ok (eq (row-count conn) 1)) 60 | 61 | (let* ((query (prepare conn "SELECT * FROM person WHERE name = ?")) 62 | (result (execute query (list "snmsts")))) 63 | (ok (string= (getf (fetch result) :|name|) "snmsts"))) 64 | 65 | (disconnect conn))) 66 | 67 | (deftest mysql-with-transaction-commit 68 | (let ((conn (get-connection *connection-pool*))) 69 | (handler-case 70 | (progn 71 | (with-transaction conn 72 | (do-sql conn "INSERT INTO person (id, name) values (4, 'meymao')")) 73 | (ok (equal (fetch (execute (prepare conn "SELECT * FROM person WHERE name = 'meymao'"))) 74 | '(:|id| 4 :|name| "meymao")))) 75 | ( () 76 | (skip "No supported"))) 77 | (disconnect conn))) 78 | 79 | (deftest mysql-with-transaction-rollback 80 | (let ((conn (get-connection *connection-pool*))) 81 | (handler-case 82 | (progn 83 | (with-transaction conn 84 | (do-sql conn "INSERT INTO person (id, name) values (5, 'mizuna')") 85 | (rollback conn)) 86 | (ok (null (fetch (execute (prepare conn "SELECT * FROM person WHERE name = 'mizuna'")))))) 87 | ( () 88 | (skip "No supported"))) 89 | (disconnect conn))) 90 | 91 | (deftest mysql-statement-error 92 | (let ((conn (get-connection *connection-pool*))) 93 | 94 | (ok (signals (do-sql conn "INSERT") 95 | ')) 96 | 97 | (ok (signals (execute (prepare conn "SELECT SELECT SELECT") '()) 98 | ')) 99 | 100 | (do-sql conn "INSERT INTO person (id, name) VALUES (5, 'mizuna')") 101 | 102 | (disconnect conn))) 103 | 104 | -------------------------------------------------------------------------------- /t/proxy/postgres.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dbi-cp-proxy-postgres-test 3 | (:use :cl 4 | :dbi-cp 5 | :rove)) 6 | (in-package :dbi-cp-proxy-postgres-test) 7 | 8 | (defvar *connection-pool* nil) 9 | 10 | (setup 11 | (setf *connection-pool* (make-dbi-connection-pool :postgres 12 | :database-name "test" 13 | :username "dbicp" 14 | :password "password" 15 | :host "postgresql-test" 16 | :port 5432 17 | :initial-size 2 18 | :max-size 2))) 19 | 20 | 21 | (teardown 22 | (shutdown *connection-pool*)) 23 | 24 | 25 | (deftest postgres-do-sql 26 | (let ((conn (get-connection *connection-pool*))) 27 | (with-transaction conn 28 | (do-sql conn "DROP TABLE IF EXISTS person") 29 | (do-sql conn "CREATE TABLE person (id INTEGER PRIMARY KEY, name VARCHAR(255) NOT NULL)")) 30 | 31 | (ok (eq (do-sql conn "INSERT INTO person (id, name) values (1, 'fukamachi')") 32 | 1)) 33 | (ok (eq (do-sql conn "INSERT INTO person (id, name) values (2, 'matsuyama')") 34 | 1)) 35 | (disconnect conn))) 36 | 37 | 38 | (deftest postgres-prepare-execute-fetch 39 | (let ((conn (get-connection *connection-pool*))) 40 | 41 | (let (query result) 42 | (setf query (prepare conn "SELECT * FROM person")) 43 | (setf result (execute query)) 44 | (ok (equal (fetch-all result) 45 | '((:|id| 1 :|name| "fukamachi") 46 | (:|id| 2 :|name| "matsuyama")))) 47 | 48 | (setf result (execute query)) 49 | (let ((result (fetch result))) 50 | (ok (string= (getf result :|name|) "fukamachi"))) 51 | (let ((result (fetch result))) 52 | (ok (string= (getf result :|name|) "matsuyama"))) 53 | (ok (null (fetch result)))) 54 | 55 | (let* ((query (prepare conn "SELECT * FROM person WHERE name = ?")) 56 | (result (execute query (list "")))) 57 | (ok (null (fetch result)))) 58 | 59 | (execute (prepare conn "INSERT INTO person (id, name) VALUES (3, 'snmsts')")) 60 | 61 | (ok (eq (row-count conn) 1)) 62 | 63 | (let* ((query (prepare conn "SELECT * FROM person WHERE name = ?")) 64 | (result (execute query (list "snmsts")))) 65 | (ok (string= (getf (fetch result) :|name|) "snmsts"))) 66 | 67 | (disconnect conn))) 68 | 69 | (deftest postgres-with-transaction-commit 70 | (let ((conn (get-connection *connection-pool*))) 71 | (handler-case 72 | (progn 73 | (with-transaction conn 74 | (do-sql conn "INSERT INTO person (id, name) values (4, 'meymao')")) 75 | (ok (equal (fetch (execute (prepare conn "SELECT * FROM person WHERE name = 'meymao'"))) 76 | '(:|id| 4 :|name| "meymao")))) 77 | ( () 78 | (skip "No supported"))) 79 | (disconnect conn))) 80 | 81 | (deftest postgres-with-transaction-rollback 82 | (let ((conn (get-connection *connection-pool*))) 83 | (handler-case 84 | (progn 85 | (with-transaction conn 86 | (do-sql conn "INSERT INTO person (id, name) values (5, 'mizuna')") 87 | (rollback conn)) 88 | (ok (null (fetch (execute (prepare conn "SELECT * FROM person WHERE name = 'mizuna'")))))) 89 | ( () 90 | (skip "No supported"))) 91 | (disconnect conn))) 92 | 93 | 94 | (deftest postgres-statement-error 95 | (let ((conn (get-connection *connection-pool*))) 96 | ;; 97 | ;; In PostgreSQL, If an error occurs during a transaction, 98 | ;; the entire transaction becomes invalid until a Commit/Rollback is performed 99 | ;; 100 | (with-transaction conn 101 | (ok (signals (do-sql conn "INSERT") 102 | ')) 103 | (rollback conn)) 104 | 105 | 106 | (with-transaction conn 107 | (ok (signals (execute (prepare conn "SELECT SELECT SELECT") '()) 108 | ')) 109 | (rollback conn)) 110 | 111 | 112 | (with-transaction conn 113 | (do-sql conn "INSERT INTO person (id, name) VALUES (5, 'mizuna')")) 114 | 115 | (disconnect conn))) 116 | 117 | -------------------------------------------------------------------------------- /t/proxy/sqlite3.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dbi-cp-proxy-sqlite3-test 3 | (:use :cl 4 | :dbi-cp 5 | :rove)) 6 | (in-package :dbi-cp-proxy-sqlite3-test) 7 | 8 | (defvar *connection-pool* nil) 9 | 10 | (setup 11 | (setf *connection-pool* (make-dbi-connection-pool :sqlite3 12 | :database-name "/app/volumes/sqlite3-test.db" 13 | :initial-size 2 14 | :max-size 3))) 15 | 16 | 17 | (teardown 18 | (shutdown *connection-pool*)) 19 | 20 | 21 | (deftest sqlite3-do-sql 22 | (let ((conn (get-connection *connection-pool*))) 23 | (do-sql conn "DROP TABLE IF EXISTS person") 24 | (do-sql conn "CREATE TABLE person (id INTEGER PRIMARY KEY, name VARCHAR(255) NOT NULL)") 25 | 26 | (ok (eq (do-sql conn "INSERT INTO person (id, name) values (1, 'fukamachi')") 27 | 1)) 28 | (ok (eq (do-sql conn "INSERT INTO person (id, name) values (2, 'matsuyama')") 29 | 1)) 30 | (disconnect conn))) 31 | 32 | 33 | (deftest sqlite3-prepare-execute-fetch 34 | (let ((conn (get-connection *connection-pool*))) 35 | 36 | (let (query result) 37 | (setf query (prepare conn "SELECT * FROM person")) 38 | (setf result (execute query)) 39 | (ok (equal (fetch-all result) 40 | '((:|id| 1 :|name| "fukamachi") 41 | (:|id| 2 :|name| "matsuyama")))) 42 | 43 | (setf result (execute query)) 44 | (let ((result (fetch result))) 45 | (ok (string= (getf result :|name|) "fukamachi"))) 46 | (let ((result (fetch result))) 47 | (ok (string= (getf result :|name|) "matsuyama"))) 48 | (ok (null (fetch result)))) 49 | 50 | (let* ((query (prepare conn "SELECT * FROM person WHERE name = ?")) 51 | (result (execute query (list "")))) 52 | (ok (null (fetch result)))) 53 | 54 | (execute (prepare conn "INSERT INTO person (id, name) VALUES (3, 'snmsts')")) 55 | 56 | (ok (eq (row-count conn) 1)) 57 | 58 | (let* ((query (prepare conn "SELECT * FROM person WHERE name = ?")) 59 | (result (execute query (list "snmsts")))) 60 | (ok (string= (getf (fetch result) :|name|) "snmsts"))) 61 | 62 | (disconnect conn))) 63 | 64 | (deftest sqlite3-with-transaction-commit 65 | (let ((conn (get-connection *connection-pool*))) 66 | (handler-case 67 | (progn 68 | (with-transaction conn 69 | (do-sql conn "INSERT INTO person (id, name) values (4, 'meymao')")) 70 | (ok (equal (fetch (execute (prepare conn "SELECT * FROM person WHERE name = 'meymao'"))) 71 | '(:|id| 4 :|name| "meymao")))) 72 | ( () 73 | (skip "No supported"))) 74 | (disconnect conn))) 75 | 76 | (deftest sqlite3-with-transaction-rollback 77 | (let ((conn (get-connection *connection-pool*))) 78 | (handler-case 79 | (progn 80 | (with-transaction conn 81 | (do-sql conn "INSERT INTO person (id, name) values (5, 'mizuna')") 82 | (rollback conn)) 83 | (ok (null (fetch (execute (prepare conn "SELECT * FROM person WHERE name = 'mizuna'")))))) 84 | ( () 85 | (skip "No supported"))) 86 | (disconnect conn))) 87 | 88 | (deftest sqlite3-statement-error 89 | (let ((conn (get-connection *connection-pool*))) 90 | 91 | (ok (signals (do-sql conn "INSERT") 92 | ')) 93 | 94 | (ok (signals (execute (prepare conn "SELECT SELECT SELECT") '()) 95 | ')) 96 | 97 | (do-sql conn "INSERT INTO person (id, name) VALUES (5, 'mizuna')") 98 | 99 | (disconnect conn))) 100 | 101 | --------------------------------------------------------------------------------