build-aux/hydra/gnu-system.scm

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