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