[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
branch master updated: Introduce log levels.
|
From: |
Mathieu Othacehe |
|
Subject: |
branch master updated: Introduce log levels. |
|
Date: |
Mon, 06 Dec 2021 08:17:04 -0500 |
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 4c2b452 Introduce log levels.
4c2b452 is described below
commit 4c2b45216e9e691d94e4360f2875fe05570fbcd2
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Mon Dec 6 14:15:41 2021 +0100
Introduce log levels.
* src/cuirass/logging.scm (log-info, log-debug, log-warning, log-error):
New procedures.
* src/cuirass/base.scm: Introduce log levels.
* src/cuirass/database.scm: Ditto.
* src/cuirass/http.scm: Ditto.
* src/cuirass/metrics.scm: Ditto.
* src/cuirass/notification.scm: Ditto.
* src/cuirass/remote.scm: Ditto.
* src/cuirass/scripts/register.scm: Ditto.
* src/cuirass/scripts/remote-server.scm: Ditto.
* src/cuirass/scripts/remote-worker.scm: Ditto.
* src/cuirass/scripts/web.scm: Ditto.
* src/cuirass/utils.scm: Ditto.
* src/cuirass/watchdog.scm: Ditto.
---
src/cuirass/base.scm | 74 +++++++++++++++++------------------
src/cuirass/database.scm | 6 +--
src/cuirass/http.scm | 6 +--
src/cuirass/logging.scm | 57 +++++++++++++++++++--------
src/cuirass/metrics.scm | 6 +--
src/cuirass/notification.scm | 8 ++--
src/cuirass/remote.scm | 4 +-
src/cuirass/scripts/register.scm | 4 +-
src/cuirass/scripts/remote-server.scm | 46 +++++++++++-----------
src/cuirass/scripts/remote-worker.scm | 25 ++++++------
src/cuirass/scripts/web.scm | 2 +-
src/cuirass/utils.scm | 6 +--
src/cuirass/watchdog.scm | 2 +-
13 files changed, 135 insertions(+), 111 deletions(-)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index afe04d3..e68179c 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -311,7 +311,7 @@ Return a list of jobs that are associated to EVAL-ID."
(close-port (cdr log-pipe))
(close-pipe port)
(let ((spec-name (specification-name spec)))
- (log-message "evaluation ~a for '~a' completed" eval-id spec-name))))
+ (log-info "evaluation ~a for '~a' completed" eval-id spec-name))))
;;;
@@ -473,26 +473,26 @@ items."
(define total (length drv))
- (log-message "building ~a derivations in batches of ~a"
- total max-batch-size)
+ (log-info "building ~a derivations in batches of ~a"
+ total max-batch-size)
;; Shuffle DRV so that we don't build sequentially i686/x86_64/aarch64,
;; master/core-updates, etc., which would be suboptimal.
(let loop ((drv (shuffle-derivations drv))
(count total))
(if (zero? count)
- (log-message "done with ~a derivations" total)
+ (log-info "done with ~a derivations" total)
(let*-values (((batch rest)
(if (> count max-batch-size)
(split-at drv max-batch-size)
(values drv '()))))
(guard (c ((store-protocol-error? c)
- (log-message "batch of builds (partially) failed: \
+ (log-error "batch of builds (partially) failed: \
~a (status: ~a)"
- (store-protocol-error-message c)
- (store-protocol-error-status c))))
- (log-message "building batch of ~a derivations (~a/~a)"
- max-batch-size (- total count) total)
+ (store-protocol-error-message c)
+ (store-protocol-error-status c))))
+ (log-info "building batch of ~a derivations (~a/~a)"
+ max-batch-size (- total count) total)
(let-values (((port finish)
(build-derivations& store batch)))
(process-build-log port
@@ -531,32 +531,32 @@ updating the database accordingly."
(('build-started drv _ ...)
(if (valid? drv)
(begin
- (log-message "build started: '~a'" drv)
+ (log-error "build started: '~a'" drv)
(db-update-build-status! drv (build-status started)
#:log-file (log-file store drv)))
- (log-message "bogus build-started event for '~a'" drv)))
+ (log-error "bogus build-started event for '~a'" drv)))
(('build-remote drv host _ ...)
- (log-message "'~a' offloaded to '~a'" drv host)
+ (log-error "'~a' offloaded to '~a'" drv host)
(db-update-build-worker! drv host))
(('build-succeeded drv _ ...)
(if (valid? drv)
(begin
- (log-message "build succeeded: '~a'" drv)
+ (log-error "build succeeded: '~a'" drv)
(set-build-successful! drv)
(register-gc-roots drv))
- (log-message "bogus build-succeeded event for '~a'" drv)))
+ (log-error "bogus build-succeeded event for '~a'" drv)))
(('build-failed drv _ ...)
(if (valid? drv)
(begin
- (log-message "build failed: '~a'" drv)
+ (log-error "build failed: '~a'" drv)
(db-update-build-status! drv (build-status failed)))
- (log-message "bogus build-failed event for '~a'" drv)))
+ (log-error "bogus build-failed event for '~a'" drv)))
(('substituter-started item _ ...)
- (log-message "substituter started: '~a'" item))
+ (log-error "substituter started: '~a'" item))
(('substituter-succeeded item _ ...)
- (log-message "substituter succeeded: '~a'" item))
+ (log-error "substituter succeeded: '~a'" item))
(_
- (log-message "build event: ~s" event))))
+ (log-error "build event: ~s" event))))
(define (build-derivation=? build1 build2)
"Return true if BUILD1 and BUILD2 correspond to the same derivation."
@@ -566,29 +566,29 @@ updating the database accordingly."
(define (clear-build-queue)
"Reset the status of builds in the database that are marked as \"started\".
This procedure is meant to be called at startup."
- (log-message "marking stale builds as \"scheduled\"...")
+ (log-info "marking stale builds as \"scheduled\"...")
(db-clear-build-queue))
(define (restart-builds)
"Restart builds whose status in the database is \"pending\" (scheduled or
started)."
(with-store store
- (log-message "retrieving list of pending builds...")
+ (log-info "retrieving list of pending builds...")
(let*-values (((valid stale)
(partition (cut valid-path? store <>)
(db-get-pending-derivations))))
;; We cannot restart builds listed in STALE, so mark them as canceled.
- (log-message "canceling ~a stale builds" (length stale))
+ (log-info "canceling ~a stale builds" (length stale))
(for-each (lambda (drv)
(db-update-build-status! drv (build-status canceled)))
stale)
;; Those in VALID can be restarted. If some of them were built in the
;; meantime behind our back, that's fine: 'spawn-builds' will DTRT.
- (log-message "restarting ~a pending builds" (length valid))
+ (log-info "restarting ~a pending builds" (length valid))
(unless (%build-remote?)
(spawn-builds store valid))
- (log-message "done with restarted builds"))))
+ (log-info "done with restarted builds"))))
(define (create-build-outputs build build-outputs)
"Given BUILDS a list of built derivations, save the build products described
@@ -616,7 +616,7 @@ by BUILD-OUTPUTS."
(build-output-job build-output))
(find-product build build-output))))
(when (and product (file-exists? product))
- (log-message "Adding build product ~a" product)
+ (log-info "Adding build product ~a" product)
(db-add-build-product
`((#:build . ,(assq-ref build #:id))
(#:type . ,(build-output-type build-output))
@@ -638,8 +638,8 @@ by BUILD-OUTPUTS."
;; collected before getting built.
(for-each (cut register-gc-roots <> #:mode 'derivation)
derivations)
- (log-message "evaluation ~a registered ~a new derivations"
- eval-id (length derivations))
+ (log-info "evaluation ~a registered ~a new derivations"
+ eval-id (length derivations))
(db-set-evaluation-status eval-id
(evaluation-status succeeded))
@@ -658,7 +658,7 @@ by BUILD-OUTPUTS."
outputs))
(fail (- (length derivations) success)))
- (log-message "outputs:\n~a" (string-join outs "\n"))
+ (log-info "outputs:\n~a" (string-join outs "\n"))
results)))
(define (prepare-git)
@@ -708,7 +708,7 @@ specification."
(timestamp (time-second (current-time time-utc)))
(channels (specification-channels spec))
(instances (non-blocking
- (log-message "Fetching channels for spec '~a'." name)
+ (log-info "Fetching channels for spec '~a'." name)
(latest-channel-instances* store channels
#:authenticate? #f)))
(new-channels (map channel-instance-channel instances))
@@ -724,12 +724,12 @@ specification."
(spawn-fiber
(lambda ()
(guard (c ((evaluation-error? c)
- (log-message "failed to evaluate spec '~a'; see ~a"
- (evaluation-error-spec-name c)
- (evaluation-log-file
- (evaluation-error-id c)))
+ (log-error "failed to evaluate spec '~a'; see ~a"
+ (evaluation-error-spec-name c)
+ (evaluation-log-file
+ (evaluation-error-id c)))
#f))
- (log-message "evaluating spec '~a'" name)
+ (log-info "evaluating spec '~a'" name)
(with-store store
;; The LATEST-CHANNEL-INSTANCES procedure may return channel
;; dependencies that are not declared in the initial
@@ -750,7 +750,7 @@ specification."
(and (new-eval? spec)
(process spec)))
(lambda (key error)
- (log-message "Git error while fetching inputs of '~a': ~s~%"
- (specification-name spec)
- (git-error-message error)))))
+ (log-error "Git error while fetching inputs of '~a': ~s~%"
+ (specification-name spec)
+ (git-error-message error)))))
jobspecs))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index efec012..ae5cd8e 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -285,13 +285,13 @@ DB is bound to the argument of that critical section: the
database connection."
#:send-timeout send-timeout
#:send-timeout-proc
(lambda ()
- (log-message
+ (log-warning
(format #f "No available database workers for ~a seconds."
(number->string send-timeout))))
#:receive-timeout receive-timeout
#:receive-timeout-proc
(lambda ()
- (log-message
+ (log-warning
(format #f "Database worker unresponsive for ~a seconds (~a)."
(number->string receive-timeout)
caller-name))))))
@@ -931,7 +931,7 @@ WHERE Builds.status = " (build-status scheduled)
(db-add-build-dependencies drv inputs)))
(with-db-worker-thread db
- (log-message "Registering builds for evaluation ~a." eval-id)
+ (log-info "Registering builds for evaluation ~a." eval-id)
(exec-query db "BEGIN TRANSACTION;")
(let ((new-jobs (filter-map register jobs)))
;; Register build dependencies after registering all the evaluation
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 3eaf0fb..e2a95a9 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -600,8 +600,8 @@ passed, only display JOBS targeting this SYSTEM."
#:body (string-append "Resource not found: "
resource_name)))
- (log-message "~a ~a" (request-method request)
- (uri-path (request-uri request)))
+ (log-info "~a ~a" (request-method request)
+ (uri-path (request-uri request)))
(match (cons (request-method request)
(request-path-components request))
@@ -1153,7 +1153,7 @@ passed, only display JOBS targeting this SYSTEM."
(let* ((host-info (gethostbyname host))
(address (inet-ntop (hostent:addrtype host-info)
(car (hostent:addr-list host-info)))))
- (log-message "listening on ~A:~A" address port)
+ (log-info "listening on ~A:~A" address port)
;; Here we use our own web backend, call 'fiberized'. We cannot use the
;; 'fibers' backend that comes with Fibers 1.0.0 because it does its own
diff --git a/src/cuirass/logging.scm b/src/cuirass/logging.scm
index e6f57c4..f4425ed 100644
--- a/src/cuirass/logging.scm
+++ b/src/cuirass/logging.scm
@@ -24,6 +24,10 @@
#:export (current-logging-port
current-logging-procedure
log-message
+ log-info
+ log-debug
+ log-warning
+ log-error
with-time-logging
log-monitoring-stats
query-logging-port
@@ -47,20 +51,41 @@
(make-parameter (lambda (str)
(log-to-port (current-logging-port) str))))
-(define (log-message fmt . args)
+(define (log-message fmt level . args)
"Log the given message as one line."
;; Note: Use '@' to make sure -Wformat detects this use of 'format'.
- ((current-logging-procedure)
- (apply (@ (ice-9 format) format) #f fmt args)))
+ (let ((fmt (cond
+ ((eq? level 'info)
+ fmt)
+ ((eq? level 'debug)
+ (string-append "debug: " fmt))
+ ((eq? level 'warning)
+ (string-append "warning: " fmt))
+ ((eq? level 'error)
+ (string-append "error: " fmt)))))
+ ((current-logging-procedure)
+ (apply (@ (ice-9 format) format) #f fmt args))))
+
+(define-syntax-rule (log-info fmt args ...)
+ (log-message fmt 'info args ...))
+
+(define-syntax-rule (log-debug fmt args ...)
+ (log-message fmt 'debug args ...))
+
+(define-syntax-rule (log-warning fmt args ...)
+ (log-message fmt 'warning args ...))
+
+(define-syntax-rule (log-error fmt args ...)
+ (log-message fmt 'error args ...))
(define (call-with-time-logging name thunk)
(let* ((start (current-time time-utc))
(result (thunk))
(end (current-time time-utc))
(elapsed (time-difference end start)))
- (log-message "~a took ~a seconds" name
- (+ (time-second elapsed)
- (/ (time-nanosecond elapsed) 1e9)))
+ (log-info "~a took ~a seconds" name
+ (+ (time-second elapsed)
+ (/ (time-nanosecond elapsed) 1e9)))
result))
(define-syntax-rule (with-time-logging name exp ...)
@@ -69,16 +94,16 @@
(define (log-monitoring-stats)
"Log info about useful metrics: heap size, number of threads, etc."
- (log-message "heap: ~,2f MiB; threads: ~a; file descriptors: ~a"
- (/ (assoc-ref (gc-stats) 'heap-size) (expt 2. 20))
- (length (all-threads))
- (length
- ;; In theory 'scandir' cannot return #f, but in practice,
- ;; we've seen it before.
- (or (scandir "/proc/self/fd"
- (lambda (file)
- (not (member file '("." "..")))))
- '()))))
+ (log-info "heap: ~,2f MiB; threads: ~a; file descriptors: ~a"
+ (/ (assoc-ref (gc-stats) 'heap-size) (expt 2. 20))
+ (length (all-threads))
+ (length
+ ;; In theory 'scandir' cannot return #f, but in practice,
+ ;; we've seen it before.
+ (or (scandir "/proc/self/fd"
+ (lambda (file)
+ (not (member file '("." "..")))))
+ '()))))
(define query-logging-port
(make-parameter #f))
diff --git a/src/cuirass/metrics.scm b/src/cuirass/metrics.scm
index 86cc2d4..992349e 100644
--- a/src/cuirass/metrics.scm
+++ b/src/cuirass/metrics.scm
@@ -384,8 +384,8 @@ for periodical metrics for instance."
(value (compute-metric metric field)))
(if value
(begin
- (log-message "Updating metric ~a (~a) to ~a."
- (symbol->string id) field value)
+ (log-info "Updating metric ~a (~a) to ~a."
+ (symbol->string id) field value)
(exec-query/bind db "\
INSERT INTO Metrics (field, type, value, timestamp) VALUES ("
field ", " (metric->type metric) ", "
@@ -393,7 +393,7 @@ INSERT INTO Metrics (field, type, value, timestamp) VALUES
("
now ")
ON CONFLICT ON CONSTRAINT metrics_pkey DO
UPDATE SET value = " value ", timestamp = " now ";"))
- (log-message "Failed to compute metric ~a (~a)."
+ (log-warning "Failed to compute metric ~a (~a)."
(symbol->string id) field)))))
(define (db-update-metrics)
diff --git a/src/cuirass/notification.scm b/src/cuirass/notification.scm
index 7402467..35ce26d 100644
--- a/src/cuirass/notification.scm
+++ b/src/cuirass/notification.scm
@@ -139,8 +139,8 @@ the detailed information about this build here: ~a."
#:subject subject
#:text text))
(lambda args
- (log-message "Failed to send the email notification: ~a."
- args)))))
+ (log-error "Failed to send the email notification: ~a."
+ args)))))
(define (send-mastodon build)
"Send a new status for the given NOTIFICATION."
@@ -149,8 +149,8 @@ the detailed information about this build here: ~a."
(lambda ()
(send-status text))
(lambda args
- (log-message "Failed to send the mastodon notification: ~a."
- args)))))
+ (log-error "Failed to send the mastodon notification: ~a."
+ args)))))
(define (start-notification-thread)
"Start a thread sending build notifications."
diff --git a/src/cuirass/remote.scm b/src/cuirass/remote.scm
index 0cc56e5..fac3c0d 100644
--- a/src/cuirass/remote.scm
+++ b/src/cuirass/remote.scm
@@ -285,7 +285,7 @@ PRIVATE-KEY to sign narinfos."
(lambda (output)
(dump-port port output)))))
(_
- (log-message "invalid log received.~%")
+ (log-error "invalid log received.~%")
#f)))
(define (wait-for-client port proc)
@@ -345,7 +345,7 @@ PRIVATE-KEY to sign narinfos."
(dump-port log sock-compressed))))
(close-port sock)))
(x
- (log-message "invalid handshake ~s.~%" x)
+ (log-error "invalid handshake ~s.~%" x)
(close-port sock)
#f)))
((() () ()) ;timeout
diff --git a/src/cuirass/scripts/register.scm b/src/cuirass/scripts/register.scm
index 3050cde..0b0c124 100644
--- a/src/cuirass/scripts/register.scm
+++ b/src/cuirass/scripts/register.scm
@@ -119,7 +119,7 @@
(min (current-processor-count) 4))))
(prepare-git)
- (log-message "running Fibers on ~a kernel threads" threads)
+ (log-info "running Fibers on ~a kernel threads" threads)
(run-fibers
(lambda ()
(with-database
@@ -155,7 +155,7 @@
(lambda ()
(while #t
(process-specs (db-get-specifications))
- (log-message
+ (log-info
"next evaluation in ~a seconds" interval)
(sleep interval)))))
diff --git a/src/cuirass/scripts/remote-server.scm
b/src/cuirass/scripts/remote-server.scm
index cb7eb23..f36a98b 100644
--- a/src/cuirass/scripts/remote-server.scm
+++ b/src/cuirass/scripts/remote-server.scm
@@ -246,9 +246,9 @@ be used to reply to the worker."
(('worker-request-work name)
(let ((worker (db-get-worker name)))
(when (and (%debug) worker)
- (log-message "~a (~a): request work."
- (worker-address worker)
- (worker-name worker)))
+ (log-debug "~a (~a): request work."
+ (worker-address worker)
+ (worker-name worker)))
(let ((build (pop-build name)))
(if build
(let ((derivation (assq-ref build #:derivation))
@@ -256,10 +256,10 @@ be used to reply to the worker."
(timeout (assq-ref build #:timeout))
(max-silent (assq-ref build #:max-silent)))
(when (and (%debug) worker)
- (log-message "~a (~a): build ~a submitted."
- (worker-address worker)
- (worker-name worker)
- derivation))
+ (log-debug "~a (~a): build ~a submitted."
+ (worker-address worker)
+ (worker-name worker)
+ derivation))
(db-update-build-worker! derivation name)
(db-update-build-status! derivation (build-status submitted))
(reply-worker
@@ -269,7 +269,7 @@ be used to reply to the worker."
#:max-silent max-silent)))
(begin
(when (and (%debug) worker)
- (log-message "~a (~a): no available build."
+ (log-info "~a (~a): no available build."
(worker-address worker)
(worker-name worker)))
(reply-worker
@@ -280,7 +280,7 @@ be used to reply to the worker."
(let ((log-file (log-path (%cache-directory) drv))
(worker (db-get-worker name)))
(when worker
- (log-message "~a (~a): build started: '~a'."
+ (log-info "~a (~a): build started: '~a'."
(worker-address worker)
(worker-name worker)
drv))
@@ -316,12 +316,12 @@ be used to reply to the worker."
(define (ensure-path* store output)
(guard (c ((store-protocol-error? c)
- (log-message "Failed to add ~a to store: store protocol error."
output)
- (log-message "The remote-worker signing key might not be
authorized.")
+ (log-error "Failed to add ~a to store: store protocol error."
output)
+ (log-error "The remote-worker signing key might not be
authorized.")
#f)
((nar-error? c)
- (log-message "Failed to add ~a to store: nar error." output)
- (log-message "The guix-daemon process may have returned
unexpectedly.")
+ (log-error "Failed to add ~a to store: nar error." output)
+ (log-error "The guix-daemon process may have returned
unexpectedly.")
#f))
(ensure-path store output)))
@@ -329,7 +329,7 @@ be used to reply to the worker."
(let* ((store-hash (strip-store-prefix output))
(narinfo-url (publish-narinfo-url url store-hash)))
(when (%debug)
- (log-message "Bake: ~a" narinfo-url))
+ (log-debug "Bake: ~a" narinfo-url))
(call-with-temporary-output-file
(lambda (tmp-file port)
(url-fetch* narinfo-url tmp-file)))))
@@ -359,11 +359,11 @@ required and #f otherwise."
(match (zmq-read-message message)
(('build-succeeded ('drv drv) _ ...)
(when (%debug)
- (log-message "Fetching required for ~a (success)" drv))
+ (log-debug "fetching required for ~a (success)" drv))
#t)
(('build-failed ('drv drv) _ ...)
(when (%debug)
- (log-message "Fetching required for ~a (fail)" drv))
+ (log-debug "fetching required for ~a (fail)" drv))
#t)
(else #f)))
@@ -384,7 +384,7 @@ directory."
(match (zmq-read-message message)
(('build-succeeded ('drv drv) ('url url) _ ...)
(let ((outputs (build-outputs drv)))
- (log-message "fetching '~a' from ~a" drv url)
+ (log-info "fetching '~a' from ~a" drv url)
(call-with-time
(lambda ()
(add-to-store drv outputs url))
@@ -392,12 +392,12 @@ directory."
(let ((duration (+ (time-second time)
(/ (time-nanosecond time) 1e9))))
(when (> duration 60)
- (log-message "fetching '~a' took ~a seconds."
+ (log-warning "fetching '~a' took ~a seconds."
drv duration)))))
- (log-message "build succeeded: '~a'" drv)
+ (log-info "build succeeded: '~a'" drv)
(set-build-successful! drv)))
(('build-failed ('drv drv) ('url url) _ ...)
- (log-message "build failed: '~a'" drv)
+ (log-info "build failed: '~a'" drv)
(db-update-build-status! drv (build-status failed)))))
(define (start-fetch-worker name)
@@ -430,9 +430,9 @@ socket."
(let loop ()
(let ((resumable (db-update-resumable-builds!))
(failed (db-update-failed-builds!)))
- (log-message "period update: ~a resumable, ~a failed builds."
+ (log-info "period update: ~a resumable, ~a failed builds."
resumable failed)
- (log-message "period update: ~a items in the fetch queue."
+ (log-info "period update: ~a items in the fetch queue."
(atomic-box-ref %fetch-queue-size)))
(sleep 30)
(loop)))))
@@ -501,7 +501,7 @@ frontend to the workers connected through the TCP backend."
(db-remove-unresponsive-workers (%worker-timeout))
(let ((delta (- (current-time) start-time)))
(when (> delta %loop-timeout)
- (log-message "Poll loop busy during ~a seconds." delta)))
+ (log-warning "Poll loop busy during ~a seconds." delta)))
(loop)))))
diff --git a/src/cuirass/scripts/remote-worker.scm
b/src/cuirass/scripts/remote-worker.scm
index 812ae4e..404e26d 100644
--- a/src/cuirass/scripts/remote-worker.scm
+++ b/src/cuirass/scripts/remote-worker.scm
@@ -205,9 +205,8 @@ still be substituted."
#:max-silent max-silent)
(reply (zmq-build-started-message drv name))
(guard (c ((store-protocol-error? c)
- (log-message (G_ "~a: derivation `~a' build failed: ~a")
- name
- drv (store-protocol-error-message c))
+ (log-info (G_ "~a: derivation `~a' build failed: ~a")
+ name drv (store-protocol-error-message c))
(reply (zmq-build-failed-message drv local-publish-url))))
(let ((result
(let-values (((port finish)
@@ -217,13 +216,13 @@ still be substituted."
(finish))))
(if result
(begin
- (log-message (G_ "~a: derivation ~a build succeeded.")
- name drv)
+ (log-info (G_ "~a: derivation ~a build succeeded.")
+ name drv)
(register-gc-roots drv)
(reply (zmq-build-succeeded-message drv local-publish-url)))
(begin
- (log-message (G_ "~a: derivation ~a build failed.")
- name drv)
+ (log-info (G_ "~a: derivation ~a build failed.")
+ name drv)
(reply
(zmq-build-failed-message drv local-publish-url)))))))))
@@ -239,16 +238,16 @@ command. REPLY is a procedure that can be used to reply
to this server."
('max-silent max-silent)
('timestamp timestamp)
('system system))
- (log-message (G_ "~a: building `~a' derivation.")
- (worker-name worker) drv)
+ (log-info (G_ "~a: building `~a' derivation.")
+ (worker-name worker) drv)
(run-build drv server
#:reply reply
#:worker worker
#:timeout timeout
#:max-silent max-silent))
(('no-build)
- (log-message (G_ "~a: no available build.")
- (worker-name worker))
+ (log-info (G_ "~a: no available build.")
+ (worker-name worker))
#t)))
(define (worker-ping worker server)
@@ -267,7 +266,7 @@ command. REPLY is a procedure that can be used to reply to
this server."
(endpoint (zmq-backend-endpoint address port)))
(zmq-connect socket endpoint)
(let loop ()
- (log-message (G_ "~a: ping ~a.") (worker-name worker) endpoint)
+ (log-info (G_ "~a: ping ~a.") (worker-name worker) endpoint)
(ping socket)
(sleep 60)
(loop))))))
@@ -346,7 +345,7 @@ and executing them. The worker can reply on the same
socket."
(ready socket worker)
(worker-ping worker server)
(let loop ()
- (log-message (G_ "~a: request work.") (worker-name wrk))
+ (log-info (G_ "~a: request work.") (worker-name wrk))
(request-work socket worker)
(match (zmq-get-msg-parts-bytevector socket '())
((empty command)
diff --git a/src/cuirass/scripts/web.scm b/src/cuirass/scripts/web.scm
index 62f822f..379d680 100644
--- a/src/cuirass/scripts/web.scm
+++ b/src/cuirass/scripts/web.scm
@@ -92,7 +92,7 @@
(min (current-processor-count) 4))))
(prepare-git)
- (log-message "running Fibers on ~a kernel threads" threads)
+ (log-info "running Fibers on ~a kernel threads" threads)
(run-fibers
(lambda ()
(with-database
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index fe17a6c..eca214b 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -291,9 +291,9 @@ die silently while the rest of the program keeps going."
(lambda (key . args)
;; If something goes wrong in this fiber, we have a problem, so stop
;; everything.
- (log-message "fatal: uncaught exception '~a' in '~a' fiber!"
- key name)
- (log-message "exception arguments: ~s" args)
+ (log-error "fatal: uncaught exception '~a' in '~a' fiber!"
+ key name)
+ (log-error "exception arguments: ~s" args)
(false-if-exception
(let ((stack (make-stack #t)))
diff --git a/src/cuirass/watchdog.scm b/src/cuirass/watchdog.scm
index 5d617eb..4b677e3 100644
--- a/src/cuirass/watchdog.scm
+++ b/src/cuirass/watchdog.scm
@@ -60,7 +60,7 @@ printed."
((scheduler . time)
(let ((diff-ping (- cur-time time)))
(when (> diff-ping timeout)
- (log-message "Scheduler ~a blocked since ~a seconds."
+ (log-warning "Scheduler ~a blocked since ~a seconds."
scheduler diff-ping)))))
pings)
cur-time)
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- branch master updated: Introduce log levels.,
Mathieu Othacehe <=