build-aux/hydra/gnu-system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;;
  21 ;;; This file defines build jobs for the Hydra continuation integration
  22 ;;; tool.
  23 ;;;
  24
  25 (use-modules (system base compile))
  26
  27 (eval-when (expand load eval)
  28
  29   ;; Pre-load the compiler so we don't end up auto-compiling it.
  30   (compile #t)
  31
  32   ;; Use our very own Guix modules.
  33   (set! %fresh-auto-compile #t)
  34
  35   ;; Ignore .go files except for Guile's.  This is because our checkout in the
  36   ;; store has mtime set to the epoch, and thus .go files look newer, even
  37   ;; though they may not correspond.  Use 'reverse' so that /gnu/store/…-guile
  38   ;; comes before /run/current-system/profile.
  39   (set! %load-compiled-path
  40     (list
  41      (dirname (dirname (search-path (reverse %load-compiled-path)
  42                                     "ice-9/boot-9.go")))))
  43
  44   (and=> (assoc-ref (current-source-location) 'filename)
  45          (lambda (file)
  46            (let ((dir (string-append (dirname file) "/../..")))
  47              (format (current-error-port) "prepending ~s to the load path~%"
  48                      dir)
  49              (set! %load-path (cons dir %load-path))))))
  50
  51 (use-modules (guix config)
  52              (guix store)
  53              (guix grafts)
  54              (guix profiles)
  55              (guix packages)
  56              (guix derivations)
  57              (guix monads)
  58              ((guix licenses) #:select (gpl3+))
  59              ((guix utils) #:select (%current-system))
  60              ((guix scripts system) #:select (read-operating-system))
  61              ((guix scripts pack)
  62               #:select (lookup-compressor self-contained-tarball))
  63              (gnu bootloader)
  64              (gnu bootloader u-boot)
  65              (gnu packages)
  66              (gnu packages gcc)
  67              (gnu packages base)
  68              (gnu packages gawk)
  69              (gnu packages guile)
  70              (gnu packages gettext)
  71              (gnu packages compression)
  72              (gnu packages multiprecision)
  73              (gnu packages make-bootstrap)
  74              (gnu packages package-management)
  75              (gnu system)
  76              (gnu system vm)
  77              (gnu system install)
  78              (gnu tests)
  79              (srfi srfi-1)
  80              (srfi srfi-26)
  81              (ice-9 match))
  82
  83 ;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
  84 ;; port to the bit bucket, let us write to the error port instead.
  85 (setvbuf (current-error-port) _IOLBF)
  86 (set-current-output-port (current-error-port))
  87
  88 (define* (package->alist store package system
  89                          #:optional (package-derivation package-derivation))
  90   "Convert PACKAGE to an alist suitable for Hydra."
  91   (parameterize ((%graft? #f))
  92     `((derivation . ,(derivation-file-name
  93                       (package-derivation store package system
  94                                           #:graft? #f)))
  95       (description . ,(package-synopsis package))
  96       (long-description . ,(package-description package))
  97       (license . ,(package-license package))
  98       (home-page . ,(package-home-page package))
  99       (maintainers . ("bug-guix@gnu.org"))
 100       (max-silent-time . ,(or (assoc-ref (package-properties package)
 101                                          'max-silent-time)
 102                               3600))              ;1 hour by default
 103       (timeout . ,(or (assoc-ref (package-properties package) 'timeout)
 104                       72000)))))                  ;20 hours by default
 105
 106 (define (package-job store job-name package system)
 107   "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
 108   (let ((job-name (symbol-append job-name (string->symbol ".")
 109                                  (string->symbol system))))
 110     `(,job-name . ,(cut package->alist store package system))))
 111
 112 (define (package-cross-job store job-name package target system)
 113   "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
 114 SYSTEM."
 115   `(,(symbol-append (string->symbol target) (string->symbol ".") job-name
 116                     (string->symbol ".") (string->symbol system)) .
 117     ,(cute package->alist store package system
 118            (lambda* (store package system #:key graft?)
 119              (package-cross-derivation store package target system
 120                                        #:graft? graft?)))))
 121
 122 (define %core-packages
 123   ;; Note: Don't put the '-final' package variants because (1) that's
 124   ;; implicit, and (2) they cannot be cross-built (due to the explicit input
 125   ;; chain.)
 126   (list gcc-4.8 gcc-4.9 gcc-5 glibc binutils
 127         gmp mpfr mpc coreutils findutils diffutils patch sed grep
 128         gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz
 129         %bootstrap-binaries-tarball
 130         %binutils-bootstrap-tarball
 131         (%glibc-bootstrap-tarball)
 132         %gcc-bootstrap-tarball
 133         %guile-bootstrap-tarball
 134         %bootstrap-tarballs))
 135
 136 (define %packages-to-cross-build
 137   %core-packages)
 138
 139 (define %cross-targets
 140   '("mips64el-linux-gnu"
 141     "mips64el-linux-gnuabi64"
 142     "arm-linux-gnueabihf"
 143     "aarch64-linux-gnu"
 144     "powerpc-linux-gnu"
 145     "i586-pc-gnu"                                 ;aka. GNU/Hurd
 146     "i686-w64-mingw32"))
 147
 148 (define %guixsd-supported-systems
 149   '("x86_64-linux" "i686-linux" "armhf-linux"))
 150
 151 (define %u-boot-systems
 152   '("armhf-linux"))
 153
 154 (define (qemu-jobs store system)
 155   "Return a list of jobs that build QEMU images for SYSTEM."
 156   (define (->alist drv)
 157     `((derivation . ,(derivation-file-name drv))
 158       (description . "Stand-alone QEMU image of the GNU system")
 159       (long-description . "This is a demo stand-alone QEMU image of the GNU
 160 system.")
 161       (license . ,gpl3+)
 162       (home-page . ,%guix-home-page-url)
 163       (maintainers . ("bug-guix@gnu.org"))))
 164
 165   (define (->job name drv)
 166     (let ((name (symbol-append name (string->symbol ".")
 167                                (string->symbol system))))
 168       `(,name . ,(lambda ()
 169                    (parameterize ((%graft? #f))
 170                      (->alist drv))))))
 171
 172   (define MiB
 173     (expt 2 20))
 174
 175   (if (member system %guixsd-supported-systems)
 176       (if (member system %u-boot-systems)
 177           (list (->job 'flash-image
 178                        (run-with-store store
 179                          (mbegin %store-monad
 180                            (set-guile-for-build (default-guile))
 181                            (system-disk-image
 182                             (operating-system (inherit installation-os)
 183                              (bootloader (bootloader-configuration
 184                                           (bootloader u-boot-bootloader)
 185                                           (target #f))))
 186                             #:disk-image-size
 187                             (* 1024 MiB))))))
 188           (list (->job 'usb-image
 189                        (run-with-store store
 190                          (mbegin %store-monad
 191                            (set-guile-for-build (default-guile))
 192                            (system-disk-image installation-os
 193                                               #:disk-image-size
 194                                               (* 1024 MiB)))))
 195                 (->job 'iso9660-image
 196                        (run-with-store store
 197                          (mbegin %store-monad
 198                            (set-guile-for-build (default-guile))
 199                            (system-disk-image installation-os
 200                                               #:file-system-type
 201                                               "iso9660"))))))
 202       '()))
 203
 204 (define (system-test-jobs store system)
 205   "Return a list of jobs for the system tests."
 206   (define (test->thunk test)
 207     (lambda ()
 208       (define drv
 209         (run-with-store store
 210           (mbegin %store-monad
 211             (set-current-system system)
 212             (set-grafting #f)
 213             (set-guile-for-build (default-guile))
 214             (system-test-value test))))
 215
 216       `((derivation . ,(derivation-file-name drv))
 217         (description . ,(format #f "GuixSD '~a' system test"
 218                                 (system-test-name test)))
 219         (long-description . ,(system-test-description test))
 220         (license . ,gpl3+)
 221         (home-page . ,%guix-home-page-url)
 222         (maintainers . ("bug-guix@gnu.org")))))
 223
 224   (define (->job test)
 225     (let ((name (string->symbol
 226                  (string-append "test." (system-test-name test)
 227                                 "." system))))
 228       (cons name (test->thunk test))))
 229
 230   (if (member system %guixsd-supported-systems)
 231       (map ->job (all-system-tests))
 232       '()))
 233
 234 (define (tarball-jobs store system)
 235   "Return Hydra jobs to build the self-contained Guix binary tarball."
 236   (define (->alist drv)
 237     `((derivation . ,(derivation-file-name drv))
 238       (description . "Stand-alone binary Guix tarball")
 239       (long-description . "This is a tarball containing binaries of Guix and
 240 all its dependencies, and ready to be installed on non-GuixSD distributions.")
 241       (license . ,gpl3+)
 242       (home-page . ,%guix-home-page-url)
 243       (maintainers . ("bug-guix@gnu.org"))))
 244
 245   (define (->job name drv)
 246     (let ((name (symbol-append name (string->symbol ".")
 247                                (string->symbol system))))
 248       `(,name . ,(lambda ()
 249                    (parameterize ((%graft? #f))
 250                      (->alist drv))))))
 251
 252   ;; XXX: Add a job for the stable Guix?
 253   (list (->job 'binary-tarball
 254                (run-with-store store
 255                  (mbegin %store-monad
 256                    (set-guile-for-build (default-guile))
 257                    (>>= (profile-derivation (packages->manifest (list guix)))
 258                         (lambda (profile)
 259                           (self-contained-tarball "guix-binary" profile
 260                                                   #:localstatedir? #t
 261                                                   #:compressor
 262                                                   (lookup-compressor "xz")))))
 263                  #:system system))))
 264
 265 (define job-name
 266   ;; Return the name of a package's job.
 267   (compose string->symbol
 268            (cut package-full-name <> "-")))
 269
 270 (define package->job
 271   (let ((base-packages
 272          (delete-duplicates
 273           (append-map (match-lambda
 274                        ((_ package _ ...)
 275                         (match (package-transitive-inputs package)
 276                           (((_ inputs _ ...) ...)
 277                            inputs))))
 278                       (%final-inputs)))))
 279     (lambda (store package system)
 280       "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
 281 valid."
 282       (cond ((member package base-packages)
 283              (package-job store (symbol-append 'base. (job-name package))
 284                           package system))
 285             ((supported-package? package system)
 286              (let ((drv (package-derivation store package system
 287                                             #:graft? #f)))
 288                (and (substitutable-derivation? drv)
 289                     (package-job store (job-name package)
 290                                  package system))))
 291             (else
 292              #f)))))
 293
 294 (define (all-packages)
 295   "Return the list of packages to build."
 296   (define (adjust package result)
 297     (cond ((package-replacement package)
 298            (cons* package                         ;build both
 299                   (package-replacement package)
 300                   result))
 301           ((package-superseded package)
 302            result)                                ;don't build it
 303           (else
 304            (cons package result))))
 305
 306   (fold-packages adjust
 307                  (fold adjust '()                 ;include base packages
 308                        (match (%final-inputs)
 309                          (((labels packages _ ...) ...)
 310                           packages)))
 311                  #:select? (const #t)))           ;include hidden packages
 312
 313 \f
 314 ;;;
 315 ;;; Hydra entry point.
 316 ;;;
 317
 318 (define (hydra-jobs store arguments)
 319   "Return Hydra jobs."
 320   (define subset
 321     (match (assoc-ref arguments 'subset)
 322       ("core" 'core)                              ; only build core packages
 323       ("hello" 'hello)                            ; only build hello
 324       (((? string?) (? string?) ...) 'list)       ; only build selected list of packages
 325       (_ 'all)))                                  ; build everything
 326
 327   (define systems
 328     (match (assoc-ref arguments 'systems)
 329       (#f              %hydra-supported-systems)
 330       ((lst ...)       lst)
 331       ((? string? str) (call-with-input-string str read))))
 332
 333   (define (cross-jobs system)
 334     (define (from-32-to-64? target)
 335       ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.  This hack
 336       ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
 337       ;; mips64el-linux-gnuabi64.
 338       (and (or (string-prefix? "i686-" system)
 339                (string-prefix? "i586-" system)
 340                (string-prefix? "armhf-" system))
 341            (string-contains target "64")))    ;x86_64, mips64el, aarch64, etc.
 342
 343     (define (same? target)
 344       ;; Return true if SYSTEM and TARGET are the same thing.  This is so we
 345       ;; don't try to cross-compile to 'mips64el-linux-gnu' from
 346       ;; 'mips64el-linux'.
 347       (or (string-contains target system)
 348           (and (string-prefix? "armhf" system)    ;armhf-linux
 349                (string-prefix? "arm" target))))   ;arm-linux-gnueabihf
 350
 351     (define (pointless? target)
 352       ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
 353       (match system
 354         ((or "x86_64-linux" "i686-linux")
 355          (if (string-contains target "mingw")
 356              (not (string=? "x86_64-linux" system))
 357              #f))
 358         (_
 359          ;; Don't try to cross-compile from non-Intel platforms: this isn't
 360          ;; very useful and these are often brittle configurations.
 361          #t)))
 362
 363     (define (either proc1 proc2 proc3)
 364       (lambda (x)
 365         (or (proc1 x) (proc2 x) (proc3 x))))
 366
 367     (append-map (lambda (target)
 368                   (map (lambda (package)
 369                          (package-cross-job store (job-name package)
 370                                             package target system))
 371                        %packages-to-cross-build))
 372                 (remove (either from-32-to-64? same? pointless?)
 373                         %cross-targets)))
 374
 375   ;; Turn off grafts.  Grafting is meant to happen on the user's machines.
 376   (parameterize ((%graft? #f))
 377     ;; Return one job for each package, except bootstrap packages.
 378     (append-map (lambda (system)
 379                   (format (current-error-port)
 380                           "evaluating for '~a' (heap size: ~a MiB)...~%"
 381                           system
 382                           (round
 383                            (/ (assoc-ref (gc-stats) 'heap-size)
 384                               (expt 2. 20))))
 385                   (invalidate-derivation-caches!)
 386                   (case subset
 387                     ((all)
 388                      ;; Build everything, including replacements.
 389                      (let ((all (all-packages))
 390                            (job (lambda (package)
 391                                   (package->job store package
 392                                                 system))))
 393                        (append (filter-map job all)
 394                                (qemu-jobs store system)
 395                                (system-test-jobs store system)
 396                                (tarball-jobs store system)
 397                                (cross-jobs system))))
 398                     ((core)
 399                      ;; Build core packages only.
 400                      (append (map (lambda (package)
 401                                     (package-job store (job-name package)
 402                                                  package system))
 403                                   %core-packages)
 404                              (cross-jobs system)))
 405                     ((hello)
 406                      ;; Build hello package only.
 407                      (if (string=? system (%current-system))
 408                          (let ((hello (specification->package "hello")))
 409                            (list (package-job store (job-name hello) hello system)))
 410                          '()))
 411                     ((list)
 412                      ;; Build selected list of packages only.
 413                      (if (string=? system (%current-system))
 414                          (let* ((names (assoc-ref arguments 'subset))
 415                                 (packages (map specification->package names)))
 416                            (map (lambda (package)
 417                                     (package-job store (job-name package)
 418                                                  package system))
 419                                   packages))
 420                          '()))
 421                     (else
 422                      (error "unknown subset" subset))))
 423                 systems)))