Introduce concurrency with Fibers.
* README: Mark Fibers as required. * configure.ac: Check for Guile 2.2 only. Check for (fibers). * bin/cuirass.in (main): Use (fibers). Run 'process-specs' and web server in separate fibers. * src/cuirass/base.scm (with-store): New macro. (non-blocking-port): New procedure. (evaluate): Use 'non-blocking-port'. Use 'read-string' followed by 'read'. (process-specs): Move 'db-add-stamp' right after 'string=?' comparison. Run evaluation and subsequent builds in a separate fiber. * src/cuirass/http.scm (run-cuirass-server): Pass 'fibers as the second argument to 'run-server'. Use 'log-message' instead of 'format'. * src/cuirass/database.scm (with-database): Remove 'dynamic-wind'.
This commit is contained in:
parent
f9481e2222
commit
ee11ba1d93
1
README
1
README
|
@ -12,6 +12,7 @@ Cuirass currently depends on the following packages:
|
|||
- Guile-JSON
|
||||
- Guile-SQLite3
|
||||
- Guile-Git
|
||||
- Fibers
|
||||
|
||||
A convenient way to install those dependencies is to install Guix and execute
|
||||
the following command:
|
||||
|
|
|
@ -26,7 +26,9 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
|||
|
||||
(use-modules (cuirass)
|
||||
(cuirass ui)
|
||||
(cuirass logging)
|
||||
(guix ui)
|
||||
(fibers)
|
||||
(ice-9 getopt-long))
|
||||
|
||||
(define (show-help)
|
||||
|
@ -90,23 +92,35 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
|||
(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 "10")))
|
||||
(interval (string->number (option-ref opts 'interval "300")))
|
||||
(specfile (option-ref opts 'specifications #f)))
|
||||
(prepare-git)
|
||||
(with-database db
|
||||
(and specfile
|
||||
(let ((new-specs (save-module-excursion
|
||||
(lambda ()
|
||||
(set-current-module (make-user-module '()))
|
||||
(primitive-load specfile)))))
|
||||
(for-each (lambda (spec) (db-add-specification db spec))
|
||||
new-specs)))
|
||||
(if one-shot?
|
||||
(process-specs db (db-get-specifications db))
|
||||
(begin
|
||||
(call-with-new-thread
|
||||
(lambda ()
|
||||
(while #t
|
||||
(process-specs db (db-get-specifications db))
|
||||
(sleep interval))))
|
||||
(run-cuirass-server db #:host host #:port port))))))))))
|
||||
(run-fibers
|
||||
(lambda ()
|
||||
(with-database db
|
||||
(and specfile
|
||||
(let ((new-specs (save-module-excursion
|
||||
(lambda ()
|
||||
(set-current-module (make-user-module '()))
|
||||
(primitive-load specfile)))))
|
||||
(for-each (lambda (spec) (db-add-specification db spec))
|
||||
new-specs)))
|
||||
(if one-shot?
|
||||
(process-specs db (db-get-specifications db))
|
||||
(begin
|
||||
(spawn-fiber
|
||||
(lambda ()
|
||||
(with-database db
|
||||
(while #t
|
||||
(process-specs db (db-get-specifications db))
|
||||
(log-message "sleeping for ~a seconds" interval)
|
||||
(sleep interval)))))
|
||||
(spawn-fiber
|
||||
(lambda ()
|
||||
(with-database db
|
||||
(run-cuirass-server db
|
||||
#:host host
|
||||
#:port port))))
|
||||
*unspecified*))))
|
||||
|
||||
#:drain? #t)))))))
|
||||
|
|
10
configure.ac
10
configure.ac
|
@ -1,7 +1,7 @@
|
|||
## Process this file with autoconf to produce a configure script.
|
||||
|
||||
# Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
|
||||
# Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
# Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
|
||||
# Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||
#
|
||||
# This file is part of Cuirass.
|
||||
|
@ -35,11 +35,8 @@ AC_CANONICAL_HOST
|
|||
AC_PROG_MKDIR_P
|
||||
AC_PROG_SED
|
||||
|
||||
GUILE_PKG([2.2 2.0])
|
||||
|
||||
if test "x$GUILE_EFFECTIVE_VERSION" = "x2.0"; then
|
||||
PKG_CHECK_MODULES([GUILE], [guile-2.0 >= 2.0.7])
|
||||
fi
|
||||
# We need Fibers, which requires 2.2+.
|
||||
GUILE_PKG([2.2])
|
||||
|
||||
AC_PATH_PROG([GUILE], [guile])
|
||||
AC_PATH_PROG([GUILD], [guild])
|
||||
|
@ -51,6 +48,7 @@ GUILE_MODULE_REQUIRED([guix git])
|
|||
GUILE_MODULE_REQUIRED([git])
|
||||
GUILE_MODULE_REQUIRED([json])
|
||||
GUILE_MODULE_REQUIRED([sqlite3])
|
||||
GUILE_MODULE_REQUIRED([fibers])
|
||||
|
||||
# We depend on new Guile-Git errors.
|
||||
GUILE_MODULE_REQUIRED_EXPORT([(git)], git-error-message)
|
||||
|
|
|
@ -20,6 +20,7 @@
|
|||
;;; along with Cuirass. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (cuirass base)
|
||||
#:use-module (fibers)
|
||||
#:use-module (cuirass logging)
|
||||
#:use-module (cuirass database)
|
||||
#:use-module (gnu packages)
|
||||
|
@ -56,6 +57,17 @@
|
|||
%use-substitutes?
|
||||
%fallback?))
|
||||
|
||||
(define-syntax-rule (with-store store exp ...)
|
||||
;; XXX: This is a 'with-store' variant that plays well with delimited
|
||||
;; continuations and fibers. The 'with-store' macro in (guix store)
|
||||
;; currently closes in a 'dynamic-wind' handler, which means it would close
|
||||
;; the store at each context switch. Remove this when the real 'with-store'
|
||||
;; has been fixed.
|
||||
(let* ((store (open-connection))
|
||||
(result (begin exp ...)))
|
||||
(close-connection store)
|
||||
result))
|
||||
|
||||
(cond-expand
|
||||
(guile-2.2
|
||||
;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
|
||||
|
@ -164,18 +176,27 @@ directory and the sha1 of the top level commit in this directory."
|
|||
evaluation-error?
|
||||
(name evaluation-error-spec-name))
|
||||
|
||||
(define (non-blocking-port port)
|
||||
"Make PORT non-blocking and return it."
|
||||
(let ((flags (fcntl port F_GETFL)))
|
||||
(fcntl port F_SETFL (logior O_NONBLOCK flags))
|
||||
port))
|
||||
|
||||
(define (evaluate store db spec)
|
||||
"Evaluate and build package derivations. Return a list of jobs."
|
||||
(let* ((port (open-pipe* OPEN_READ
|
||||
"evaluate"
|
||||
(string-append (%package-cachedir) "/"
|
||||
(assq-ref spec #:name) "/"
|
||||
(assq-ref spec #:load-path))
|
||||
(%guix-package-path)
|
||||
(%package-cachedir)
|
||||
(object->string spec)
|
||||
(%package-database)))
|
||||
(jobs (match (read port)
|
||||
(let* ((port (non-blocking-port
|
||||
(open-pipe* OPEN_READ
|
||||
"evaluate"
|
||||
(string-append (%package-cachedir) "/"
|
||||
(assq-ref spec #:name) "/"
|
||||
(assq-ref spec #:load-path))
|
||||
(%guix-package-path)
|
||||
(%package-cachedir)
|
||||
(object->string spec)
|
||||
(%package-database))))
|
||||
;; XXX: Since 'read' is not suspendable as of Guile 2.2.3, we use
|
||||
;; 'read-string' (which is suspendable) and then 'read'.
|
||||
(jobs (match (read-string port)
|
||||
;; If an error occured during evaluation report it,
|
||||
;; otherwise, suppose that data read from port are
|
||||
;; correct and keep things going.
|
||||
|
@ -183,9 +204,11 @@ directory and the sha1 of the top level commit in this directory."
|
|||
(raise (condition
|
||||
(&evaluation-error
|
||||
(name (assq-ref spec #:name))))))
|
||||
(data data))))
|
||||
((? string? data)
|
||||
(call-with-input-string data read)))))
|
||||
(close-pipe port)
|
||||
jobs))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Build status.
|
||||
|
@ -359,6 +382,10 @@ and so on. "
|
|||
name commit stamp)
|
||||
(when commit
|
||||
(unless (string=? commit stamp)
|
||||
;; Immediately mark COMMIT as being processed so we don't spawn
|
||||
;; a concurrent evaluation of that same commit.
|
||||
(db-add-stamp db spec commit)
|
||||
|
||||
(copy-repository-cache checkout spec)
|
||||
|
||||
(unless (assq-ref spec #:no-compile?)
|
||||
|
@ -371,18 +398,23 @@ and so on. "
|
|||
#:fallback? (%fallback?)
|
||||
#:keep-going? #t)
|
||||
|
||||
(guard (c ((evaluation-error? c)
|
||||
(format #t "Failed to evaluate ~s specification.~%"
|
||||
(evaluation-error-spec-name c))
|
||||
#f))
|
||||
(log-message "evaluating '~a' with commit ~s"
|
||||
name commit)
|
||||
(let* ((spec* (acons #:current-commit commit spec))
|
||||
(jobs (evaluate store db spec*)))
|
||||
(log-message "building ~a jobs for '~a'"
|
||||
(length jobs) name)
|
||||
(build-packages store db jobs))))
|
||||
(db-add-stamp db spec commit))))))
|
||||
(spawn-fiber
|
||||
(lambda ()
|
||||
(guard (c ((evaluation-error? c)
|
||||
(log-message "failed to evaluate spec '~s'"
|
||||
(evaluation-error-spec-name c))
|
||||
#f))
|
||||
(log-message "evaluating '~a' with commit ~s"
|
||||
name commit)
|
||||
(with-store store
|
||||
(let* ((spec* (acons #:current-commit commit spec))
|
||||
(jobs (evaluate store db spec*)))
|
||||
(log-message "building ~a jobs for '~a'"
|
||||
(length jobs) name)
|
||||
(build-packages store db jobs))))))
|
||||
|
||||
;; 'spawn-fiber' returns zero values but we need one.
|
||||
*unspecified*))))))
|
||||
|
||||
(for-each process jobspecs))
|
||||
|
||||
|
|
|
@ -174,11 +174,13 @@ INSERT INTO Evaluations (specification, revision) VALUES ('~A', '~A');"
|
|||
|
||||
(define-syntax-rule (with-database db body ...)
|
||||
"Run BODY with a connection to the database which is bound to DB in BODY."
|
||||
(let ((db (db-open)))
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda () body ...)
|
||||
(lambda () (db-close db)))))
|
||||
;; XXX: We don't install an unwind handler to play well with delimited
|
||||
;; continuations and fibers. But as a consequence, we leak DB when BODY
|
||||
;; raises an exception.
|
||||
(let* ((db (db-open))
|
||||
(result (begin body ...)))
|
||||
(db-close db)
|
||||
result))
|
||||
|
||||
(define* (read-quoted-string #:optional (port (current-input-port)))
|
||||
"Read all of the characters out of PORT and return them as a SQL quoted
|
||||
|
|
|
@ -21,6 +21,7 @@
|
|||
(define-module (cuirass http)
|
||||
#:use-module (cuirass database)
|
||||
#:use-module (cuirass utils)
|
||||
#:use-module (cuirass logging)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (json)
|
||||
#:use-module (web request)
|
||||
|
@ -160,8 +161,8 @@
|
|||
(let* ((host-info (gethostbyname host))
|
||||
(address (inet-ntop (hostent:addrtype host-info)
|
||||
(car (hostent:addr-list host-info)))))
|
||||
(format (current-error-port) "listening on ~A:~A~%" address port)
|
||||
(log-message "listening on ~A:~A" address port)
|
||||
(run-server url-handler
|
||||
'http
|
||||
'fibers ;the fibers web backend
|
||||
`(#:host ,address #:port ,port)
|
||||
db)))
|
||||
|
|
Loading…
Reference in New Issue