gnu/tests/cuirass.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu tests cuirass)
  20   #:use-module (gnu tests)
  21   #:use-module (gnu system)
  22   #:use-module (gnu system vm)
  23   #:use-module (gnu system install)
  24   #:use-module (gnu packages databases)
  25   #:use-module (gnu packages guile)
  26   #:use-module (gnu packages version-control)
  27   #:use-module (gnu services)
  28   #:use-module (gnu services avahi)
  29   #:use-module (gnu services base)
  30   #:use-module (gnu services cuirass)
  31   #:use-module (gnu services databases)
  32   #:use-module (gnu services networking)
  33   #:use-module (gnu system nss)
  34   #:use-module (guix channels)
  35   #:use-module (guix gexp)
  36   #:use-module (guix store)
  37   #:export (%cuirass-test
  38             %cuirass-remote-test
  39             %cuirass-simple-test))
  40
  41 (define %derivation-file
  42   (scheme-file
  43    "derivation.scm"
  44    '(begin
  45       (use-modules (guix)
  46                    (srfi srfi-1)
  47                    (ice-9 match))
  48
  49       (define (derivation->alist store drv)
  50         `((#:derivation . ,(derivation-file-name drv))
  51           (#:log . ,(log-file store (derivation-file-name drv)))
  52           (#:outputs . ,(filter-map (lambda (res)
  53                                       (match res
  54                                         ((name . path)
  55                                          `(,name . ,path))))
  56                                     (derivation->output-paths drv)))
  57           (#:nix-name . ,(derivation-name drv))
  58           (#:system . ,(derivation-system drv))
  59           (#:max-silent-time . 3600)
  60           (#:timeout . 3600)))
  61
  62       (define (cuirass-jobs store arguments)
  63         (let* ((file (plain-file "test" "this is a test derivation"))
  64                (job-name "test-job")
  65                (drv  (run-with-store store
  66                        (gexp->derivation
  67                         job-name
  68                         #~(begin
  69                             (mkdir #$output)
  70                             (symlink #$file
  71                                      (string-append #$output "/file")))))))
  72           (list (lambda ()
  73                   `((#:job-name . ,job-name)
  74                     ,@(derivation->alist store drv)))))))))
  75
  76 (define git-service
  77   ;; Create a Git repository to host Cuirass' specification.
  78   (simple-service
  79    'create-git-directory activation-service-type
  80    #~(begin
  81        (let* ((git (string-append #$git "/bin/git"))
  82               (main "/tmp/cuirass-main")
  83               (file (string-append main "/build-aux/cuirass/gnu-system.scm")))
  84          (mkdir-p (dirname file))
  85          (with-directory-excursion main
  86            (copy-file #$%derivation-file file)
  87            (invoke git "config" "--global" "user.email"
  88                    "charlie@example.org")
  89            (invoke git "config" "--global" "user.name" "A U Thor")
  90            (invoke git "init")
  91            (invoke git "add" ".")
  92            (invoke git "commit" "-m" "That's a commit."))))))
  93
  94 (define cow-service
  95   ;; The Guix-daemon & Cuirass will complain if the store is
  96   ;; read-only. Create a store overlay to solve this issue.
  97   (simple-service
  98    'mount-cow-store activation-service-type
  99    #~(begin
 100        (use-modules (guix build syscalls)
 101                     (guix build utils))
 102        (mkdir-p "/rw-store")
 103        (mount "none" "/rw-store" "tmpfs")
 104
 105        (mkdir-p "/rw-store/upper")
 106        (mkdir-p "/rw-store/work")
 107        (mount "none" "/gnu/store" "overlay" 0
 108               "lowerdir=/gnu/store,upperdir=/rw-store/upper,workdir=/rw-store/work"))))
 109
 110 (define %cuirass-specs
 111     #~(list
 112        '((#:name . "test")
 113          (#:load-path-inputs . ())
 114          (#:package-path-inputs . ())
 115          (#:proc-input . "main")
 116          (#:proc-file . "build-aux/cuirass/gnu-system.scm")
 117          (#:proc . cuirass-jobs)
 118          (#:proc-args . ())
 119          (#:inputs . (((#:name . "main")
 120                        (#:url . "file:///tmp/cuirass-main/")
 121                        (#:load-path . ".")
 122                        (#:branch . "master")
 123                        (#:no-compile? . #t))))
 124          (#:build-outputs . ())
 125          (#:priority . 1))))
 126
 127 (define* (cuirass-services #:key remote-build?)
 128   (list
 129    (service cuirass-service-type
 130             (cuirass-configuration
 131              (specifications %cuirass-specs)
 132              (remote-server (and remote-build?
 133                                  (cuirass-remote-server-configuration)))
 134              (host "0.0.0.0")
 135              (use-substitutes? #t)))))
 136
 137 (define (run-cuirass-test name os)
 138   (define os*
 139     (let ((modules '((gnu services herd)
 140                      (guix combinators)
 141                      (guix build syscalls)
 142                      (guix build utils))))
 143       (marionette-operating-system
 144        os
 145        #:imported-modules modules)))
 146
 147   (define cuirass-web-port 8081)
 148   (define forward-port 5000)
 149
 150   (define vm
 151     (virtual-machine
 152      (operating-system os*)
 153      (memory-size 1024)
 154      (port-forwardings `((,forward-port . ,cuirass-web-port)))))
 155
 156   (define test
 157     (with-extensions (list guile-json-4)
 158       (with-imported-modules '((gnu build marionette))
 159         #~(begin
 160             (use-modules (srfi srfi-11) (srfi srfi-64)
 161                          (gnu build marionette)
 162                          (ice-9 match)
 163                          (ice-9 rdelim)
 164                          (json)
 165                          (rnrs bytevectors)
 166                          (web client) (web response))
 167
 168             (define marionette
 169               (make-marionette (list #$vm)))
 170
 171             (define (query path)
 172               (http-get
 173                (format #f "http://localhost:~a~a"
 174                        #$(number->string forward-port)
 175                        path)))
 176
 177             (define* (retry f #:key times delay)
 178               (let loop ((attempt 1))
 179                 (let ((result (f)))
 180                   (cond
 181                    (result result)
 182                    (else
 183                     (if (>= attempt times)
 184                         #f
 185                         (begin
 186                           (sleep delay)
 187                           (loop (+ 1 attempt)))))))))
 188
 189             (mkdir #$output)
 190             (chdir #$output)
 191
 192             (test-begin "cuirass")
 193
 194             (test-assert "cuirass-web running"
 195               (begin
 196                 (wait-for-tcp-port #$cuirass-web-port marionette)
 197                 (retry
 198                  (lambda ()
 199                    (let-values (((response text)
 200                                  (query "/")))
 201                      (eq? (response-code response) 200)))
 202                  #:times 5
 203                  #:delay 5)))
 204
 205             (test-assert "cuirass-web evaluation"
 206               (begin
 207                 (retry
 208                  (lambda ()
 209                    (let-values (((response text)
 210                                  (query "/api/evaluation?id=1")))
 211                      (let ((result
 212                             (false-if-exception
 213                              (json-string->scm
 214                               (utf8->string text)))))
 215                        (eq? (and result
 216                                  (assoc-ref result "id"))
 217                             1))))
 218                  #:times 5
 219                  #:delay 5)))
 220
 221             ;; Even though there's a store overlay, the Guix database is not
 222             ;; initialized, meaning that we won't be able to perform the
 223             ;; build. Check at least that it is queued.
 224             (test-assert "cuirass-web build queued"
 225               (begin
 226                 (retry
 227                  (lambda ()
 228                    (let-values (((response text)
 229                                  (query "/api/queue?nr=1")))
 230                      (let ((result
 231                             (json-string->scm
 232                              (utf8->string text))))
 233                        (match (vector->list result)
 234                          ((build)
 235                           (string=? (assoc-ref build "job") "test-job"))
 236                          (else #f)))))
 237                  #:times 5
 238                  #:delay 10)))
 239
 240             (test-end)
 241             (exit (= (test-runner-fail-count (test-runner-current)) 0))))))
 242
 243   (gexp->derivation name test))
 244
 245 (define %cuirass-test
 246   (let ((os (operating-system
 247               (inherit %simple-os)
 248               (services
 249                (append (list cow-service
 250                              (service dhcp-client-service-type)
 251                              git-service)
 252                        (cuirass-services)
 253                        (operating-system-user-services %simple-os))))))
 254     (system-test
 255      (name "cuirass")
 256      (description "Connect to a Cuirass server.")
 257      (value
 258       (run-cuirass-test name os)))))
 259
 260 (define %cuirass-remote-test
 261   (let ((os (operating-system
 262               (inherit %simple-os)
 263               (name-service-switch %mdns-host-lookup-nss)
 264               (services
 265                (append (list (service avahi-service-type)
 266                              cow-service
 267                              (service dhcp-client-service-type)
 268                              git-service)
 269                        (cuirass-services #:remote-build? #t)
 270                        (operating-system-user-services %simple-os))))))
 271     (system-test
 272      (name "cuirass-remote")
 273      (description "Connect to a Cuirass server with remote build.")
 274      (value (run-cuirass-test name os)))))
 275
 276 (define simple-cuirass-service
 277   (service cuirass-service-type
 278            (cuirass-configuration
 279             (specifications
 280              (simple-cuirass-configuration->specs
 281               (simple-cuirass-configuration
 282                (build 'all)
 283                (channels
 284                 (list (channel
 285                        (name 'guix)
 286                        (url "file:///tmp/cuirass-main/")))))))
 287             (host "0.0.0.0")
 288             (use-substitutes? #t))))
 289
 290 (define %cuirass-simple-test
 291   (let ((os (operating-system
 292               (inherit %simple-os)
 293               (services
 294                (append
 295                 (list cow-service
 296                       (service dhcp-client-service-type)
 297                       git-service
 298                       simple-cuirass-service)
 299                 (operating-system-user-services %simple-os))))))
 300     (system-test
 301      (name "cuirass-simple")
 302      (description "Connect to a simple Cuirass server.")
 303      (value
 304       (run-cuirass-test name os)))))