aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile.am11
-rw-r--r--configure.ac7
-rw-r--r--guix-build-coordinator/config.scm.in7
-rw-r--r--guix-build-coordinator/coordinator.scm10
-rw-r--r--guix-build-coordinator/datastore.scm18
-rw-r--r--guix-build-coordinator/datastore/abstract.scm5
-rw-r--r--guix-build-coordinator/datastore/postgresql.scm15
-rw-r--r--guix-build-coordinator/datastore/sqlite.scm190
-rw-r--r--guix-build-coordinator/utils.scm110
-rw-r--r--scripts/guix-build-coordinator.in16
10 files changed, 382 insertions, 7 deletions
diff --git a/Makefile.am b/Makefile.am
index e4e4509..fc34fbe 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -5,5 +5,14 @@ bin_SCRIPTS = \
scripts/guix-build-coordinator-agent
SOURCES = \
+ guix-build-coordinator/agent-messaging/http.scm \
guix-build-coordinator/agent.scm \
- guix-build-coordinator/config.scm
+ guix-build-coordinator/build-allocator.scm \
+ guix-build-coordinator/config.scm \
+ guix-build-coordinator/coordinator.scm \
+ guix-build-coordinator/datastore.scm \
+ guix-build-coordinator/datastore/abstract.scm \
+ guix-build-coordinator/datastore/postgresql.scm \
+ guix-build-coordinator/datastore/sqlite.scm \
+ guix-build-coordinator/hooks.scm \
+ guix-build-coordinator/utils.scm
diff --git a/configure.ac b/configure.ac
index 92b5d2c..d1f7c1a 100644
--- a/configure.ac
+++ b/configure.ac
@@ -8,6 +8,13 @@ if test "x$GUILD" = "x"; then
AC_MSG_ERROR(['guild' binary not found; please check your guile-3.x installation.])
fi
+AC_PATH_PROG([guix], [guix])
+
+AC_PATH_PROG([sqitch], [sqitch])
+AC_PATH_PROG([sqlite3], [sqlite3])
+AC_PATH_PROG([psql], [psql])
+
+
AC_CONFIG_FILES([Makefile])
AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
AC_CONFIG_FILES([guix-build-coordinator/config.scm])
diff --git a/guix-build-coordinator/config.scm.in b/guix-build-coordinator/config.scm.in
index 09a86bc..025f66d 100644
--- a/guix-build-coordinator/config.scm.in
+++ b/guix-build-coordinator/config.scm.in
@@ -24,10 +24,11 @@
(define %config
(let ((config
- `((guix . "@guix@")
+ `((guix . "@guix@")
- (sqitch . "@sqitch@")
- (sqitch-psql . "@psql@")
+ (sqitch . "@sqitch@")
+ (sqitch-psql . "@psql@")
+ (sqitch-sqlite . "@sqlite3@")
(sqitch-plan
. ,(let ((installed-plan
"@prefix@/share/guix-build-coordinator/sqitch/sqitch.plan")
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 4246871..2851b2c 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -19,4 +19,12 @@
;;; <http://www.gnu.org/licenses/>.
(define-module (guix-build-coordinator coordinator)
- )
+ #:use-module (guix derivations)
+ #:use-module (guix-build-coordinator datastore)
+ #:export (submit-build))
+
+(define (submit-build datastore derivation-file)
+ (let ((derivation
+ (read-derivation-from-file derivation-file)))
+
+ (datastore-store-derivation datastore derivation)))
diff --git a/guix-build-coordinator/datastore.scm b/guix-build-coordinator/datastore.scm
new file mode 100644
index 0000000..968363d
--- /dev/null
+++ b/guix-build-coordinator/datastore.scm
@@ -0,0 +1,18 @@
+(define-module (guix-build-coordinator datastore)
+ #:use-module (oop goops)
+ #:duplicates (merge-generics)
+ #:use-module (guix-build-coordinator datastore abstract)
+ #:use-module (guix-build-coordinator datastore sqlite)
+ ;; #:use-module (guix-build-coordinator datastore postgresql)
+ #:re-export (datastore-store-derivation)
+ #:export (database-uri->datastore))
+
+(define (database-uri->datastore database)
+ (cond
+ ((string-prefix? "pg://" database)
+ (postgresql-datastore database))
+ ((string-prefix? "sqlite://" database)
+ (sqlite-datastore database))
+ (else
+ (error
+ (simple-format #f "Unknown database ~A" database)))))
diff --git a/guix-build-coordinator/datastore/abstract.scm b/guix-build-coordinator/datastore/abstract.scm
new file mode 100644
index 0000000..c242b0a
--- /dev/null
+++ b/guix-build-coordinator/datastore/abstract.scm
@@ -0,0 +1,5 @@
+(define-module (guix-build-coordinator datastore abstract)
+ #:use-module (oop goops)
+ #:export (<abstract-datastore>))
+
+(define-class <abstract-datastore> ())
diff --git a/guix-build-coordinator/datastore/postgresql.scm b/guix-build-coordinator/datastore/postgresql.scm
new file mode 100644
index 0000000..e1abb7a
--- /dev/null
+++ b/guix-build-coordinator/datastore/postgresql.scm
@@ -0,0 +1,15 @@
+(define-module (guix-build-coordinator datastore postgresql)
+ #:use-module (oop goops)
+ #:use-module (guix-build-coordinator datastore abstract)
+ #:export (postgresql-datastore
+ datastore-store-derivation))
+
+(define-class <postgresql-datastore> (<abstract-datastore>))
+
+(define (make-postgresql-datastore)
+ (make <postgresql-datastore>))
+
+(define-method (datastore-store-derivation
+ (datastore <postgresql-datastore>)
+ derivation)
+ (peek "POSTGRESQL store derivation" datastore derivation))
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
new file mode 100644
index 0000000..d50a521
--- /dev/null
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -0,0 +1,190 @@
+(define-module (guix-build-coordinator datastore sqlite)
+ #:use-module (oop goops)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 threads)
+ #:use-module (sqlite3)
+ #:use-module (guix derivations)
+ #:use-module (guix-build-coordinator utils)
+ #:use-module (guix-build-coordinator config)
+ #:use-module (guix-build-coordinator datastore abstract)
+ #:export (sqlite-datastore
+ datastore-store-derivation))
+
+(define-class <sqlite-datastore> (<abstract-datastore>)
+ worker-thread-channel)
+
+(define* (sqlite-datastore database-uri #:key update-database?)
+ (define database-file
+ (string-drop database-uri
+ (string-length "sqlite://")))
+
+ (when update-database?
+ (run-sqitch database-file))
+
+ (let ((datastore (make <sqlite-datastore>)))
+
+ (slot-set!
+ datastore
+ 'worker-thread-channel
+ (make-worker-thread-channel (lambda ()
+ (list (db-open database-file)))
+ #:parallelism
+ (min (current-processor-count) 4)))
+
+ datastore))
+
+(define-method (datastore-store-derivation
+ (datastore <sqlite-datastore>)
+ derivation)
+ (call-with-worker-thread
+ (slot-ref datastore 'worker-thread-channel)
+ (lambda (db)
+ (sqlite-exec db "BEGIN TRANSACTION;")
+ (insert-derivation-and-return-outputs db derivation)
+ (sqlite-exec db "COMMIT TRANSACTION;")))
+ #t)
+
+(define (db-open database)
+ (define flags
+ (list SQLITE_OPEN_READWRITE
+ SQLITE_OPEN_NOMUTEX))
+
+ (unless (file-exists? database)
+ (run-sqitch database))
+
+ (sqlite-open database (apply logior flags)))
+
+(define (run-sqitch database-file)
+ (let ((command
+ (list (%config 'sqitch)
+ "deploy"
+ "--db-client" (%config 'sqitch-sqlite)
+ "--chdir" (dirname (dirname (%config 'sqitch-plan)))
+ "--plan-file" (%config 'sqitch-plan)
+ (string-append "db:sqlite:" database-file))))
+
+ (simple-format #t "running command: ~A\n"
+ (string-join command))
+ (unless (zero? (apply system* command))
+ (simple-format
+ (current-error-port)
+ "error: sqitch command failed\n")
+ (exit 1))))
+
+(define (changes-count db)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "SELECT changes();")))
+ (let ((count
+ (vector-ref (sqlite-step statement)
+ 0)))
+
+ (sqlite-reset statement)
+
+ count)))
+
+(define (select-derivation-outputs db derivation-name)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+SELECT name, id FROM derivation_outputs WHERE derivation_name = :derivation_name")))
+
+ (sqlite-bind-arguments
+ statement
+ #:derivation_name derivation-name)
+
+ (let ((outputs (sqlite-map
+ (match-lambda
+ (#(name output-id)
+ (cons name output-id)))
+ statement)))
+ (sqlite-reset statement)
+
+ outputs)))
+
+(define (insert-derivation-and-return-outputs db derivation)
+ (define derivation-name
+ (derivation-file-name derivation))
+
+ (define (insert-derivation)
+ (let ((statement
+ (sqlite-prepare
+ db
+ "
+INSERT OR IGNORE INTO derivations (name, system) VALUES (:name, :system)")))
+
+ (sqlite-bind-arguments
+ statement
+ #:name derivation-name
+ #:system (derivation-system derivation))
+
+ (sqlite-step statement)
+ (sqlite-reset statement)
+
+ (changes-count db)))
+
+ (let ((changes (insert-derivation)))
+ (unless (eq? changes 0)
+ (insert-derivation-inputs
+ db
+ derivation-name
+ (derivation-inputs derivation))
+
+ (insert-derivation-outputs
+ db
+ derivation-name
+ (derivation-outputs derivation)))
+
+ (select-derivation-outputs db derivation-name)))
+
+(define (insert-derivation-inputs db derivation-name derivation-inputs)
+ (unless (null? derivation-inputs)
+ (let ((derivation-output-ids
+ (append-map
+ (lambda (derivation-input)
+ (let ((output-ids-by-name
+ (insert-derivation-and-return-outputs
+ db
+ (derivation-input-derivation derivation-input))))
+ (map
+ (lambda (output-name)
+ (assoc-ref output-ids-by-name output-name))
+ (derivation-input-sub-derivations derivation-input))))
+ derivation-inputs)))
+ (sqlite-exec
+ db
+ (string-append
+ "
+INSERT INTO derivation_inputs (derivation_name, derivation_output_id) VALUES "
+ (string-join
+ (map (lambda (derivation-output-id)
+ (simple-format
+ #f
+ "('~A', ~A)"
+ derivation-name
+ derivation-output-id))
+ derivation-output-ids)
+ ", ")
+ ";")))))
+
+(define (insert-derivation-outputs db derivation-name derivation-outputs)
+ (sqlite-exec
+ db
+ (string-append
+ "
+INSERT INTO derivation_outputs (derivation_name, name, output) VALUES "
+ (string-join
+ (map (match-lambda
+ ((name . derivation-output)
+ (simple-format
+ #f
+ "('~A', '~A', '~A')"
+ derivation-name
+ name
+ (derivation-output-path derivation-output))))
+ derivation-outputs)
+ ", ")
+ ";")))
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
new file mode 100644
index 0000000..1f25571
--- /dev/null
+++ b/guix-build-coordinator/utils.scm
@@ -0,0 +1,110 @@
+(define-module (guix-build-coordinator utils)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-60)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 threads)
+ #:use-module (rnrs bytevectors)
+ #:use-module (gcrypt random)
+ #:use-module (fibers)
+ #:use-module (fibers channels)
+ #:export (make-worker-thread-channel
+ call-with-worker-thread
+
+ random-v4-uuid))
+
+(define %worker-thread-args
+ (make-parameter #f))
+
+(define* (make-worker-thread-channel initializer
+ #:key (parallelism 1))
+ "Return a channel used to offload work to a dedicated thread. ARGS are the
+arguments of the worker thread procedure."
+ (parameterize (((@@ (fibers internal) current-fiber) #f))
+ (let ((channel (make-channel)))
+ (for-each
+ (lambda _
+ (let ((args (initializer)))
+ (call-with-new-thread
+ (lambda ()
+ (parameterize ((%worker-thread-args args))
+ (let loop ()
+ (match (get-message channel)
+ (((? channel? reply) . (? procedure? proc))
+ (put-message reply
+ (catch #t
+ (lambda ()
+ (apply proc args))
+ (lambda (key . args)
+ (cons* 'worker-thread-error key args))))))
+ (loop)))))))
+ (iota parallelism))
+ channel)))
+
+(define (call-with-worker-thread channel proc)
+ "Send PROC to the worker thread through CHANNEL. Return the result of PROC.
+If already in the worker thread, call PROC immediately."
+ (let ((args (%worker-thread-args)))
+ (if args
+ (apply proc args)
+ (let ((reply (make-channel)))
+ (put-message channel (cons reply proc))
+ (match (get-message reply)
+ (('worker-thread-error key args ...)
+ (apply throw key args))
+ (result result))))))
+
+(define (random-v4-uuid)
+ ;; https://tools.ietf.org/html/rfc4122#page-14
+ ;;
+ ;; The pattern in characters is: 8, 4, 4, 4, 12
+ ;; The pattern in bytes is: 4, 2, 2, 2, 6
+ ;;
+ ;; time-low "-" time-mid "-" time-high-and-version "-"
+ ;; clock-seq-and-reserved clock-seq-low "-" node
+ ;;
+ ;; - Set the two most significant bits (bits 6 and 7) of the
+ ;; clock_seq_hi_and_reserved to zero and one, respectively.
+ ;; - Set the four most significant bits (bits 12 through 15) of the
+ ;; time_hi_and_version field to the 4-bit version number from
+ ;; Section 4.1.3.
+
+ (let* ((bytes 16)
+ (bv (gen-random-bv bytes)))
+
+ (let ((version 4)
+ (6th-byte (array-ref bv 6)) ; Most significant byte in
+ ; time_hi_and_version
+ (8th-byte (array-ref bv 8))) ; Most significant byte in
+ ; clock_seq_hi_and_reserved
+
+ (array-set!
+ bv
+ (logior (logand #b00001111 6th-byte)
+ (rotate-bit-field version 4 0 8))
+ 6)
+
+ (array-set!
+ bv
+ ;; Set bits 6 and 7 to 0 and 1 respectively
+ (logior #b10000000
+ (logand #b00111111
+ 8th-byte))
+ 8))
+
+ (let* ((int
+ (bytevector-uint-ref bv 0 (endianness big) bytes))
+ (hex-string
+ (format #f "~32,'0x" int)))
+ (string-join
+ (fold (lambda (part-length result)
+ (let ((start (string-length
+ (string-join result ""))))
+ (append
+ result
+ (list (substring hex-string
+ start
+ (+ start part-length))))))
+ '()
+ (list 8 4 4 4 12))
+ "-"))))
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index ad6991b..286b464 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -22,9 +22,11 @@
;;; along with the guix-data-service. If not, see
;;; <http://www.gnu.org/licenses/>.
-(use-modules (srfi srfi-37)
+(use-modules (srfi srfi-1)
+ (srfi srfi-37)
(ice-9 match)
(guix-build-coordinator config)
+ (guix-build-coordinator datastore)
(guix-build-coordinator coordinator))
(define %options
@@ -40,6 +42,11 @@
(string-trim-right
(call-with-input-file arg get-string-all))
result)))
+ (option '("database") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'database
+ arg
+ result)))
(option '("update-database") #f #f
(lambda (opt name _ result)
(alist-cons 'update-database #t result)))
@@ -77,7 +84,12 @@
(("build" rest ...)
(let ((opts (parse-options rest)))
- (peek "BUILD" rest)))
+ (match (assq-ref opts 'arguments)
+ ((derivation-file)
+ (submit-build
+ (database-uri->datastore
+ (assq-ref opts 'database))
+ derivation-file)))))
((arguments ...)
(let ((opts (parse-options arguments)))
generated by cgit v1.2.3 (git 2.25.4) at 2024-06-07 23:30:56 +0000