Linus Björnstam
b7e9c8076f
Every operation suspends its fiber while it waits for the server, and the ambient cancellation token cancels the query. A Db is a pool; a transaction holds one connection and hands its function a Db bound to it, and a nested one is a savepoint. Each SqlValue is a typed parameter, and a value is read back by the PostgreSQL type of its column. The server's errors are DbError with its SQLSTATE, and a lost connection is DbError 08000. 🤖 Generated with [ECA](https://eca.dev) Co-Authored-By: eca-agent <git@eca.dev>
292 lines
13 KiB
Text
292 lines
13 KiB
Text
;; This Source Code Form is subject to the terms of the Mozilla Public
|
|
;; License, v. 2.0. If a copy of the MPL was not distributed with this
|
|
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
|
|
|
;; bjopg/tests/pg.bjo — against a real PostgreSQL.
|
|
;;
|
|
;; BJOPG_TEST="Host=localhost;Database=bjosql_test" bjo run tests/pg.bjo
|
|
;;
|
|
;; The tables it makes are dropped first and last. Without BJOPG_TEST it says
|
|
;; so and runs nothing. Every other line should start with "ok:".
|
|
|
|
(import (std prelude))
|
|
(import (std simpletest))
|
|
(import (std datetime))
|
|
(import (std uuid))
|
|
(import (bjosql core))
|
|
(import (bjopg core))
|
|
|
|
(import/class
|
|
(Exception (: System.Exception))
|
|
(InvalidOperation (: System.InvalidOperationException (-> string InvalidOperation))))
|
|
|
|
(def/table events Event #:sql-name "bjopg_events"
|
|
(key Uuid #:primary-key)
|
|
(day Date)
|
|
(at Time)
|
|
(local DateTime)
|
|
(happened Instant)
|
|
(price decimal)
|
|
(doc JsonDoc)
|
|
(count int)
|
|
(note (Option Instant))
|
|
(tag (Option Uuid)))
|
|
|
|
(def/table people Person #:sql-name "bjopg_people"
|
|
(id int #:primary-key #:auto)
|
|
(name string)
|
|
(email (Option string))
|
|
(score double)
|
|
(admin bool)
|
|
(avatar (Option (Array byte))))
|
|
|
|
;; A type of one's own, which PostgreSQL has and bjosql does not.
|
|
(type (: Inet (Struct (: text string))))
|
|
|
|
(impl (ToSql Inet) (defun (to-sql a) (SqlOther "inet" (struct-ref a text))))
|
|
|
|
(impl (FromSql Inet)
|
|
(defun (from-sql v)
|
|
(match v
|
|
((SqlOther "inet" s) (Ok (Inet (text s))))
|
|
(_ (Err (str "expected an inet, got " (describe-sql-value v)))))))
|
|
|
|
(def/table hosts Host #:sql-name "bjopg_hosts"
|
|
(name string #:primary-key)
|
|
(addr Inet #:sql-type "INET"))
|
|
|
|
(: some! (-> (Option %a) %a))
|
|
(defun (some! o)
|
|
(match o
|
|
((Some x) x)
|
|
(None (panic! "expected a value"))))
|
|
|
|
(: instant (-> string Instant))
|
|
(defun (instant s) (some! (iso8601->instant s)))
|
|
|
|
(: ok! (-> (Result SqlError %a) %a))
|
|
(defun (ok! r)
|
|
(match r
|
|
((Ok x) x)
|
|
((Err e) (panic! (sql-error-message e)))))
|
|
|
|
(: code-of (-> (Result SqlError %a) string))
|
|
(defun (code-of r)
|
|
(match r
|
|
((Ok _) "ok")
|
|
((Err (DbError code _)) code)
|
|
((Err e) (sql-error-message e))))
|
|
|
|
(: event (-> Uuid string string Event))
|
|
(defun (event key when price)
|
|
(Event (key key)
|
|
(day (some! (date 2026 10 12)))
|
|
(at (some! (time 14 5 #:seconds 9 #:nanoseconds 250000000)))
|
|
(local (some! (datetime 2026 10 12 #:hours 14 #:minutes 5 #:seconds 9 #:nanoseconds 123456000)))
|
|
(happened (instant when))
|
|
(price (string->decimal price))
|
|
(doc (json-doc "{\"b\": 1, \"a\": [1,2]}"))
|
|
(count 3)
|
|
(note None)
|
|
(tag None)))
|
|
|
|
(: person (-> string Person))
|
|
(defun (person name)
|
|
(Person (id 0) (name name) (email None) (score 1.0) (admin #f) (avatar None)))
|
|
|
|
;; A column read as a long.
|
|
(: long-field (-> Row string (Result SqlError long)))
|
|
(defun (long-field row name) (row-field row name))
|
|
|
|
;; One column of every row, as text, in the order the server gave them.
|
|
(: column (-bjo-> Db string (List string)))
|
|
(defbjo (column db query)
|
|
(list-map (fun (row) (match (row-value row "c")
|
|
((Some (SqlText s)) s)
|
|
((Some v) (describe-sql-value v))
|
|
(None "none")))
|
|
(ok! (query-sql db (sql query Nil)))))
|
|
|
|
(: names (-bjo-> Db (List string)))
|
|
(defbjo (names db)
|
|
(list-map (fun (p) (record-ref p name)) (ok! (fetch db people '(select (order-by name))))))
|
|
|
|
(: drop-all (-bjo-> Db void))
|
|
(defbjo (drop-all db)
|
|
(ignore (ok! (execute-sql db (sql "DROP TABLE IF EXISTS bjopg_events, bjopg_people, bjopg_hosts" Nil)))))
|
|
|
|
(: run (-bjo-> Db void))
|
|
(defbjo (run db)
|
|
(drop-all db)
|
|
(ignore (ok! (create-table db events)))
|
|
(ignore (ok! (create-table db people)))
|
|
(ignore (ok! (create-table db hosts)))
|
|
(expect "the columns have PostgreSQL's own types"
|
|
(column db "SELECT data_type AS c FROM information_schema.columns WHERE table_name = 'bjopg_events' ORDER BY ordinal_position")
|
|
(list "uuid" "date" "time without time zone" "timestamp without time zone" "timestamp with time zone"
|
|
"numeric" "jsonb" "integer" "timestamp with time zone" "uuid"))
|
|
|
|
;; ---- written and read back ---------------------------------------------
|
|
(def first (event (uuid-v7) "2026-10-12T09:00:00.5Z" "12.50"))
|
|
(def stored (ok! (insert db events first)))
|
|
(expect "a row of every new type comes back equal"
|
|
(list (= (record-ref stored key) (record-ref first key))
|
|
(= (compare (record-ref stored day) (record-ref first day)) 0)
|
|
(= (compare (record-ref stored at) (record-ref first at)) 0)
|
|
(= (compare (record-ref stored local) (record-ref first local)) 0)
|
|
(= (compare (record-ref stored happened) (record-ref first happened)) 0)
|
|
(= (decimal->string (record-ref stored price)) "12.50")
|
|
(= (record-ref stored count) 3)
|
|
(none? (record-ref stored note))
|
|
(none? (record-ref stored tag)))
|
|
(list #t #t #t #t #t #t #t #t #t))
|
|
(expect "jsonb keeps the value, in its own form"
|
|
(json-doc-text (record-ref stored doc))
|
|
"{\"a\": [1, 2], \"b\": 1}")
|
|
(expect "the instant is stored as a point in time"
|
|
(column db "SELECT to_char(happened AT TIME ZONE 'UTC', 'YYYY-MM-DD HH24:MI:SS.US') AS c FROM bjopg_events")
|
|
(list "2026-10-12 09:00:00.500000"))
|
|
|
|
;; ---- queries ------------------------------------------------------------
|
|
(ignore (ok! (insert db events (event (uuid-v7) "2026-10-12T09:00:00.25Z" "7.00"))))
|
|
(ignore (ok! (insert db events (event (uuid-v7) "2026-10-12T09:00:00Z" "100.00"))))
|
|
(ignore (ok! (insert db events (event (uuid-v7) "2026-10-12T10:00:00+02:00" "-3.00"))))
|
|
(expect "ORDER BY an instant"
|
|
(list-map (fun (e) (->str (record-ref e happened))) (ok! (fetch db events '(select (order-by happened)))))
|
|
(list "2026-10-12T08:00:00Z" "2026-10-12T09:00:00Z" "2026-10-12T09:00:00.25Z" "2026-10-12T09:00:00.5Z"))
|
|
(expect "ORDER BY a version 7 uuid sorts by the time it was made"
|
|
(list-map (fun (e) (decimal->string (record-ref e price))) (ok! (fetch db events '(select (order-by key)))))
|
|
(list "12.50" "7.00" "100.00" "-3.00"))
|
|
(expect "ORDER BY a decimal is numeric, as SQLite's text is not"
|
|
(list-map (fun (e) (decimal->string (record-ref e price))) (ok! (fetch db events '(select (order-by price)))))
|
|
(list "-3.00" "7.00" "12.50" "100.00"))
|
|
(expect "a test on a decimal is numeric"
|
|
(list-length (ok! (fetch db events '(select (where (price (> 10.0M)))))))
|
|
2)
|
|
(expect "a test on an instant"
|
|
(list-length (ok! (fetch db events '(select (where (happened (>= ,(instant "2026-10-12T09:00:00.25Z"))))))))
|
|
2)
|
|
(expect "a test on a uuid"
|
|
(list-length (ok! (fetch db events '(select (where (key (= ,(record-ref first key))))))))
|
|
1)
|
|
(def label (uuid-v4))
|
|
(expect "a nullable uuid and instant set from values"
|
|
(ok! (execute db events '(update (set (tag ,(Some label)) (note ,(Some (instant "2026-01-01T00:00:00Z"))))
|
|
(where (key (= ,(record-ref first key)))))))
|
|
1)
|
|
(expect "and read back"
|
|
(match (ok! (fetch-one db events '(select (where (tag not-null)))))
|
|
((Some e) (list (if (= (some! (record-ref e tag)) label) "the label" "another uuid")
|
|
(->str (record-ref e note))))
|
|
(None (list "none")))
|
|
(list "the label" "(Some 2026-01-01T00:00:00Z)"))
|
|
(expect "set back to NULL"
|
|
(ok! (execute db events '(update (set (tag null) (note null)) (where (tag not-null)))))
|
|
1)
|
|
|
|
;; ---- the six that were there --------------------------------------------
|
|
(def ada (ok! (insert db people (Person (id 0) (name "Ada") (email (Some "ada@example.org")) (score 9.5)
|
|
(admin #t) (avatar (Some #[1uy 2uy 3uy]))))))
|
|
(expect "an #:auto key comes back" (record-ref ada id) 1)
|
|
(expect "the rest of the row"
|
|
(str (record-ref ada name) " " (->str (record-ref ada email)) " " (double->string (record-ref ada score))
|
|
" " (->str (record-ref ada admin)) " "
|
|
(match (record-ref ada avatar) ((Some b) (int->string (array-length b))) (None "none")))
|
|
"Ada (Some ada@example.org) 9.5 True 3")
|
|
(expect "insert-all"
|
|
(list-map (fun (p) (record-ref p id)) (ok! (insert-all db people (list (person "Grace") (person "Linus")))))
|
|
(list 2 3))
|
|
(expect "SQL by hand, with ? for a value"
|
|
(match (ok! (query-sql db (sql "SELECT count(*) AS n FROM bjopg_people WHERE score > ?" (list (to-sql 5.0)))))
|
|
((Cons row _) (match (long-field row "n") ((Ok n) n) ((Err _) -1L)))
|
|
(Nil -1L))
|
|
1L)
|
|
(expect "an update counts its rows" (ok! (execute db people '(update (set (score 2.0)) (where (admin (= #f)))))) 2)
|
|
(expect "a delete counts its rows" (ok! (execute db people '(delete (where (name (= "Linus")))))) 1)
|
|
|
|
;; ---- errors ---------------------------------------------------------------
|
|
(ignore (ok! (execute-sql db (sql "CREATE UNIQUE INDEX bjopg_people_name ON bjopg_people (name)" Nil))))
|
|
(expect "a unique violation is SQLSTATE 23505" (code-of (insert db people (person "Ada"))) "23505")
|
|
(expect "SQL the server cannot parse is 42601" (code-of (execute-sql db (sql "SELEKT 1" Nil))) "42601")
|
|
|
|
;; ---- transactions -----------------------------------------------------------
|
|
(expect "Ok commits"
|
|
(code-of (with-transaction db (bjoroutine (tx) (insert tx people (person "Barbara")))))
|
|
"ok")
|
|
(expect "Err rolls back"
|
|
(code-of (with-transaction db
|
|
(bjoroutine (tx)
|
|
(ignore (ok! (insert tx people (person "Edsger"))))
|
|
(Err (BadQuery "changed my mind")))))
|
|
"changed my mind")
|
|
(expect "a throw rolls back, and is thrown on"
|
|
(match (try (with-transaction db
|
|
(bjoroutine (tx)
|
|
(ignore (ok! (insert tx people (person "Niklaus"))))
|
|
(raise (cast Exception (InvalidOperation. "boom")))))
|
|
#:catch (System.Exception))
|
|
((Ok _) "returned")
|
|
((Err _) "thrown"))
|
|
"thrown")
|
|
(expect "after a failed savepoint, the outer transaction goes on"
|
|
(code-of (with-transaction db
|
|
(bjoroutine (tx)
|
|
(ignore (ok! (insert tx people (person "Alan"))))
|
|
(expect "the inner one fails on the unique name"
|
|
(code-of (with-transaction tx (bjoroutine (inner) (insert inner people (person "Ada")))))
|
|
"23505")
|
|
(insert tx people (person "Tony")))))
|
|
"ok")
|
|
(expect "who is there"
|
|
(names db)
|
|
(list "Ada" "Alan" "Barbara" "Grace" "Tony"))
|
|
|
|
;; ---- a type of one's own ------------------------------------------------------
|
|
(ignore (ok! (insert db hosts (Host (name "router") (addr (Inet (text "10.0.0.1")))))))
|
|
(expect "SqlOther is sent with a cast to its type"
|
|
(list-map (fun (h) (struct-ref (record-ref h addr) text))
|
|
(ok! (fetch db hosts '(select (where (addr (= ,(Inet (text "10.0.0.1")))))))))
|
|
(list "10.0.0.1"))
|
|
(expect "and the server checks it"
|
|
(code-of (insert db hosts (Host (name "bad") (addr (Inet (text "not an address"))))))
|
|
"22P02")
|
|
|
|
;; ---- many fibers, one pool ------------------------------------------------------
|
|
;; Each query waits a little on the server, so the 20 overlap: they are only
|
|
;; done in a fraction of 20 times the wait if the fibers suspend while they
|
|
;; wait, rather than holding a thread each.
|
|
(def started (monotonic-ms))
|
|
(def queries
|
|
(loop (:for i (range 0 20))
|
|
(:acc out (listing (bjo (query-sql db (sql "SELECT count(*) AS n, pg_sleep(0.2) FROM bjopg_people" Nil)))))
|
|
=> out))
|
|
(def answers
|
|
(loop (:for p queries)
|
|
(:acc out (listing (match (sync (promise-join p))
|
|
((Ok (Ok (Cons row _))) (match (long-field row "n") ((Ok n) n) ((Err e) -1L)))
|
|
((Ok (Err e)) -1L)
|
|
((Ok (Ok Nil)) -2L)
|
|
((Err e) -3L))))
|
|
=> out))
|
|
(expect "20 queries at once through the pool all answer" answers (list-map (fun (_) 5L) (range-list 0 20)))
|
|
(expect-true "and they overlap" (< (- (monotonic-ms) started) 2000L))
|
|
|
|
(drop-all db))
|
|
|
|
(: range-list (-> int int (List int)))
|
|
(defun (range-list a b) (loop (:for i (range a b)) (:acc out (listing i)) => out))
|
|
|
|
(defbjo (main args)
|
|
(match (get-environment-variable "BJOPG_TEST")
|
|
(None (println "skipped: set BJOPG_TEST to a connection string, such as Host=localhost;Database=bjosql_test"))
|
|
((Some connection-string)
|
|
(expect "a server that is not there is DbError 08000"
|
|
(code-of (open-db "Host=localhost;Port=1;Database=nothing;Timeout=2"))
|
|
"08000")
|
|
(expect "a database that is not there is the server's 3D000"
|
|
(code-of (open-db (str connection-string ";Database=bjopg_no_such_database")))
|
|
"3D000")
|
|
(match (open-db connection-string)
|
|
((Err e) (println (str "FAILURE: open: " (sql-error-message e))))
|
|
((Ok db) (try (run db) #:finally (close-db db))))))
|
|
0)
|