Implement storing derivations

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)))