Cursor support (only for PostgreSQL)

mito-core.asd

@@ -2,7 +2,7 @@
   :version "0.2.0"
   :author "Eitaro Fukamachi"
   :license "LLGPL"
-  :depends-on ((:version "dbi" "0.10.0")
+  :depends-on ((:version "dbi" "0.11.1")
                "sxql"
                "cl-ppcre"
                "closer-mop"

qlfile.lock

@@ -5,7 +5,7 @@
 ("cl-dbi" .
  (:class qlot/source/ql:source-ql-upstream
   :initargs nil
-  :version "ql-upstream-2ff41f0706180e140a31b844da4f0272e1a281cd"
+  :version "ql-upstream-f58761b4da39e0559fcfbd744fa6f024182c6d94"
   :remote-url "https://github.com/fukamachi/cl-dbi.git"))
 ("cl-mysql" .
  (:class qlot/source/ql:source-ql-upstream

src/core/dao.lisp

@@ -28,13 +28,16 @@
                 #:last-insert-id
                 #:execute-sql
                 #:retrieve-by-sql
-                #:table-exists-p)
+                #:table-exists-p
+                #:ensure-sql)
   (:import-from #:mito.logger
                 #:with-sql-logging)
   (:import-from #:mito.util
+                #:lispify
                 #:unlispify
                 #:symbol-name-literally
-                #:ensure-class)
+                #:ensure-class
+                #:execute-with-retry)
   (:import-from #:trivia
                 #:match
                 #:guard)
@@ -58,7 +61,8 @@
            #:count-dao
            #:recreate-table
            #:ensure-table-exists
-           #:deftable))
+           #:deftable
+           #:do-cursor))
 (in-package #:mito.dao)
 
 (defun foreign-value (obj slot)
@@ -198,6 +202,33 @@
         (update-dao obj)
         (insert-dao obj))))
 
+(defstruct mito-cursor
+  cursor
+  fields
+  class)
+
+(defun select-by-sql-as-cursor (class sql &key binds)
+  (multiple-value-bind (sql yield-binds)
+      (ensure-sql sql)
+    (let* ((cursor (dbi:make-cursor *connection* sql))
+           (cursor (execute-with-retry cursor (or binds yield-binds))))
+      (make-mito-cursor :cursor cursor
+                        :fields (mapcar (lambda (column-name)
+                                          (intern (lispify (string-upcase column-name)) :keyword))
+                                        (dbi.driver:query-fields cursor))
+                        :class class))))
+
+(defun fetch-dao-from-cursor (cursor)
+  (let ((fields (mito-cursor-fields cursor))
+        (row (dbi:fetch (mito-cursor-cursor cursor)
+                        :format :values)))
+    (when row
+      (apply #'make-dao-instance (mito-cursor-class cursor)
+             (loop for field in fields
+                   for value in row
+                   collect field
+                   collect value)))))
+
 (defun select-by-sql (class sql &key binds)
   (mapcar (lambda (result)
             (apply #'make-dao-instance class result))
@@ -305,6 +336,8 @@
                                   (expand-op arg class)) args)))
       (otherwise object))))
 
+(defparameter *want-cursor* nil)
+
 (defmacro select-dao (class &body clauses)
   (with-gensyms (sql clause results include-classes foreign-class)
     (once-only (class)
@@ -327,10 +360,12 @@
                 (dolist (,clause (list ,@clauses))
                   (when ,clause
                     (add-child ,sql ,clause)))
-                (let ((,results (select-by-sql ,class ,sql)))
-                  (dolist (,foreign-class (remove-duplicates ,include-classes))
-                    (include-foreign-objects ,foreign-class ,results))
-                  (values ,results ,sql))))))))))
+                (if *want-cursor*
+                    (select-by-sql-as-cursor ,class ,sql)
+                    (let ((,results (select-by-sql ,class ,sql)))
+                      (dolist (,foreign-class (remove-duplicates ,include-classes))
+                        (include-foreign-objects ,foreign-class ,results))
+                      (values ,results ,sql)))))))))))
 
 (defun where-and (fields-and-values class)
   (when fields-and-values
@@ -417,3 +452,17 @@
      ,@(unless (find :conc-name options :key #'car)
                `((:conc-name ,(intern (format nil "~@:(~A-~)" name) (symbol-package name)))))
      ,@options))
+
+(defmacro do-cursor ((dao select &optional index) &body body)
+  (with-gensyms (main cursor)
+    `(flet ((,main ()
+              (let* ((*want-cursor* t)
+                     (,cursor ,select))
+                (loop ,@(and index `(for ,index from 0))
+                      for ,dao = (fetch-dao-from-cursor ,cursor)
+                      while ,dao
+                      do (progn ,@body)))))
+       (if (dbi:in-transaction *connection*)
+           (,main)
+           (dbi:with-transaction *connection*
+             (,main))))))

src/core/db.lisp

@@ -115,6 +115,18 @@ Note that DBI:PREPARE-CACHED is added CL-DBI v0.9.5.")
             :format :plist)
            t))))
 
+(defun sxql-to-sql (sql)
+  (with-quote-char (sxql:yield sql)))
+
+(defun ensure-sql (sql)
+  (etypecase sql
+    (string sql)
+    ((or sql-statement
+         composed-statement
+         ;; For UNION [ALL]
+         conjunctive-op)
+     (sxql-to-sql sql))))
+
 (defgeneric execute-sql (sql &optional binds)
   (:method ((sql string) &optional binds)
     (check-connected)
@@ -124,10 +136,9 @@ Note that DBI:PREPARE-CACHED is added CL-DBI v0.9.5.")
         (query-row-count query))))
   (:method ((sql sql-statement) &optional binds)
     (declare (ignore binds))
-    (with-quote-char
-      (multiple-value-bind (sql binds)
-          (sxql:yield sql)
-        (execute-sql sql binds)))))
+    (multiple-value-bind (sql binds)
+        (sxql-to-sql sql)
+      (execute-sql sql binds))))
 
 (defun lispified-fields (query)
   (mapcar (lambda (field)
@@ -203,25 +214,11 @@ Note that DBI:PREPARE-CACHED is added CL-DBI v0.9.5.")
                      (:plist t)
                      (otherwise nil)))))
         (retrieve-from-query query format))))
-  (:method ((sql sql-statement) &rest args &key binds &allow-other-keys)
-    (assert (null binds))
-    (with-quote-char
-      (multiple-value-bind (sql binds)
-          (sxql:yield sql)
-        (apply #'retrieve-by-sql sql :binds binds args))))
-  (:method ((sql composed-statement) &rest args &key binds &allow-other-keys)
-    (assert (null binds))
-    (with-quote-char
-      (multiple-value-bind (sql binds)
-          (sxql:yield sql)
-        (apply #'retrieve-by-sql sql :binds binds args))))
-  ;; For UNION [ALL]
-  (:method ((sql conjunctive-op) &rest args &key binds &allow-other-keys)
+  (:method (sql &rest args &key binds &allow-other-keys)
     (assert (null binds))
-    (with-quote-char
-      (multiple-value-bind (sql binds)
-          (sxql:yield sql)
-        (apply #'retrieve-by-sql sql :binds binds args)))))
+    (multiple-value-bind (sql binds)
+        (ensure-sql sql)
+      (apply #'retrieve-by-sql sql :binds binds args))))
 
 (defun acquire-advisory-lock (conn id)
   (funcall

t/dao.lisp

@@ -240,6 +240,47 @@
 
   (dolist (class-name '(user-setting user tweet friend-relationship tweet2))
     (setf (find-class class-name) nil))
+
+  (disconnect-toplevel))
+
+(deftest cursor
+  (setf *connection* (connect-to-testdb :postgres))
+  (when (find-class 'user nil)
+    (setf (find-class 'user) nil))
+  (defclass user ()
+    ((name :col-type :text
+           :initarg :name))
+    (:metaclass dao-table-class))
+  (mito:execute-sql "DROP TABLE IF EXISTS \"user\"")
+  (mito:ensure-table-exists 'user)
+  (mito:create-dao 'user :name "Eitaro")
+  (mito:create-dao 'user :name "Btaro")
+  (mito:create-dao 'user :name "Charlie")
+  (dbi:with-transaction *connection*
+    (let* ((mito.dao::*want-cursor* t)
+           (cursor (mito.dao:select-dao 'user
+                     (where (:like :name "%aro")))))
+      (ok (typep cursor 'mito.dao::mito-cursor))
+      (let ((row (mito.dao::fetch-dao-from-cursor cursor)))
+        (ok (typep row 'user))
+        (ok (equal (slot-value row 'name) "Eitaro")))
+      (let ((row (mito.dao::fetch-dao-from-cursor cursor)))
+        (ok (typep row 'user))
+        (ok (equal (slot-value row 'name) "Btaro")))
+      (ok (null (mito.dao::fetch-dao-from-cursor cursor)))))
+
+  (let ((records '()))
+    (do-cursor (dao (mito.dao:select-dao 'user) i)
+      (push (cons i dao) records)
+      (when (<= 1 i)
+        (return)))
+    (ok (= (length records) 2))
+    (ok (every (lambda (record)
+                 (typep (cdr record) 'user))
+               records)))
+
+  (when (find-class 'user nil)
+    (setf (find-class 'user) nil))
   (disconnect-toplevel))
 
 (deftest foreign-slots