diff --git a/pgloader.asd b/pgloader.asd index 110dce9..627f03a 100644 --- a/pgloader.asd +++ b/pgloader.asd @@ -36,6 +36,8 @@ #:quri ; decode URI parameters #:cl-ppcre ; Perl Compatible Regular Expressions #:cl-mustache ; Logic-less templates + #:yason ; JSON routines + #:closer-mop ; introspection ) :components ((:module "src" @@ -71,7 +73,9 @@ ;; State, monitoring, reporting (:file "reject" :depends-on ("state")) + (:file "pretty-print-state" :depends-on ("state")) (:file "report" :depends-on ("state" + "pretty-print-state" "utils" "catalog")) (:file "monitor" :depends-on ("logs" diff --git a/src/package.lisp b/src/package.lisp index 9522659..801b905 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -191,7 +191,15 @@ (defpackage #:pgloader.state (:use #:cl #:pgloader.params #:pgloader.catalog) - (:export #:make-pgstate + (:export #:create-state + #:make-state + #:state-preload + #:state-data + #:state-postload + #:state-secs + #:get-state-section + + #:make-pgstate #:pgstate-tabnames #:pgstate-tables #:pgstate-read diff --git a/src/utils/monitor.lisp b/src/utils/monitor.lisp index c416478..f3bacf6 100644 --- a/src/utils/monitor.lisp +++ b/src/utils/monitor.lisp @@ -21,8 +21,8 @@ (defvar *monitoring-channel* nil "Internal lparallel channel.") -(defvar *sections* '(:pre nil :data nil :post nil) - "plist of load sections: :pre, :data and :post.") +(defvar *sections* (create-state) + "Global pgloader state, maintained by the dedicated monitor thread.") ;;; @@ -163,9 +163,7 @@ (defmacro with-monitor ((&key (start-logger t)) &body body) "Start and stop the monitor around BODY code. The monitor is responsible for processing logs into a central logfile" - `(let ((*sections* (list :pre (make-pgstate) - :data (make-pgstate) - :post (make-pgstate)))) + `(let ((*sections* (create-state))) (if ,start-logger (let* ((*monitoring-queue* (lq:make-queue)) (*monitoring-channel* (start-monitor :start-logger ,start-logger))) @@ -203,9 +201,7 @@ (report-current-summary start-time) (when (report-summary-reset event) - (setf *sections* (list :pre (make-pgstate) - :data (make-pgstate) - :post (make-pgstate))))) + (setf *sections* (create-state)))) (log-message ;; cl-log:log-message is a macro, we can't use apply @@ -219,16 +215,20 @@ (cl-log:log-message (log-message-category event) "~a" mesg))) (new-label - (let ((label - (pgstate-new-label (getf *sections* (new-label-section event)) - (new-label-label event)))) + (let* ((section + (get-state-section *sections* + (new-label-section event))) + (label + (pgstate-new-label section + (new-label-label event)))) (when (eq :data (new-label-section event)) (pgtable-initialize-reject-files label (new-label-dbname event))))) (update-stats - (let* ((pgstate (getf *sections* (update-stats-section event))) + (let* ((pgstate (get-state-section *sections* + (update-stats-section event))) (label (update-stats-label event)) (table (pgstate-new-label pgstate label))) @@ -300,8 +300,8 @@ :if-exists :rename :if-does-not-exist :create))) (*report-stream* (or summary-stream *standard-output*))) - (report-full-summary "Total import time" - *sections* + (report-full-summary *sections* + "Total import time" (elapsed-time-since start-time)) (when summary-stream (close summary-stream)))) diff --git a/src/utils/pretty-print-state.lisp b/src/utils/pretty-print-state.lisp new file mode 100644 index 0000000..8ad6b97 --- /dev/null +++ b/src/utils/pretty-print-state.lisp @@ -0,0 +1,312 @@ +;;; +;;; Pretty print a report while doing bulk operations +;;; + +(in-package :pgloader.state) + +;; +;; define a tree of print format so that we can generalize some methods on +;; any “data” type format or any “human readable” print format. +;; +(defstruct print-format ()) + +(defstruct (print-format-human-readable (:include print-format) + (:conc-name pf-)) + (legend nil :type (or null string)) + (max-label-length 1 :type fixnum)) + +(defstruct (print-format-text (:include print-format-human-readable))) +(defstruct (print-format-verbose (:include print-format-human-readable))) + +(defstruct (print-format-tab (:include print-format))) +(defstruct (print-format-csv (:include print-format-tab))) +(defstruct (print-format-copy (:include print-format-tab))) + +(defstruct (print-format-json (:include print-format))) + +(defgeneric pretty-print (stream state format &key)) + + +;;; +;;; The pretty-print methods for data and human readable formats for a +;;; global state are a “shell” that calls into the more specialized version, +;;; for pgstate then pgtable. +;;; +(defmethod pretty-print ((stream stream) + (state state) + (format print-format-tab) + &key) + (loop :for pgstate :in (list (state-preload state) + (state-data state) + (state-postload state)) + :do (pretty-print stream pgstate format))) + +(defmethod pretty-print ((stream stream) + (state state) + (format print-format-json) + &key) + (yason:encode state stream)) + +(defmethod pretty-print ((stream stream) + (state state) + (format print-format-human-readable) + &key) + (when (and (state-preload state) (pgstate-tabnames (state-preload state))) + (pretty-print *report-stream* + (state-preload state) + format + :header t + :footer nil + :extra-sep-line t)) + + (pretty-print *report-stream* + (state-data state) + format + :header (not (and (state-preload state) + (pgstate-tabnames (state-preload state)))) + :footer (unless (and (state-postload state) + (pgstate-tabnames (state-postload state))) + (pf-legend format)) + :extra-sep-line t) + + (when (and (state-postload state) (pgstate-tabnames (state-postload state))) + (pretty-print *report-stream* + (state-postload state) + format + :header nil + :footer (pf-legend format)))) + + +;;; +;;; Support for TEXT format, human readable +;;; +(defmethod pretty-print ((stream stream) + (pgstate pgstate) + (format print-format-text) + &key + header + footer + extra-sep-line) + (let* ((max-len (pf-max-label-length format)) + (col-label (make-string max-len :initial-element #\-)) + (col-sep (make-string 9 :initial-element #\-)) + (col-long-sep (make-string 14 :initial-element #\-)) + (sep-line (format nil + "~&~v@a ~9@a ~9@a ~9@a ~14@a~%" + max-len + col-label col-sep col-sep col-sep col-long-sep))) + (when header + (format stream + "~&~v@a ~9@a ~9@a ~9@a ~14@a~%" + max-len + "table name" "read" "imported" "errors" "total time") + (format stream sep-line)) + + (loop + :for label :in (reverse (pgstate-tabnames pgstate)) + :for pgtable := (gethash label (pgstate-tables pgstate)) + :do (let ((legend (etypecase label + (string label) + (table (format-table-name label))))) + (pretty-print stream pgtable format + :legend legend + :max-label-length max-len))) + + (cond (extra-sep-line + (format stream sep-line)) + + (footer + (with-slots (tabnames read rows errs secs) pgstate + (when tabnames + (format stream sep-line) + (format stream + "~&~v@a ~9@a ~9@a ~9@a ~14@a~%" + max-len + footer read rows errs + (format-interval secs nil)))))))) + +(defmethod pretty-print ((stream stream) + (pgtable pgtable) + (format print-format-text) + &key legend max-label-length) + (with-slots (read rows errs secs rs ws) pgtable + (format stream + "~&~v@a ~9@a ~9@a ~9@a ~14@a~%" + max-label-length + legend + read + rows + errs + (format-interval-guess secs rs ws)))) + + +;;; +;;; Support for VERBOSE format, human readable +;;; +(defmethod pretty-print ((stream stream) + (pgstate pgstate) + (format print-format-verbose) + &key + header + footer + extra-sep-line) + (let* ((max-len (pf-max-label-length format)) + (col-label (make-string max-len :initial-element #\-)) + (col-sep (make-string 9 :initial-element #\-)) + (col-long-sep (make-string 14 :initial-element #\-)) + (sep-line (format nil + "~&~v@a ~9@a ~9@a ~9@a ~14@a ~9@a ~9@a~%" + max-len col-label + col-sep col-sep col-sep + col-long-sep col-sep col-sep))) + (when header + (format stream + "~&~v@a ~9@a ~9@a ~9@a ~14@a ~9@a ~9@a~%" + max-len + "table name" "read" "imported" "errors" "total time" "read" "write") + (format stream sep-line)) + + (loop + :for label :in (reverse (pgstate-tabnames pgstate)) + :for pgtable := (gethash label (pgstate-tables pgstate)) + :do (let ((legend (etypecase label + (string label) + (table (format-table-name label))))) + (pretty-print stream pgtable format + :legend legend + :max-label-length max-len))) + + (cond (extra-sep-line + (format stream sep-line)) + + (footer + (with-slots (tabnames read rows errs secs rs ws) pgstate + (when tabnames + (format stream sep-line) + (format stream + "~&~v@a ~9@a ~9@a ~9@a ~14@a ~@[~9@a~] ~@[~9@a~]~%" + max-len + footer read rows errs + (format-interval secs nil) + (when (and rs (/= rs 0.0)) + (format-interval rs nil)) + (when (and ws (/= ws 0.0)) + (format-interval ws nil))))))))) + +(defmethod pretty-print ((stream stream) + (pgtable pgtable) + (format print-format-verbose) + &key legend max-label-length) + (with-slots (read rows errs secs rs ws) pgtable + (format stream + "~&~v@a ~9@a ~9@a ~9@a ~14@a ~@[~9@a~] ~@[~9@a~]~%" + max-label-length + legend + read + rows + errs + (format-interval-guess secs rs ws) + (when (and rs (/= rs 0.0)) (format-interval rs nil)) + (when (and ws (/= ws 0.0)) (format-interval ws nil))))) + + +;;; +;;; Support for CSV format +;;; +(defmethod pretty-print ((stream stream) + (pgstate pgstate) + (format print-format-csv) + &key) + (loop + :for label :in (reverse (pgstate-tabnames pgstate)) + :for pgtable := (gethash label (pgstate-tables pgstate)) + :do (let ((legend (etypecase label + (string label) + (table (format-table-name label))))) + (pretty-print stream pgtable format :legend legend)))) + +(defmethod pretty-print ((stream stream) + (pgtable pgtable) + (format print-format-csv) + &key legend) + (with-slots (read rows errs secs rs ws) pgtable + (format stream + "~&~s;~s;~s;~s;~s" + legend + read + rows + errs + (format-interval-guess secs rs ws)))) + + +;;; +;;; Support for COPY format +;;; +(defmethod pretty-print ((stream stream) + (pgstate pgstate) + (format print-format-copy) + &key) + (loop + :for label :in (reverse (pgstate-tabnames pgstate)) + :for pgtable := (gethash label (pgstate-tables pgstate)) + :do (let ((legend (etypecase label + (string label) + (table (format-table-name label))))) + (pretty-print stream pgtable format :legend legend)))) + +(defmethod pretty-print ((stream stream) + (pgtable pgtable) + (format print-format-copy) + &key legend) + (with-slots (read rows errs secs rs ws) pgtable + (format stream + "~&~a ~s ~s ~s ~s" + legend + read + rows + errs + (format-interval-guess secs rs ws)))) + + +;;; +;;; In the main output format, guess what's the real time spent when we +;;; don't have it. +;;; +(defun format-interval-guess (secs rs ws) + (cond ((> 0 secs) (format-interval secs nil)) + ((and rs ws (= 0 secs)) (format-interval (max rs ws) nil)) + (t (format-interval secs nil)))) + + +;;; +;;; Have yason output JSON formated output, straight from our instances. +;;; +(defmacro define-yason-encoder (class) + "Define a new yason:encode method for CLASS." + `(defmethod yason:encode ((instance ,class) + &optional (stream *standard-output*)) + "Encode an EXTENSION object into JSON." + (yason:with-output (stream) + (yason:with-object () + (loop :for slot :in (closer-mop:compute-slots ,class) + :for slot-name := (closer-mop:slot-definition-name slot) + :do (unless (member slot-name '(reject-data reject-logs)) + (yason:encode-object-element + (string slot-name) + (slot-value instance slot-name)))))))) + +(define-yason-encoder #. (find-class 'state)) +(define-yason-encoder #. (find-class 'pgtable)) + +(defmethod yason:encode ((pgstate pgstate) &optional (stream *standard-output*)) + "Output catalog tables by name only, don't recurse into the catalog..." + (yason:with-output (stream) + (yason:with-array () + (yason:encode-array-element + (loop :for label :in (reverse (pgstate-tabnames pgstate)) + :for pgtable := (gethash label (pgstate-tables pgstate)) + :collect pgtable))))) + +(defmethod yason:encode ((table table) &optional (stream *standard-output*)) + (yason:with-output (stream) + (yason:encode (format-table-name table)))) diff --git a/src/utils/reject.lisp b/src/utils/reject.lisp index b20e6ee..a65bba1 100644 --- a/src/utils/reject.lisp +++ b/src/utils/reject.lisp @@ -12,7 +12,7 @@ (defun %process-bad-row (table-name condition row) "Add the row to the reject file, in PostgreSQL COPY TEXT format" ;; first, update the stats. - (let ((state (getf *sections* :data))) + (let ((state (get-state-section *sections* :data))) (pgstate-incf state table-name :errs 1) ;; now, the bad row processing diff --git a/src/utils/report.lisp b/src/utils/report.lisp index 7268e5b..29ef3f0 100644 --- a/src/utils/report.lisp +++ b/src/utils/report.lisp @@ -4,76 +4,6 @@ (in-package :pgloader.state) -(defvar *header-line* - "~&~v@{~A~:*~} --------- --------- --------- -------------- --------- ---------") - -(defvar *header* "~&") -(defvar *footer* "~&") -(defvar *end-of-line-format* "~%") -(defvar *max-length-table-name* 30) -(defvar *header-tname-format* "~&~v@a") -(defvar *header-stats-format* " ~9@a ~9@a ~9@a ~14@a ~@[~9@a~] ~@[~9@a~]") -(defvar *header-cols-format* (concatenate 'string *header-tname-format* - *header-stats-format*)) -(defvar *header-cols-names* '("table name" "read" "imported" "errors" "time")) - -(defvar *header-format-strings* - '((:human-readable - (:header "~&" - :footer "~%" - :end-of-line-format "~%" - :header-line "~&~v@{~A~:*~} --------- --------- --------- --------------" - :header-tname-format "~&~v@a" - :header-stats-format " ~9@a ~9@a ~9@a ~14@a ~*~*" - :header-cols-format "~&~v@a ~9@a ~9@a ~9@a ~14@a" - :header-cols-names ("table name" "read" "imported" "errors" "total time"))) - - (:human-readable-verbose - (:header "~&" - :footer "~%" - :end-of-line-format "~%" - :header-line "~&~v@{~A~:*~} --------- --------- --------- -------------- --------- ---------" - - :header-tname-format "~&~v@a" - :header-stats-format " ~9@a ~9@a ~9@a ~14@a ~:[~9<~>~;~:*~9@a~] ~:[~9<~>~;~:*~9@a~]" - :header-cols-format "~&~v@a ~9@a ~9@a ~9@a ~14@a ~9@a ~9@a" - :header-cols-names ("table name" "read" "imported" "errors" - "total time" "read" "write"))) - - (:csv - (:header "~&" - :footer "~%" - :end-of-line-format "~%" - :header-line "~*~*" - :header-tname-format "~&~*~s;" - :header-stats-format "~s;~s;~s;~s~*~*" - :header-cols-format "~&~*~s;~s;~s;~s;~s" - :header-cols-names ("table name" "read" "imported" "errors" "time"))) - - (:copy - (:header "~&" - :footer "~%" - :end-of-line-format "~%" - :header-line "~&~*~*" - :header-tname-format "~&~*~a " - :header-stats-format "~s ~s ~s ~s~*~*" - :header-cols-format "~*~*~*~*~*~*" ; skip it - :header-cols-names ("table name" "read" "imported" "errors" "time"))) - - (:json - (:header "~&[" - :footer "~&]~%" - :end-of-line-format ",~%" - :header-line "~&~*~*" - :header-tname-format "~& {\"table-name\": ~*~s," - :header-stats-format "\"read\":~s,\"imported\":~s,\"errors\":~s,\"time\":~s~@[,\"read\":~s~]~@[,\"write\":~s~]}" - :header-cols-format "~*~*~*~*~*~*" ; skip it - :header-cols-names ("table name" "read" "imported" "errors" "time"))))) - -(defun get-format-for (type key) - "Return the format string to use for a given TYPE of output and KEY." - (getf (cadr (assoc type *header-format-strings*)) key)) - ;;; ;;; Timing Formating ;;; @@ -96,92 +26,18 @@ q) secs))))) -;;; -;;; Pretty printing reports in several formats -;;; -(defun report-header () - ;; (apply #'format *report-stream* *header-cols-format* *header-cols-names*) - (format *report-stream* - "~{~}" - *header-cols-format* - (list* *max-length-table-name* - *header-cols-names*)) - (format *report-stream* *header-line* *max-length-table-name* "-")) - -(defun report-table-name (table-name) - (format *report-stream* - *header-tname-format* - *max-length-table-name* table-name)) - -(defun report-results (read rows errors seconds rs ws &optional (eol t)) - (format *report-stream* *header-stats-format* read rows errors seconds rs ws) - (when eol - (format *report-stream* *end-of-line-format*))) - -(defun report-footer (legend read rows errors seconds &optional rs ws) - (format *report-stream* *header-line* *max-length-table-name* "-") - (format *report-stream* - "~{~}" - *header-tname-format* - (list* *max-length-table-name* - (list legend))) - (report-results read rows errors - (format-interval seconds nil) - (when (and rs (not (= rs 0.0))) (format-interval rs nil)) - (when (and ws (not (= rs 0.0))) (format-interval ws nil)) - nil) - (format *report-stream* *footer*)) - -;;; -;;; Pretty print a report from a pgtable and pgstats counters -;;; -(defun report-pgtable-stats (pgstate name) - (with-slots (read rows errs secs rs ws) (pgstate-get-label pgstate name) - (report-results read rows errs - (format-interval secs nil) - (when (and rs (not (= rs 0.0))) (format-interval rs nil)) - (when (and ws (not (= ws 0.0))) (format-interval ws nil))))) - -(defun report-pgstate-stats (pgstate legend) - (with-slots (tabnames read rows errs secs rs ws) pgstate - (when tabnames - (report-footer legend read rows errs secs rs ws)))) - -;;; -;;; Pretty print the whole summary from a state -;;; -(defun report-summary (pgstate &key (header t) footer) - "Report a whole summary." - (when header (report-header)) - (loop - :for label :in (reverse (pgstate-tabnames pgstate)) - :for pgtable := (gethash label (pgstate-tables pgstate)) - :do (with-slots (read rows errs secs rs ws) pgtable - (format *report-stream* - *header-tname-format* - *max-length-table-name* - (etypecase label - (string label) - (table (format-table-name label)))) - (report-results read rows errs - (cond ((> 0 secs) (format-interval secs nil)) - ((and rs ws (= 0 secs)) - (format-interval (max rs ws) nil)) - (t (format-interval secs nil))) - (when (and rs (not (= rs 0.0))) (format-interval rs nil)) - (when (and ws (not (= ws 0.0))) (format-interval ws nil)))) - :finally (when footer - (report-pgstate-stats pgstate footer)))) - (defun parse-summary-type (&optional (pathname *summary-pathname*)) "Return the summary type we want: human-readable, csv, json." - (when pathname - (cond ((string= "csv" (pathname-type pathname)) :csv) - ((string= "json" (pathname-type pathname)) :json) - ((string= "copy" (pathname-type pathname)) :copy) - (t :human-readable)))) + (if pathname + (cond ((string= "csv" (pathname-type pathname)) 'print-format-csv) + ((string= "json" (pathname-type pathname)) 'print-format-json) + ((string= "copy" (pathname-type pathname)) 'print-format-copy)) + (if (member *client-min-messages* + '(:notice :sql :info :debug :data)) + 'print-format-verbose + 'print-format-text))) -(defun max-length-table-name (legend data pre post) +(defun max-length-table-name (state legend) "Compute the max length of a table-name in the legend." (reduce #'max (mapcar #'length @@ -189,51 +45,25 @@ (etypecase entry (string entry) (table (format-table-name entry)))) - (append (pgstate-tabnames data) - (pgstate-tabnames pre) - (pgstate-tabnames post) + (append (pgstate-tabnames (state-data state)) + (pgstate-tabnames (state-preload state)) + (pgstate-tabnames (state-postload state)) (list legend)))) :initial-value 0)) -(defun report-full-summary (legend sections total-secs) +(defun report-full-summary (state legend total-secs) "Report the full story when given three different sections of reporting." + (let* ((ftype (parse-summary-type *summary-pathname*)) + (format (make-instance ftype)) + (max-label-length (max-length-table-name state legend))) - (let* ((data (getf sections :data)) - (pre (getf sections :pre)) - (post (getf sections :post)) - - (stype (or (parse-summary-type *summary-pathname*) - (if (member *client-min-messages* - '(:notice :sql :info :debug :data)) - :human-readable-verbose - :human-readable))) - - (*header* (get-format-for stype :header)) - (*footer* (get-format-for stype :footer)) - (*end-of-line-format* (get-format-for stype :end-of-line-format)) - (*header-line* (get-format-for stype :header-line)) - (*max-length-table-name* (max-length-table-name legend data pre post)) - (*header-tname-format* (get-format-for stype :header-tname-format)) - (*header-stats-format* (get-format-for stype :header-stats-format)) - (*header-cols-format* (get-format-for stype :header-cols-format)) - (*header-cols-names* (get-format-for stype :header-cols-names))) - - (when *header* - (format *report-stream* *header*)) - - (when (and pre (pgstate-tabnames pre)) - (report-summary pre :footer nil) - (format *report-stream* *header-line* *max-length-table-name* "-")) - - (report-summary data :header (null pre) :footer nil) - - (when (and post (pgstate-tabnames post)) - (format *report-stream* *header-line* *max-length-table-name* "-") - (report-summary post :header nil :footer nil)) + (when (typep format 'print-format-human-readable) + (setf (pf-max-label-length format) max-label-length) + (setf (pf-legend format) legend)) ;; replace the grand total now - (setf (pgstate-secs data) total-secs) + (setf (state-secs state) total-secs) + (setf (pgstate-secs (state-data state)) total-secs) - ;; and report the Grand Total - (report-pgstate-stats data legend))) + (pretty-print *report-stream* state format))) diff --git a/src/utils/state.lisp b/src/utils/state.lisp index b9c6213..1ac214e 100644 --- a/src/utils/state.lisp +++ b/src/utils/state.lisp @@ -32,6 +32,23 @@ (ws 0.0 :type float) (bytes 0 :type fixnum)) +(defstruct state + (preload nil :type (or null pgstate)) + (data nil :type (or null pgstate)) + (postload nil :type (or null pgstate)) + (secs 0.0 :type float)) + +(defun create-state () + (make-state :preload (make-pgstate) + :data (make-pgstate) + :postload (make-pgstate))) + +(defun get-state-section (state section) + (ecase section + (:pre (state-preload state)) + (:data (state-data state)) + (:post (state-postload state)))) + (defun relative-pathname (filename type &optional dbname) "Return the pathname of a file of type TYPE (dat or log) under *ROOT-DIR*" (let ((dir (if dbname