diff options
| -rw-r--r-- | Makefile.am | 12 | ||||
| -rw-r--r-- | src/cuirass/base.scm | 23 | ||||
| -rw-r--r-- | src/cuirass/logging.scm | 48 |
3 files changed, 62 insertions, 21 deletions
diff --git a/Makefile.am b/Makefile.am index 3a3740f..f81f862 100644 --- a/Makefile.am +++ b/Makefile.am @@ -2,6 +2,7 @@ # Copyright © 1995-2016 Free Software Foundation, Inc. # Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org> +# Copyright © 2018 Ludovic Courtès <ludo@gnu.org> # # This file is part of Cuirass. # @@ -30,11 +31,12 @@ nodist_guileobject_DATA = $(dist_guilesite_DATA:.scm=.go) pkgmoduledir = $(guilesitedir)/$(PACKAGE) pkgobjectdir = $(guileobjectdir)/$(PACKAGE) -dist_pkgmodule_DATA = \ - src/cuirass/base.scm \ - src/cuirass/database.scm \ - src/cuirass/http.scm \ - src/cuirass/ui.scm \ +dist_pkgmodule_DATA = \ + src/cuirass/base.scm \ + src/cuirass/database.scm \ + src/cuirass/http.scm \ + src/cuirass/logging.scm \ + src/cuirass/ui.scm \ src/cuirass/utils.scm nodist_pkgmodule_DATA = \ diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index 1daa428..d57612e 100644 --- a/src/cuirass/base.scm +++ b/src/cuirass/base.scm @@ -20,6 +20,7 @@ ;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>. (define-module (cuirass base) + #:use-module (cuirass logging) #:use-module (cuirass database) #:use-module (gnu packages) #:use-module (guix build utils) @@ -247,30 +248,20 @@ and so on. " (define* (handle-build-event db event #:key (log-port (current-error-port))) "Handle EVENT, a build event sexp as produced by 'build-event-output-port'." - (define now - (current-time time-utc)) - - (define date - (date->string (time-utc->date now) "~5")) - - (define (log fmt . args) - (apply format log-port (string-append date " " fmt "\n") - args)) - ;; TODO: Update DB according to EVENT. (match event (('build-started drv _ ...) - (log "build started: '~a'" drv)) + (log-message "build started: '~a'" drv)) (('build-remote drv host _ ...) - (log "build of '~a' offloaded to '~a'" drv host)) + (log-message "build of '~a' offloaded to '~a'" drv host)) (('build-succeeded drv _ ...) - (log "build succeeded: '~a'" drv)) + (log-message "build succeeded: '~a'" drv)) (('substituter-started item _ ...) - (log "substituter started: '~a'" item)) + (log-message "substituter started: '~a'" item)) (('substituter-succeeded item _ ...) - (log "substituter succeeded: '~a'" item)) + (log-message "substituter succeeded: '~a'" item)) (_ - (log "build event: ~s" event)))) + (log-message "build event: ~s" event)))) (define (build-packages store db jobs) "Build JOBS and return a list of Build results." diff --git a/src/cuirass/logging.scm b/src/cuirass/logging.scm new file mode 100644 index 0000000..bd1eed3 --- /dev/null +++ b/src/cuirass/logging.scm @@ -0,0 +1,48 @@ +;;; logging.scm -- Event logging. +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of Cuirass. +;;; +;;; Cuirass is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Cuirass is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>. + +(define-module (cuirass logging) + #:use-module (srfi srfi-19) + #:use-module (ice-9 format) + #:export (current-logging-port + current-logging-procedure + log-message)) + +(define current-logging-port + (make-parameter (current-error-port))) + +(define (log-to-port port str) + (define now + (current-time time-utc)) + + (define date + (date->string (time-utc->date now) "~5")) + + (display (string-append date " " str "\n") + port)) + +(define current-logging-procedure + ;; The logging procedure. This could be 'syslog', for instance. + (make-parameter (lambda (str) + (log-to-port (current-logging-port) str)))) + +(define-syntax-rule (log-message fmt args ...) + "Log the given message as one line." + ;; Note: Use '@' to make sure -Wformat detects this use of 'format'. + ((current-logging-procedure) + ((@ (ice-9 format) format) #f fmt args ...))) |