branch master updated: Add SQL query logging support.

[Mathieu Othacehe]

This is an automated email from the git hooks/post-receive script.

mothacehe pushed a commit to branch master
in repository guix-cuirass.

The following commit(s) were added to refs/heads/master by this push:
     new b310f17  Add SQL query logging support.
b310f17 is described below

commit b310f17aaff8f17af0e7cf77b0b9d6866fe89abe
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Tue Sep 22 15:17:31 2020 +0200

    Add SQL query logging support.
    
    * bin/cuirass.in (show-help): Document "--log-queries" option.
    (%options): Add it.
    (main): Enable query logging if the above option is set.
    * src/cuirass/database.scm (db-log-queries): New procedure.
    * src/cuirass/logging.scm (query-logging-port): New parameter.
    (log-query): New procedure.
---
 bin/cuirass.in           | 17 +++++++++++++----
 src/cuirass/database.scm | 18 ++++++++++++++++++
 src/cuirass/logging.scm  | 17 ++++++++++++++++-
 3 files changed, 47 insertions(+), 5 deletions(-)

diff --git a/bin/cuirass.in b/bin/cuirass.in
index ed21ed7..c322a71 100644
--- a/bin/cuirass.in
+++ b/bin/cuirass.in
@@ -27,6 +27,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (use-modules (cuirass)
+             (cuirass base)
              (cuirass ui)
              (cuirass logging)
              (cuirass metrics)
@@ -54,6 +55,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
   -p  --port=NUM            Port of the HTTP server.
       --listen=HOST         Listen on the network interface for HOST
   -I, --interval=N          Wait N seconds between each poll
+      --log-queries=FILE    Log SQL queries in FILE.
       --use-substitutes     Allow usage of pre-built substitutes
       --record-events       Record events for distribution
       --threads=N           Use up to N kernel threads
@@ -74,6 +76,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
     (use-substitutes                  (value #f))
     (threads                          (value #t))
     (fallback                         (value #f))
+    (log-queries                      (value #t))
     (record-events                    (value #f))
     (ttl                              (value #t))
     (version        (single-char #\V) (value #f))
@@ -111,10 +114,11 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" 
"$@"
        (else
         (mkdir-p (%gc-root-directory))
         (let ((one-shot? (option-ref opts 'one-shot #f))
-              (port      (string->number (option-ref opts 'port "8080")))
-              (host      (option-ref opts 'listen "localhost"))
-              (interval  (string->number (option-ref opts 'interval "300")))
-              (specfile  (option-ref opts 'specifications #f))
+              (port (string->number (option-ref opts 'port "8080")))
+              (host (option-ref opts 'listen "localhost"))
+              (interval (string->number (option-ref opts 'interval "300")))
+              (specfile (option-ref opts 'specifications #f))
+              (queries-file (option-ref opts 'log-queries #f))
 
               ;; Since our work is mostly I/O-bound, default to a maximum of 4
               ;; kernel threads.  Going beyond that can increase overhead (GC
@@ -139,6 +143,11 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" 
"$@"
                                           (set-current-module 
(make-user-module '()))
                                           (primitive-load specfile)))))
                         (for-each db-add-specification new-specs)))
+
+                 (when queries-file
+                   (log-message "Enable SQL query logging.")
+                   (db-log-queries queries-file))
+
                  (if one-shot?
                      (process-specs (db-get-specifications))
                      (let ((exit-channel (make-channel)))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 8cc9376..666a20b 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -34,12 +34,15 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
+  #:use-module (system foreign)
+  #:use-module (rnrs bytevectors)
   #:use-module (sqlite3)
   #:export (;; Procedures.
             db-init
             db-open
             db-close
             db-optimize
+            db-log-queries
             db-add-specification
             db-remove-specification
             db-get-specification
@@ -303,6 +306,21 @@ database object."
     (sqlite-exec db "PRAGMA wal_checkpoint(TRUNCATE);")
     (db-close db)))
 
+(define (trace-callback trace p x)
+  (log-query (pointer->string
+              (sqlite-expanded-sql p))
+             (make-time 'time-duration
+                        (bytevector-uint-ref
+                         (pointer->bytevector x (sizeof uint64))
+                         0 (native-endianness)
+                         (sizeof uint64))
+                        0)))
+
+(define (db-log-queries file)
+  (with-db-worker-thread db
+    (query-logging-port (open-output-file file))
+    (sqlite-trace db SQLITE_TRACE_PROFILE trace-callback)))
+
 (define (last-insert-rowid db)
   (vector-ref (car (sqlite-exec db "SELECT last_insert_rowid();"))
               0))
diff --git a/src/cuirass/logging.scm b/src/cuirass/logging.scm
index 6258eed..97eb6f7 100644
--- a/src/cuirass/logging.scm
+++ b/src/cuirass/logging.scm
@@ -25,7 +25,9 @@
             current-logging-procedure
             log-message
             with-time-logging
-            log-monitoring-stats))
+            log-monitoring-stats
+            query-logging-port
+            log-query))
 
 (define current-logging-port
   (make-parameter (current-error-port)))
@@ -77,3 +79,16 @@
                              (lambda (file)
                                (not (member file '("." "..")))))
                     '()))))
+
+(define query-logging-port
+  (make-parameter #f))
+
+(define (log-query query time)
+  (format (query-logging-port) "~a ~,2f~%"
+          (string-join
+           (string-tokenize query
+                            (char-set-complement
+                             (char-set #\space #\newline #\;)))
+           " ")
+          (+ (time-second time)
+             (/ (time-nanosecond time) 1e9))))