├── examples ├── package.lisp ├── util.lisp ├── simple.lisp ├── filter.lisp ├── human-2.lisp ├── human-1.lisp └── customize.lisp ├── postgres ├── s-sql.lisp ├── util.lisp ├── postmodern.lisp ├── commands.lisp └── transactions.lisp ├── t ├── package.lisp ├── model │ └── interface.lisp ├── base.lisp └── transactions.lisp ├── markdown-docstrings.asd ├── postgres-json-test.asd ├── postgres-json-parallel.asd ├── postgres-json-examples.asd ├── errors.lisp ├── postgres-json.asd ├── LICENSE ├── model ├── history.lisp ├── types.lisp ├── transactions.lisp ├── query.lisp ├── user-query.lisp ├── model.lisp └── interface.lisp ├── util.lisp ├── tests ├── thread-lock-test.lisp └── thread-test.lisp ├── specials.lisp ├── package.lisp ├── interface.lisp ├── TODO.md ├── doc ├── beginners.md ├── user-guide.md └── api.md ├── parallel.lisp ├── README.md └── markdown-docstrings.lisp /examples/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Model user interface 2 | 3 | (defpackage :pj-human 4 | (:use :cl :postgres-json :alexandria)) 5 | -------------------------------------------------------------------------------- /postgres/s-sql.lisp: -------------------------------------------------------------------------------- 1 | (in-package :s-sql) 2 | 3 | ;; additional json and jsonb operators 4 | (register-sql-operators :2+-ary :->> :#> :#>>) 5 | -------------------------------------------------------------------------------- /t/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :postgres-json-test 2 | (:use #:cl #:postgres-json #:1am #:alexandria) 3 | (:export #:run-pgj-tests) 4 | (:documentation "Test Postgres-JSON.")) 5 | -------------------------------------------------------------------------------- /markdown-docstrings.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem markdown-docstrings 2 | :author "Gregory Tod " 3 | :version "0.2.0" 4 | :license "MIT" 5 | :description "Horrible little docstrings to Markdown converter" 6 | :depends-on (#:alexandria 7 | #:uiop 8 | #:cl-ppcre) 9 | :components ((:file "markdown-docstrings"))) 10 | -------------------------------------------------------------------------------- /postgres-json-test.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem postgres-json-test 2 | :author "Gregory Tod " 3 | :version "0.1.5" 4 | :license "MIT" 5 | :homepage "https://github.com/gtod/postgres-json" 6 | :description "Tests for Postgres-JSON, a Postgres JSON document store" 7 | :depends-on (#:postgres-json-parallel #:1am) 8 | :components 9 | ((:module "t" 10 | :serial t 11 | :components ((:file "package") 12 | (:file "base") 13 | (:file "transactions") 14 | (:file "model/interface"))))) 15 | -------------------------------------------------------------------------------- /t/model/interface.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json-test) 2 | 3 | (test update-history 4 | (with-temp-model (with-history (pgj-history-model)) 5 | (insert with-history (obj "a" "b") 7) 6 | (supersede with-history 7 (obj "a" "c")) 7 | (supersede with-history 7 (obj "a" "d")) 8 | (is (= 2 (length (history with-history 7)))) 9 | (with-model-transaction () 10 | (insert with-history 123 8) 11 | (supersede with-history 8 124) 12 | (supersede with-history 8 125) 13 | (is (= 2 (length (history with-history 8 :validity-keys-p nil))))))) 14 | -------------------------------------------------------------------------------- /postgres-json-parallel.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem postgres-json-parallel 2 | :author "Gregory Tod " 3 | :version "0.1.5" 4 | :license "MIT" 5 | :homepage "https://github.com/gtod/postgres-json" 6 | :description "lparallel support for Postgres-JSON, a Postgres JSON document store" 7 | :depends-on (#:postgres-json 8 | #:lparallel 9 | ;; Try git clone https://github.com/sionescu/bordeaux-threads.git 10 | ;; in your quicklips/local-projects and then (ql:register-local-projects) 11 | ;; at the REPL to fix this. 12 | (:version #:bordeaux-threads "0.8.3.99")) 13 | :components 14 | ((:file "parallel"))) 15 | -------------------------------------------------------------------------------- /examples/util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Some little helper code for the human examples 2 | 3 | (in-package :pj-human) 4 | 5 | (defmacro with-pj-connection (() &body body) 6 | `(progn 7 | (assert *postmodern-connection*) 8 | (pomo:with-connection *postmodern-connection* 9 | (pomo:set-search-path *default-search-path*) 10 | ,@body))) 11 | 12 | (defmacro show (form) 13 | `(progn 14 | (print ',form) 15 | (pp-json ,form))) 16 | 17 | (defmacro with-keys ((&rest pairs) object &body body) 18 | (once-only (object) 19 | `(symbol-macrolet (,@(loop for pair in pairs 20 | collect `(,(car pair) (gethash ,(cadr pair) ,object)))) 21 | ,@body))) 22 | -------------------------------------------------------------------------------- /postgres-json-examples.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem postgres-json-examples 2 | :author "Gregory Tod " 3 | :version "0.1.5" 4 | :license "MIT" 5 | :homepage "https://github.com/gtod/postgres-json" 6 | :description "Examples for Postgres-JSON, a Postgres JSON document store" 7 | :depends-on (#:postgres-json 8 | #:alexandria 9 | #:postmodern 10 | #:yason) 11 | :components 12 | ((:module examples 13 | :serial t 14 | :components ((:file "package") 15 | (:file "util") 16 | (:file "simple") 17 | (:file "filter") 18 | (:file "customize") 19 | (:file "human-1") 20 | (:file "human-2"))))) 21 | -------------------------------------------------------------------------------- /postgres/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | (defvar *debug-sql* nil 4 | "Set true to inspect S-SQL forms sent to RUN, instead of compiling 5 | and executing.") 6 | 7 | ;;;; Qualified PostgreSQL table names using Postmodern's S-SQL 8 | 9 | (defun qualified-name (name &optional (schema *pgj-schema*)) 10 | "Return the S-SQL :dot form of NAME and SCHEMA, both symbols." 11 | `(:dot ',schema ',name)) 12 | 13 | (defun qualified-name-string (name &optional (schema *pgj-schema*)) 14 | "Return a string of the Postgres 'qualified name' of NAME and SCHEMA, 15 | both symbols." 16 | (sql-compile (qualified-name name schema))) 17 | 18 | ;;;; Utility 19 | 20 | (defun run (form) 21 | "Compile and then run the S-SQL form FORM, unless *DEBUG-SQL* is true 22 | is which case just PRINT the FORM." 23 | (if *debug-sql* 24 | (print form) 25 | (if (stringp form) 26 | (query form) 27 | (query (sql-compile form))))) 28 | 29 | -------------------------------------------------------------------------------- /errors.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | ;;;; Ancestor condition for entire library 4 | 5 | (define-condition postgres-json-error (error) ()) 6 | 7 | ;;;; Database conditions 8 | 9 | (define-condition postgres-json-database-error (postgres-json-error) ()) 10 | 11 | (define-condition database-safety-net (postgres-json-database-error) 12 | ((attempted-to :initarg :attempted-to :reader attempted-to) 13 | (suggestion :initarg :suggestion :reader suggestion)) 14 | (:report (lambda (condition stream) 15 | (format stream "To save you from yourself I refuse to: ~A.~%May I suggest you: ~A." 16 | (attempted-to condition) 17 | (suggestion condition)))) 18 | (:documentation "Signaled to prevent accidental deletion of database 19 | assets such as tables or schema.")) 20 | 21 | (defun really-do-it (condition) 22 | "Invoke a 'REALLY-DO-IT restart." 23 | (declare (ignore condition)) 24 | (invoke-restart 'really-do-it)) 25 | -------------------------------------------------------------------------------- /postgres-json.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem postgres-json 2 | :author "Gregory Tod " 3 | :version "0.2.0" 4 | :license "MIT" 5 | :homepage "https://github.com/gtod/postgres-json" 6 | :description "Store and query JSON documents in PostgreSQL" 7 | :depends-on (#:alexandria 8 | #:postmodern 9 | #:global-vars 10 | #:log4cl 11 | #:yason) 12 | :serial t 13 | :components 14 | ((:file "package") 15 | (:file "util") 16 | (:file "errors") 17 | (:file "specials") 18 | (:module "postgres" 19 | :serial t 20 | :components ((:file "s-sql") 21 | (:file "postmodern") 22 | (:file "util") 23 | (:file "commands") 24 | (:file "transactions"))) 25 | (:module "model" 26 | :serial t 27 | :components ((:file "transactions") 28 | (:file "user-query") 29 | (:file "types") 30 | (:file "model") 31 | (:file "history") 32 | (:file "query") 33 | (:file "interface"))) 34 | (:file "interface"))) 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Gregory Tod 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /postgres/postmodern.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postmodern) 2 | 3 | ;;; This is the smallest change I could think of and ideally becomes 4 | ;;; part of Postmodern proper. Has current behaviour by default. 5 | 6 | ;; 1) Define and 2) Export this 3) Export the various call-with functions 7 | (defvar *transaction-mode* "") 8 | 9 | (export '(*transaction-mode* call-with-transaction call-with-logical-transaction 10 | call-with-ensured-transaction abort-logical-transaction commit-logical-transaction)) 11 | 12 | (defun call-with-transaction (body) 13 | (let ((transaction (make-instance 'transaction-handle))) 14 | (execute (format nil "BEGIN ~A" *transaction-mode*)) ; 4) This one line change 15 | (unwind-protect 16 | (multiple-value-prog1 17 | (let ((*transaction-level* (1+ *transaction-level*)) 18 | (*current-logical-transaction* transaction)) 19 | (funcall body transaction)) 20 | (commit-transaction transaction)) 21 | (abort-transaction transaction)))) 22 | 23 | ;; 5) This is a bug fix 24 | (defmethod commit-logical-transaction ((savepoint savepoint-handle)) 25 | (release-savepoint savepoint)) 26 | -------------------------------------------------------------------------------- /model/history.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | ;;;; Add keeping a permanent history of all rows to basic PGJ-MODEL 4 | 5 | (defgeneric model-old-table (model) 6 | (:documentation "The Postgres qualified name as an S-SQL form for a 7 | history or 'old' table of MODEL.") 8 | (:method ((model pgj-history-model)) 9 | (qualified-name (sym-suffix (model-name model) "old")))) 10 | 11 | (defgeneric create-old-table (model) 12 | (:documentation "Create a Postgres table to contain the previous 13 | values of JSON documents in the base table of MODEL.") 14 | (:method ((model pgj-history-model)) 15 | (let ((old-table (sql-compile (model-old-table model))) 16 | (key-name (model-key-name model)) 17 | (key-type (model-key-type model))) 18 | (run `(:create-table ,old-table 19 | ((,key-name :type ,key-type ) 20 | (valid-to :type timestamptz) 21 | (valid-from :type timestamptz) 22 | (jdoc :type jsonb)) 23 | (:primary-key ,key-name valid-to)))))) 24 | 25 | (defmethod create-backend ((model pgj-history-model)) 26 | (call-next-method) 27 | (create-old-table model)) 28 | 29 | (defmethod backend-exists-p ((model pgj-history-model)) 30 | (and (call-next-method) 31 | (%table-exists-p (sql-compile (model-old-table model))))) 32 | 33 | (defmethod drop-backend ((model pgj-history-model)) 34 | (call-next-method) 35 | (drop-db-table-cascade (sql-compile (model-old-table model)))) 36 | -------------------------------------------------------------------------------- /util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | ;;;; JSON related small functions 4 | 5 | (defun obj (&rest args) 6 | "Return an 'equal key/value hash-table consisting of pairs of ARGS. 7 | For JSON use your keys must be Common Lisp strings." 8 | (let ((hash (make-hash-table :test #'equal))) 9 | (loop for (key val) on args by #'cddr do 10 | (setf (gethash key hash) val)) 11 | hash)) 12 | 13 | (defun from-json (string) 14 | "Parse the JSON string STRING and return the resulting lisp object." 15 | (yason:parse string :json-arrays-as-vectors t)) 16 | 17 | (defun to-json (object) 18 | "Convert a lisp OBJECT to a string of JSON." 19 | (with-output-to-string (s) 20 | (yason:encode object s))) 21 | 22 | (defun pp-json (object &key (stream *standard-output*) (indent 4)) 23 | "Pretty print lisp OBJECT as JSON to STREAM with specified INDENT." 24 | (fresh-line stream) 25 | (let ((s (yason:make-json-output-stream stream :indent indent))) 26 | (yason:encode object s))) 27 | 28 | ;;;; True utility functions and macros, waiting for a real home 29 | 30 | (defmacro first-value (form) 31 | `(nth-value 0 ,form)) 32 | 33 | (defun sym (package-name &rest args) 34 | "Return symbol being the concatenation of upcasing ARGS. See 35 | ALEXANDRIA:FORMAT-SYMBOL for effect of PACKAGE-NAME." 36 | (format-symbol package-name "~:@(~{~A~}~)" args)) 37 | 38 | (defun sym-prefix (prefix symbol) 39 | (sym t prefix "-" symbol)) 40 | 41 | (defun sym-suffix (symbol suffix) 42 | (sym t symbol "-" suffix)) 43 | 44 | (defun walk-tree (fun tree) 45 | "Walk TREE and call FUN at each node. Thanks to Lisp Tips." 46 | (subst-if t (constantly nil) tree :key fun)) 47 | -------------------------------------------------------------------------------- /tests/thread-lock-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; At one stage there was a *model-parameters* hash to cache the 2 | ;;;; model params once they had been fetch from the *meta-model* 3 | ;;;; table. Because this hash would have been accessed by all threads 4 | ;;;; it needed a lock for write access. The following code was a 5 | ;;;; demonstration of that need (thanks to the SBCL doc on threads). 6 | 7 | ;;;; But since postgres-json-parallel.asd it is moot. 8 | 9 | ;;;; So this is just a reminder of the need for thread safe locks on 10 | ;;;; hash table writes. 11 | 12 | (defpackage :thread-lock-test 13 | (:use :cl) 14 | (:import-from :postgres-json :pp-json)) 15 | 16 | (in-package :thread-lock-test) 17 | 18 | (defparameter *trample* (make-hash-table :test #'equal)) 19 | 20 | (defun run (total-threads) 21 | (setf *trample* (make-hash-table :test #'equal)) 22 | (mapc #'bt:join-thread 23 | (loop for i from 1 to total-threads 24 | collect (bt:make-thread 25 | (lambda () 26 | (loop repeat 1000 27 | do (incf (gethash "foo" *trample* 0)) 28 | (sleep 0.00001)))))) 29 | (pp-json *trample*)) 30 | 31 | (defun trample () 32 | (setf *trample* (make-hash-table :test #'equal)) 33 | (let ((lock (bt:make-lock))) 34 | (mapc #'bt:join-thread 35 | (loop for i from 1 to 1000 36 | collect (bt:make-thread 37 | (lambda () 38 | (loop repeat 1000 39 | do (bt:with-lock-held (lock) 40 | (incf (gethash "foo" *trample* 0))) 41 | (sleep 0.00001))))))) 42 | (pp-json *trample*)) 43 | -------------------------------------------------------------------------------- /examples/simple.lisp: -------------------------------------------------------------------------------- 1 | ;;; Evaluate something like the following before proceeding: 2 | ;;; (setf *postmodern-connection* '("mydb" "myname" "" "localhost")) 3 | 4 | ;;; Evaluate (setup), (insert-some-pigs) and (local-rat) 5 | 6 | (defpackage :simple 7 | (:use :cl :postgres-json)) 8 | 9 | (in-package :simple) 10 | 11 | (define-global-model pig -pig- (pgj-object-model)) 12 | 13 | (defun setup () 14 | (ensure-top-level-connection) 15 | (ensure-backend -pig-)) 16 | 17 | (defun insert-some-pigs () 18 | (insert -pig- (obj "name" "Leon" "coat" "pink")) 19 | (insert -pig- (obj "name" "Roger" "coat" "Tan")) 20 | (insert -pig- (obj "name" "Zebedee" "coat" "black pied")) 21 | 22 | (format t "Pig keys: ~A~%" (keys -pig-)) 23 | 24 | (excise -pig- (first (keys -pig-))) 25 | 26 | (format t "Pig keys: ~A~%" (keys -pig-)) 27 | 28 | (pp-json (fetch -pig- (second (keys -pig-)))) 29 | 30 | (format t "~%Total pigs: ~A~%" (tally -pig-)) 31 | 32 | (let* ((key (first (keys -pig-))) 33 | (pig (fetch -pig- key))) 34 | (setf (gethash "age" pig) 7) 35 | (setf (gethash "likes" pig) '("rain" "sunflowers")) 36 | (supersede -pig- key pig)) 37 | 38 | (pp-json (fetch-all -pig-))) 39 | 40 | ;; Models need not be global. Macroexpand the define-global-model 41 | ;; form above to see what it really is. But because there are no 42 | ;; slots in PGJ-OBJECT-MODEL (or relatives) *all instances are always 43 | ;; the same* which is why making the single global instance is 44 | ;; sensible. 45 | (defun local-rat () 46 | (let ((rat (make-instance (defclass rat (pgj-object-model) ())))) 47 | (ensure-backend rat) 48 | (insert rat (obj "name" "Ratty" "color" "black")) 49 | (format t "Rats: ~A~%" (tally rat)))) 50 | 51 | (defun drop () 52 | (drop-backend -pig-)) 53 | -------------------------------------------------------------------------------- /specials.lisp: -------------------------------------------------------------------------------- 1 | ;;;; This file does not contain all the specials in the library. 2 | ;;;; Those closeley tied to implementaion code sit in those files. 3 | 4 | (in-package :postgres-json) 5 | 6 | (defvar *pgj-schema* 'pgj-model 7 | "A symbol being the name of the Postgres schema created to house all 8 | database backend objects.") 9 | 10 | (defvar *pgj-sequence* 'pgj-seq 11 | "A symbol being the name of the default Postgres sequence created to 12 | automatically generate primary keys for JSON documents inserted into a 13 | backend model.") 14 | 15 | ;; I think it sort of makes sense not to sleep at all for the first 16 | ;; retry, but then to back off pretty fast. But I am no expert... 17 | (defvar *serialization-failure-sleep-times* '(0 1 2 4 7) 18 | "The length of this list of real numbers determines the number of 19 | times to retry when a Postgres transaction COMMIT sees a 20 | CL-POSTGRES-ERROR:SERIALIZATION-FAILURE condition. For each retry we 21 | sleep the duration specified plus a random number of milliseconds 22 | between 0 and 2000. However, if 0 sleep is specified, we do not sleep 23 | at all. If set to NIL no condition handling is performed hence the 24 | client will always see any such serialization failures.") 25 | 26 | ;; We are not locking write access to this hash so it is not thread 27 | ;; safe. See postgres-json-parallel.asd and parallel.lisp for one 28 | ;; solution... 29 | (defvar *query-functions* (make-hash-table :test #'equal) 30 | "Hash of schema/model/query-name => query function.") 31 | 32 | (defvar *from-json* #'from-json 33 | "A function designator for a function of one argument which returns 34 | the result of parsing the JSON string being its input.") 35 | 36 | (defvar *to-json* #'to-json 37 | "A function designator for a function of one argument which 38 | serializes a lisp object to a JSON string.") 39 | -------------------------------------------------------------------------------- /postgres/commands.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | ;;;; High level DB operations 4 | ;;;; See also postmodern util.lisp 5 | 6 | ;;; We can get away with these not being prepared statments because (I 7 | ;;; imagine) they are infrequently used, and usually from the REPL. 8 | 9 | ;; We could use the pomo:sequence-exists-p but that checks in _all_ 10 | ;; schemas which is not really what we want. Just let them see the 11 | ;; error... 12 | (defun create-db-sequence (sequence &optional (schema *pgj-schema*)) 13 | "Create a PostgreSQL sequence with name SEQUENCE in SCHEMA (both symbols). 14 | Requires an active DB connection." 15 | (run `(:create-sequence ,(qualified-name sequence schema))) 16 | (values)) 17 | 18 | (defun drop-db-table-cascade (table) 19 | "Drop a Postgres TABLE, a string, and all dependent views, 20 | indexes etc. Use with care." 21 | (run (format nil "drop table ~A cascade" table))) 22 | 23 | (defun drop-db-schema-cascade (schema) 24 | "Drop a PostgreSQL schema and cascade delete all contained DB 25 | objects(!) with name SCHEMA, a symbol. Requires an active DB 26 | connection." 27 | (when (string-equal "public" (symbol-name schema)) 28 | (error 'database-safety-net 29 | :attempted-to "Drop schema PUBLIC" 30 | :suggestion "Try pomo:drop-schema")) 31 | (pomo:drop-schema schema :cascade t) 32 | (values)) 33 | 34 | (defun %table-exists-p (table) 35 | "Does TABLE, a string, exist in the Postgres backend?" 36 | (let ((query (sql-compile `(:select (:type ,table regclass))))) 37 | (first-value (ignore-errors (query query :single))))) 38 | 39 | (defun flush-prepared-queries () 40 | "If you get a 'Database error 26000: prepared statement ... does not 41 | exist error' while mucking around at the REPL, call this. A similar 42 | error in production code should be investigated." 43 | (setf *query-functions* (make-hash-table :test #'equal))) 44 | -------------------------------------------------------------------------------- /examples/filter.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :filtering 2 | (:use :cl :postgres-json)) 3 | 4 | (in-package :filtering) 5 | 6 | (define-global-model cat -cat- (pgj-object-model)) 7 | 8 | (defun setup () 9 | (ensure-top-level-connection) 10 | (ensure-backend -cat-)) 11 | 12 | (defun cleanup () 13 | (drop-backend -cat-)) 14 | 15 | (defmacro show (form) 16 | `(progn 17 | (print ',form) 18 | (pp-json ,form))) 19 | 20 | (defun insert-some-cats () 21 | (insert -cat- (obj "name" "Joey" "coat" "tabby" "age" 7 22 | "likes" '("sunshine" "rain") 23 | "trips" (obj "Barcelona" '(2014 2012 2009) 24 | "Kansas City" '(2013)))) 25 | (insert -cat- (obj "name" "Maud" "coat" "tortoiseshell" "age" 3)) 26 | (insert -cat- (obj "name" "Manny" "coat" "tortoiseshell" "age" 9)) 27 | (insert -cat- (obj "name" "Max" "coat" "graphite" "age" 2))) 28 | 29 | ;; Postgres top level property 'existence' operator, better called HAVING-PROPERTY 30 | ;; Requires the (slower/bigger) jsonb_ops index 31 | ;; See 8.14.3/4 in Postgres manual 9.4 32 | (defun existence () 33 | (show (length (having-property -cat- "name"))) 34 | (show (having-property -cat- "trips"))) 35 | 36 | ;; FILTER uses the Postgres Containment operator 37 | ;; See 8.14.3 in Postgres manual 9.4 38 | ;; A simple version could be implemented like so: 39 | ;; (define-json-query filter ((*to-json* contains)) 40 | ;; (:select 'jdoc 41 | ;; :from 'cat 42 | ;; :where (:@> 'jdoc contains))) 43 | (defun filtering () 44 | (show (filter -cat- :contains (obj "coat" "tortoiseshell"))) 45 | 46 | ;; When using containment it's OK to omit spurious keys, but you must get 47 | ;; the nesting right. 48 | (show (filter -cat- :contains (obj "Kansas City" '(2013)))) ; No 49 | (show (filter -cat- :contains (obj "trips" (obj "Kansas City" '(2013))))) ; Works 50 | (show (filter -cat- :contains (obj "trips" (obj "Barcelona" '(2012 2009))))) ; Works! 51 | ) 52 | -------------------------------------------------------------------------------- /t/base.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json-test) 2 | 3 | (define-global-model pgj-test-model -model- (pgj-history-model)) 4 | (define-global-model pgj-cat -cat- (pgj-history-model)) 5 | 6 | (defparameter *updates* 12) 7 | (defparameter *workers* 4) 8 | (defparameter *process-results-timeout* 4) 9 | 10 | ;; Of course key violations are not really OK, but a few are expected 11 | ;; given the nature of some testing. 12 | (defparameter *ok-key-violations* 2) 13 | 14 | ;;;; Impl 15 | 16 | (defmacro flatten-errors (() &body body) 17 | `(handler-case (progn ,@body) 18 | (error (e) 19 | (values (format nil "Task error: ~A" e) t)))) 20 | 21 | (defmacro with-conn (() &body body) 22 | `(with-connected-thread () 23 | (flatten-errors () 24 | ,@body))) 25 | 26 | (defun maybe-drop (model) 27 | (when (backend-exists-p model) 28 | (handler-bind ((database-safety-net #'really-do-it)) 29 | (drop-backend model)))) 30 | 31 | (defun process-results (&optional (timeout *process-results-timeout*)) 32 | (let ((results '())) 33 | (loop (multiple-value-bind (result has-result-p) 34 | (flatten-errors () 35 | (try-receive-pgj-result :timeout timeout)) 36 | (unless has-result-p 37 | (return)) 38 | (push result results))) 39 | (nreverse results))) 40 | 41 | (defun insert-some-cats (&optional (number 40)) 42 | (with-conn () 43 | (with-model-transaction (some-cats) 44 | (dotimes (i number (tally -cat-)) 45 | (insert -cat- (obj "name" (format nil "name-~A" i) "coat" "scruffy")))))) 46 | 47 | (defun call-with-temp-model ()) 48 | 49 | (defmacro with-temp-model ((instance (&rest superclasses)) &body body) 50 | (let ((model-name (gensym "PGJ-TEMP-"))) 51 | `(let ((,instance (make-instance (defclass ,model-name (,@superclasses) ())))) 52 | (unwind-protect 53 | (progn 54 | (create-backend ,instance) 55 | ,@body) 56 | (maybe-drop ,instance) 57 | (setf (find-class ',model-name) nil))))) 58 | 59 | ;;;; Interface 60 | 61 | (defun setup () 62 | (assert *postmodern-connection*) 63 | (setf *pgj-kernel* (make-pgj-kernel *postmodern-connection* *workers*)) 64 | (ensure-top-level-connection) 65 | (ensure-backend -model-) 66 | (ensure-backend -cat-) 67 | (insert-some-cats)) 68 | 69 | (defun teardown () 70 | (with-conn () 71 | (handler-bind ((database-safety-net #'really-do-it)) 72 | (maybe-drop -model-) 73 | (maybe-drop -cat-))) 74 | (end-pgj-kernel)) 75 | 76 | (defun run-pgj-tests () 77 | (setup) 78 | (unwind-protect (run) 79 | (teardown))) 80 | -------------------------------------------------------------------------------- /examples/human-2.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pj-human) 2 | 3 | ;;;; This is the second part of the human JSON example. You need to 4 | ;;;; have setup your Postgres connection and run (create) and 5 | ;;;; (load-humans) from human-1.lisp before this will work. 6 | 7 | ;;;; Simply evaluate (query-test) 8 | 9 | ;;;; Gift model 10 | 11 | (defparameter *gift-types* '("Gold" "Book" "Patience" "Goat")) 12 | 13 | (defun random-gift-type () 14 | (elt *gift-types* (random (length *gift-types*)))) 15 | 16 | (defun distribute-gifts () 17 | (format t "~%Loading gifts...~%") 18 | (with-model-transaction () 19 | (dotimes (i (tally -human-) (tally -gift-)) 20 | (let ((human (random-human))) 21 | (let ((gift (obj "human-key" (gethash "key" human) 22 | "type" (random-gift-type) 23 | "quantity" (1+ (random 30))))) 24 | (insert -gift- gift)))))) 25 | 26 | ;;;; User defined S-SQL queries 27 | 28 | ;;; For when FILTER and the other interface functions demonstrated in 29 | ;;; human-1 are not sufficient. 30 | 31 | ;;; These queries must return a single JSON object per result row. 32 | ;;; Macroexpand the define-json-query forms and the individual j->, 33 | ;;; j->>, jbuild and to-jsonb forms to see the generated S-SQL. See 34 | ;;; also the User Guide on "User defined queries" and "JSON query 35 | ;;; syntactic sugar" for details on these queries. 36 | 37 | (define-json-query rich-humans$ (min-balance gender) 38 | (:order-by 39 | (:select (jbuild ("key" "guid" "gender" "name" "balance")) 40 | :from 'human 41 | :where (:and (:>= (:type (j->> "balance") real) min-balance) 42 | (:= (j->> "gender") gender))) 43 | (:type (j->> "balance") real))) 44 | 45 | (define-json-query one-friend-humans$ ((*to-json* filter) email-regex) 46 | (:select 'jdoc 47 | :from 'human 48 | :where (:and (:or (:@> 'jdoc filter)) 49 | (:= (:jsonb-array-length (j-> "friends")) 1) 50 | (:~ (j->> "email") email-regex)))) 51 | 52 | (define-json-query uncharitable-humans$ () 53 | (:select (jbuild (human "name") (gift "type" "quantity")) 54 | :from 'human 55 | :inner-join 'gift 56 | :on (:= (j-> human "key") (j-> gift "human-key")) 57 | :where (:= (j-> gift "quantity") (to-jsonb 1)))) 58 | 59 | ;;;; Interface 60 | 61 | (defun query-test () 62 | (with-pj-connection () 63 | (show (rich-humans$ 3900 "male")) 64 | 65 | (show (one-friend-humans$ (obj "gender" "female") "^c")) 66 | 67 | (when (zerop (tally -gift-)) 68 | (distribute-gifts)) 69 | 70 | (show (uncharitable-humans$))) 71 | 72 | (values)) 73 | -------------------------------------------------------------------------------- /model/types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Types 2 | 3 | ;;; There are no slots by design, the focus is on types not state. 4 | ;;; Because there are no slots, one instance is identical to another 5 | ;;; so we can use a single global instance if desired --- see 6 | ;;; DEFINE-GLOBAL-MODEL. 7 | 8 | ;;; There's a danger of combinatorial explosion below but it seems a 9 | ;;; good idea to use types to signify intent where possible. See, for 10 | ;;; example, HAVING-PROPERTY and ENUMERATE-PROPERTY. Only types 11 | ;;; currently in use are documented. 12 | 13 | ;;; Clients will typically subclass either PGJ-OBJECT-MODEL or 14 | ;;; PGJ-HISTORY-OBJECT-MODEL and store JSON objects in their models. 15 | ;;; However most interface methods are specialized only on the base 16 | ;;; class PGJ-MODEL so it's also simple to store JSON numbers, strings 17 | ;;; or arrays in a model. 18 | 19 | (in-package :postgres-json) 20 | 21 | ;;;; JSON document types 22 | 23 | ;; The nouns in the doc strings below such as array, object, 24 | ;; structure, number and string are used in their JSON sense. 25 | (defclass json-document () () 26 | (:documentation "Base class for types of JSON documents.")) 27 | 28 | (defclass scalar-jdoc (json-document) ()) 29 | (defclass string-jdoc (scalar-jdoc) ()) 30 | (defclass number-jdoc (scalar-jdoc) ()) 31 | (defclass structure-jdoc (json-document) ()) 32 | (defclass object-jdoc (structure-jdoc) ()) 33 | (defclass array-jdoc (structure-jdoc) ()) 34 | 35 | ;;;; Postgres-JSON model types 36 | 37 | (defclass pgj-model () () 38 | (:documentation "The Postgres-JSON model base class supported by 39 | implementation and interface methods for storing, querying and 40 | modifying JSON documents in a Postgres database.")) 41 | 42 | (defclass pgj-structure-model (pgj-model structure-jdoc) () 43 | (:documentation "A Postgres-JSON model that consists of JSON 44 | documents having either an object or array root node.")) 45 | 46 | (defclass pgj-object-model (pgj-structure-model) () 47 | (:documentation "A Postgres-JSON model that consists of JSON 48 | documents having an object root node.")) 49 | 50 | (defclass pgj-array-model (pgj-structure-model) ()) 51 | 52 | ;;;; Postgres-JSON model history types 53 | 54 | (defclass pgj-history-model (pgj-model) () 55 | (:documentation "A Postgres-JSON model that maintains a history of 56 | previous values of updated or deleted documents.")) 57 | 58 | (defclass pgj-history-structure-model (pgj-history-model pgj-structure-model) ()) 59 | 60 | (defclass pgj-history-object-model (pgj-history-model pgj-object-model) () 61 | (:documentation "A Postgres-JSON model that maintains history and 62 | consists of JSON documents having an object root node.")) 63 | 64 | (defclass pgj-history-array-model (pgj-history-model pgj-array-model) ()) 65 | -------------------------------------------------------------------------------- /examples/human-1.lisp: -------------------------------------------------------------------------------- 1 | (in-package :pj-human) 2 | 3 | ;;; Set this if you have not already done so: 4 | ;;; (setf *postmodern-connection* '("mydb" "myusername" "" "localhost")) 5 | 6 | ;;; Then do (setup), (load-humans) and (model-test) 7 | 8 | ;;; Examples of user defined queries are in human-2.lisp, you might 9 | ;;; want to try them before running the cleanup or drop forms. 10 | 11 | (defparameter *human-url* "http://gtod.github.io/human.json") 12 | (defparameter *human-file* "/tmp/postgres-json-human.json") 13 | 14 | (define-global-model human -human- (pgj-history-object-model)) 15 | (define-global-model gift -gift- (pgj-object-model)) 16 | 17 | ;;;; Backend interface 18 | 19 | (defun setup () 20 | (with-pj-connection () 21 | (ensure-backend -human-) 22 | (ensure-backend -gift-))) 23 | 24 | (defun cleanup () 25 | (with-pj-connection() 26 | (excise-all -human-) 27 | (excise-all -gift-))) 28 | 29 | (defun drop () 30 | (with-pj-connection () 31 | (drop-backend -human-) 32 | (drop-backend -gift-))) 33 | 34 | ;;;; Human model 35 | 36 | (defun random-human () 37 | (let ((tally (tally -human-))) 38 | (assert (not (zerop tally))) 39 | (fetch -human- (elt (keys -human-) (random tally))))) 40 | 41 | (defun load-humans () 42 | (unless (probe-file *human-file*) 43 | (write-line "Fetching humans...") 44 | (ql-http:fetch *human-url* *human-file*)) 45 | 46 | (with-input-from-file (stream *human-file*) 47 | (with-pj-connection () 48 | (with-model-transaction () 49 | (write-line "Loading humans...") 50 | (loop for human across (yason:parse stream :json-arrays-as-vectors t) 51 | do (insert -human- human) 52 | finally (return (tally -human-))))))) 53 | 54 | ;;;; Interface 55 | 56 | (defun model-test () 57 | (with-pj-connection () 58 | (show (length (filter -human- :contains (obj "gender" "female")))) 59 | 60 | (show (gethash "name" (random-human))) 61 | 62 | (let ((human (show (first (filter -human- :contains (obj "name" "Marcella Marquez")))))) 63 | (with-keys ((key "key") (friends "friends")) human 64 | ;; This is naughty because it requires knowing yason vectors are adjustable. 65 | ;; But specialize DESERIALIZE on your model and do what you like... 66 | (vector-push-extend (obj "name" "Horace Morris" "id" (length friends)) friends) 67 | (show (supersede -human- key human)) 68 | (show (gethash "friends" (fetch -human- key))) 69 | (show (history -human- key)))) 70 | 71 | (show (filter -human- :contains (obj "tags" '("ut" "labore")) :properties '("age" "tags"))) 72 | (show (length (filter -human- :contains (obj "isActive" t "age" 21)))) 73 | 74 | (show (length (having-property -human- "eyeColor"))) 75 | (show (enumerate-property -human- "favoriteFruit"))) 76 | (values)) 77 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :postgres-json 2 | (:use #:cl #:alexandria #:postmodern #:s-sql #:global-vars) 3 | 4 | ;; Connections 5 | (:export 6 | #:*postmodern-connection* 7 | #:ensure-top-level-connection) 8 | 9 | ;; Model types 10 | (:export 11 | #:pgj-model 12 | #:pgj-history-model 13 | #:pgj-object-model 14 | #:pgj-history-object-model) 15 | 16 | ;; Basic model management 17 | (:export 18 | #:define-global-model 19 | #:ensure-backend 20 | #:drop-backend) 21 | 22 | ;; Model CRUD generic functions 23 | (:export 24 | #:insert 25 | #:supersede 26 | #:fetch 27 | #:fetch-all 28 | #:excise 29 | #:excise-all 30 | #:keys 31 | #:tally 32 | #:having-property 33 | #:enumerate-property 34 | #:filter 35 | #:history) 36 | 37 | ;; Model transactions 38 | (:export 39 | #:with-model-transaction 40 | #:rollback 41 | #:commit 42 | #:*serialization-failure-sleep-times*) 43 | 44 | ;; JSON helper functions and specials 45 | (:export 46 | #:obj 47 | #:pp-json 48 | #:*to-json* 49 | #:*from-json*) 50 | 51 | ;; User queries and JSON syntactic sugar for S-SQL 52 | (:export 53 | #:define-json-query 54 | #:jdoc 55 | #:j-> 56 | #:j->> 57 | #:to-jsonb 58 | #:jbuild) 59 | 60 | ;; Model customization generic functions 61 | (:export 62 | #:model-sequence 63 | #:model-key-name 64 | #:model-key-type 65 | #:model-initial-gin-operator-class 66 | #:serialize 67 | #:deserialize 68 | #:stash) 69 | 70 | ;; Further model management 71 | (:export 72 | #:create-backend 73 | #:backend-exists-p 74 | #:database-safety-net 75 | #:really-do-it 76 | #:*gin-operator-classes* 77 | #:use-gin-index) 78 | 79 | ;; Postgres backend 80 | (:export 81 | #:*pgj-schema* 82 | #:drop-pgj-schema 83 | #:*default-search-path* 84 | #:alter-role-set-search-path 85 | #:create-db-sequence 86 | #:flush-prepared-queries) 87 | 88 | ;; Postmodern isolation level transactions 89 | (:export 90 | #:*pgj-default-isolation-level* 91 | #:incompatible-transaction-setting 92 | 93 | #:+serializable-rw+ 94 | #:+repeatable-read-rw+ 95 | #:+read-committed-rw+ 96 | #:+read-committed-ro+ 97 | 98 | #:with-transaction-level 99 | #:with-logical-transaction-level 100 | #:ensure-transaction-level) 101 | 102 | ;; lparallel support (optional) 103 | (:export 104 | #:*pgj-kernel* 105 | #:*pgj-database* 106 | #:make-pgj-kernel 107 | #:end-pgj-kernel 108 | 109 | #:call-with-connected-thread 110 | #:with-connected-thread 111 | 112 | #:*pgj-channel* 113 | #:make-pgj-channel 114 | 115 | #:submit-pgj-function 116 | #:submit-pgj-task 117 | #:receive-pgj-result 118 | #:try-receive-pgj-result) 119 | 120 | (:documentation "Postgres-JSON is a JSON document store for Common 121 | Lisp using PostgreSQL")) 122 | -------------------------------------------------------------------------------- /examples/customize.lisp: -------------------------------------------------------------------------------- 1 | ;;; Evaluate something like the following before proceeding: 2 | ;;; (setf *postmodern-connection* '("mydb" "myname" "" "localhost")) 3 | 4 | ;;; Now evaluate (setup), (insert-some-ungulates), 5 | ;;; (insert-invalid-sheep), (fetch-sheep), (pp-json *) 6 | 7 | ;;; Maybe quickload JSOWN, recompile and call (fetch-sheep) again... 8 | 9 | ;;; Maybe call (insert-some-ungulates) again to see the sheep primary 10 | ;;; key errors. 11 | 12 | ;;; (change-sheep-index) merely demonstrates syntax for selecting 13 | ;;; model GIN indexes at run time. 14 | 15 | (defpackage :customize 16 | (:use :cl :postgres-json)) 17 | 18 | (in-package :customize) 19 | 20 | ;;; 1. Give model its own sequence, see SETUP below 21 | ;;; where we make the sequence 22 | (define-global-model goat -goat- (pgj-object-model)) 23 | 24 | (defmethod model-sequence ((model goat)) 25 | 'goat-seq) 26 | 27 | ;;; 2. Give model a different key type 28 | ;;; Presently this means you need to explicitly supply the key with 29 | ;;; each insert --- see below. 30 | (define-global-model sheep -sheep- (pgj-object-model)) 31 | 32 | (defmethod model-key-type ((model sheep)) 33 | 'text) 34 | 35 | ;;; 3. Rudimentary validation 36 | (defmethod serialize :before ((model sheep) (object hash-table)) 37 | (assert (nth-value 1 (gethash "name" object)))) 38 | 39 | ;;; 4. Customize deserialization 40 | ;;; Do (ql:quickload :jsown) and recompile this file to test. 41 | ;;; In fact, you can also just bind or set *from-json* to achieve 42 | ;;; the same end, but not easily on a per model basis... 43 | (eval-when (:compile-toplevel :load-toplevel :execute) 44 | (when (asdf:system-registered-p :jsown) 45 | (pushnew :jsown *features*))) 46 | 47 | #+jsown 48 | (defmethod deserialize ((model sheep) jdoc) 49 | (log:info "Deserializing sheep using JSOWN") 50 | (jsown:parse jdoc)) 51 | 52 | (defun setup () 53 | (ensure-top-level-connection) 54 | (unless (pomo:sequence-exists-p 'goat-seq) 55 | (create-db-sequence 'goat-seq)) 56 | (ensure-backend -goat-) 57 | (ensure-backend -sheep-)) 58 | 59 | (defun insert-some-ungulates () 60 | (insert -goat- (obj "name" "Billy" "coat" "white")) 61 | (insert -goat- (obj "name" "Grumpy" "coat" "black")) 62 | 63 | (format t "Goat keys: ~A~%" (keys -goat-)) 64 | 65 | (insert -sheep- (obj "name" "Shaun" "coat" "white") "shaun") 66 | (insert -sheep- (obj "name" "Harold" "coat" "white") "harold") 67 | 68 | (format t "Sheep keys: ~A~%" (keys -sheep-))) 69 | 70 | (defun insert-invalid-sheep () 71 | (insert -sheep- (obj "nickname" "Boris" "coat" "brown") "boris")) 72 | 73 | ;; If JSOWN is not loaded Yason will return a list of hash tables so 74 | ;; then just do (pp-json *). For JSOWN, you are on your own. 75 | (defun fetch-sheep () 76 | (fetch-all -sheep-)) 77 | 78 | (defun change-sheep-index () 79 | ;; Faster but does not support Postgres ? operator, used by 80 | ;; HAVING-PROPERTY for example 81 | (use-gin-index -sheep- :jsonb-path-ops) 82 | 83 | ;; The default 84 | (use-gin-index -sheep- :jsonb-ops)) 85 | 86 | ;;;; Cleanup 87 | 88 | (defun cleanup () 89 | (excise-all -goat-) 90 | (excise-all -sheep-)) 91 | 92 | (defun drop () 93 | (drop-backend -goat-) 94 | (drop-backend -sheep-)) 95 | -------------------------------------------------------------------------------- /model/transactions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | ;;;; Postgres-JSON internal and user transaction handling 4 | ;;;; Depends on postgres/transactions.lisp 5 | 6 | ;;; Guidelines for transaction handling of the mode interface 7 | ;;; functions gleaned from the Postgres 9.4 doco: 8 | 9 | ;;; 'read committed' is the Postgres default isolation level but is 10 | ;;; set explicitly by model functions for clarity. 11 | 12 | ;;; We set 'read only' on transactions where possible. 13 | 14 | ;;; The model interface functions use: 1) select by key, 2) insert 15 | ;;; into -old, 3) update or delete for their update and excise 16 | ;;; operations. AFAIK using the repeatable read isolation level 17 | ;;; (rather than serializable) should suffice. Certainly read 18 | ;;; committed is insufficent due to the multiple steps required for 19 | ;;; maintaining history rows. 20 | 21 | (defun call-with-maybe-transaction (label isolation-level thunk) 22 | (if *top-isolation-level* 23 | (call-with-ensured-transaction-level label isolation-level thunk) 24 | (if (potential-serialization-failure-p isolation-level) 25 | (call-with-retry-serialization-failure 26 | label 27 | (lambda () 28 | (call-with-transaction-level label isolation-level thunk))) 29 | (call-with-transaction-level label isolation-level thunk)))) 30 | 31 | (defun call-with-model-transaction (label isolation-level thunk) 32 | (if *top-isolation-level* 33 | (call-with-logical-transaction-level label isolation-level thunk) 34 | (call-with-retry-serialization-failure 35 | label 36 | (lambda () 37 | (call-with-transaction-level label isolation-level thunk))))) 38 | 39 | ;;;; Postrgre-JSON model interface function use 40 | 41 | (defmacro maybe-transaction ((name isolation-level) &body body) 42 | "Just a wrapper around an ensured transaction using ISOLATION-LEVEL 43 | and with retry for serialization failures. NAME is used only for 44 | logging." 45 | `(call-with-maybe-transaction ',name ',isolation-level 46 | ,(transaction-thunk name body))) 47 | 48 | ;;;; Public 49 | 50 | (defmacro with-model-transaction ((&optional name) &body body) 51 | "Evaluate BODY inside a Postgres transaction using the 'repeatable 52 | read' isolation level in read/write mode. Retry any serialization 53 | failures although chronic incidence will still result in the client 54 | seeing CL-POSTGRES-ERROR:SERIALIZATION-FAILURE conditions --- see also 55 | *SERIALIZATION-FAILURE-SLEEP-TIMES*. Implemented using Postmodern 56 | WITH-LOGICAL-TRANSACTION so may be nested. NAME can be used with 57 | Postmodern's abort-transaction and commit-transaction. NAME should not 58 | be a Postgres reserved word. Ideal for any group of mutating model 59 | interface functions." 60 | (let ((name (or name (gensym "TRAN")))) 61 | `(call-with-model-transaction ',name ',*pgj-default-isolation-level* 62 | ,(transaction-thunk name body)))) 63 | 64 | (defun rollback (name) 65 | "If this is the root node of a nested set of WITH-MODEL-TRANSACTIONs 66 | then 'rollback' the transaction NAME. Otherwise rollback to the 67 | Postgres savepoint NAME." 68 | (pomo:abort-logical-transaction name)) 69 | 70 | (defun commit (name) 71 | "If this is the root node of a nested set of WITH-MODEL-TRANSACTIONs 72 | then 'commit' the transaction NAME. Otherwise merely release the 73 | savepoint NAME." 74 | (pomo:commit-logical-transaction name)) 75 | -------------------------------------------------------------------------------- /interface.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | ;;;; Implementation 4 | 5 | (defun create-pgj-schema () 6 | "Create the schema *PGJ-SCHEMA* and other backend objects needed to 7 | house user created PostgreSQL JSON persistence models. Call just once 8 | in a given PostgreSQL database." 9 | (maybe-transaction (create-backend +read-committed-rw+) 10 | (pomo:create-schema *pgj-schema*) 11 | (create-db-sequence *pgj-sequence* *pgj-schema*) 12 | *pgj-schema*)) 13 | 14 | (defun pgj-schema-exists-p () 15 | "Does the backend *PGJ-SCHEMA* exist?" 16 | (pomo:schema-exist-p *pgj-schema*)) 17 | 18 | (defun ensure-pgj-schema () 19 | "Call CREATE-PGJ-SCHEMA unless the Postgres *PGJ-SCHEMA* already exists." 20 | (unless (pgj-schema-exists-p) 21 | (create-pgj-schema))) 22 | 23 | ;;;; Interface 24 | 25 | (defvar *postmodern-connection* nil 26 | "Set this to a list congruent with the parameters expected by 27 | POSTMODERN:CONNECT-TOPLEVEL, for use by the testing and example 28 | code.") 29 | 30 | (defun ensure-top-level-connection (&optional (connect-spec *postmodern-connection*)) 31 | "Ensure a Postmodern top level connection is active by applying the 32 | contents of the list CONNECT-SPEC to POMO:CONNECT-TOPLEVEL." 33 | (unless connect-spec 34 | (error "Try setting POSTGRES-JSON:*POSTMODERN-CONNECTION* to a 35 | list congruent with the parameters expected by POSTMODERN:CONNECT-TOPLEVEL. 36 | For example: '\(\"mydb\", \"myusername\", \"\", \"localhost\"\). 37 | This connection list is used by the example and testing code.")) 38 | (unless (and pomo:*database* (pomo:connected-p pomo:*database*)) 39 | (apply #'pomo:connect-toplevel connect-spec))) 40 | 41 | (defun drop-pgj-schema () 42 | "Drop the entire Postgres schema *PGJ-SCHEMA* in the database 43 | Postmodern is currently connected to. This will irrevocably delete 44 | ALL your data in ALL your models so it uses a RESTART-CASE to guard 45 | against human error." 46 | (flet ((drop () 47 | (maybe-transaction (drop-backend +read-committed-rw+) 48 | (drop-db-schema-cascade *pgj-schema*)))) 49 | (when (pgj-schema-exists-p) 50 | (let ((attempted-to (format nil "DROP all models' data(!) in schema: ~A" *pgj-schema*))) 51 | (restart-case (error 'database-safety-net 52 | :attempted-to attempted-to 53 | :suggestion "Pick an appropriate restart") 54 | (cancel () :report "Leave this schema alone." (return-from drop-pgj-schema nil)) 55 | (really-do-it () :report "I really want to drop ALL data in ALL models(!)" (drop))))))) 56 | 57 | ;; I _hate_ this search_path nonsense and have largely avoided it by 58 | ;; using fully qualified relation names. But DEFINE-MODEL-QUERY 59 | ;; presents a challege I have not yet surmounted (we want to write 60 | ;; 'cat not 'pgj_model.cat). In the mean time we have this... If 61 | ;; you don't know anything about search paths this should do the job, 62 | ;; and if you do you can look after yourself. 63 | (defvar *default-search-path* (format nil "~A,public" (to-sql-name *pgj-schema*)) 64 | "The default value used by ALTER-ROLE-SET-SEARCH-PATH.") 65 | 66 | (defun alter-role-set-search-path (user &optional (search-path *default-search-path*)) 67 | "Alter the role of Postgres user USER, a string, to set the 68 | 'search_path' setting to the string SEARCH-PATH. In most cases this 69 | is what you want so than when defining your own queries with 70 | DEFINE-MODEL-QUERY unqualified relation names can be found in our 71 | default schema (which is not the PUBLIC schema). This setting does 72 | _not_ effect the normal model interface functions such as FETCH and 73 | FILTER as they use fully qualified table names at all times. Will 74 | only take effect upon your next connection. Beware, may be overridden 75 | by settings in your ~/.psqlrc file. See also the Postgres 76 | documentation on search paths and settings." 77 | (query (format nil "ALTER ROLE ~A SET search_path TO ~A" user search-path))) 78 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | TODO 2 | ==== 3 | 4 | ## Interface 5 | 6 | * Timestamps in a JSON document: Either in the document or do we add 7 | extra columns to the model table? First see just how far we can get 8 | with columns in the JSON doc... But then they have to be just an 9 | integer... Sure, but you can sort by them and local-time can 10 | reconstitute them... 11 | 12 | ## Want to have 13 | 14 | * Allow raw importing of JSON, without the serialization step. 15 | 16 | * unique ids from UUID example 17 | 18 | * Make using Fkeys between tables easy... "Promote" to Fkey as you 19 | can't do in JSON... We could promote to foreign key: What key and 20 | Postgres type in your child model? What master table? We make a 21 | column, populate it, add the index For every insert, we grab that 22 | named key and stuff it into the FKey col Something similar for 23 | timestamps? 24 | 25 | * Unicode handling tests. UTF-8, 16? For web deployment investigate 26 | quri. 27 | 28 | * More extensive test suite. 29 | 30 | * Revise, cull, doco once again. Provide more motivating examples. 31 | 32 | ## Maybe have 33 | 34 | * Define a schema for your model, get automatic validation either on 35 | client or server side. Can do server side with PLV8 or whatever... 36 | 37 | * Investigate new lateral type in Postgres. 38 | https://news.ycombinator.com/item?id=8689159 and 39 | http://www.postgresql.org/docs/9.4/static/queries-table-expressions.html#QUERIES-LATERAL 40 | 41 | * Investigate making all integer keys bigints. Seems like a premature 42 | optimization not too. How hard would a manual migration be for the 43 | user? Presumably no problem in lisp, but would have to alter table 44 | the various model tables, and sequences (indexes? meta model?) 45 | 46 | * How practical would it be to serialize FSET collections to JSON? 47 | Why would you do that? 48 | 49 | ## Nice to have 50 | 51 | * Push changes to S-SQL and Postmodern (see postgres dir) upstream. 52 | 53 | * Compound primary keys shouldn't be too hard. We make it either an 54 | ordered list or a map. And stashing the key in your JSON obj would 55 | be the same. 56 | 57 | * There are some fascinating Postgres functions for the jsonb type: 58 | `select distinct jsonb_object_keys(jdoc) from cat;`. What use 59 | might we put them to? 60 | 61 | ## Postmodern/Postgres maybe have 62 | 63 | ### Server side JSON support 64 | 65 | You could send a list of key/value pairs and do the JSON serialization 66 | on the server: `json_object_agg`. Server side update support. 67 | 68 | PLV8. 69 | 70 | ### Prepared queries data types 71 | 72 | Would be nice to cast `min-balance` to Postgres `jsonb` here (instead 73 | of converting every balance to text and then to real) but Postmodern 74 | prepared queries do not support types, so when we do `(to-json 75 | min-balance)` the parser doesn't know what type min-balance is... 76 | 77 | ```common-lisp 78 | (define-json-query rich-humans$ (min-balance gender) 79 | (:order-by 80 | (:select (jbuild ("key" "guid" "gender" "name" "balance")) 81 | :from 'human 82 | :where (:and (:>= (:type (j->> "balance") real) min-balance) 83 | (:= (j->> "gender") gender))) 84 | (:type (j->> "balance") real))) 85 | ``` 86 | 87 | ### Batched Postgres row fetching 88 | 89 | The postmodern layer of query and prepare over cl-postgres is pretty 90 | straightforward if we need to dig down just one layer. 91 | 92 | Looks like cl-postgres is *not* using named portals (but is using 93 | named prepared statements). How does this affect performance? See: 94 | http://www.postgresql.org/docs/9.4/static/protocol-overview.html#PROTOCOL-QUERY-CONCEPTS 95 | specifically paragraph 3. Can we/need we specialize 96 | simple-execute-message to only **retrieve batches of rows at a time**? 97 | 98 | Named portal optimized for multiple uses... But it only lives inside the 99 | transaction. Would it make sense to have a 1-1 prepared stmt:named portal 100 | map? Ahh, a portal is a cursor, see 101 | http://www.postgresql.org/docs/9.4/static/plpgsql-cursors.html 102 | We could have a with-cursor(name) form and let the user 103 | do what they like with the rows. All this inside a single RO 104 | tran? http://www.pgcon.org/2014/schedule/attachments/330_postgres-for-the-wire.pdf 105 | 106 | ### Connection handling 107 | 108 | Why did we see 50 open clients after running just 30 threads 109 | (admittedly several times). Was this a Lisp impl. thing? 110 | -------------------------------------------------------------------------------- /doc/beginners.md: -------------------------------------------------------------------------------- 1 | Using JSON with Common Lisp for beginners 2 | ========================================= 3 | 4 | JSON is a [lightweight data-interchange format](http://www.json.org) 5 | which amounts to a text representation of *objects*, *arrays*, 6 | *strings* and *numbers*. **JSON is just text**: it's a text 7 | blueprint for constructing the preceeding list of data 8 | structures/types in any given programming language. 9 | http://www.json.org is an excellent summary. 10 | 11 | There are several JSON libraries for Common Lisp and they make 12 | different choices about how to parse a given JSON text 13 | into [Common Lisp objects](http://www.lispworks.com/documentation/lw50/CLHS/Body/26_glo_o.htm). 14 | 15 | For example, a *JSON object* (**not** to be confused with the much 16 | more general notion of Common Lisp *object* just mentioned) "is an 17 | unordered set of name/value pairs", like this: 18 | 19 | ```json 20 | { "name": "Milo", "age": 21, "likes": "snow" } 21 | ``` 22 | 23 | In Common Lisp we could represent this many ways, a few of which 24 | follow. (We assume `stream` is an open stream to a file which 25 | contains the above JSON): 26 | 27 | ```common-lisp 28 | (yason:parse stream :object-as :alist) 29 | (("name" . "Milo") ("age" . 21) ("likes" . "snow")) 30 | 31 | (yason:parse stream :object-as :plist) 32 | ("name" "Milo" "age" 21 "likes" "snow") 33 | 34 | (yason:parse stream :object-as :hash-table) 35 | # 36 | ``` 37 | 38 | where the last one is unreadble because a Common Lisp hash 39 | table has no literal representation. The point is that a *JSON 40 | object* is just Unicode text in some file, and choices have to be 41 | made about how to represent that as a Common Lisp *object*. 42 | 43 | Something similar happens with the JSON *array*, and the special 44 | values `true`, `false` and `null`: 45 | 46 | ```json 47 | [ 28.8, 14, "Fred", true, false, null ] 48 | ``` 49 | 50 | ```common-lisp 51 | (yason:parse stream) 52 | (28.8 14 "Fred" T NIL NIL) 53 | 54 | (yason:parse stream :json-arrays-as-vectors t) 55 | #(28.8 14 "Fred" T NIL NIL) 56 | 57 | (yason:parse stream :json-booleans-as-symbols t :json-nulls-as-keyword t) 58 | (28.8 14 "Fred" YASON:TRUE YASON:FALSE :NULL) 59 | ``` 60 | 61 | Postgres-JSON is agnostic about your choice of JSON library because it 62 | is JSON strings that go into the Postgres backend, and JSON strings 63 | that come out. 64 | 65 | How your lisp objects are converted (or "serialized") into JSON 66 | strings (often called *to-json*) and how those JSON strings are then 67 | parsed or "deserialized" (*from-json*) back into Common Lisp objects 68 | is the job of your fine JSON library. 69 | 70 | It should now be clear that a more esoteric Common Lisp object such as 71 | a symbol, a function or a CLOS object can't be directly serialized to 72 | JSON. It would first need to be shoehorned into an *object* or 73 | *array* or *string* or *number* or `true` or `false` or `null` (that's 74 | the entire list of possibilities, JSON is simple). 75 | 76 | I tend to use Common Lisp hash tables for JSON objects and Common Lisp 77 | vectors for JSON arrays. The unreadability of the Common Lisp hash 78 | table is easily fixed in the special case *where it only contains 79 | strings, numbers, NIL and (nested as deep as you like) vectors, lists 80 | and hash tables* because those Common Lisp objects have a JSON 81 | representation (at least according to 82 | [YASON](http://common-lisp.net/project/yason/)): 83 | 84 | ```common-lisp 85 | (defun pp-json (object &key (stream *standard-output*) (indent 4)) 86 | "Pretty print lisp OBJECT as JSON to STREAM with specified INDENT." 87 | (fresh-line stream) 88 | (let ((s (yason:make-json-output-stream stream :indent indent))) 89 | (yason:encode object s))) 90 | ``` 91 | 92 | and now 93 | 94 | ```common-lisp 95 | (pp-json (yason:parse stream :object-as :hash-table)) 96 | { 97 | "name":"Milo", 98 | "likes":"snow", 99 | "age":21 100 | } 101 | ``` 102 | 103 | When you run `pp-json` you are asking Yason to turn your Common Lisp 104 | object (here a hash table) into **JSON text**. It does this and sends 105 | it to standard output. The function in `*to-json*` defined as part of 106 | Postgres-JSON does something similar (automatically) on your behalf 107 | when you evaluate 108 | 109 | ```common-lisp 110 | (insert 'cat (obj "name" "Milo" "likes" "snow" "age" 21)) 111 | ``` 112 | 113 | You should now be asking what `obj` does. It's a trivial function 114 | that turns a list of pairs into a Common Lisp hash table. Since the 115 | JSON spec requires that the key (we call them *properties*) of a *JSON 116 | object* must be a *JSON string* you must use Common Lisp strings as 117 | the even numbered arguments to `obj`. 118 | -------------------------------------------------------------------------------- /model/query.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | ;;;; Postmodern queries proper and support 4 | 5 | (defun query-key (model-name operation) 6 | "Return a string: *PGJ-SCHEMA*:MODEL-NAME:OPERATION to key a prepared 7 | query. An 'operation' is the name of a DB query, for example FETCH$." 8 | (format nil "~A:~A:~A" 9 | (symbol-name *pgj-schema*) 10 | model-name 11 | (symbol-name operation))) 12 | 13 | (defun lookup-query (model-name operation) 14 | "Return the prepared query for the triple *PGJ-SCHEMA*, 15 | MODEL, OPERATION." 16 | (gethash (query-key model-name operation) *query-functions*)) 17 | 18 | (defun set-lookup-query (model-name operation query) 19 | "Set the prepared query for the triple *PGJ-SCHEMA*, 20 | MODEL, OPERATION." 21 | (setf (gethash (query-key model-name operation) *query-functions*) 22 | query)) 23 | 24 | (defsetf lookup-query set-lookup-query) 25 | 26 | ;;;; Our queries are made on demand for a schema/model/query-name 27 | ;;;; combination. This is the factory for creating such queries. The 28 | ;;;; convention is to suffix queries proper (aka 'operations') with 29 | ;;;; #\$. 30 | 31 | (defmacro make-query (name (&rest query-args) (&rest model-params) 32 | (query-form &optional (format :rows))) 33 | "Defun a function called NAME, a symbol, accepting an instance of 34 | PGJ-MODEL as the first argument followed by zero or more symbols, 35 | QUERY-ARGS, which become the numbered parameters supplied to a 36 | Postmodern query when NAME is called. MODEL-PARAMS may be a list of 37 | symbols which will be bound when making the query to the result of 38 | calling model- on MODEL, the first argument to the function. 39 | QUERY-FORM is a quoted backquoted S-SQL query form optionally containing 40 | evaluated expressions including the bound values. FORMAT must be a 41 | valid Postmodern results format." 42 | `(defun ,name (model ,@query-args) 43 | (let ((model-name (model-name model))) 44 | (symbol-macrolet ((query (lookup-query model-name ',name))) 45 | (unless query 46 | (let ,(loop for param in model-params 47 | collect (list param `(,(sym-suffix 'model param) model))) 48 | (setf query (prepare (sql-compile ,@(cdr query-form)) ,format)))) 49 | (funcall query ,@query-args))))) 50 | 51 | ;;;; Queries proper to implement model interface functions 52 | 53 | ;;; Base queries 54 | 55 | (make-query nextval-sequence$ () (sequence) 56 | ('`(:select (:nextval ,(qualified-name-string sequence))) :single!)) 57 | 58 | (make-query insert$ (key jdoc) (table key-name) 59 | ('`(:insert-into ,table :set ',key-name '$1 'jdoc '$2 60 | :returning ',key-name) 61 | :single!)) 62 | 63 | (make-query supersede$ (key jdoc) (table key-name) 64 | ('`(:update ,table 65 | :set 'jdoc '$2 'valid-from (:clock-timestamp) 66 | :where (:= ',key-name '$1) 67 | :returning ',key-name) 68 | :single)) 69 | 70 | (make-query fetch$ (key) (table key-name) 71 | ('`(:select 'jdoc :from ,table :where (:= ',key-name '$1)) 72 | :single)) 73 | 74 | (make-query fetch-all$ () (table) 75 | ('`(:select 'jdoc :from ,table) 76 | :column)) 77 | 78 | (make-query excise$ (key) (table key-name) 79 | ('`(:delete-from ,table :where (:= ',key-name '$1) :returning ',key-name) 80 | :single)) 81 | 82 | (make-query excise-all$ () (table) 83 | ('`(:delete-from ,table) 84 | :single)) 85 | 86 | (make-query keys$ () (table key-name) 87 | ('`(:select ',key-name :from ,table) 88 | :column)) 89 | 90 | (make-query tally$ () (table) 91 | ('`(:select (:count '*) :from ,table) 92 | :single!)) 93 | 94 | (make-query exists$ (json) (table) 95 | ('`( :select 'jdoc 96 | :from ,table 97 | :where (:? 'jdoc '$1)) 98 | :column)) 99 | 100 | ;;; History queries 101 | 102 | (make-query insert-old$ (key) (table old-table key-name) 103 | ('`(:insert-into ,old-table 104 | ;; Note the dependence on the column ordering of 105 | ;; CREATE-OLD-TABLE since :insert-into will not let 106 | ;; me explicitly specify column names... 107 | (:select ',key-name 108 | (:clock-timestamp) 109 | 'valid-from 110 | 'jdoc 111 | :from ,table 112 | :where (:= ',key-name '$1))))) 113 | 114 | (make-query history$ (key) (old-table key-name) 115 | ('`(:order-by 116 | (:select 'jdoc 'valid-from 'valid-to 117 | :from ,old-table 118 | :where (:= ',key-name '$1)) 119 | 'valid-to) 120 | :rows)) 121 | -------------------------------------------------------------------------------- /parallel.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | (defvar *pgj-database* nil 4 | "Thread local Postmodern database connection.") 5 | 6 | (defun set-default-search-path () 7 | (let ((pomo:*database* *pgj-database*)) 8 | (pomo:set-search-path *default-search-path*))) 9 | 10 | (defun ensure-connected () 11 | (unless (pomo:connected-p *pgj-database*) 12 | (log:trace "Reconnecting...") 13 | (pomo:reconnect *pgj-database*) 14 | (set-default-search-path))) 15 | 16 | (defun worker-context (worker-loop) 17 | (set-default-search-path) 18 | (funcall worker-loop) 19 | (pomo:disconnect *pgj-database*)) 20 | 21 | ;;; The only mutable global state we keep in the running image is the 22 | ;;; cache of *query-functions*. So these need to become thread local. 23 | 24 | ;;; The neatest solution is to ensure that worker thread : postmodern 25 | ;;; connection is 1 : 1, so that's what we do. Consider pgpool II for 26 | ;;; more sophisticated needs. 27 | 28 | (defun worker-bindings (connect-spec) 29 | `((*standard-output* . ,*standard-output*) 30 | (*error-output* . ,*error-output*) 31 | (*pgj-database* . (apply #'pomo:connect ',connect-spec)) 32 | (*query-functions* . (make-hash-table :test #'equal)))) 33 | 34 | (defun make-pgj-task (function) 35 | (lambda () 36 | (ensure-connected) 37 | (let ((pomo:*database* *pgj-database*)) 38 | (funcall function)))) 39 | 40 | ;;;; Interface 41 | 42 | (defvar *pgj-kernel* nil 43 | "An lparallel kernel to manage worker threads. Typically bound to 44 | the result of MAKE-PGJ-KERNEL for use by interface calls such 45 | WITH-CONNECTED-THREAD.") 46 | 47 | (defvar *pgj-channel* nil 48 | "A single lparallel channel for submitting tasks via SUBMIT-PGJ-TASK 49 | and receiving results via RECEIVE-PGJ-RESULT.") 50 | 51 | (defun make-pgj-kernel (connect-spec &optional (n 4)) 52 | "Make an lparallel kernel object where each worker thread is given a 53 | permanent DB connection, made using a Postmodern CONNECT-SPEC, a list. 54 | Start N workers. Ensure your Postgres can handle at least N 55 | concurrent connecions." 56 | (lparallel:make-kernel n :bindings (worker-bindings connect-spec) 57 | :context #'worker-context)) 58 | 59 | (defun end-pgj-kernel () 60 | "End the lparallel kernel in *PGJ-KERNEL*." 61 | (let ((lparallel:*kernel* *pgj-kernel*)) 62 | (lparallel:end-kernel))) 63 | 64 | (defun make-pgj-channel () 65 | "Make an lparallel channel. *PGJ-KERNEL* must be bound to the 66 | result of MAKE-PGJ-KERNEL." 67 | (let ((lparallel:*kernel* *pgj-kernel*)) 68 | (lparallel:make-channel))) 69 | 70 | ;;; Blocking function and wrapper macro 71 | 72 | (defun call-with-connected-thread (function) 73 | "Ask that an lparallel worker perform FUNCTION, a function, given a 74 | current Postmodern DB connection. Block until the result is received 75 | and return it. *PGJ-KERNEL* must be bound to the result of 76 | MAKE-PGJ-KERNEL." 77 | (let* ((lparallel:*kernel* *pgj-kernel*) 78 | (channel (lparallel:make-channel))) 79 | (lparallel:task-handler-bind ((error 'lparallel:invoke-transfer-error)) 80 | (lparallel:submit-task channel (make-pgj-task function))) 81 | (lparallel:receive-result channel))) 82 | 83 | (defmacro with-connected-thread (() &body body) 84 | "Wrap BODY in a lambda and invoke CALL-WITH-CONNECTED-THREAD. 85 | *PGJ-KERNEL* must be bound to the result of MAKE-PGJ-KERNEL." 86 | `(call-with-connected-thread (lambda () ,@body))) 87 | 88 | ;;; Non blocking functions and macro 89 | 90 | (defun submit-pgj-function (function) 91 | "Submit the function FUNCTION, with a Postmodern connection, as an 92 | lparallel task on our channel *PGJ-CHANNEL*. *PGJ-KERNEL* must be 93 | bound to the result of MAKE-PGJ-KERNEL." 94 | (let ((lparallel:*kernel* *pgj-kernel*)) 95 | (lparallel:task-handler-bind ((error 'lparallel:invoke-transfer-error)) 96 | (lparallel:submit-task *pgj-channel* (make-pgj-task function))))) 97 | 98 | (defmacro submit-pgj-task (() &body body) 99 | "Wrap BODY in a lambda and call SUBMIT-PGJ-FUNCTION. 100 | *PGJ-KERNEL* must be bound to the result of MAKE-PGJ-KERNEL." 101 | `(submit-pgj-function (lambda () ,@body))) 102 | 103 | (defun receive-pgj-result () 104 | "Call lparallel:receive-result on our *PGJ-CHANNEL*. 105 | *PGJ-KERNEL* must be bound to the result of MAKE-PGJ-KERNEL." 106 | (let ((lparallel:*kernel* *pgj-kernel*)) 107 | (lparallel:receive-result *pgj-channel*))) 108 | 109 | (defun try-receive-pgj-result (&key timeout) 110 | "Call lparallel:try-receive-result on our *PGJ-CHANNEL*, 111 | with timeout TIMEOUT, a real. *PGJ-KERNEL* must be bound to the 112 | result of MAKE-PGJ-KERNEL." 113 | (let ((lparallel:*kernel* *pgj-kernel*)) 114 | (lparallel:try-receive-result *pgj-channel* :timeout timeout))) 115 | -------------------------------------------------------------------------------- /tests/thread-test.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Some informal lparallel tests for the REPL 2 | 3 | ;;;; See t/transactions.lisp for a more formal set of unit tests 4 | ;;;; of serialization failure handling. 5 | 6 | ;;;; For the :timeout option to work you need a version of 7 | ;;;; bordeaux-threads *after* 0.8.3, which is the version in quicklisp 8 | ;;;; as at Dec 2014. I suggest you clone 9 | ;;;; https://github.com/sionescu/bordeaux-threads to your QL 10 | ;;;; local-projects if the QL bordeaux-threads is still at 0.8.3 11 | 12 | ;;;; Set your own *connection* values, compile this file and follow 13 | ;;;; the instructions under Interface below. 14 | 15 | (defpackage :thread-test 16 | (:use :cl :postgres-json)) 17 | 18 | (in-package :thread-test) 19 | 20 | (defparameter *connection* '("cusoon" "gtod" "" "localhost" :port 5433)) 21 | 22 | (log:config :info) 23 | 24 | ;;;; Implementation 25 | 26 | (defun really-do-it (c) 27 | (declare (ignore c)) 28 | (invoke-restart 'really-do-it)) 29 | 30 | (defmacro flatten-errors (() &body body) 31 | `(handler-case (progn ,@body) 32 | (error (e) 33 | (values (format nil "Task error: ~A" e) t)))) 34 | 35 | (defmacro with-conn (() &body body) 36 | `(with-connected-thread () 37 | (flatten-errors () 38 | ,@body))) 39 | 40 | (defun supersede-cat (model key) 41 | (submit-pgj-task () 42 | (supersede model key (obj "name" (format nil "name-~A" key) "coat" "scruffy")))) 43 | 44 | ;; This is just an example of how easy lparallel makes it to deal with 45 | ;; errors in a worker at the point of receiving the results because 46 | ;; we ask for them to be transferred --- see SUBMIT-PGJ-FUNCTION. 47 | (defun process-results (&optional (timeout 0.5)) 48 | (log:info "Processing results") 49 | (loop (multiple-value-bind (result has-result-p) 50 | (flatten-errors () 51 | (try-receive-pgj-result :timeout timeout)) 52 | (unless has-result-p 53 | (return)) 54 | (log:info "Result: ~A" result)))) 55 | 56 | ;; Not sure how sensible this is but it's food for thought... 57 | (defun process-n-results (n) 58 | (log:info "Processing results") 59 | (dotimes (i n) 60 | (let ((result (flatten-errors () 61 | (receive-pgj-result)))) 62 | (log:info "Result: ~A" result)))) 63 | 64 | ;;;; Interface 65 | 66 | (define-global-model cat -cat- (pgj-history-object-model)) 67 | 68 | ;; We make these three, but never give then a DB backend so we can see 69 | ;; what happens when we get DB errors... 70 | (define-global-model bar -bar- (pgj-model)) 71 | (define-global-model foo -foo- (pgj-model)) 72 | (define-global-model baz -baz- (pgj-model)) 73 | 74 | ;; Run first 75 | (defun start-test (&optional (workers 5)) 76 | (setf *pgj-kernel* (make-pgj-kernel *connection* workers)) 77 | (setf *pgj-channel* (make-pgj-channel)) 78 | (with-conn () 79 | (ensure-backend -cat-) 80 | (excise-all -cat-))) 81 | 82 | ;; Run second 83 | (defun insert-some-cats (&optional (number 40)) 84 | (with-conn () 85 | (with-model-transaction (some-cats) 86 | (dotimes (i number (tally -cat-)) 87 | (insert -cat- (obj "name" (format nil "name-~A" i) "coat" "scruffy")))))) 88 | 89 | ;; Run third 90 | (defun update-all () 91 | (let ((keys (with-conn () (keys -cat-)))) 92 | (dolist (key keys) 93 | (log:info "Updating ~A" key) 94 | (supersede-cat -cat- key)) 95 | (process-results))) 96 | 97 | ;; Run fourth 98 | ;; In production code you would certainly not expect to see 20 99 | ;; different users all trying to update a single record at once. But 100 | ;; this is an interesting, completely informal, stress test of the 101 | ;; serialization handling retry code. Of course, there is no 102 | ;; guarantee that all the results are processed, even with a timeout 103 | ;; of say 8 seconds... 104 | (defun update-one (&optional (n 20)) 105 | (log:config :debug) 106 | (let ((key (with-conn () (first (keys -cat-))))) 107 | (dotimes (i n) 108 | (log:info "Updating ~A" key) 109 | (supersede-cat -cat- key)) 110 | (process-results 8) 111 | (log:config :info) 112 | (with-conn () (history -cat- key)))) 113 | 114 | ;; Run fifth 115 | (defun update-broken-1 () 116 | (with-conn () 117 | (let ((key (first (keys -cat-)))) 118 | (supersede -bar- key (obj "foo" "bar"))))) 119 | 120 | ;; Run sixth 121 | (defun update-broken-2 () 122 | (let ((keys (with-conn () (keys -cat-)))) 123 | (let ((key (first keys))) 124 | (supersede-cat -foo- key) 125 | (supersede-cat -cat- key) 126 | (supersede-cat -baz- key) 127 | (process-results)))) 128 | 129 | ;; Run seventh 130 | (defun update-broken-3 () 131 | (let ((keys (with-conn () (keys -cat-)))) 132 | (let ((key (first keys))) 133 | (supersede-cat -foo- key) 134 | (supersede-cat -cat- key) 135 | (supersede-cat -baz- key) 136 | (process-n-results 3)))) 137 | 138 | ;; Run last 139 | (defun end-test () 140 | (with-conn () 141 | (handler-bind ((database-safety-net #'really-do-it)) 142 | (drop-backend -cat-))) 143 | (end-pgj-kernel) 144 | (log:config :info)) 145 | -------------------------------------------------------------------------------- /model/user-query.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | ;;;; JSON queries syntactic sugar 4 | 5 | (defun model-from-list-head (head) 6 | "You can write \(jbuild \('cat \"id\"\)\) or without the quote: 7 | \(jbuild \(cat \"id\"\)\). If HEAD is a symbol or a quoted 8 | symbol, return said symbol." 9 | (if (or (symbolp head) (consp head)) 10 | (if (symbolp head) head (cadr head)) 11 | nil)) 12 | 13 | ;;; We (and you can) macroexpand these macros to see what they 14 | ;;; transform into, but they must not be evaluated, the code is not 15 | ;;; lisp. 16 | 17 | ;; Maybe a bridge too far from S-SQL 18 | ;; (defmacro qn (model &optional as) 19 | ;; "Syntactic sugar to qualify the name of MODEL, a symbol in 20 | ;; *PGJ-SCHEMA*. Wrap in an S-SQL :as form using MODEL as the 21 | ;; abbreviation for the qualified MODEL, or use the symbol AS as the 22 | ;; abbreviation if it is supplied." 23 | ;; `(:as ',(sym t *pgj-schema* "." model) ',(if as as model))) 24 | 25 | (defmacro j-> (form1 &optional form2) 26 | "S-SQL syntactic sugar to turn a single string FORM1 into a 27 | Postgres -> operation using the default JSON column 'jdoc and the 28 | property FORM1; or to turn a symbol FORM1 and string FORM2 into a -> 29 | operation using the 'jdoc JSON column in table FORM1 and the property 30 | FORM2." 31 | (if form2 32 | (let ((model (model-from-list-head form1))) 33 | `(:-> ',(sym t model ".jdoc") ,form2)) 34 | `(:-> 'jdoc ,form1))) 35 | 36 | (defmacro j->> (form1 &optional form2) 37 | "S-SQL syntactic sugar to turn a single string FORM1 into a Postgres 38 | ->> operation using the default JSON column 'jdoc and the property 39 | FORM1; or to turn a symbol FORM1 and string FORM2 into a ->> operation 40 | using the 'jdoc JSON column in table FORM1 and the property FORM2." 41 | (if form2 42 | (let ((model (model-from-list-head form1))) 43 | `(:->> ',(sym t model ".jdoc") ,form2)) 44 | `(:->> 'jdoc ,form1))) 45 | 46 | (defmacro to-jsonb (form) 47 | "S-SQL syntactic sugar to cast FORM to the Postgres jsonb type." 48 | `(:type (:to-json ,form) ,(sym t 'jsonb))) 49 | 50 | (defmacro jbuild (&rest key-forms) 51 | "S-SQL syntactic sugar to create a new Postgres JSON object from the 52 | KEY-FORMS. Each KEY-FORM is a list. In the simplest and first case 53 | it may be a list of strings, said strings indicating properties of the 54 | top level JSON object in the 'jdoc column of the query; the properties 55 | and their values will be returned by JBUILD, in a fresh JSON object. 56 | In the second case the list may start with a symbol \(or a quoted 57 | symbol\) in which case the following strings indicate properties of 58 | the top level JSON document in the 'jdoc column in the DB table named 59 | by the symbol. Now, a la `with-slots`, each string in the list may 60 | itself be replaced by a list of two strings, the first being the 61 | resulting property name in the object returned by JBUILD, the second 62 | being the accessor property for the top level JSON object in the 'jdoc 63 | column. This flexibility is required because we are building a JSON 64 | object and cannot have duplicate properties so if we need the \"id\" 65 | property from both a `cat` and a `dog` model, one of them needs to be 66 | relabeled." 67 | (let ((pairs '())) 68 | (flet ((nsubst-keys (column keys) 69 | (dolist (key keys) 70 | (let ((label (if (consp key) (car key) key)) 71 | (key (if (consp key) (cadr key) key))) 72 | (push label pairs) 73 | (push `(:-> ,column ,key) pairs))))) 74 | (dolist (form key-forms) 75 | (let ((model (model-from-list-head (car form)))) 76 | (if model 77 | (nsubst-keys `(quote ,(sym t model ".jdoc")) (cdr form)) 78 | (nsubst-keys `(quote jdoc) form)))) 79 | `(:json-build-object ,@(reverse pairs))))) 80 | 81 | (defparameter *json-sugar-list-heads* '("j->" "j->>" "jbuild" "to-jsonb")) 82 | 83 | ;; Based on Graham's On Lisp 5.6 84 | (defun subst-json-sugar (tree) 85 | "Replace all POSTGRES-JSON syntactic sugar variants in TREE with 86 | their S-SQL representations." 87 | (if (atom tree) 88 | tree 89 | (let ((car (car tree))) 90 | (when (and (symbolp car) (not (keywordp car))) 91 | (let ((head (symbol-name car))) 92 | (when (member head *json-sugar-list-heads* :test #'string-equal) 93 | (setf tree (macroexpand-1 tree))))) 94 | (cons (subst-json-sugar (car tree)) 95 | (if (cdr tree) (subst-json-sugar (cdr tree))))))) 96 | 97 | ;;;; JSON queries named parameter interpolation 98 | ;;;; See the User Guide for details 99 | 100 | (defun subst-params-in-query (query-params query-form) 101 | "Walk the QUERY-FORM and substitute and symbol matching a symbol in 102 | the list of symbols QUERY-PARAMS with $1, '$2, etc, based on their 103 | order in QUERY-PARAMS." 104 | (let ((tree (copy-tree query-form))) 105 | (loop for param in query-params 106 | for i from 1 107 | do (nsubst `(quote ,(sym t "$" i)) param tree)) 108 | tree)) 109 | 110 | (defun json-query-to-s-sql (query-form &optional params) 111 | "Transform a JSON QUERY-FORM into S-SQL, interpolating the list of 112 | PARAMS, if any. The acceptaple format of QUERY-FORM is documented 113 | in the User Guide under 'User defined JSON queries'." 114 | (subst-json-sugar (subst-params-in-query params query-form))) 115 | 116 | ;;;; Define json query and support 117 | ;;;; See the User Guide for details 118 | 119 | (defun decompose-query-params-list (query-params) 120 | "Turns (foo (*to-json* bar baz) blot) into two values: 121 | (FOO BAR BAZ BLOT) and 122 | ((BAR (FUNCALL *TO-JSON* BAR)) (BAZ (FUNCALL *TO-JSON* BAZ))) 123 | for use in the define-query macro." 124 | (let ((params '()) 125 | (transforms '())) 126 | (dolist (form query-params) 127 | (if (consp form) 128 | (let ((function (first form))) 129 | (dolist (param (rest form)) 130 | (push param params) 131 | (push `(,param (funcall ,function ,param)) transforms))) 132 | (push form params))) 133 | (values (nreverse params) (nreverse transforms)))) 134 | 135 | (defmacro define-json-query (name (&rest query-params) &body query) 136 | "Define a Postmodern S-SQL based QUERY with name NAME, a symbol. 137 | QUERY may use the macro forms j->, j->> jbuild and to-json, documented 138 | separately. Elements of QUERY-PARAMS may be symbols, the number and 139 | order of said symbols serving to define the parameters the query will 140 | be supplied with at run time. Additionally, any occurence of a symbol 141 | from the QUERY-PARAMS list in the QUERY from proper will be replaced 142 | with '$1, '$2 etc. as appropriate based on the order of QUERY-PARAMS. 143 | In this way your queries may use named parameters, but this is not 144 | mandatory. 145 | 146 | Furthermore, a la `cl-ppcre:register-groups-bind`, any element of the 147 | QUERY-PARAMS list may itself be a list of the form 148 | \(function-designator &rest params\) in which case the PARAMS are 149 | still treated as parameters, in order, but at run time 150 | FUNCTION-DESIGNATOR is called on each of the actual arguments of the 151 | PARAMS to transform said arguments before use by the underlying query. 152 | For example `\(foo \(*to-json* bar baz\) blot\)` is an acceptable 153 | QUERY-PARAMS list, as long as *to-json* is funcallable. bar and baz 154 | will be replaced by the result of funcalling *to-json* on them, 155 | repectively. 156 | 157 | The Postmodern result format is always `:column` and so you must 158 | ensure that each row produces just a single datum, being a valid 159 | Postgres JSON type. In practice this means either i) returning the 160 | column named `jdoc` in any model, which is the entire JSON document, 161 | or ii) using the `jbuild` macro to build a JSON object on the fly." 162 | (with-unique-names (query-function) 163 | (multiple-value-bind (params transforms) (decompose-query-params-list query-params) 164 | (let ((s-sql-query (json-query-to-s-sql (car query) params))) 165 | `(let ((,query-function (prepare ,s-sql-query :column))) 166 | (defun ,name (,@params &key (from-json *from-json*)) 167 | (let (,@transforms) 168 | (mapcar from-json (funcall ,query-function ,@params))))))))) 169 | -------------------------------------------------------------------------------- /model/model.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | ;;;; Model properties 4 | 5 | (defgeneric model-name (model) 6 | (:documentation "The symbol being the proper name of the 7 | MODEL.") 8 | (:method ((model pgj-model)) 9 | (type-of model))) 10 | 11 | (defgeneric model-table (model) 12 | (:documentation "The Postgres qualified name as an S-SQL form for 13 | the base table of MODEL.") 14 | (:method ((model pgj-model)) 15 | (qualified-name (model-name model)))) 16 | 17 | (defgeneric model-sequence (model) 18 | (:documentation "The name, a symbol, of a Postgres sequence to 19 | provide primary keys upon insertion of fresh documents into a backend 20 | model. May be NIL, in which case explicit primary keys must be 21 | supplied for all inserts.") 22 | (:method ((model pgj-model)) 23 | *pgj-sequence*)) 24 | 25 | ;; Compound keys? 26 | (defgeneric model-key-name (model) 27 | (:documentation "The name, a symbol, for the primary key column in 28 | backend model tables.") 29 | (:method ((model pgj-model)) 30 | 'key)) 31 | 32 | (defgeneric model-key-type (model) 33 | (:documentation "The name, a symbol, for the Postgres type of the 34 | primary key column in the backend model tables. KEY arguments to 35 | model interface methods must be compatible with this type.") 36 | (:method ((model pgj-model)) 37 | 'integer)) 38 | 39 | (defgeneric model-initial-gin-operator-class (model) 40 | (:documentation "The name, a keyword, for the initial Postgres GIN 41 | operator class to use for the model's GIN index. See also 42 | USE-GIN-INDEX. If NIL, make no GIN index.") 43 | (:method ((model pgj-model)) 44 | :jsonb-ops)) 45 | 46 | ;;;; Model GIN indexes 47 | 48 | ;; See Postgres manual 9.4, 8.14.4. 49 | ;; Choices for gin-operator-class are jsonb_ops and jsonb_path_ops. 50 | ;; The later is smaller and faster but does not support the existence 51 | ;; operator: ? 52 | 53 | ;; In fact we can create a simple BTREE index too: 54 | ;; CREATE INDEX geodata_index ON 55 | ;; geodata_json ((data->>'country_code'), (data->>'asciiname')); 56 | ;; which will be smaller but you need to explicitly list the keys to index and 57 | ;; it does not support @> 58 | 59 | ;; It's easy to test and change indexes at run time: 60 | ;; explain analyze select jdoc from booking where jdoc @> '{"state": "pending"}'; 61 | ;; drop index booking_gin; 62 | ;; create index booking_gin on booking using GIN (jdoc jsonb_path_ops); 63 | ;; etc... 64 | 65 | (defparameter *gin-operator-classes* '(:jsonb-ops :jsonb-path-ops) 66 | "A list of keywords representing Postgres GIN operator classes.") 67 | 68 | (defgeneric use-gin-index (model gin-operator-class) 69 | (:documentation "Create a Postgres GIN index for MODEL using 70 | GIN-OPERATOR-CLASS, a keyword that must be a member of 71 | *gin-operator-classes*. First drop any existing GIN index.") 72 | (:method :before ((model pgj-model) gin-operator-class) 73 | (assert (member gin-operator-class *gin-operator-classes*))) 74 | (:method ((model pgj-model) gin-operator-class) 75 | (let ((table (sql-compile (model-table model))) 76 | (index-name (sym-suffix (model-name model) "gin")) 77 | (op-class (to-sql-name gin-operator-class))) 78 | (maybe-transaction (use-gin-index +read-committed-rw+) 79 | (handler-case (run `(:drop-index :if-exists ,index-name)) 80 | (warning () nil)) 81 | (run `(:create-index ,index-name :on ,table 82 | :using gin :fields (:raw ,(format nil "jdoc ~A" op-class)))))))) 83 | 84 | ;;;; Model backend 85 | 86 | (defgeneric create-base-table (model) 87 | (:documentation "Create a Postgres table to contain JSON documents 88 | for MODEL.") 89 | (:method ((model pgj-model)) 90 | (let ((table (sql-compile (model-table model))) 91 | (key-name (model-key-name model)) 92 | (key-type (model-key-type model))) 93 | (run `(:create-table ,table 94 | ((,key-name :type ,key-type :primary-key t) 95 | (valid-to :type timestamptz :default (:type "infinity" timestamptz)) 96 | (valid-from :type timestamptz :default (:transaction-timestamp)) 97 | (jdoc :type jsonb))))))) 98 | 99 | (defgeneric create-backend (model) 100 | (:documentation "Create the backend tables and indexes for a 101 | MODEL.") 102 | (:method :around ((model pgj-model)) 103 | (maybe-transaction (create-backend +read-committed-rw+) 104 | (ensure-pgj-schema) 105 | (call-next-method))) 106 | (:method ((model pgj-model)) 107 | (create-base-table model) 108 | (when-let ((op-class (model-initial-gin-operator-class model))) 109 | (use-gin-index model op-class)))) 110 | 111 | (defgeneric backend-exists-p (model) 112 | (:documentation "Return true if MODEL has a Postgres backend, NIL 113 | otherwise.") 114 | (:method ((model pgj-model)) 115 | (%table-exists-p (sql-compile (model-table model))))) 116 | 117 | (defgeneric ensure-backend (model) 118 | (:documentation "Call CREATE-BACKEND on MODEL unless said backend 119 | already exists.") 120 | (:method ((model pgj-model)) 121 | (unless (backend-exists-p model) 122 | (create-backend model)))) 123 | 124 | (defgeneric drop-backend (model) 125 | (:documentation "Drop the Postgres backend of MODEL. This will 126 | irrevocably delete all data associated with the model.") 127 | (:method :around ((model pgj-model)) 128 | (flet ((drop () 129 | (maybe-transaction (drop-backend +read-committed-rw+) 130 | (call-next-method)))) 131 | (restart-case (error 'database-safety-net 132 | :attempted-to (format nil "DROP model ~A" (model-name model)) 133 | :suggestion "Pick an appropriate restart") 134 | (cancel () :report "Leave this model alone.") 135 | (really-do-it () :report "I really want to DROP this model's backend." (drop))))) 136 | (:method ((model pgj-model)) 137 | (drop-db-table-cascade (sql-compile (model-table model))))) 138 | 139 | ;;;; JSON de/serialization 140 | 141 | ;;; These two methods are specifically for *entire JSON documents* 142 | ;;; going to/from the model's backend. It may be that validation is 143 | ;;; performed before serialization or derived keys inserted after 144 | ;;; deserialization. When interface methods need to convert to/from 145 | ;;; JSON for other uses cases (see FILTER, for example) then *TO-JSON* 146 | ;;; and *FROM-JSON* are used... 147 | 148 | (defgeneric serialize (model object) 149 | (:documentation "Serialize lisp OBJECT to a form suitable for 150 | storage as a JSON document in backend MODEL. Return same. Called by 151 | INSERT, for example, to convert Lisp objects to JSON before DB 152 | insertion proper.") 153 | (:method ((model pgj-model) object) 154 | (funcall *to-json* object))) 155 | 156 | (defgeneric deserialize (model jdoc) 157 | (:documentation "Deserialize the string JDOC from MODEL's backend to 158 | a lisp object. Return same. Called by FETCH, for example, to convert 159 | JSON strings from the backend into Lisp objects.") 160 | (:method ((model pgj-model) (jdoc string)) 161 | (funcall *from-json* jdoc))) 162 | 163 | (defgeneric stash (model object key) 164 | (:documentation "Called before SERIALIZE which is called before 165 | document inserts or updates. An opportunity to modify the lisp OBJECT 166 | using the intended/current primary KEY of the JSON document in the 167 | MODEL's backend.") 168 | (:method ((model pgj-model) object key) 169 | "Do nothing and return OBJECT." 170 | (declare (ignore key)) 171 | object) 172 | (:method ((model pgj-object-model) (object hash-table) key) 173 | "Destructively modify hash-table OBJECT by assigning the value KEY 174 | to a key named by the downcased symbol name of MODEL-KEY-NAME of 175 | MODEL. Returns the modified OBJECT." 176 | (let ((key-name (string-downcase (symbol-name (model-key-name model))))) 177 | (setf (gethash key-name object) key) 178 | object))) 179 | 180 | ;;;; Interface 181 | 182 | ;; By design DEFINE-GLOBAL-VAR* symbols should not be rebound 183 | (defmacro define-global-model (name constant (&rest superclasses)) 184 | "Define a new class named NAME, a symbol, having SUPERCLASSES, all 185 | symbols. Define a global variable named CONSTANT, a symbol, with 186 | value an instance of the new class." 187 | `(progn 188 | (defclass ,name (,@superclasses) ()) 189 | (define-global-var* ,constant (make-instance ',name)))) 190 | -------------------------------------------------------------------------------- /model/interface.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | ;;;; Define the CRUD++ interface to the Postgre-JSON persistence model 4 | 5 | (defgeneric insert (model object &optional key) 6 | (:documentation "Insert lisp object OBJECT into the backend MODEL, 7 | after JSON serialization. If KEY is supplied use that as the primary 8 | key for the JSON document rather than an automatically generated one. 9 | Return the new primary key.") 10 | (:method ((model pgj-model) object &optional key) 11 | (maybe-transaction (insert +read-committed-rw+) 12 | (let ((key (or key (nextval-sequence$ model)))) 13 | (let ((object (stash model object key))) 14 | (first-value (insert$ model key (serialize model object)))))))) 15 | 16 | ;; We also need a MERGE, or MIXIN or UPDATE of some sort. The Postgres 17 | ;; people may help us with the next release or there are suggestions 18 | ;; on stackexchange... 19 | (defgeneric supersede (model key object) 20 | (:documentation "Replace the current value of the JSON document 21 | having primary key KEY in MODEL with the JSON serialization of lisp 22 | object OBJECT. Return KEY on success, NIL if no such KEY is found.") 23 | (:method ((model pgj-model) key object) 24 | (maybe-transaction (supersede +read-committed-rw+) 25 | (let ((object (stash model object key))) 26 | (first-value (supersede$ model key (serialize model object))))))) 27 | 28 | (defgeneric fetch (model key) 29 | (:documentation "If there is a JSON document with primary key KEY in 30 | MODEL return the result of deserializing it. Otherwise return NIL.") 31 | (:method ((model pgj-model) key) 32 | (let ((jdoc (maybe-transaction (fetch +read-committed-ro+) 33 | (fetch$ model key)))) 34 | (if jdoc (deserialize model jdoc) nil)))) 35 | 36 | (defgeneric fetch-all (model) 37 | (:documentation "Return as a list the result of deserializing all 38 | JSON documents in MODEL.") 39 | (:method ((model pgj-model)) 40 | (maybe-transaction (fetch-all +read-committed-ro+) 41 | (mapcar (curry #'deserialize model) (fetch-all$ model))))) 42 | 43 | (defgeneric excise (model key) 44 | (:documentation "Delete the JSON document with primary key KEY from 45 | MODEL. Return KEY on success, NIL if no such KEY exists.") 46 | (:method ((model pgj-model) key) 47 | (maybe-transaction (excise +read-committed-rw+) 48 | (first-value (excise$ model key))))) 49 | 50 | (defgeneric excise-all (model) 51 | (:documentation "Delete all JSON documents in MODEL. Returns the 52 | number of documents deleted.") 53 | (:method ((model pgj-model)) 54 | (maybe-transaction (excise-all +read-committed-rw+) 55 | (nth-value 1 (excise-all$ model))))) 56 | 57 | (defgeneric keys (model) 58 | (:documentation "Return two values: a list of all primary keys for 59 | MODEL and the length of that list.") 60 | (:method ((model pgj-model)) 61 | (maybe-transaction (keys +read-committed-ro+) 62 | (keys$ model)))) 63 | 64 | (defgeneric tally (model) 65 | (:documentation "Return the count of all JSON documents in MODEL.") 66 | (:method ((model pgj-model)) 67 | (maybe-transaction (count +read-committed-ro+) 68 | (first-value (tally$ model))))) 69 | 70 | (defgeneric having-property (model property) 71 | (:documentation "Return the result of deserializing all JSON 72 | documents in MODEL which have a top level object property PROPERTY, a 73 | string, or if said string appears as an element of a top level array. 74 | This is in the Postgres operator ? sense. Requires a Postgres GIN 75 | index with operator class :jsonb-ops defined on MODEL.") 76 | (:method ((model pgj-structure-model) (property string)) 77 | (maybe-transaction (contains +read-committed-ro+) 78 | (mapcar (curry #'deserialize model) (exists$ model property))))) 79 | 80 | (defgeneric enumerate-property (model property) 81 | (:documentation "Return all distinct values of the top level 82 | PROPERTY, a string, in all of the JSON documents of MODEL. JSON 83 | deserialization is performed by funcalling *FROM-JSON*. Note that 84 | this is _not_ a prepared query so care must be taken that PROPERTY is 85 | sanitized if it derives from arbitrary user input.") 86 | (:method ((model pgj-object-model) (property string)) 87 | (let ((query `(:select (j-> ,property) 88 | :distinct 89 | :from ,(model-table model)))) 90 | (maybe-transaction (distinct +read-committed-ro+) 91 | (mapcar *from-json* 92 | (query (sql-compile (json-query-to-s-sql query)) 93 | :column)))))) 94 | 95 | (defgeneric filter (model &key contains) 96 | (:documentation "Filter all JSON documents in MODEL by checking they 97 | 'contain', in the Postgres @> operator sense, the object CONTAINS which 98 | will be serialized to a JSON document by funcalling *TO-JSON*. If 99 | CONTAINS is NIL, apply no containment restriction.") 100 | (:method ((model pgj-object-model) &key contains properties limit) 101 | "Filter all JSON documents in MODEL as follows. Each document 102 | must 'contain', in the Postgres @> operator sense, the object CONTAINS 103 | which will be serialized to a JSON document by funcalling *TO-JSON*. 104 | If CONTAINS is NIL, apply no containment restriction. PROPERTIES may 105 | be a list of strings being properties in the top level of the JSON 106 | documents in MODEL and only the values of said properties will be 107 | returned, bundled together in a JSON document. If PROPERTIES is NIL 108 | the entire JSON document will be returned. LIMIT, if supplied, must 109 | be an integer that represents the maximum number of objects that will 110 | be returned. If properties is NIL JSON deserialization is performed 111 | by DESERILIZE, otherwise by funcalling *FROM-JSON*. Note that this is 112 | _not_ a prepared query so extra care must be taken if PROPERTIES or 113 | CONTAIN derive from unsanitized user input." 114 | (let ((filter (if contains (funcall *to-json* contains) nil))) 115 | (let ((select `(:select ,(if properties `(jbuild ,properties) 'jdoc) 116 | :from ,(model-table model) 117 | :where ,(if filter `(:@> 'jdoc ,filter) "t")))) 118 | (let ((query (if (integerp limit) `(:limit ,select ,limit) select)) 119 | (from-json (if properties *from-json* (curry #'deserialize model)))) 120 | (maybe-transaction (filter +read-committed-ro+) 121 | (mapcar from-json 122 | (query (sql-compile (json-query-to-s-sql query)) 123 | :column)))))))) 124 | 125 | ;;;; History methods 126 | 127 | (defmethod supersede ((model pgj-history-model) key object) 128 | "As per SUPERSEDE but keep a separate record of all previous rows." 129 | (declare (ignore object)) 130 | (maybe-transaction (supersede-history +repeatable-read-rw+) 131 | (insert-old$ model key) 132 | (call-next-method))) 133 | 134 | (defmethod excise ((model pgj-history-model) key) 135 | "As per EXCISE but keep a separate record of all deleted rows." 136 | (maybe-transaction (excise-history +repeatable-read-rw+) 137 | (insert-old$ model key) 138 | (call-next-method))) 139 | 140 | (defmethod excise-all ((model pgj-history-model)) 141 | "As per EXCISE-ALL but keep a separate record of all deleted rows." 142 | (maybe-transaction (excise-all-history +repeatable-read-rw+) 143 | (dolist (key (keys model)) 144 | (excise model key)))) 145 | 146 | (defgeneric history (model key &key) 147 | (:documentation "Return a list of the result of deserializing all 148 | previous values of the JSON document with primary key KEY in MODEL.") 149 | (:method ((model pgj-history-model) key 150 | &key (validity-keys-p t) 151 | (valid-from-key "_validFrom") (valid-to-key "_validTo")) 152 | "Return a list of the result of deserializing all previous values 153 | of the JSON document with primary key KEY in MODEL, in chronological 154 | order. If VALIDITY-KEYS-P is true, include the 'valid_from' and 155 | 'valid_to' Postgres timestamps for the historical document as 156 | properties in the top level JSON object --- it must be an object in 157 | this case. VALID-FROM-KEY and VALID-TO-KEY are strings that will be 158 | the property names of the respective timestamps." 159 | (let ((rows (maybe-transaction (history +read-committed-ro+) 160 | (history$ model key)))) 161 | (loop for (jdoc valid-from valid-to) in rows 162 | for obj = (deserialize model jdoc) 163 | when validity-keys-p 164 | do (setf (gethash valid-from-key obj) valid-from) 165 | (setf (gethash valid-to-key obj) valid-to) 166 | collect obj)))) 167 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Postgres-JSON 2 | =============== 3 | 4 | ## What is it? 5 | 6 | A Common Lisp library that provides a user friendly layer over the new 7 | [jsonb type](http://www.postgresql.org/docs/9.4/static/datatype-json.html) 8 | of PostgreSQL 9.4, allowing trivial storage and retrieval of 9 | JSON documents. Thanks to the excellent JSON libraries for Common 10 | Lisp, Postgres-JSON thus facilitates easy serialization of lisp data 11 | structures to and from a proper database. 12 | 13 | ## Why would you use it? 14 | 15 | 1. You have some existing JSON documents you want to store persistently. 16 | 17 | 2. You want to serialize Common Lisp hash tables, lists, vectors, 18 | et cetera to a database. 19 | 20 | 3. You like the [ACID](http://en.wikipedia.org/wiki/ACID) qualities of 21 | PostgreSQL but rigid data schema are not suitable for your project. 22 | 23 | In some sense Postgres-JSON is a primitive *NoSQL document database*. 24 | It was inspired by the excellent 25 | [cl-rethinkdb](https://github.com/orthecreedence/cl-rethinkdb) 26 | interface to [RethinkDB](http://rethinkdb.com/) but uses a traditional 27 | blocking I/O interface via Postmodern. 28 | 29 | ## Built on 30 | 31 | * [PostgreSQL 9.4](http://www.postgresql.org). 32 | 33 | * Marijn Haverbeke's wonderful [Postmodern](http://marijnhaverbeke.nl/postmodern/). 34 | 35 | * Any Common Lisp JSON library. 36 | [Yason](http://common-lisp.net/project/yason/) is a dependency of this 37 | project but you can use whatever library you like: 38 | see the comparison by Sabra On The Hill: [JSON libraries] 39 | (https://sites.google.com/site/sabraonthehill/home/json-libraries). 40 | 41 | ## Status 42 | 43 | As at January 2015 and according to the langauge of [Semantic 44 | versioning](http://semver.org) Postgres-JSON is in the "initial 45 | development phase". Anything might change. 46 | 47 | That said, the interface is relatively stable and the documentation 48 | largely complete. So do not use it in production but any and all 49 | feedback is most welcome to postgres-json@gtod.net or by raising a 50 | GitHub issue. 51 | 52 | ## Documentation 53 | 54 | * [Beginner's guide to JSON with Common Lisp] 55 | (doc/beginners.md) 56 | * [User's Guide](doc/user-guide.md) 57 | * [API](doc/api.md) 58 | 59 | Most of the library code has docstrings. 60 | 61 | ## Quickstart 62 | 63 | #### Postgres 64 | 65 | You will need a working PostgreSQL 9.4 install. On Debian this may be 66 | as simple as `apt-get install postgresql-9.4`. If this does not work, see 67 | https://wiki.postgresql.org/wiki/Apt for help updating your apt sources. 68 | 69 | Once installed, try `pg_lsclusters` to see what port your 9.4 install 70 | is on, if it is not 5432 you will need to explicitly supply the port 71 | as I have in the example below. `pg_upgradecluster` may have been 72 | automatically run for you, in which case your new install may already 73 | be on port 5432. 74 | 75 | If this is your first time using Postgres you can setup a database 76 | user to match your unix login (in my case `gtod`) at the unix shell as 77 | follows: 78 | 79 | ``` 80 | sudo su postgres 81 | createuser gtod 82 | createdb -O gtod mydb 83 | exit 84 | ``` 85 | 86 | `psql -l` or `psql -p5433 -l` should now list your new database. 87 | 88 | For passwordless Postmodern connections I edit the 89 | `/etc/postgresql/9.4/main/pg_hba.conf` file (which may be elsewhere on 90 | non Debian systems). There is a line: 91 | 92 | ``` 93 | host all all 127.0.0.1/32 md5 94 | ``` 95 | 96 | Change `md5` to `trust`. See [auth 97 | trust](http://www.postgresql.org/docs/9.4/static/auth-methods.html#AUTH-TRUST) 98 | for the pros and cons of such an approach. 99 | 100 | Then `sudo service postgresql restart`. Again, may be different on 101 | non Debian systems. 102 | 103 | #### Postgres-JSON 104 | 105 | Navigate to your `~/quicklisp/local-projects` directory and do 106 | 107 | `git clone https://github.com/gtod/postgres-json.git`. Then at your 108 | REPL evaluate: 109 | 110 | ```common-lisp 111 | (ql:register-local-projects) 112 | (ql:quickload :postgres-json) 113 | ``` 114 | 115 | Now: 116 | 117 | ```common-lisp 118 | (defpackage :simple 119 | (:use :cl :postgres-json)) 120 | 121 | (in-package :simple) 122 | 123 | ;; Change to suit your Postgres DB 124 | (setf *postmodern-connection* '("mydb" "gtod" "" "localhost" :port 5433)) 125 | (ensure-top-level-connection) 126 | 127 | ;; Create a Postgres-JSON model (and global instance) to store cats 128 | (define-global-model cat -cat- (pgj-object-model)) 129 | 130 | ;; Ensure there is a database backend for our cat model 131 | (ensure-backend -cat-) 132 | ``` 133 | 134 | In the output below I have elided some of the return values for 135 | brevity. `obj` is a trivial function to turn a list of pairs into a 136 | hash table. `pp-json` is a trivial function to pretty print a nested 137 | lisp object of hash tables and sequences as JSON. 138 | 139 | ```common-lisp 140 | (insert -cat- (obj "name" "joey" "coat" "tabby")) 141 | 1 142 | 143 | (pp-json (fetch -cat- 1)) 144 | { 145 | "key":1, 146 | "coat":"tabby", 147 | "name":"joey" 148 | } 149 | 150 | (insert -cat- (obj "name" "max" "coat" "ginger")) 151 | 152 | (insert -cat- (obj "name" "maud" "coat" "tortoiseshell")) 153 | 154 | (keys -cat-) 155 | (1 2 3) 156 | 157 | (excise -cat- 2) 158 | 2 159 | 160 | (keys -cat-) 161 | (1 3) 162 | 163 | (tally -cat-) 164 | 2 165 | 166 | (supersede -cat- 3 (obj "name" "maud" "coat" "tortoiseshell" "age" 7 167 | "likes" '("sunshine" 42))) 168 | 3 169 | 170 | (pp-json (fetch -cat- 3)) 171 | { 172 | "age":7, 173 | "key":3, 174 | "coat":"tortoiseshell", 175 | "name":"maud", 176 | "likes":[ 177 | "sunshine", 178 | 42 179 | ] 180 | } 181 | ``` 182 | 183 | #### Examples 184 | 185 | See [simple](examples/simple.lisp) for similar code to the above. 186 | There is an extended example in [human-1](examples/human-1.lisp) and 187 | [human-2](examples/human-2.lisp). An example of the simple 188 | customizations available by specializing generic functions is shown in 189 | [customize](examples/customize.lisp). `(ql:quickload 190 | :postgres-json-examples)` will compile all the examples. 191 | 192 | An example user defined query from [human-2](examples/human-2.lisp) 193 | and documented in [User defined JSON 194 | queries](doc/user-guide.md#user-defined-json-queries): 195 | 196 | ```common-lisp 197 | (define-json-query uncharitable-humans$ () 198 | (:select (jbuild (human "name") (gift "type" "quantity")) 199 | :from 'human 200 | :inner-join 'gift 201 | :on (:= (j-> human "key") (j-> gift "human-key")) 202 | :where (:= (j-> gift "quantity") (to-jsonb 1)))) 203 | ``` 204 | 205 | A reminder that none of this will work unless 206 | `*postmodern-connection*` is set correctly for your Postgres database. 207 | 208 | ## Features 209 | 210 | #### Immutability 211 | 212 | By writing 213 | 214 | ```common-lisp 215 | (define-global-model cat -cat- (pgj-history-object-model)) 216 | ``` 217 | 218 | our `cat` model descends from a class which maintains history. Now when 219 | you call [`supersede`](doc/api.md#supersede) (which means *replace* 220 | but is not a Common Lisp standard symbol) or 221 | [`excise`](doc/api.md/#excise) (which means *delete*...) a [JSON 222 | document](doc/user-guide.md#json-document) in a 223 | [model](doc/user-guide.md#model), a copy of the current row is 224 | inserted into the `_old` table before proceeding. So there is 225 | a full [`history`](doc/api.md#history) of the document's lifetime. 226 | 227 | #### PostgreSQL 9.4 + JSON == NoSQL++ 228 | 229 | The whole point is that we are only using a few columns in the 230 | PostgreSQL model tables, and just for management purposes: all the 231 | goodies are in the JSON. Needless to say it makes sense to keep the 232 | objects you end up serializing to a specific model table pretty 233 | consistent in their content... 234 | 235 | However, I think it may well be practical to support referential 236 | integrity, based just on the primary key column in different models. 237 | So we should be able to support a *CAT owns one or more HUMANS* 238 | relationship etc. This is the point of using Postgres for JSON 239 | documents: we can choose precisely how much of the old fashioned 240 | relational database goodness to mix with the new fashioned NoSQL devil 241 | may care hedonism... 242 | 243 | #### lparallel support 244 | 245 | There is (preliminary) [lparallel](http://lparallel.org) support in 246 | the `postgres-json-parallel` system. As at January 2015 you need a 247 | bleeding edge bordeaux-threads to use it. Do a 248 | 249 | ``` 250 | git clone https://github.com/sionescu/bordeaux-threads.git 251 | ``` 252 | 253 | in your quicklisp/local-projects directory, register and build, as 254 | shown above. 255 | 256 | ## Tests 257 | 258 | There is a test suite (radically incomplete) which relies upon the 259 | lparallel support described above *so you cannot run the tests without 260 | a recent bordeaux-threads*. The same goes for the more informal tests 261 | in [thread-test](tests/thread-test.lisp). 262 | 263 | ``` 264 | (ql:quickload :postgres-json-test) 265 | (in-package :postgres-json-test) 266 | (setf *postmodern-connection* '("mydb" "myuname" "" "mydbserver")) 267 | (run-pgj-tests) 268 | ``` 269 | 270 | It would be nice to have this automated for cl-test-grid but how to 271 | surmount the need for a working PostgreSQL 9.4 install? 272 | -------------------------------------------------------------------------------- /markdown-docstrings.lisp: -------------------------------------------------------------------------------- 1 | ;;;; This is gross, broken and inflexible and has been done better a 2 | ;;;; hundered times before but it does make decent looking API doco, 3 | ;;;; in the same order as my package exports and with nice sub heading 4 | ;;;; links... And because it's markdown, I can link to specific API 5 | ;;;; functions in other documents like the README and User's Guide. 6 | 7 | (defpackage :markdown-docstrings 8 | (:use #:cl #:alexandria #:cl-ppcre) 9 | (:export #:generate)) 10 | 11 | (in-package :markdown-docstrings) 12 | 13 | (defparameter *lambda-junk* '(t nil &key &optional &rest &body)) 14 | 15 | (defvar *doc-cache*) 16 | (defvar *doc-package*) 17 | 18 | ;; We want to print just the exported symbols in PACKAGE-FILE. So 19 | ;; first we cache the output for every function and special we can 20 | ;; find in all the lisp files in the source directory of SYSTEM, a 21 | ;; keyword, and only then do we iterate over the exported symbols and 22 | ;; write the Markdown to DESTINATION. PACKAGE must be a package 23 | ;; designator for the package where the all the functions and specials 24 | ;; we find are interned. It's a straight-jacket, I know. 25 | 26 | (defun generate (&key system (package system) (package-file "package.lisp") 27 | (destination (asdf:system-relative-pathname system "doc/api.md"))) 28 | (let ((*doc-package* package) 29 | (*doc-cache* (make-hash-table :test #'equal)) 30 | (*print-right-margin* 1000) 31 | (package-file (asdf:system-relative-pathname system package-file))) 32 | (uiop/filesystem:collect-sub*directories (asdf:system-source-directory system) 33 | #'constantly #'constantly #'per-directory) 34 | (uiop/filesystem:delete-file-if-exists destination) 35 | (with-output-to-file (out destination :if-does-not-exist :create) 36 | (with-input-from-file (stream package-file) 37 | (write-line "# Postgres-JSON Interface" out) 38 | ;; We assume defpackage form is first 39 | (let ((defpackage-form (read-with-comments stream))) 40 | (dolist (form defpackage-form) 41 | (when (stringp form) 42 | (let ((heading (string-left-trim "; " form))) 43 | (format out "* [~A](#~A)~%" heading (substitute #\- #\Space (string-downcase heading)))))) 44 | (format out "~%---~%") 45 | (dolist (form defpackage-form) 46 | (when (stringp form) 47 | (format out "## ~A~%" (string-left-trim "; " form))) 48 | (when (and (consp form) (eq :export (car form))) 49 | (dolist (symbol (cdr form)) 50 | (multiple-value-bind (doc-list present-p) (gethash (symbol-name symbol) *doc-cache*) 51 | (when present-p 52 | (dolist (text (reverse doc-list)) 53 | (princ text out))))) 54 | (format out "~%---~%")))))))) 55 | 56 | (defun read-with-comments (stream) 57 | (flet ((comment-reader (stream char) 58 | (declare (ignore char)) 59 | (read-line stream nil #\Newline t))) 60 | (let ((*readtable* (copy-readtable))) 61 | (set-macro-character #\; #'comment-reader) 62 | (read stream)))) 63 | 64 | (defun walk-tree (fun tree) 65 | "Walk TREE and call FUN at each node. Thanks to Lisp Tips." 66 | (subst-if t (constantly nil) tree :key fun)) 67 | 68 | (defun per-directory (dir) 69 | (dolist (file (uiop/filesystem:directory-files dir)) 70 | (when (scan "\\.lisp$" (file-namestring file)) 71 | (with-input-from-file (stream file) 72 | (handler-case (loop (handle-top-form (read stream))) 73 | (end-of-file () 74 | t)))))) 75 | 76 | (defun write-inverted (form) 77 | (let ((*readtable* (copy-readtable))) 78 | (setf (readtable-case *readtable*) :invert) 79 | (write form))) 80 | 81 | (defun markdown-escape (string) 82 | (regex-replace-all "\\*" string "\\\\*")) 83 | 84 | (defun class-docstring (class-form) 85 | (dolist (form (cdddr class-form)) 86 | (when (eq :documentation (car form)) 87 | (return (cadr form))))) 88 | 89 | (defun method-qualifier-p (form) 90 | (and (eq 'cl:defmethod (car form)) 91 | (keywordp (third form)))) 92 | 93 | (defun declaration-p (form) 94 | (and (consp form) (eq 'cl:declare (car form)))) 95 | 96 | (defun def-docstring (def-form) 97 | (let ((n (if (method-qualifier-p def-form) 4 3))) 98 | (dolist (form (nthcdr n def-form)) 99 | (unless (or (declaration-p form) (stringp form)) 100 | (return)) 101 | (when (stringp form) 102 | (return form))))) 103 | 104 | (defun def-form-name (head) 105 | (ecase head 106 | (alexandria:define-constant "Constant") 107 | (cl:defvar "Dynamic variable") 108 | (cl:defparameter "Dynamic variable") 109 | (cl:defclass "Class") 110 | (cl:define-condition "Condition") 111 | (cl:defun "Function") 112 | (cl:defgeneric "Generic function") 113 | (cl:defmethod "Method") 114 | (cl:defmacro "Macro"))) 115 | 116 | (defun output-def-form (name head lambda-list docstring) 117 | (with-output-to-string (*standard-output*) 118 | (format t "#### ~A~%" (string-downcase name)) 119 | (format t "*~A*~%" (def-form-name head)) 120 | (terpri) 121 | (when lambda-list 122 | (write-line "```common-lisp") 123 | (dolist (form lambda-list) 124 | (write-inverted form) 125 | (write-char #\Space)) 126 | (terpri) 127 | (write-line "```") 128 | (terpri)) 129 | ;; Pad the docstring so regex below always works 130 | (let ((docstring (format nil " ~A " (markdown-escape docstring))) 131 | (symbols (list name))) 132 | (walk-tree (lambda (node) 133 | (when (and (symbolp node) (not (member node *lambda-junk*))) 134 | (pushnew node symbols))) 135 | lambda-list) 136 | (dolist (symbol (sort symbols (lambda (a b ) 137 | (> (length (symbol-name a)) 138 | (length (symbol-name b)))))) 139 | (labels ((node-name (node) 140 | (string-upcase (symbol-name node))) 141 | (regex (node) 142 | (format nil "([\\s.,'\"])(~A)([\\s.,'\"])" 143 | (markdown-escape (node-name node))))) 144 | (setf docstring (regex-replace-all (regex symbol) 145 | docstring "\\1**\\2**\\3")))) 146 | (format t "~A~%~%" (string-trim " " docstring))))) 147 | 148 | (defun output-param-form (name head value value-supplied-p docstring) 149 | (with-output-to-string (*standard-output*) 150 | (format t "#### ~A~%" (markdown-escape (string-downcase name))) 151 | (format t "*~A*~%" (def-form-name head)) 152 | (when (and value-supplied-p value) 153 | (terpri) 154 | (write-line "```common-lisp") 155 | (write-inverted value) 156 | (terpri) 157 | (write-line "```")) 158 | (terpri) 159 | (format t "~A~%~%" (markdown-escape docstring)))) 160 | 161 | (defun handle-top-form (form) 162 | (when (consp form) 163 | (let ((head (car form))) 164 | (case head 165 | ((cl:defvar cl:defparameter) 166 | (destructuring-bind (name &optional (value nil value-supplied-p) doc) (rest form) 167 | (push (output-param-form name head value value-supplied-p doc) 168 | (gethash (symbol-name name) *doc-cache* '())))) 169 | ((alexandria:define-constant) 170 | (destructuring-bind (name value &key test documentation) (rest form) 171 | (declare (ignore test)) 172 | (push (output-param-form name head value t documentation) 173 | (gethash (symbol-name name) *doc-cache* '())))) 174 | ((cl:defclass cl:define-condition) 175 | (let ((name (cadr form))) 176 | (when-let (docstring (class-docstring form)) 177 | (push (with-output-to-string (*standard-output*) 178 | (format t "#### ~A~%" (markdown-escape (string-downcase name))) 179 | (format t "*~A*~%" (def-form-name head)) 180 | (terpri) 181 | (format t "~A~%~%" (markdown-escape docstring))) 182 | (gethash (symbol-name name) *doc-cache* '()))))) 183 | ((cl:defgeneric) 184 | (let ((name (cadr form))) 185 | (when-let (docstring (class-docstring form)) 186 | (push (output-def-form name head (third form) docstring) 187 | (gethash (symbol-name name) *doc-cache* '()))) 188 | (dolist (form (cdddr form)) 189 | (when (eq :method (car form)) 190 | (when-let ((docstring (def-docstring (cons 'foo form)))) 191 | (let ((lambda-list (if (keywordp (cadr form)) (third form) (second form)))) 192 | (push (output-def-form name 'cl:defmethod lambda-list docstring) 193 | (gethash (symbol-name name) *doc-cache* '())))))))) 194 | ((cl:defun cl:defmacro cl:defmethod) 195 | (destructuring-bind (name lambda-list &rest forms) (rest form) 196 | (declare (ignore forms)) 197 | (when-let (docstring (def-docstring form)) 198 | (push (output-def-form name head lambda-list docstring) 199 | (gethash (symbol-name name) *doc-cache* '()))))))))) 200 | -------------------------------------------------------------------------------- /postgres/transactions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json) 2 | 3 | ;;;; Postmodern transactions with isolation levels and RO, RW 4 | ;;;; settings plus serialization failure handling. 5 | 6 | ;;; The following adds support for setting the isolation level of a 7 | ;;; Postmodern transaction, and setting the read only or read write 8 | ;;; status of that transaction at the same time. See 9 | ;;; http://www.postgresql.org/docs/9.4/static/sql-set-transaction.html 10 | 11 | ;;; There is also support for a rudimentary retry loop to catch the 12 | ;;; cl-postgres-error:serialization-failure conditions that may arise 13 | ;;; when using 'repeatable read' or 'serializable' isolation levels. 14 | ;;; Since 'read committed' is the default isolation level, many 15 | ;;; Postgres users will never have seen such failures. Postgres-JSON 16 | ;;; requires either of the above isolation levels because of, say, 17 | ;;; SUPERSEDE keeping a full history under the covers... 18 | 19 | ;;; A small change to Postmodern is required to support these 20 | ;;; additions, see postgres/postmodern.lisp 21 | 22 | ;;;; Public specials 23 | 24 | (define-constant +serializable-rw+ 25 | "isolation level serializable read write" :test 'string= 26 | :documentation "START TRANSACTION string to set Postgres 27 | 'Serializable' isolation level and read/write.") 28 | 29 | (define-constant +repeatable-read-rw+ 30 | "isolation level repeatable read read write" :test 'string= 31 | :documentation "START TRANSACTION string to set Postgres 'Repeatable 32 | read' isolation level and read/write." ) 33 | 34 | (define-constant +read-committed-ro+ 35 | "isolation level read committed read only" :test 'string= 36 | :documentation "START TRANSACTION string to set Postgres 'Read 37 | committed' isolation level, which is the default, and read only.") 38 | 39 | (define-constant +read-committed-rw+ 40 | "isolation level read committed read write" :test 'string= 41 | :documentation "START TRANSACTION string to set Postgres 'Read 42 | committed' isolation level, which is the default, and read write.") 43 | 44 | (defvar *pgj-default-isolation-level* '+repeatable-read-rw+ 45 | "The isolation level, a symbol, to use for WITH-MODEL-TRANSACTION. 46 | For models that maintain history can only be +REPEATABLE-READ-RW+ or 47 | +SERIALIZABLE-RW+. For models without history could conceivably be 48 | +READ-COMMITTED-RW+.") 49 | 50 | ;;;; Implementation 51 | 52 | ;; This should be thread safe as it it only ever bound local to a 53 | ;; specific thread. 54 | (defvar *top-isolation-level* nil 55 | "When we start the first transaction in a nested group, bind this 56 | to the isolation level requested.") 57 | 58 | ;; By abuse of notation I am referring to the combination of isolation 59 | ;; level _and_ read only/read write settings as just 'isolation 60 | ;; level'. For calculating the congruence of nested transactions the 61 | ;; true isolation level is paramount but clearly you can't nest a RW 62 | ;; level inside a RO one... 63 | (defvar *isolation-levels-hierarchy* 64 | '(+read-committed-ro+ +read-committed-rw+ +repeatable-read-rw+ +serializable-rw+) 65 | "A list of symbols for string constants which set Postgres isolation 66 | levels, and read only or read/write settings. Nested transactions must 67 | be started with an isolation level to the left of, or at the same 68 | level as, the top level in the nested group.") 69 | 70 | (defun potential-serialization-failure-p (isolation-level) 71 | "Certain isolation levels require client handling of the 72 | cl-postgres-error:serialization-failure condition. This function 73 | returns true if ISOLATION-LEVEL, a symbol, is such an isolation 74 | level." 75 | (member isolation-level '(+repeatable-read-rw+ +serializable-rw+))) 76 | 77 | (defun isolation-level-position (isolation-level) 78 | "What POSITION does ISOLATION-LEVEL, a symbol, hold in the 79 | *ISOLATION-LEVELS-HIERARCHY*?" 80 | (position isolation-level *isolation-levels-hierarchy*)) 81 | 82 | (defun nestable-isolation-level-p (top-isolation-level isolation-level) 83 | "Can you nest a new (virtual) transaction with ISOLATION-LEVEL, a 84 | symbol, inside a (true) transaction with TOP-ISOLATION-LEVEL?" 85 | (<= (isolation-level-position isolation-level) 86 | (isolation-level-position top-isolation-level))) 87 | 88 | (define-condition incompatible-transaction-setting (error) 89 | ((transaction-name :initarg :transaction-name :reader transaction-name) 90 | (original :initarg :original :reader original) 91 | (current :initarg :current :reader current)) 92 | (:report (lambda (condition stream) 93 | (format stream "You cannot nest the transaction named ~A with isolation level ~A 94 | inside a transaction with isolation level ~A." 95 | (transaction-name condition) 96 | (current condition) 97 | (original condition)))) 98 | (:documentation "Signaled for a nested invocation of 99 | WITH-ENSURED-TRANSACTION-LEVEL or WITH-LOGICAL-TRANSACTION-LEVEL 100 | inside a previous invocation with an incongruent isolation level.")) 101 | 102 | (defun check-isolation-level (label isolation-level) 103 | (unless (nestable-isolation-level-p *top-isolation-level* isolation-level) 104 | (error 'incompatible-transaction-setting 105 | :transaction-name label 106 | :original *top-isolation-level* 107 | :current isolation-level))) 108 | 109 | (defun transaction-thunk (transaction body) 110 | `(lambda (,transaction) 111 | (declare (ignorable ,transaction)) 112 | ,@body)) 113 | 114 | ;;;; Transactions proper in CALL-WITH style. 115 | ;;;; Semi public - some clients may need/want these 116 | 117 | (defun call-with-transaction-level (label isolation-level thunk) 118 | (log:debug "Starting transaction ~A" label) 119 | ;; See postgres/postmodern.lisp for our proposed mods to Postmodern 120 | (let ((pomo:*transaction-mode* (symbol-value isolation-level)) 121 | (*top-isolation-level* isolation-level)) 122 | (multiple-value-prog1 (pomo:call-with-transaction thunk) 123 | (log:debug "Completing transaction ~A" label)))) 124 | 125 | (defun call-with-logical-transaction-level (label isolation-level thunk) 126 | (multiple-value-prog1 127 | (if *top-isolation-level* 128 | (progn 129 | (check-isolation-level label isolation-level) 130 | (log:debug "Nesting logical transaction ~A" label) 131 | (pomo:call-with-logical-transaction label thunk)) 132 | (call-with-transaction-level label isolation-level thunk)) 133 | (log:debug "Completing logical transaction ~A" label))) 134 | 135 | (defun call-with-ensured-transaction-level (label isolation-level thunk) 136 | (multiple-value-prog1 137 | (if *top-isolation-level* 138 | (progn 139 | (check-isolation-level label isolation-level) 140 | (log:trace "Nesting ensured transaction ~A" label) 141 | ;; There is no "real" transaction to abort, so don't pass in label 142 | (funcall thunk nil)) 143 | (progn 144 | (log:trace "Starting ensured transaction ~A" label) 145 | (call-with-transaction-level label isolation-level thunk))) 146 | (log:trace "Completing ensured transaction ~A" label))) 147 | 148 | (defun call-with-retry-serialization-failure (label thunk) 149 | (if *serialization-failure-sleep-times* 150 | (dolist (sleep *serialization-failure-sleep-times* (funcall thunk)) 151 | (log:trace "In retry serial loop with sleep: ~A" sleep) 152 | (handler-case 153 | (return (funcall thunk)) 154 | (cl-postgres-error:serialization-failure () 155 | (log:debug "Handle serialization failure of ~A. Sleeping around: ~A" label sleep) 156 | (unless (zerop sleep) ; Do not wait the first time through 157 | (sleep (+ sleep (/ (random 2000) 1000))))))) 158 | (funcall thunk))) 159 | 160 | ;;;; Public macro interface 161 | 162 | ;;; These have the same name as their Postmodern counterparts but with 163 | ;;; a -level suffix. The do the same thing but allow specification of 164 | ;;; an isolation level. 165 | 166 | (defmacro with-transaction-level ((name isolation-level) &body body) 167 | "Unilaterally evaluate BODY inside a Postmodern WITH-TRANSACTION 168 | form with Postgres 'transaction mode' set to the symbol-value of 169 | ISOLATION-LEVEL, a symbol. The symbol NAME is bound to the Postmodern 170 | `transaction-handle' and may be used in calls to Postmodern's 171 | abort-transaction and commit-transaction." 172 | `(call-with-transaction-level ',name ',isolation-level 173 | ,(transaction-thunk name body))) 174 | 175 | (defmacro with-logical-transaction-level ((name isolation-level) &body body) 176 | "Similar to Postmodern's WITH-LOGICAL-TRANSACTION but start any top 177 | level transaction with Postgres 'transaction mode' set to the 178 | symbol-value of ISOLATION-LEVEL. The symbol NAME is bound to the 179 | Postmodern `transaction-handle' and may be used in calls to 180 | Postmodern's abort-transaction and commit-transaction. The condition 181 | `incompatible-transaction-setting' will be signaled for incongruent 182 | nested isolation levels." 183 | `(call-with-logical-transaction-level ',name ',isolation-level 184 | ,(transaction-thunk name body))) 185 | 186 | (defmacro ensure-transaction-level ((isolation-level) &body body) 187 | "Similar to Postmodern's ENSURE-TRANSACTION but start any top level 188 | transaction with Postgres 'transaction mode' set to the symbol-value 189 | of ISOLATION-LEVEL. The condition `incompatible-transaction-setting' 190 | will be signaled for incongruent nested isolation levels." 191 | (let ((label (gensym "TRAN"))) 192 | `(call-with-ensured-transaction-level ',label ',isolation-level 193 | ,(transaction-thunk label body)))) 194 | -------------------------------------------------------------------------------- /t/transactions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :postgres-json-test) 2 | 3 | ;;;; Transactions with isolation levels 4 | 5 | (test no-nesting-actual-tran 6 | (with-transaction-level (foo +read-committed-rw+) 7 | (signals cl-postgres:postgresql-warning 8 | (with-transaction-level (foo +read-committed-rw+) 9 | (pomo:query "create temp table foo (bar int)"))))) 10 | 11 | (test not-nestable-isolation-levels 12 | (ensure-transaction-level (+read-committed-ro+) 13 | (tally -model-) 14 | (signals postgres-json:incompatible-transaction-setting 15 | (ensure-transaction-level (+repeatable-read-rw+) 16 | (excise -model- 7)))) 17 | 18 | (ensure-transaction-level (+read-committed-rw+) 19 | (tally -model-) 20 | (signals postgres-json:incompatible-transaction-setting 21 | (ensure-transaction-level (+serializable-rw+) 22 | (excise -model- 7)))) 23 | 24 | (ensure-transaction-level (+repeatable-read-rw+) 25 | (tally -model-) 26 | (ensure-transaction-level (+read-committed-ro+) 27 | (keys -model-) 28 | (signals postgres-json:incompatible-transaction-setting 29 | (ensure-transaction-level (+serializable-rw+) 30 | (excise -model- 7)))))) 31 | 32 | (test read-only-tran 33 | (with-transaction-level (foo +read-committed-ro+) 34 | (signals cl-postgres:database-error 35 | (pomo:query "create temp table foo (bar int)")))) 36 | 37 | (test manual-tran 38 | (with-model-transaction (a) 39 | (excise -model- 7) 40 | (insert -model- (obj "foo" 17 "bar" #(1 2 3)) 7) 41 | (supersede -model- 7 (obj "foo" 17 "bar" #(1 2 3 4))) 42 | (is (= 17 (gethash "foo" (fetch -model- 7))))) 43 | 44 | (with-model-transaction (b) 45 | (excise -model- 7) 46 | (insert -model- (obj "foo" 17 "bar" #(1 2 3)) 7) 47 | (with-model-transaction (c) 48 | (supersede -model- 7 (obj "foo" 17 "bar" #(1 2 3 4))) 49 | (is (= 17 (gethash "foo" (fetch -model- 7))))))) 50 | 51 | ;; ;;;; Parallel tests 52 | 53 | (defun call-with-multiple-supersedes (thunk) 54 | (dotimes (i *updates*) 55 | (funcall thunk))) 56 | 57 | (defmacro with-multiple-supersedes (() &body body) 58 | `(call-with-multiple-supersedes (lambda () ,@body))) 59 | 60 | (defmacro with-key-supersede ((key) &body body) 61 | `(let ((*pgj-channel* (make-pgj-channel)) 62 | (,key (with-conn () (first (keys -cat-))))) 63 | (flet ((supersede () 64 | (supersede -cat- ,key (obj "name" (format nil "name-~A" key) "coat" "scruffy")))) 65 | ,@body))) 66 | 67 | (defun count-text-in-list (text list) 68 | (count-if (lambda (value) 69 | (and (stringp value) 70 | (search text value))) 71 | list)) 72 | 73 | (defun key-violation-p (text) 74 | (and (stringp text) 75 | (search "Database error 23505" text))) 76 | 77 | (defun results-serialization-failure-p (results) 78 | (not (zerop (count-text-in-list "Database error 40001" results)))) 79 | 80 | (defun strip-results () 81 | (let ((results (process-results))) 82 | ;; It certainly is not a perfect method... 83 | (unless (= *updates* (length results)) 84 | (setf results (append results (process-results (* *process-results-timeout* 2))))) 85 | (let ((stripped (remove-if #'key-violation-p results))) 86 | (let ((key-violations (- (length results) (length stripped)))) 87 | (unless (zerop key-violations) 88 | (log:info "Saw ~A key violations. 1 or 2 are possible..." key-violations)) 89 | (values key-violations stripped))))) 90 | 91 | ;;; Here we supersede a single record in one of our models *updates* 92 | ;;; times, all at once by using lparallel. This is an unusual use 93 | ;;; case, but does serve to exercise the serialization failure 94 | ;;; handling. Some key violations in the cat_old table are possible 95 | ;;; as the primary key there is just the key from the cat table plus 96 | ;;; the Postgres clock timestamp... 97 | 98 | ;;; Unfortunately these are non-deterministic because just asking that 99 | ;;; serialization failures be handled under the covers doesn't mean 100 | ;;; they will be as we do not sleep indefinitely waiting till the 101 | ;;; failures disappear. The idea is that it becomes *very unlikely* 102 | ;;; except under *extremely pathological cases*, which means we expect 103 | ;;; these tests to pass. 104 | 105 | (test default-multiple 106 | (with-key-supersede (key) 107 | (with-multiple-supersedes () 108 | (submit-pgj-task () 109 | (supersede))) 110 | (multiple-value-bind (key-violations results) (strip-results) 111 | (is (= *updates* (+ key-violations (length results)))) 112 | (is (>= *ok-key-violations* key-violations)) 113 | (is (= key (reduce #'min results)))))) 114 | 115 | (test model-tran-multiple 116 | (with-key-supersede (key) 117 | (with-multiple-supersedes () 118 | (submit-pgj-task () 119 | (with-model-transaction () 120 | (supersede)))) 121 | (multiple-value-bind (key-violations results) (strip-results) 122 | (is (= *updates* (+ key-violations (length results)))) 123 | (is (>= *ok-key-violations* key-violations)) 124 | (is (= key (reduce #'min results)))))) 125 | 126 | (test no-serial-multiple 127 | (with-key-supersede (key) 128 | (with-multiple-supersedes () 129 | (submit-pgj-task () 130 | (let ((*serialization-failure-sleep-times* nil)) 131 | (supersede)))) 132 | (is (results-serialization-failure-p (process-results))))) 133 | 134 | (test ensure-tran-multiple 135 | (with-key-supersede (key) 136 | (with-multiple-supersedes () 137 | (submit-pgj-task () 138 | ;; We set the right isolation level but fail to handle the 139 | ;; resulting serialization failures 400001... 140 | (ensure-transaction-level (+repeatable-read-rw+) 141 | (supersede)))) 142 | (is (results-serialization-failure-p (process-results))))) 143 | 144 | ;; ;;;; Model transaction handling 145 | 146 | (test no-explicit-tran 147 | (excise -model- 7) 148 | (insert -model- (obj "foo" 17 "bar" #(1 2 3)) 7) 149 | (supersede -model- 7 (obj "foo" 17 "bar" #(1 2 3 4))) 150 | (is (= 4 (length (gethash "bar" (fetch -model- 7)))))) 151 | 152 | (test model-tran 153 | (with-model-transaction () 154 | (excise -model- 7) 155 | (insert -model- (obj "foo" 17 "bar" #(1 2 3)) 7) 156 | (supersede -model- 7 (obj "foo" 17 "bar" #(1 2 3 4))) 157 | (is (= 4 (length (gethash "bar" (fetch -model- 7))))))) 158 | 159 | (test rollback-1 160 | (let (key) 161 | (ignore-errors 162 | (with-model-transaction (foo) 163 | (setf key (insert -model- 1234)) 164 | (error "Foo"))) 165 | (is (not (fetch -model- key))))) 166 | 167 | (test rollback-2 168 | (let (key) 169 | (with-model-transaction (foo) 170 | (setf key (insert -model- 1234)) 171 | (pomo:abort-transaction foo)) 172 | (is (not (fetch -model- key))))) 173 | 174 | (test nested-rollback-1 175 | (with-model-transaction (a) 176 | (excise -model- 7)) 177 | (with-model-transaction (b) 178 | (insert -model- (obj "foo" 17 "bar" #(1 2 3)) 7) 179 | (rollback b) 180 | (is (not (fetch -model- 7)))) 181 | (is (not (fetch -model- 7)))) 182 | 183 | (test nested-rollback-2 184 | (with-model-transaction (a) 185 | (excise -model- 7)) 186 | (with-model-transaction (b) 187 | (insert -model- 123 7) 188 | (with-model-transaction (c) 189 | (supersede -model- 7 124) 190 | (is (= 124 (fetch -model- 7))) 191 | (rollback c)) 192 | (is (= 123 (fetch -model- 7)))) 193 | (is (= 123 (fetch -model- 7)))) 194 | 195 | (test nested-rollback-3 196 | (with-model-transaction (a) 197 | (excise -model- 7)) 198 | (with-model-transaction (b) 199 | (insert -model- 123 7) 200 | (with-model-transaction (c) 201 | (supersede -model- 7 124) 202 | (is (= 124 (fetch -model- 7))) 203 | (rollback c) 204 | (is (= 123 (fetch -model- 7)))) 205 | (is (= 123 (fetch -model- 7))) 206 | (rollback b) 207 | (is (not (fetch -model- 7)))) 208 | (is (not (fetch -model- 7)))) 209 | 210 | (test nested-rollback-4 211 | (with-model-transaction (a) 212 | (excise -model- 7) 213 | (with-model-transaction (b) 214 | (insert -model- (obj "foo" 17 "bar" #(1 2 3)) 7) 215 | (with-model-transaction (c) 216 | (supersede -model- 7 (obj "foo" 18 "bar" #(1 2 3))) 217 | (rollback c)) 218 | (is (= 17 (gethash "foo" (fetch -model- 7)))) 219 | (rollback b)) 220 | (is (not (fetch -model- 7))))) 221 | 222 | (test nested-commit-1 223 | (with-model-transaction (a) 224 | (excise -model- 7)) 225 | (with-model-transaction (b) 226 | (insert -model- 123 7) 227 | (is (= 123 (fetch -model- 7)))) 228 | (is (= 123 (fetch -model- 7)))) 229 | 230 | (test nested-commit-2 231 | (with-model-transaction (a) 232 | (excise -model- 7)) 233 | (with-model-transaction (b) 234 | (insert -model- 123 7) 235 | (with-model-transaction (c) 236 | (supersede -model- 7 124) 237 | (is (= 124 (fetch -model- 7)))) 238 | (is (= 124 (fetch -model- 7)))) 239 | (is (= 124 (fetch -model- 7)))) 240 | 241 | (test nested-commit-3 242 | (with-model-transaction (a) 243 | (excise -model- 7)) 244 | (with-model-transaction (b) 245 | (insert -model- 123 7) 246 | (with-model-transaction (c) 247 | (supersede -model- 7 124) 248 | (is (= 124 (fetch -model- 7))) 249 | (commit c) 250 | (is (= 124 (fetch -model- 7)))) 251 | (is (= 124 (fetch -model- 7))) 252 | (rollback b) 253 | (is (not (fetch -model- 7)))) 254 | (is (not (fetch -model- 7)))) 255 | 256 | (test commit-early 257 | (let (key) 258 | (with-model-transaction (foo) 259 | (setf key (insert -model- 1234)) 260 | (commit foo) 261 | (rollback foo)) 262 | (is (fetch -model- key)))) 263 | 264 | (test nested-model-tran-1 265 | (with-model-transaction (a) 266 | (excise -model- 7) 267 | (with-model-transaction (b) 268 | (insert -model- (obj "foo" 17 "bar" #(1 2 3)) 7) 269 | (with-model-transaction (c) 270 | (supersede -model- 7 (obj "foo" 17 "bar" #(1 2 3))))) 271 | (is (= 3 (length (gethash "bar" (fetch -model- 7)))))) 272 | (is (= 3 (length (gethash "bar" (fetch -model- 7)))))) 273 | 274 | (test nested-model-tran-2 275 | (flet ((supersede-many (key) 276 | (with-model-transaction (bar) 277 | (dotimes (i 10) 278 | (supersede -model- key (obj "name" "Joey" "coat" "tabby" "count" i)))))) 279 | (with-model-transaction (foo) 280 | (excise -model- 6) 281 | (insert -model- (obj "name" "Joey" "coat" "tabby") 6) 282 | (let ((len (length (history -model- 6)))) 283 | (supersede-many 6) 284 | (is (= 10 (- (length (history -model- 6)) len))))))) 285 | -------------------------------------------------------------------------------- /doc/user-guide.md: -------------------------------------------------------------------------------- 1 | Postgres-JSON User Guide 2 | ======================== 3 | 4 | ## Introduction 5 | 6 | If you are already proficient in Common Lisp and relational databases 7 | and/or JSON you should find the [examples](../examples) and the [reference 8 | documentation](api.md) sufficent to get going. Otherwise the 9 | [Beginner's Guide](beginners.md) and this document may help. 10 | 11 | ### Motivation 12 | 13 | Consider the (edited) first JSON object in the JSON file 14 | http://gtod.github.io/human.json: 15 | 16 | ```JSON 17 | { 18 | "guid": "d3129e77-9931-4fb1-bfca-d2a28bb641bf", 19 | "name": "Henry Gibson", 20 | "tags": [ 21 | "nostrud", 22 | "et" 23 | ], 24 | "gender": "male", 25 | "age": 31, 26 | "favoriteFruit": "banana", 27 | "email": "henrygibson@kengen.com", 28 | "phone": "+1 (942) 411-3974", 29 | "address": "833 Gerald Court, Lewis, Virginia, 9307", 30 | "friends": [ 31 | { 32 | "id": 0, 33 | "name": "Dena Marquez" 34 | } 35 | ], 36 | "isActive": false 37 | }, 38 | ``` 39 | 40 | For some projects it makes sense to spend a lot of design time on data 41 | dictionaries and table definitions in 3NF and other projects call for 42 | just: 43 | 44 | ```common-lisp 45 | (define-global-model human -human- (pgj-object-model)) 46 | (ensure-backend -human-) 47 | 48 | (with-input-from-file (stream *human-file*) 49 | (with-model-transaction () 50 | (dolist (human (yason:parse stream)) 51 | (insert -human- human)))) 52 | ``` 53 | 54 | ## Overview 55 | 56 | A *model* such as `human` above is simply a Common Lisp class. 57 | [`define-global-model`](api.md#define-global-model) makes this class 58 | and also makes a single instance of it (here called `-human-`). We 59 | only need one instance because Postgres-JSON model classes *have no 60 | slots* so all instances are functionally equivalent. Of course, you 61 | are free to define a model class and any instances without using 62 | `define-global-model`. 63 | 64 | There are a few [Model types](api.md#model-types) to chose as a direct 65 | superclass for your model but typically you want `pgj-object-model` or 66 | `pgj-history-object-model`. The later gives you 67 | [`history`](api.md#history). *TODO: more history generic functions*. 68 | 69 | To customize a model you simply [specialize generic functions] 70 | (api.md#model-customization-generic-functions): see 71 | [customize](../examples/customize.lisp) for examples. However in many 72 | cases you will find no customization is necessary --- you simply 73 | [define a model](api.md#define-global-model), [ensure it has a 74 | backend](api.md#ensure-backend) in your Postgres DB and then call 75 | [model interface](api.md#model-crud-generic-functions) generic 76 | functions on it. 77 | 78 | If necesary you can make some [user defined 79 | queries](#user-defined-json-queries), exemplified in 80 | [human-2](../examples/human-2.lisp). 81 | 82 | In some sense this is all pretty elementary. It's easy to get away 83 | with this because Common Lisp and Postgres are themselves very 84 | flexible and powerful. The mapping between JSON and lisp objects is 85 | relatively natural and so a lot can be accomplished by leveraging 86 | these three technologies in concert... 87 | 88 | ## Terminology 89 | 90 | ### JSON terms 91 | 92 | The [Beginner's Guide](beginners.md) has informal definitions and 93 | http://www.json.org has formal defintions of the following terms: 94 | *JSON object, JSON array, JSON value, JSON string, JSON number*. 95 | 96 | It's worth repeating that a *JSON object* is a key/value map, where 97 | the keys must be strings. It's important to keep this notion distinct 98 | from the more general notion of a *lisp object*, and often which 99 | *object* is meant must be gleaned from context. 100 | 101 | ##### JSON document 102 | 103 | * Abstract DB: A *relation* has many *tuples*. 104 | * Concrete DB: A *table* has may *rows*. 105 | * Postgres-JSON: A *model* has many *JSON documents*. 106 | 107 | A *JSON document* in the broadest sense is any piece of JSON text. We 108 | use it to mean a specific JSON text (typically using a *JSON object* 109 | as it's *top level*) that resides in a specific *model*. 110 | 111 | ###### Homogeneous JSON documents 112 | 113 | It is worth saying explicitly that there is nothing stopping you 114 | creating some model `cat` and then stuffing *any JSON document you 115 | like* into it: 116 | 117 | ```common-lisp 118 | (define-global-model cat -cat- (pgj-model)) 119 | (ensure-backend -cat-) 120 | 121 | (insert -cat- 1) 122 | (insert -cat- "Foo") 123 | (insert -cat- (list 1 2 "Foo")) 124 | (insert -cat- (obj "name" "Joey" "coat" "tabby" "age" 7)) 125 | ``` 126 | 127 | This is the power (and the terror) of the NoSQL approach compared with 128 | the traditional relational one. Typically, however, you want to put 129 | **only** cat like JSON documents into a cat model: 130 | 131 | ```common-lisp 132 | (define-global-model cat -cat- (pgj-object-model)) 133 | (ensure-backend -cat-) 134 | 135 | (insert -cat- (obj "name" "Joey" "coat" "tabby" "age" 7)) 136 | (insert -cat- (obj "name" "max" "coat" "ginger")) 137 | (insert -cat- (obj "name" "maud" "coat" "tortoiseshell")) 138 | ``` 139 | 140 | Although we have signaled our intent to use only *JSON objects* as 141 | cats by giving `cat` the direct superclass `pgj-object-model` this is 142 | not really enforced by the interface code. It's just that certain 143 | methods such as [`enumerate-property`](api.md#enumerate-property) 144 | are only specialized on `pgj-object-model`. 145 | 146 | ##### Top level 147 | 148 | You can arbitrarily nest JSON structures (objects or arrays) but, by 149 | the definition of nesting, there will be a root or *top level* 150 | structure. (In fact you can store strings and numbers directly in a 151 | *model* but then you have no top level structure). It is this 152 | structure that the Postgres [existence operator] 153 | (http://www.postgresql.org/docs/9.4/static/datatype-json.html#JSON-CONTAINMENT) 154 | works on. 155 | 156 | Here the [*properties*](#property) `"guid"` is at the top level, but `"id"` is not: 157 | 158 | ```common-lisp 159 | { 160 | "guid": "d3129e77-9931-4fb1-bfca-d2a28bb641bf", 161 | "name": "Henry Gibson", 162 | "friends": [ 163 | { 164 | "id": 0, 165 | "name": "Dena Marquez" 166 | } 167 | ], 168 | }, 169 | 170 | ``` 171 | 172 | ##### JSON Serialization 173 | 174 | The process of converting a Common Lisp *object* to a *JSON document*, 175 | which is really just a string or stream of JSON. Typically Lisp 176 | objects are serialized to JSON before being inserted into a Postgres 177 | *backend* *model*. 178 | 179 | ### Common Lisp terms 180 | 181 | ##### Object 182 | 183 | When not explicitly qualifed by a "JSON" prefix, *object* is used in 184 | the most general Common Lisp sense of "any common lisp datum". 185 | Examples of Common Lisp objects include hash tables, vectors, strings 186 | and numbers and in fact these are just the sort of objects ideal for 187 | *JSON serialization*. The `object` parameter of many of the [model 188 | CRUD functions](api.md#model-crud-generic-functions) is used in this 189 | sense. 190 | 191 | ### Postgres-JSON terms 192 | 193 | ##### Backend 194 | 195 | *Backend* describes a thin layer of abstraction over the Postgres 196 | schema [`*pgj-schema*`](api.md#pgj-schema) in which all *models* are 197 | created. A Postgres schema is similar to a Common Lisp package in 198 | that it provides a namespace for database tables etc. All the [model 199 | interface](api.md#model-crud-generic-functions) functions use the 200 | default schema automatically. But for [user defined 201 | queries](#user-defined-json-queries) you must go 202 | to a little more trouble. The (trivial) backend functions are 203 | documented in the API under [Postgres 204 | backend](api.md#postgres-backend). 205 | 206 | ##### Model 207 | 208 | The term *model* (or *backend model*) serves to describe a thin layer 209 | of abstraction over one (or two, if we are keeping history) Postgres 210 | tables in which *JSON documents* of a similar nature are stored. It's 211 | a term best understood when used concretely: "the cat model", "the 212 | human model" etc. Every model has the same *model interface*. 213 | 214 | Specific models in Postgres-JSON are CLOS classes, for which 215 | (typically) we create just a single global instance in order to call 216 | methods on the model. We only need a single instance as the **objects 217 | have no slots** so all instances are functionally equivalent. 218 | 219 | ##### Model interface 220 | 221 | The set of Common Lisp functions such as `insert` and `fetch` that 222 | provide a simple inteface to the underlying database operations on the 223 | *JSON documents* of a specific *model*. See the [model 224 | interface](api.md#model-crud-generic-functions). 225 | 226 | ##### Key 227 | 228 | Typically used in the database sense of the *primary key* of a *JSON 229 | document* stored in a specific Postgres-JSON *model*. *Key* is often 230 | short in Common Lisp for "hash table key" but we try and use 231 | *property* for the second meaning. 232 | 233 | ##### Property 234 | 235 | * Common Lisp: A *hash table* maps a *key* to a *value*. 236 | * JavaScript: An *object* maps a *property* to a *value*. 237 | * JSON: An *object* maps a *string* to a *value*. 238 | 239 | Because we want to reserve the word *key* for use in the database 240 | sense of *primary key*, and because *string* is too general, we use 241 | the word *property* to describe the left hand side of a *JSON object* 242 | string/value pair. Note well, a property is **always a string**. The 243 | following *JSON object* has the three properties `key`, `coat` 244 | and `name`. 245 | 246 | ```common-lisp 247 | { 248 | "key":1, 249 | "coat":"tabby", 250 | "name":"joey" 251 | } 252 | ``` 253 | 254 | See, for example, [having-property](api.md#having-property). 255 | 256 | ## User defined JSON queries 257 | 258 | These are documented as part of the [API] 259 | (api.md#user-queries-and-json-syntactic-sugar-for-s-sql) 260 | but some explanation and examples follow. 261 | 262 | Because any given [*model*](#model) is just a thin layer over some 263 | Postgres database tables, we can query them directly. In some sense 264 | this means our abstraction leaks but I'm not in the business of trying 265 | to pretend SQL isn't a fine way to query a relational database... 266 | 267 | [`define-json-query`](api.md#define-json-query) is a fairly light 268 | wrapper over a standard Postmodern S-SQL query form. If you are not 269 | familair with S-SQL, read one or both of these: 270 | 271 | * https://sites.google.com/site/sabraonthehill/postmodern-examples/postmodern-intro-to-s-sql#simple-queries 272 | * https://marijnhaverbeke.nl/postmodern/s-sql.html). 273 | 274 | What you get in addition is some syntactic sugar and the optional use 275 | of parameter names in the prepared queries. 276 | 277 | #### JSON query syntactic sugar 278 | 279 | S-SQL largely supports the various JSON operators and does the right 280 | thing when you use function syntax such as `(:json-build-object ...)`. 281 | 282 | But the standard syntax becomes verbose with heavy use so 283 | some more concise forms are defined in 284 | [user-query.lisp](../model/user-query.lisp). Everything else is still 285 | S-SQL but any list starting with a symbol in the list below gets 286 | special treatment when used in a `define-json-query` query: 287 | 288 | * [`j->`](api.md#j-) returns a JSON object propery as JSON. 289 | * [`j->>`](api.md#j--1) returns a JSON object propery as text. 290 | * [`jbuild`](api.md#jbuild) returns a JSON object built out of JSON pieces on the database side. 291 | * [`to-jsonb`](api.md#to-jsonb) casts an S-SQL form to Postgres type `jsonb`. 292 | 293 | You can use the full model name such as `'cat` with these macros 294 | (the quote is optional) but if in your `:from` or `:join` clause you 295 | use an `:as` assignment then you can also use the assigned 296 | symbol. 297 | 298 | **Because they are all macros you can simply macroexpand them to see 299 | what S-SQL they turn into**. Do not evaluate them, they are not 300 | Common Lisp. 301 | 302 | ```common-lisp 303 | ; sugar ; S-SQL 304 | (j-> "id") (:-> 'jdoc "id") 305 | (j-> 'cat "id") (:-> 'cat.jdoc "id"). 306 | (j->> 'c "id") (:->> 'c.jdoc "id"). 307 | ``` 308 | 309 | ```common-lisp 310 | ; sugar ; S-SQL 311 | (to-jsonb 1) (:TYPE (:TO-JSON 1) JSONB) 312 | ``` 313 | 314 | ```common-lisp 315 | ; sugar ; S-SQL 316 | (jbuild ("id" "name")) (:JSON-BUILD-OBJECT "id" (:-> 'JDOC "id") "name" (:-> 'JDOC "name")) 317 | (jbuild ('cat "id" "name")) (:JSON-BUILD-OBJECT "id" (:-> 'CAT.JDOC "id") "name" (:-> 'CAT.JDOC "name")) 318 | ``` 319 | 320 | ```common-lisp 321 | ;; OK, no duplicated keys 322 | (jbuild (cat "id" "name") (dog "age")) ; No quotes actually needed 323 | 324 | (:JSON-BUILD-OBJECT "id" (:-> 'CAT.JDOC "id") "name" (:-> 'CAT.JDOC "name") 325 | "age" (:-> 'DOG.JDOC "age")) 326 | ``` 327 | 328 | ```common-lisp 329 | ;; Explicitly label duplicate key 330 | (jbuild ('cat "id" "name") ('dog ("dog-id" "id") "age")) 331 | 332 | (:JSON-BUILD-OBJECT "id" (:-> 'CAT.JDOC "id") "name" (:-> 'CAT.JDOC "name") 333 | "dog-id" (:-> 'DOG.JDOC "id") "age" (:-> 'DOG.JDOC "age")) 334 | ``` 335 | 336 | `j->` and `j->>` only take one or two args. As shown above the table 337 | name is optional, unless of course this would lead to ambiguity. 338 | 339 | `to-jsonb` takes a single form as an argument, which will be converted 340 | by the Postgres TO-JSON function and then cast to the Postgres `jsonb` 341 | type. 342 | 343 | `jbuild` takes 1 or more lists as args. It is documented in the [API] 344 | (api.md#jbuild) but the above 345 | examples tell the full story. 346 | 347 | #### JSON query named parameter interpolation 348 | 349 | When using [`define-json-query`](api.md#define-json-query) you must 350 | supply some **QUERY-PARAMS** for each of the parameters the query will 351 | require at run time. Here `min-balance` and `gender`: 352 | 353 | ```common-lisp 354 | (define-json-query rich-humans$ (min-balance gender) 355 | (:order-by 356 | (:select (jbuild ("key" "guid" "gender" "name" "balance")) 357 | :from 'human 358 | :where (:and (:>= (:type (j->> "balance") real) min-balance) 359 | (:= (j->> "gender") gender))) 360 | (:type (j->> "balance") real))) 361 | 362 | (rich-humans$ 3900 "male") 363 | ``` 364 | 365 | You may write the symbols of the parameters list *inside the query 366 | form itself*, instead of the standard S-SQL '$1, '$2 etc, as evidenced 367 | above. 368 | 369 | And, similar to 370 | [`cl-ppcre:register-groups-bind`](http://weitz.de/cl-ppcre/#register-groups-bind), 371 | you may write each parameter as a list, the first element of which is 372 | a function designator to transform the actual arguments to the query 373 | at run time. See [`define-json-query`](api.md#define-json-query) and 374 | the example below. 375 | 376 | #### Examples 377 | 378 | ```common-lisp 379 | ;; We need filter arg as a JSON string, so request a funcall on *to-json* at run time 380 | (define-json-query one-friend-humans$ ((*to-json* filter) email-regex) 381 | (:select 'jdoc ;; 'jdoc is the generic name for the JSON column in all models 382 | :from 'human 383 | 384 | ;; Our 'jdoc column is Postgres type jsonb. j-> is sugar for 385 | ;; Postgres operator -> which returns a top level property in the 386 | ;; jdoc column as Postgres type jsonb. Thus we must apply jsonb 387 | ;; functions to it... 388 | :where (:and (:or (:@> 'jdoc filter)) ;; Postgres json containment 389 | (:= (:jsonb-array-length (j-> "friends")) 1) ;; Postgres jsonb function 390 | (:~ (j->> "email") email-regex)))) ;; Postgres regex operator 391 | ``` 392 | 393 | See [Empty JSON arrays and Common 394 | Lisp](#empty-json-arrays-and-common-lisp) for further discusson 395 | of the `jsonb-array-length` comparison above. 396 | 397 | ##### Joins 398 | 399 | ```common-lisp 400 | (define-json-query uncharitable-humans$ () 401 | (:select (jbuild (human "name") (gift "type" "quantity")) 402 | :from 'human 403 | :inner-join 'gift 404 | :on (:= (j-> human "key") (j-> gift "human-key")) 405 | :where (:= (j-> gift "quantity") (to-jsonb 1)))) 406 | ``` 407 | 408 | We could also write the above `:where` clause as 409 | ```common-lisp 410 | :where (:= (:type (j->> gift "quantity") int4) 1) 411 | ``` 412 | 413 | `j->>` asks that gift `"quantity"` be converted to Postgres type 414 | text, which we then cast to Postgres type int4 to compare with 1. 415 | 416 | What we actually did is convert Postgres type integer 1 to Postgres 417 | type jsonb using `(to-jsonb 1)`. We then compared it with property 418 | `"quantity"`, which is also Postgres type jsonb because Postgres 419 | operator `->` gives the raw jsonb of the key while Postgres operator 420 | `->>` converts it to text. *The type of the `jdoc` column in all 421 | models is Postgres jsonb.* 422 | 423 | See also [Prepared queries data 424 | types](../TODO.md#prepared-queries-data-types) in the TODO. 425 | 426 | #### Search path shenanigans 427 | 428 | We don't have to worry too much about schema search paths because the 429 | Postgres *qualified name* is harcoded into model based queries using 430 | [`*pgj-schema*`](api.md#pgj-schema). But they are important for user 431 | defined queries because `:from 'cat` (which is what we want to write) 432 | does not qualify the cat table, we really need `:from 'pgj-model.cat`. 433 | When using PSQL you can do: 434 | 435 | ```sql 436 | SET search_path TO pgj_model, public; 437 | ``` 438 | 439 | so that `select * from cat` will just work. For connections 440 | from Common Lisp you can: 441 | 442 | * Wrap connection calls in a macro such as this where 443 | [`*default-search-path*`](api.md#default-search-path) is an exported 444 | symbol of the Postgres-JSON package. However there is a little 445 | overhead to such a call: 446 | 447 | 448 | ```common-lisp 449 | (defmacro with-pj-connection (() &body body) 450 | `(pomo:with-connection *connection* 451 | (pomo:set-search-path *default-search-path*) 452 | ,@body)) 453 | ``` 454 | 455 | * Use 456 | [`alter-role-set-search-path`](api.md#alter-role-set-search-path) 457 | where you tell Postgres to use the specified search path for every 458 | connection of a given user. 459 | 460 | * Use the parallel version of Postgres-JSON (courtesy of 461 | http://lparallel.org/) where each worker has a persistent connection 462 | and the search path is set in a manner similar to the above. See 463 | [threads-test](../tests/thread-test.lisp). 464 | 465 | * Do anything else that works, such as hardcoding into `postgresql.conf`. 466 | I considered writing another sugar macro so that `(qn cat)` became 467 | `'pgj-model.cat` but did not want the syntax for user defined queries 468 | to stray too far from S-SQL. YMMV. 469 | 470 | ## Miscellaneous 471 | 472 | #### Empty JSON arrays and Common Lisp 473 | 474 | By default Yason will parse JSON arrays as Common Lisp lists and thus 475 | an empty array becomes an empty list, which is CL `NIL`. When we then 476 | ask yason to serialize our empty list back to JSON we get JSON `null`: 477 | 478 | ```common-lisp 479 | CL-USER> (yason:encode (yason:parse "[]")) 480 | null 481 | NIL 482 | ``` 483 | 484 | Now in order to write a Postgres query such as the following 485 | 486 | ```common-lisp 487 | (:select 'jdoc 488 | :from 'human 489 | :where (:= (:jsonb-array-length (j-> "friends")) 1)) 490 | ``` 491 | 492 | we need the values of the JSON object property `"friends"` to actually be an 493 | array, rather than `null`, when the person happens to be friendless. 494 | So instead we ask yason to do 495 | 496 | ``` 497 | CL-USER> (yason:encode (yason:parse "[]" :json-arrays-as-vectors t)) 498 | [] 499 | #() 500 | ``` 501 | 502 | which is what we want. Of course, YMMV with other JSON libraries. 503 | Yason is optional, you can use any JSON library you like, that is what 504 | [`*to-json*`](api.md#to-json) and [`*from-json*`](api.md#from-json) 505 | are for. You can also specialize [`serialize`](api.md#serialize) and 506 | [`deserialize`](api.md#deserialize) for more fine grained control 507 | based on the type of a model. 508 | 509 | #### Postmodern conditions 510 | 511 | All the Postmodern conditions will leak through this abstraction, it 512 | is a pretty thin layer. However because we are using the Postgres 513 | *repeatable read isolation level* to safely insert and update two 514 | tables at once in order to keep history, work has been done to handle 515 | *serialization failures* under the covers. 516 | -------------------------------------------------------------------------------- /doc/api.md: -------------------------------------------------------------------------------- 1 | # Postgres-JSON Interface 2 | * [Connections](#connections) 3 | * [Model types](#model-types) 4 | * [Basic model management](#basic-model-management) 5 | * [Model CRUD generic functions](#model-crud-generic-functions) 6 | * [Model transactions](#model-transactions) 7 | * [JSON helper functions and specials](#json-helper-functions-and-specials) 8 | * [User queries and JSON syntactic sugar for S-SQL](#user-queries-and-json-syntactic-sugar-for-s-sql) 9 | * [Model customization generic functions](#model-customization-generic-functions) 10 | * [Further model management](#further-model-management) 11 | * [Postgres backend](#postgres-backend) 12 | * [Postmodern isolation level transactions](#postmodern-isolation-level-transactions) 13 | * [lparallel support (optional)](#lparallel-support-(optional)) 14 | 15 | --- 16 | ## Connections 17 | #### \*postmodern-connection\* 18 | *Dynamic variable* 19 | 20 | Set this to a list congruent with the parameters expected by 21 | POSTMODERN:CONNECT-TOPLEVEL, for use by the testing and example 22 | code. 23 | 24 | #### ensure-top-level-connection 25 | *Function* 26 | 27 | ```common-lisp 28 | &optional (connect-spec *postmodern-connection*) 29 | ``` 30 | 31 | Ensure a Postmodern top level connection is active by applying the 32 | contents of the list **CONNECT-SPEC** to POMO:CONNECT-TOPLEVEL. 33 | 34 | 35 | --- 36 | ## Model types 37 | #### pgj-model 38 | *Class* 39 | 40 | The Postgres-JSON model base class supported by 41 | implementation and interface methods for storing, querying and 42 | modifying JSON documents in a Postgres database. 43 | 44 | #### pgj-history-model 45 | *Class* 46 | 47 | A Postgres-JSON model that maintains a history of 48 | previous values of updated or deleted documents. 49 | 50 | #### pgj-object-model 51 | *Class* 52 | 53 | A Postgres-JSON model that consists of JSON 54 | documents having an object root node. 55 | 56 | #### pgj-history-object-model 57 | *Class* 58 | 59 | A Postgres-JSON model that maintains history and 60 | consists of JSON documents having an object root node. 61 | 62 | 63 | --- 64 | ## Basic model management 65 | #### define-global-model 66 | *Macro* 67 | 68 | ```common-lisp 69 | name constant (&rest superclasses) 70 | ``` 71 | 72 | Define a new class named **NAME**, a symbol, having **SUPERCLASSES**, all 73 | symbols. Define a global variable named **CONSTANT**, a symbol, with 74 | value an instance of the new class. 75 | 76 | #### ensure-backend 77 | *Generic function* 78 | 79 | ```common-lisp 80 | model 81 | ``` 82 | 83 | Call CREATE-BACKEND on **MODEL** unless said backend 84 | already exists. 85 | 86 | #### drop-backend 87 | *Generic function* 88 | 89 | ```common-lisp 90 | model 91 | ``` 92 | 93 | Drop the Postgres backend of **MODEL**. This will 94 | irrevocably delete all data associated with the model. 95 | 96 | 97 | --- 98 | ## Model CRUD generic functions 99 | #### insert 100 | *Generic function* 101 | 102 | ```common-lisp 103 | model object &optional key 104 | ``` 105 | 106 | Insert lisp object **OBJECT** into the backend **MODEL**, 107 | after JSON serialization. If **KEY** is supplied use that as the primary 108 | key for the JSON document rather than an automatically generated one. 109 | Return the new primary key. 110 | 111 | #### supersede 112 | *Generic function* 113 | 114 | ```common-lisp 115 | model key object 116 | ``` 117 | 118 | Replace the current value of the JSON document 119 | having primary key **KEY** in **MODEL** with the JSON serialization of lisp 120 | object **OBJECT**. Return **KEY** on success, NIL if no such **KEY** is found. 121 | 122 | #### supersede 123 | *Method* 124 | 125 | ```common-lisp 126 | (model pgj-history-model) key object 127 | ``` 128 | 129 | As per **SUPERSEDE** but keep a separate record of all previous rows. 130 | 131 | #### fetch 132 | *Generic function* 133 | 134 | ```common-lisp 135 | model key 136 | ``` 137 | 138 | If there is a JSON document with primary key **KEY** in 139 | **MODEL** return the result of deserializing it. Otherwise return NIL. 140 | 141 | #### fetch-all 142 | *Generic function* 143 | 144 | ```common-lisp 145 | model 146 | ``` 147 | 148 | Return as a list the result of deserializing all 149 | JSON documents in **MODEL**. 150 | 151 | #### excise 152 | *Generic function* 153 | 154 | ```common-lisp 155 | model key 156 | ``` 157 | 158 | Delete the JSON document with primary key **KEY** from 159 | **MODEL**. Return **KEY** on success, NIL if no such **KEY** exists. 160 | 161 | #### excise 162 | *Method* 163 | 164 | ```common-lisp 165 | (model pgj-history-model) key 166 | ``` 167 | 168 | As per **EXCISE** but keep a separate record of all deleted rows. 169 | 170 | #### excise-all 171 | *Generic function* 172 | 173 | ```common-lisp 174 | model 175 | ``` 176 | 177 | Delete all JSON documents in **MODEL**. Returns the 178 | number of documents deleted. 179 | 180 | #### excise-all 181 | *Method* 182 | 183 | ```common-lisp 184 | (model pgj-history-model) 185 | ``` 186 | 187 | As per **EXCISE-ALL** but keep a separate record of all deleted rows. 188 | 189 | #### keys 190 | *Generic function* 191 | 192 | ```common-lisp 193 | model 194 | ``` 195 | 196 | Return two values: a list of all primary keys for 197 | **MODEL** and the length of that list. 198 | 199 | #### tally 200 | *Generic function* 201 | 202 | ```common-lisp 203 | model 204 | ``` 205 | 206 | Return the count of all JSON documents in **MODEL**. 207 | 208 | #### having-property 209 | *Generic function* 210 | 211 | ```common-lisp 212 | model property 213 | ``` 214 | 215 | Return the result of deserializing all JSON 216 | documents in **MODEL** which have a top level object property **PROPERTY**, a 217 | string, or if said string appears as an element of a top level array. 218 | This is in the Postgres operator ? sense. Requires a Postgres GIN 219 | index with operator class :jsonb-ops defined on **MODEL**. 220 | 221 | #### enumerate-property 222 | *Generic function* 223 | 224 | ```common-lisp 225 | model property 226 | ``` 227 | 228 | Return all distinct values of the top level 229 | **PROPERTY**, a string, in all of the JSON documents of **MODEL**. JSON 230 | deserialization is performed by funcalling \*FROM-JSON\*. Note that 231 | this is _not_ a prepared query so care must be taken that **PROPERTY** is 232 | sanitized if it derives from arbitrary user input. 233 | 234 | #### filter 235 | *Generic function* 236 | 237 | ```common-lisp 238 | model &key contains 239 | ``` 240 | 241 | Filter all JSON documents in **MODEL** by checking they 242 | 'contain', in the Postgres @> operator sense, the object **CONTAINS** which 243 | will be serialized to a JSON document by funcalling \*TO-JSON\*. If 244 | **CONTAINS** is NIL, apply no containment restriction. 245 | 246 | #### filter 247 | *Method* 248 | 249 | ```common-lisp 250 | (model pgj-object-model) &key contains properties limit 251 | ``` 252 | 253 | Filter all JSON documents in **MODEL** as follows. Each document 254 | must 'contain', in the Postgres @> operator sense, the object **CONTAINS** 255 | which will be serialized to a JSON document by funcalling \*TO-JSON\*. 256 | If **CONTAINS** is NIL, apply no containment restriction. **PROPERTIES** may 257 | be a list of strings being properties in the top level of the JSON 258 | documents in **MODEL** and only the values of said properties will be 259 | returned, bundled together in a JSON document. If **PROPERTIES** is NIL 260 | the entire JSON document will be returned. **LIMIT**, if supplied, must 261 | be an integer that represents the maximum number of objects that will 262 | be returned. If properties is NIL JSON deserialization is performed 263 | by DESERILIZE, otherwise by funcalling \*FROM-JSON\*. Note that this is 264 | _not_ a prepared query so extra care must be taken if **PROPERTIES** or 265 | CONTAIN derive from unsanitized user input. 266 | 267 | #### history 268 | *Generic function* 269 | 270 | ```common-lisp 271 | model key &key 272 | ``` 273 | 274 | Return a list of the result of deserializing all 275 | previous values of the JSON document with primary key **KEY** in **MODEL**. 276 | 277 | #### history 278 | *Method* 279 | 280 | ```common-lisp 281 | (model pgj-history-model) key &key (validity-keys-p t) (valid-from-key "_validFrom") (valid-to-key "_validTo") 282 | ``` 283 | 284 | Return a list of the result of deserializing all previous values 285 | of the JSON document with primary key **KEY** in **MODEL**, in chronological 286 | order. If **VALIDITY-KEYS-P** is true, include the 'valid_from' and 287 | 'valid_to' Postgres timestamps for the historical document as 288 | properties in the top level JSON object --- it must be an object in 289 | this case. **VALID-FROM-KEY** and **VALID-TO-KEY** are strings that will be 290 | the property names of the respective timestamps. 291 | 292 | 293 | --- 294 | ## Model transactions 295 | #### with-model-transaction 296 | *Macro* 297 | 298 | ```common-lisp 299 | (&optional name) &body body 300 | ``` 301 | 302 | Evaluate **BODY** inside a Postgres transaction using the 'repeatable 303 | read' isolation level in read/write mode. Retry any serialization 304 | failures although chronic incidence will still result in the client 305 | seeing CL-POSTGRES-ERROR:SERIALIZATION-FAILURE conditions --- see also 306 | \*SERIALIZATION-FAILURE-SLEEP-TIMES\*. Implemented using Postmodern 307 | WITH-LOGICAL-TRANSACTION so may be nested. **NAME** can be used with 308 | Postmodern's abort-transaction and commit-transaction. **NAME** should not 309 | be a Postgres reserved word. Ideal for any group of mutating model 310 | interface functions. 311 | 312 | #### rollback 313 | *Function* 314 | 315 | ```common-lisp 316 | name 317 | ``` 318 | 319 | If this is the root node of a nested set of WITH-MODEL-TRANSACTIONs 320 | then 'rollback' the transaction **NAME**. Otherwise rollback to the 321 | Postgres savepoint **NAME**. 322 | 323 | #### commit 324 | *Function* 325 | 326 | ```common-lisp 327 | name 328 | ``` 329 | 330 | If this is the root node of a nested set of WITH-MODEL-TRANSACTIONs 331 | then 'commit' the transaction **NAME**. Otherwise merely release the 332 | savepoint **NAME**. 333 | 334 | #### \*serialization-failure-sleep-times\* 335 | *Dynamic variable* 336 | 337 | ```common-lisp 338 | '(0 1 2 4 7) 339 | ``` 340 | 341 | The length of this list of real numbers determines the number of 342 | times to retry when a Postgres transaction COMMIT sees a 343 | CL-POSTGRES-ERROR:SERIALIZATION-FAILURE condition. For each retry we 344 | sleep the duration specified plus a random number of milliseconds 345 | between 0 and 2000. However, if 0 sleep is specified, we do not sleep 346 | at all. If set to NIL no condition handling is performed hence the 347 | client will always see any such serialization failures. 348 | 349 | 350 | --- 351 | ## JSON helper functions and specials 352 | #### obj 353 | *Function* 354 | 355 | ```common-lisp 356 | &rest args 357 | ``` 358 | 359 | Return an 'equal key/value hash-table consisting of pairs of **ARGS**. 360 | For JSON use your keys must be Common Lisp strings. 361 | 362 | #### pp-json 363 | *Function* 364 | 365 | ```common-lisp 366 | object &key (stream *standard-output*) (indent 4) 367 | ``` 368 | 369 | Pretty print lisp **OBJECT** as JSON to **STREAM** with specified **INDENT**. 370 | 371 | #### \*to-json\* 372 | *Dynamic variable* 373 | 374 | ```common-lisp 375 | #'to-json 376 | ``` 377 | 378 | A function designator for a function of one argument which 379 | serializes a lisp object to a JSON string. 380 | 381 | #### \*from-json\* 382 | *Dynamic variable* 383 | 384 | ```common-lisp 385 | #'from-json 386 | ``` 387 | 388 | A function designator for a function of one argument which returns 389 | the result of parsing the JSON string being its input. 390 | 391 | 392 | --- 393 | ## User queries and JSON syntactic sugar for S-SQL 394 | #### define-json-query 395 | *Macro* 396 | 397 | ```common-lisp 398 | name (&rest query-params) &body query 399 | ``` 400 | 401 | Define a Postmodern S-SQL based **QUERY** with name **NAME**, a symbol. 402 | **QUERY** may use the macro forms j->, j->> jbuild and to-json, documented 403 | separately. Elements of **QUERY-PARAMS** may be symbols, the number and 404 | order of said symbols serving to define the parameters the query will 405 | be supplied with at run time. Additionally, any occurence of a symbol 406 | from the **QUERY-PARAMS** list in the **QUERY** from proper will be replaced 407 | with '$1, '$2 etc. as appropriate based on the order of **QUERY-PARAMS**. 408 | In this way your queries may use named parameters, but this is not 409 | mandatory. 410 | 411 | Furthermore, a la `cl-ppcre:register-groups-bind`, any element of the 412 | **QUERY-PARAMS** list may itself be a list of the form 413 | (function-designator &rest params) in which case the PARAMS are 414 | still treated as parameters, in order, but at run time 415 | FUNCTION-DESIGNATOR is called on each of the actual arguments of the 416 | PARAMS to transform said arguments before use by the underlying query. 417 | For example `(foo (\*to-json\* bar baz) blot)` is an acceptable 418 | **QUERY-PARAMS** list, as long as \*to-json\* is funcallable. bar and baz 419 | will be replaced by the result of funcalling \*to-json\* on them, 420 | repectively. 421 | 422 | The Postmodern result format is always `:column` and so you must 423 | ensure that each row produces just a single datum, being a valid 424 | Postgres JSON type. In practice this means either i) returning the 425 | column named `jdoc` in any model, which is the entire JSON document, 426 | or ii) using the `jbuild` macro to build a JSON object on the fly. 427 | 428 | #### j-> 429 | *Macro* 430 | 431 | ```common-lisp 432 | form1 &optional form2 433 | ``` 434 | 435 | S-SQL syntactic sugar to turn a single string **FORM1** into a 436 | Postgres -> operation using the default JSON column 'jdoc and the 437 | property FORM1; or to turn a symbol **FORM1** and string **FORM2** into a -> 438 | operation using the 'jdoc JSON column in table **FORM1** and the property 439 | **FORM2**. 440 | 441 | #### j->> 442 | *Macro* 443 | 444 | ```common-lisp 445 | form1 &optional form2 446 | ``` 447 | 448 | S-SQL syntactic sugar to turn a single string **FORM1** into a Postgres 449 | ->> operation using the default JSON column 'jdoc and the property 450 | FORM1; or to turn a symbol **FORM1** and string **FORM2** into a ->> operation 451 | using the 'jdoc JSON column in table **FORM1** and the property **FORM2**. 452 | 453 | #### to-jsonb 454 | *Macro* 455 | 456 | ```common-lisp 457 | form 458 | ``` 459 | 460 | S-SQL syntactic sugar to cast **FORM** to the Postgres jsonb type. 461 | 462 | #### jbuild 463 | *Macro* 464 | 465 | ```common-lisp 466 | &rest key-forms 467 | ``` 468 | 469 | S-SQL syntactic sugar to create a new Postgres JSON object from the 470 | **KEY-FORMS**. Each KEY-FORM is a list. In the simplest and first case 471 | it may be a list of strings, said strings indicating properties of the 472 | top level JSON object in the 'jdoc column of the query; the properties 473 | and their values will be returned by **JBUILD**, in a fresh JSON object. 474 | In the second case the list may start with a symbol (or a quoted 475 | symbol) in which case the following strings indicate properties of 476 | the top level JSON document in the 'jdoc column in the DB table named 477 | by the symbol. Now, a la `with-slots`, each string in the list may 478 | itself be replaced by a list of two strings, the first being the 479 | resulting property name in the object returned by **JBUILD**, the second 480 | being the accessor property for the top level JSON object in the 'jdoc 481 | column. This flexibility is required because we are building a JSON 482 | object and cannot have duplicate properties so if we need the "id" 483 | property from both a `cat` and a `dog` model, one of them needs to be 484 | relabeled. 485 | 486 | 487 | --- 488 | ## Model customization generic functions 489 | #### model-sequence 490 | *Generic function* 491 | 492 | ```common-lisp 493 | model 494 | ``` 495 | 496 | The name, a symbol, of a Postgres sequence to 497 | provide primary keys upon insertion of fresh documents into a backend 498 | model. May be NIL, in which case explicit primary keys must be 499 | supplied for all inserts. 500 | 501 | #### model-key-name 502 | *Generic function* 503 | 504 | ```common-lisp 505 | model 506 | ``` 507 | 508 | The name, a symbol, for the primary key column in 509 | backend model tables. 510 | 511 | #### model-key-type 512 | *Generic function* 513 | 514 | ```common-lisp 515 | model 516 | ``` 517 | 518 | The name, a symbol, for the Postgres type of the 519 | primary key column in the backend model tables. KEY arguments to 520 | model interface methods must be compatible with this type. 521 | 522 | #### model-initial-gin-operator-class 523 | *Generic function* 524 | 525 | ```common-lisp 526 | model 527 | ``` 528 | 529 | The name, a keyword, for the initial Postgres GIN 530 | operator class to use for the model's GIN index. See also 531 | USE-GIN-INDEX. If NIL, make no GIN index. 532 | 533 | #### serialize 534 | *Generic function* 535 | 536 | ```common-lisp 537 | model object 538 | ``` 539 | 540 | Serialize lisp **OBJECT** to a form suitable for 541 | storage as a JSON document in backend **MODEL**. Return same. Called by 542 | INSERT, for example, to convert Lisp objects to JSON before DB 543 | insertion proper. 544 | 545 | #### deserialize 546 | *Generic function* 547 | 548 | ```common-lisp 549 | model jdoc 550 | ``` 551 | 552 | Deserialize the string **JDOC** from **MODEL**'s backend to 553 | a lisp object. Return same. Called by FETCH, for example, to convert 554 | JSON strings from the backend into Lisp objects. 555 | 556 | #### stash 557 | *Generic function* 558 | 559 | ```common-lisp 560 | model object key 561 | ``` 562 | 563 | Called before SERIALIZE which is called before 564 | document inserts or updates. An opportunity to modify the lisp **OBJECT** 565 | using the intended/current primary **KEY** of the JSON document in the 566 | **MODEL**'s backend. 567 | 568 | #### stash 569 | *Method* 570 | 571 | ```common-lisp 572 | (model pgj-model) object key 573 | ``` 574 | 575 | Do nothing and return **OBJECT**. 576 | 577 | #### stash 578 | *Method* 579 | 580 | ```common-lisp 581 | (model pgj-object-model) (object hash-table) key 582 | ``` 583 | 584 | Destructively modify hash-table **OBJECT** by assigning the value **KEY** 585 | to a key named by the downcased symbol name of MODEL-KEY-NAME of 586 | **MODEL**. Returns the modified **OBJECT**. 587 | 588 | 589 | --- 590 | ## Further model management 591 | #### create-backend 592 | *Generic function* 593 | 594 | ```common-lisp 595 | model 596 | ``` 597 | 598 | Create the backend tables and indexes for a 599 | **MODEL**. 600 | 601 | #### backend-exists-p 602 | *Generic function* 603 | 604 | ```common-lisp 605 | model 606 | ``` 607 | 608 | Return true if **MODEL** has a Postgres backend, NIL 609 | otherwise. 610 | 611 | #### database-safety-net 612 | *Condition* 613 | 614 | Signaled to prevent accidental deletion of database 615 | assets such as tables or schema. 616 | 617 | #### really-do-it 618 | *Function* 619 | 620 | ```common-lisp 621 | condition 622 | ``` 623 | 624 | Invoke a '**REALLY-DO-IT** restart. 625 | 626 | #### \*gin-operator-classes\* 627 | *Dynamic variable* 628 | 629 | ```common-lisp 630 | '(:jsonb-ops :jsonb-path-ops) 631 | ``` 632 | 633 | A list of keywords representing Postgres GIN operator classes. 634 | 635 | #### use-gin-index 636 | *Generic function* 637 | 638 | ```common-lisp 639 | model gin-operator-class 640 | ``` 641 | 642 | Create a Postgres GIN index for **MODEL** using 643 | **GIN-OPERATOR-CLASS**, a keyword that must be a member of 644 | \*gin-operator-classes\*. First drop any existing GIN index. 645 | 646 | 647 | --- 648 | ## Postgres backend 649 | #### \*pgj-schema\* 650 | *Dynamic variable* 651 | 652 | ```common-lisp 653 | 'pgj-model 654 | ``` 655 | 656 | A symbol being the name of the Postgres schema created to house all 657 | database backend objects. 658 | 659 | #### drop-pgj-schema 660 | *Function* 661 | 662 | Drop the entire Postgres schema \*PGJ-SCHEMA\* in the database 663 | Postmodern is currently connected to. This will irrevocably delete 664 | ALL your data in ALL your models so it uses a RESTART-CASE to guard 665 | against human error. 666 | 667 | #### \*default-search-path\* 668 | *Dynamic variable* 669 | 670 | ```common-lisp 671 | (format nil "~A,public" (to-sql-name *pgj-schema*)) 672 | ``` 673 | 674 | The default value used by ALTER-ROLE-SET-SEARCH-PATH. 675 | 676 | #### alter-role-set-search-path 677 | *Function* 678 | 679 | ```common-lisp 680 | user &optional (search-path *default-search-path*) 681 | ``` 682 | 683 | Alter the role of Postgres user **USER**, a string, to set the 684 | 'search_path' setting to the string **SEARCH-PATH**. In most cases this 685 | is what you want so than when defining your own queries with 686 | DEFINE-MODEL-QUERY unqualified relation names can be found in our 687 | default schema (which is not the PUBLIC schema). This setting does 688 | _not_ effect the normal model interface functions such as FETCH and 689 | FILTER as they use fully qualified table names at all times. Will 690 | only take effect upon your next connection. Beware, may be overridden 691 | by settings in your ~/.psqlrc file. See also the Postgres 692 | documentation on search paths and settings. 693 | 694 | #### create-db-sequence 695 | *Function* 696 | 697 | ```common-lisp 698 | sequence &optional (schema *pgj-schema*) 699 | ``` 700 | 701 | Create a PostgreSQL sequence with name **SEQUENCE** in **SCHEMA** (both symbols). 702 | Requires an active DB connection. 703 | 704 | #### flush-prepared-queries 705 | *Function* 706 | 707 | If you get a 'Database error 26000: prepared statement ... does not 708 | exist error' while mucking around at the REPL, call this. A similar 709 | error in production code should be investigated. 710 | 711 | 712 | --- 713 | ## Postmodern isolation level transactions 714 | #### \*pgj-default-isolation-level\* 715 | *Dynamic variable* 716 | 717 | ```common-lisp 718 | '+repeatable-read-rw+ 719 | ``` 720 | 721 | The isolation level, a symbol, to use for WITH-MODEL-TRANSACTION. 722 | For models that maintain history can only be +REPEATABLE-READ-RW+ or 723 | +SERIALIZABLE-RW+. For models without history could conceivably be 724 | +READ-COMMITTED-RW+. 725 | 726 | #### incompatible-transaction-setting 727 | *Condition* 728 | 729 | Signaled for a nested invocation of 730 | WITH-ENSURED-TRANSACTION-LEVEL or WITH-LOGICAL-TRANSACTION-LEVEL 731 | inside a previous invocation with an incongruent isolation level. 732 | 733 | #### +serializable-rw+ 734 | *Constant* 735 | 736 | ```common-lisp 737 | "isolation level serializable read write" 738 | ``` 739 | 740 | START TRANSACTION string to set Postgres 741 | 'Serializable' isolation level and read/write. 742 | 743 | #### +repeatable-read-rw+ 744 | *Constant* 745 | 746 | ```common-lisp 747 | "isolation level repeatable read read write" 748 | ``` 749 | 750 | START TRANSACTION string to set Postgres 'Repeatable 751 | read' isolation level and read/write. 752 | 753 | #### +read-committed-rw+ 754 | *Constant* 755 | 756 | ```common-lisp 757 | "isolation level read committed read write" 758 | ``` 759 | 760 | START TRANSACTION string to set Postgres 'Read 761 | committed' isolation level, which is the default, and read write. 762 | 763 | #### +read-committed-ro+ 764 | *Constant* 765 | 766 | ```common-lisp 767 | "isolation level read committed read only" 768 | ``` 769 | 770 | START TRANSACTION string to set Postgres 'Read 771 | committed' isolation level, which is the default, and read only. 772 | 773 | #### with-transaction-level 774 | *Macro* 775 | 776 | ```common-lisp 777 | (name isolation-level) &body body 778 | ``` 779 | 780 | Unilaterally evaluate **BODY** inside a Postmodern WITH-TRANSACTION 781 | form with Postgres 'transaction mode' set to the symbol-value of 782 | **ISOLATION-LEVEL**, a symbol. The symbol **NAME** is bound to the Postmodern 783 | `transaction-handle' and may be used in calls to Postmodern's 784 | abort-transaction and commit-transaction. 785 | 786 | #### with-logical-transaction-level 787 | *Macro* 788 | 789 | ```common-lisp 790 | (name isolation-level) &body body 791 | ``` 792 | 793 | Similar to Postmodern's WITH-LOGICAL-TRANSACTION but start any top 794 | level transaction with Postgres 'transaction mode' set to the 795 | symbol-value of **ISOLATION-LEVEL**. The symbol **NAME** is bound to the 796 | Postmodern `transaction-handle' and may be used in calls to 797 | Postmodern's abort-transaction and commit-transaction. The condition 798 | `incompatible-transaction-setting' will be signaled for incongruent 799 | nested isolation levels. 800 | 801 | #### ensure-transaction-level 802 | *Macro* 803 | 804 | ```common-lisp 805 | (isolation-level) &body body 806 | ``` 807 | 808 | Similar to Postmodern's ENSURE-TRANSACTION but start any top level 809 | transaction with Postgres 'transaction mode' set to the symbol-value 810 | of **ISOLATION-LEVEL**. The condition `incompatible-transaction-setting' 811 | will be signaled for incongruent nested isolation levels. 812 | 813 | 814 | --- 815 | ## lparallel support (optional) 816 | #### \*pgj-kernel\* 817 | *Dynamic variable* 818 | 819 | An lparallel kernel to manage worker threads. Typically bound to 820 | the result of MAKE-PGJ-KERNEL for use by interface calls such 821 | WITH-CONNECTED-THREAD. 822 | 823 | #### \*pgj-database\* 824 | *Dynamic variable* 825 | 826 | Thread local Postmodern database connection. 827 | 828 | #### make-pgj-kernel 829 | *Function* 830 | 831 | ```common-lisp 832 | connect-spec &optional (n 4) 833 | ``` 834 | 835 | Make an lparallel kernel object where each worker thread is given a 836 | permanent DB connection, made using a Postmodern **CONNECT-SPEC**, a list. 837 | Start **N** workers. Ensure your Postgres can handle at least **N** 838 | concurrent connecions. 839 | 840 | #### end-pgj-kernel 841 | *Function* 842 | 843 | End the lparallel kernel in \*PGJ-KERNEL\*. 844 | 845 | #### call-with-connected-thread 846 | *Function* 847 | 848 | ```common-lisp 849 | function 850 | ``` 851 | 852 | Ask that an lparallel worker perform **FUNCTION**, a function, given a 853 | current Postmodern DB connection. Block until the result is received 854 | and return it. \*PGJ-KERNEL\* must be bound to the result of 855 | MAKE-PGJ-KERNEL. 856 | 857 | #### with-connected-thread 858 | *Macro* 859 | 860 | ```common-lisp 861 | nil &body body 862 | ``` 863 | 864 | Wrap **BODY** in a lambda and invoke CALL-WITH-CONNECTED-THREAD. 865 | \*PGJ-KERNEL\* must be bound to the result of MAKE-PGJ-KERNEL. 866 | 867 | #### \*pgj-channel\* 868 | *Dynamic variable* 869 | 870 | A single lparallel channel for submitting tasks via SUBMIT-PGJ-TASK 871 | and receiving results via RECEIVE-PGJ-RESULT. 872 | 873 | #### make-pgj-channel 874 | *Function* 875 | 876 | Make an lparallel channel. \*PGJ-KERNEL\* must be bound to the 877 | result of MAKE-PGJ-KERNEL. 878 | 879 | #### submit-pgj-function 880 | *Function* 881 | 882 | ```common-lisp 883 | function 884 | ``` 885 | 886 | Submit the function **FUNCTION**, with a Postmodern connection, as an 887 | lparallel task on our channel \*PGJ-CHANNEL\*. \*PGJ-KERNEL\* must be 888 | bound to the result of MAKE-PGJ-KERNEL. 889 | 890 | #### submit-pgj-task 891 | *Macro* 892 | 893 | ```common-lisp 894 | nil &body body 895 | ``` 896 | 897 | Wrap **BODY** in a lambda and call SUBMIT-PGJ-FUNCTION. 898 | \*PGJ-KERNEL\* must be bound to the result of MAKE-PGJ-KERNEL. 899 | 900 | #### receive-pgj-result 901 | *Function* 902 | 903 | Call lparallel:receive-result on our \*PGJ-CHANNEL\*. 904 | \*PGJ-KERNEL\* must be bound to the result of MAKE-PGJ-KERNEL. 905 | 906 | #### try-receive-pgj-result 907 | *Function* 908 | 909 | ```common-lisp 910 | &key timeout 911 | ``` 912 | 913 | Call lparallel:try-receive-result on our \*PGJ-CHANNEL\*, 914 | with timeout **TIMEOUT**, a real. \*PGJ-KERNEL\* must be bound to the 915 | result of MAKE-PGJ-KERNEL. 916 | 917 | 918 | --- 919 | --------------------------------------------------------------------------------