guix-tribes/tests/tribes-deploy-worker.scm

(define-module (tests tribes-deploy-worker)
  #:use-module (guix build utils)
  #:use-module (ice-9 atomic)
  #:use-module (ice-9 threads)
  #:use-module (srfi srfi-64)
  #:use-module (tests support)
  #:use-module (tribes deploy config)
  #:use-module (tribes deploy json)
  #:use-module (tribes deploy state)
  #:use-module (tribes deploy worker)
  #:export (run-tests))

(define *fixture-counter* 0)

(define (delete-directory-if-present path)
  (when (false-if-exception (lstat path))
    (delete-file-recursively path)))

(define (fresh-root)
  (set! *fixture-counter* (+ *fixture-counter* 1))
  (let ((root (string-append "/tmp/tribes-worker-test-"
                             (number->string *fixture-counter*))))
    (delete-directory-if-present root)
    (mkdir-p root)
    root))

(define (fixture-config root)
  (deploy-config
   (deploy-directory (string-append root "/deploy"))
   (host-config-file (string-append root "/host-config.json"))
   (channels-file (string-append root "/channels.scm"))
   (current-config-file (string-append root "/configuration.scm"))
   (current-system-link (string-append root "/run/current-system"))
   (system-profile-link (string-append root "/profiles/system"))
   (system-profile-directory (string-append root "/profiles"))
   (helper-binary "fake-helper-not-used")))

(define (eventually? predicate)
  (let loop ((attempts 200))
    (cond
     ((predicate) #t)
     ((zero? attempts) #f)
     (else
      (usleep 10000)
      (loop (- attempts 1))))))

(define (snapshot-field worker key)
  (json-ref (worker-status worker) key))

(define (run-tests)
  (test-begin "tribes-deploy-worker")

  (let* ((root (fresh-root))
         (config (fixture-config root))
         (state (make-state-store config))
         (worker (make-worker config state))
         (release? (make-atomic-box #f)))
    (call-with-values
        (lambda ()
          (worker-submit!
           worker 'prepare "plan-a"
           (lambda (update!)
             (update! "pulling")
             (let loop ()
               (unless (atomic-box-ref release?)
                 (usleep 10000)
                 (loop)))
             (update! "building")
             (make-job-result
              #t
              '(("schemaVersion" . "2")
                ("ok" . #t)
                ("status" . "completed")
                ("phase" . "ready")
                ("plan_hash" . "plan-a"))))))
      (lambda (status snapshot)
        (test-equal "worker accepts first long-running job"
          'accepted status)
        (test-equal "accepted job starts queued"
          "queued" (json-ref snapshot "phase"))))
    (test-assert "worker status reaches helper phase while job runs"
      (eventually? (lambda ()
                     (string=? (or (snapshot-field worker "phase") "")
                               "pulling"))))
    (call-with-values
        (lambda ()
          (worker-submit! worker 'prepare "plan-a"
                          (lambda (_update!)
                            (make-job-result #t '()))))
      (lambda (status _snapshot)
        (test-equal "same plan is idempotent while running"
          'idempotent status)))
    (call-with-values
        (lambda ()
          (worker-submit! worker 'prepare "plan-b"
                          (lambda (_update!)
                            (make-job-result #t '()))))
      (lambda (status snapshot)
        (test-equal "different plan is busy while running"
          'busy status)
        (test-equal "busy response exposes running phase"
          "pulling" (json-ref snapshot "phase"))))
    (let ((aborted (worker-abort! worker)))
      (test-equal "abort marks snapshot aborted"
        "aborted" (json-ref aborted "phase")))
    (call-with-values
        (lambda ()
          (worker-submit! worker 'prepare "plan-c"
                          (lambda (_update!)
                            (make-job-result #t '()))))
      (lambda (status snapshot)
        (test-equal "aborted running job still blocks new work"
          'busy status)
        (test-equal "busy response preserves aborted phase"
          "aborted" (json-ref snapshot "phase"))))
    (atomic-box-set! release? #t)
    (test-assert "worker records final result after long job exits"
      (eventually? (lambda ()
                     (string=? (or (snapshot-field worker "status") "")
                               "completed"))))
    (worker-shutdown! worker))

  (let* ((root (fresh-root))
         (config (fixture-config root))
         (state (make-state-store config))
         (worker (make-worker config state)))
    (call-with-values
        (lambda ()
          (worker-submit! worker 'prepare "plan-error"
                          (lambda (_update!)
                            (error "synthetic worker failure"))))
      (lambda (status _snapshot)
        (test-equal "worker accepts failing job"
          'accepted status)))
    (test-assert "worker converts job exceptions into failed snapshots"
      (eventually? (lambda ()
                     (string=? (or (snapshot-field worker "status") "")
                               "failed"))))
    (test-equal "worker failure snapshot is machine readable"
      "broker_internal" (snapshot-field worker "code"))
    (worker-shutdown! worker))

  (test-end "tribes-deploy-worker"))

(run-tests-when-script "tests/tribes-deploy-worker.scm" run-tests)