Merge 9afe15c into 5e5a32f

src/core/db.lisp

@@ -7,7 +7,7 @@
                 #:connection-quote-character
                 #:check-connected)
   (:import-from #:mito.logger
-                #:trace-sql)
+                #:with-trace-sql)
   (:import-from #:mito.util
                 #:lispify
                 #:with-prepared-query)
@@ -107,15 +107,14 @@
     (declare (ignore sql binds))
     (check-connected))
   (:method ((sql string) &optional binds)
-    (trace-sql sql binds)
-    (apply #'dbi:do-sql *connection* sql binds))
+    (with-trace-sql
+      (apply #'dbi:do-sql *connection* sql binds)))
   (:method ((sql sql-statement) &optional binds)
     (declare (ignore binds))
     (with-quote-char
       (multiple-value-bind (sql binds)
           (sxql:yield sql)
-        (trace-sql sql binds)
-        (apply #'dbi:do-sql *connection* sql binds)))))
+        (with-trace-sql (apply #'dbi:do-sql *connection* sql binds))))))
 
 (defun array-convert-nulls-to-nils (results-array)
   (let ((darray (make-array (array-total-size results-array)
@@ -155,8 +154,8 @@
     (with-prepared-query query (*connection* sql)
       (let* ((results
                (dbi:fetch-all
-                (apply #'dbi:execute query
-                       binds)))
+                (with-trace-sql
+                  (apply #'dbi:execute query binds))))
              (results
                (loop for result in results
                      collect
@@ -169,7 +168,6 @@
                                           (array-convert-nulls-to-nils v))
                                          (t v))))))
 
-        (trace-sql sql binds results)
         results)))
   (:method ((sql sql-statement) &key binds)
     (declare (ignore binds))

src/core/logger.lisp

@@ -1,32 +1,33 @@
 (in-package :cl-user)
 (defpackage mito.logger
   (:use #:cl)
+  (:import-from #:dbi
+                #:*sql-execution-hooks*)
   (:import-from #:alexandria
                 #:delete-from-plist)
   (:export #:*mito-logger-stream*
            #:*mito-migration-logger-stream*
-           #:with-sql-logging
-           #:trace-sql
-           #:*trace-sql-hooks*))
+           #:*trace-sql-hooks*
+           #:mito-sql-logger
+           #:with-trace-sql
+           #:with-sql-logging))
 (in-package :mito.logger)
 
 (defvar *mito-logger-stream* nil)
 
 (defvar *mito-migration-logger-stream* (make-synonym-stream '*standard-output*)
   "Stream to output sql generated during migrations.")
 
-(defmacro with-sql-logging (&body body)
-  `(let ((*mito-logger-stream* *mito-migration-logger-stream*))
-     ,@body))
-
 (defun get-prev-stack ()
   (labels ((stack-call (stack)
              (let ((call (dissect:call stack)))
                (typecase call
                  (symbol call)
                  (cons
-                  (when (eq (first call) :method)
-                    (second call))))))
+                   (case (first call)
+                     (:method (second call))
+                     (lambda nil)
+                     (otherwise (second call)))))))
            #+sbcl
            (sbcl-package-p (package)
              (let ((name (package-name package)))
@@ -36,36 +37,46 @@
                (let ((package (symbol-package call)))
                  (or #+sbcl (sbcl-package-p package)
                      (find (package-name package)
-                           '(:common-lisp :mito.logger)
+                           '(:common-lisp :mito.logger :mito.db :mito.dao :mito.util :dbi.logger :dbi.driver)
                            :test #'string=)))))
            (users-stack-p (stack)
              (let ((call (stack-call stack)))
                (and call
-                    (not (system-call-p call))))))
+                    (or (not (symbolp call))
+                        (not (system-call-p call)))))))
 
     (loop with prev-stack = nil
-          repeat 5
           for stack in (dissect:stack)
           when (users-stack-p stack)
-            do (setf prev-stack stack)
-          finally (return (when prev-stack
-                            (stack-call prev-stack))))))
+            do (return (stack-call stack)))))
 
-(defun default-trace-sql-hook (sql params results)
+(defun mito-sql-logger (sql params row-count took-ms prev-stack)
   (when *mito-logger-stream*
     (format *mito-logger-stream*
-            "~&~<;; ~@; ~A (~{~S~^, ~}) [~D row~:P]~:[~;~:* | ~S~]~:>~%"
+            "~&~<;; ~@;~A (~{~S~^, ~}) ~@[[~D row~:P]~]~@[ (~Dms)~]~:[~;~:* | ~S~]~:>~%"
             (list sql
                   (mapcar (lambda (param)
                             (if (typep param '(simple-array (unsigned-byte 8) (*)))
                                 (map 'string #'code-char param)
                                 param))
                           params)
-                  (length results)
-                  (get-prev-stack)))))
+                  row-count
+                  took-ms
+                  prev-stack))))
+
+(defvar *trace-sql-hooks* (list #'mito-sql-logger))
 
-(defvar *trace-sql-hooks* (list #'default-trace-sql-hook))
+(defun trace-sql (sql params row-count took-ms)
+  (when *trace-sql-hooks*
+    (let ((prev-stack (get-prev-stack)))
+      (dolist (hook *trace-sql-hooks*)
+        (funcall hook sql params row-count took-ms prev-stack)))))
 
-(defun trace-sql (sql params &optional results)
-  (dolist (hook *trace-sql-hooks*)
-    (funcall hook sql params results)))
+(defmacro with-trace-sql (&body body)
+  `(let ((dbi:*sql-execution-hooks* (cons #'trace-sql
+                                          dbi:*sql-execution-hooks*)))
+     ,@body))
+
+(defmacro with-sql-logging (&body body)
+  `(let ((*mito-logger-stream* *mito-migration-logger-stream*))
+     (with-trace-sql ,@body)))