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