;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu ci)
  #:use-module (guix config)
  #:use-module (guix store)
  #:use-module (guix grafts)
  #:use-module (guix profiles)
  #:use-mod</td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=da2877237ecd0e1c837758ee5e07ab450c827537'>refs</a><a href='/guix/log/gnu/services/telephony.scm'>log</a><a href='/guix/tree/gnu/services/telephony.scm?id=da2877237ecd0e1c837758ee5e07ab450c827537'>tree</a><a class='active' href='/guix/commit/gnu/services/telephony.scm?id=da2877237ecd0e1c837758ee5e07ab450c827537'>commit</a><a href='/guix/diff/gnu/services/telephony.scm?id=da2877237ecd0e1c837758ee5e07ab450c827537'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/gnu/services/telephony.scm'>
<input type='hidden' name='id' value='da2877237ecd0e1c837758ee5e07ab450c827537'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/commit/?id=da2877237ecd0e1c837758ee5e07ab450c827537'>root</a>/<a href='/guix/commit/gnu?id=da2877237ecd0e1c837758ee5e07ab450c827537'>gnu</a>/<a href='/guix/commit/gnu/services?id=da2877237ecd0e1c837758ee5e07ab450c827537'>services</a>/<a href='/guix/commit/gnu/services/telephony.scm?id=da2877237ecd0e1c837758ee5e07ab450c827537'>telephony.scm</a></div><div class='content'><div class='cgit-panel'><b>diff options</b><form method='get'><input type='hidden' name='id' value='da2877237ecd0e1c837758ee5e07ab450c827537'/><table><tr><td colspan='2'/></tr><tr><td class='label'>context:</td><td class='ctrl'><select name='context' onchange='this.form.submit();'><option value='1'>1</option><option value='2'>2</option><option value='3' selected='selected'>3</option><option value='4'>4</option><option value='5'>5</option><option value='6'>6</option><option value='7'>7</option><option value='8'>8</option><option value='9'>9</option><option value='10'>10</option><option value='15'>15</option><option value='20'>20</option><option value='25'>25</option><option value='30'>30</option><option value='35'>35</option><option value='40'>40</option></select></td></tr><tr><td class='label'>space:</td><td class='ctrl'><select name='ignorews' onchange='this.form.submit();'><option value='0' selected='selected'>include</option><option value='1'>ignore</option></select></td></tr><tr><td class='label'>mode:</td><td class='ctrl'><select name='dt' onchange='this.form.submit();'><option value='0' selected='selected'>unified</option><option value='1'>ssdiff</option><option value='2'>stat only</option></select></td></tr><tr><td/><td class='ctrl'><noscript><input type='submit' value='reload'/></noscript></td></tr></table></form></div><table summary='commit info' class='commit-info'>
<tr><th>author</th><td>Leo Famulari &lt;leo@famulari.name&gt;</td><td class='right'>2020-12-24 19:14:10 -0500</td></tr>
<tr><th>committer</th><td>Leo Famulari &lt;leo@famulari.name&gt;</td><td class='right'>2020-12-29 16:03:04 -0500</td></tr>
<tr><th>commit</th><td colspan='2' class='oid'><a href='/guix/commit/gnu/services/telephony.scm?id=da2877237ecd0e1c837758ee5e07ab450c827537'>da2877237ecd0e1c837758ee5e07ab450c827537</a> (<a href='/guix/patch/gnu/services/telephony.scm?id=da2877237ecd0e1c837758ee5e07ab450c827537'>patch</a>)</td></tr>
<tr><th>tree</th><td colspan='2' class='oid'><a href='/guix/tree/?id=da2877237ecd0e1c837758ee5e07ab450c827537'>d89fd8373f4999586a42bb1d41b8e5ec8d34f835</a> /<a href='/guix/tree/gnu/services/telephony.scm?id=da2877237ecd0e1c837758ee5e07ab450c827537'>gnu/services/telephony.scm</a></td></tr>
<tr><th>parent</th><td colspan='2' class='oid'><a href='/guix/commit/gnu/services/telephony.scm?id=fad9b4bb5f3265a07578430af6caa12103ebbfdf'>fad9b4bb5f3265a07578430af6caa12103ebbfdf</a> (<a href='/guix/diff/gnu/services/telephony.scm?id=da2877237ecd0e1c837758ee5e07ab450c827537&amp;id2=fad9b4bb5f3265a07578430af6caa12103ebbfdf'>diff</a>)</td></tr><tr><th>download</th><td colspan='2' class='oid'><a href='/guix/snapshot/guix-da2877237ecd0e1c837758ee5e07ab450c827537.tar.gz'>guix-da2877237ecd0e1c837758ee5e07ab450c827537.tar.gz</a><br/><a href='/guix/snapshot/guix-da2877237ecd0e1c837758ee5e07ab450c827537.zip'>guix-da2877237ecd0e1c837758ee5e07ab450c827537.zip</a><br/></td></tr></table>
<div class='commit-subject'>gnu: SVT-AV1: It only supports 64-bit Intel-compatible systems.</div><div class='commit-msg'>* gnu/packages/video.scm (svt-av1)[supported-systems]: Remove i686-linux.
</div><div class='diffstat-header'><a href='/guix/diff/?id=da2877237ecd0e1c837758ee5e07ab450c827537'>Diffstat</a> (limited to 'gnu/services/telephony.scm')</div><table summary='diffstat' class='diffstat'></table><div class='diffstat-summary'>0 files changed, 0 insertions, 0 deletions</div><table summary='diff' class='diff'><tr><td></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
rted-systems)
      (if (member system %u-boot-systems)
          (list (->job 'flash-image
                       (run-with-store store
                         (mbegin %store-monad
                           (set-guile-for-build (default-guile))
                           (system-disk-image
                            (operating-system (inherit installation-os)
                             (bootloader (bootloader-configuration
                                          (bootloader u-boot-bootloader)
                                          (target #f))))
                            #:disk-image-size
                            (* 1500 MiB))))))
          (list (->job 'usb-image
                       (run-with-store store
                         (mbegin %store-monad
                           (set-guile-for-build (default-guile))
                           (system-disk-image installation-os
                                              #:disk-image-size
                                              (* 1500 MiB)))))
                (->job 'iso9660-image
                       (run-with-store store
                         (mbegin %store-monad
                           (set-guile-for-build (default-guile))
                           (system-disk-image installation-os
                                              #:file-system-type
                                              "iso9660"))))))
      '()))

(define channel-build-system
  ;; Build system used to "convert" a channel instance to a package.
  (let* ((build (lambda* (store name inputs
                                #:key instance system
                                #:allow-other-keys)
                  (run-with-store store
                    (channel-instances->derivation (list instance))
                    #:system system)))
         (lower (lambda* (name #:key system instance #:allow-other-keys)
                  (bag
                    (name name)
                    (system system)
                    (build build)
                    (arguments `(#:instance ,instance))))))
    (build-system (name 'channel)
                  (description "Turn a channel instance into a package.")
                  (lower lower))))

(define (channel-instance->package instance)
  "Return a package for the given channel INSTANCE."
  (package
    (inherit guix)
    (version (or (string-take (channel-instance-commit instance) 7)
                 (string-append (package-version guix) "+")))
    (build-system channel-build-system)
    (arguments `(#:instance ,instance))
    (inputs '())
    (native-inputs '())
    (propagated-inputs '())))

(define* (system-test-jobs store system
                           #:key source commit)
  "Return a list of jobs for the system tests."
  (define instance
    (checkout->channel-instance source #:commit commit))

  (define (test->thunk test)
    (lambda ()
      (define drv
        (run-with-store store
          (mbegin %store-monad
            (set-current-system system)
            (set-grafting #f)
            (set-guile-for-build (default-guile))
            (system-test-value test))))

      `((derivation . ,(derivation-file-name drv))
        (description . ,(format #f "Guix '~a' system test"
                                (system-test-name test)))
        (long-description . ,(system-test-description test))
        (license . ,(license-name gpl3+))
        (max-silent-time . 600)
        (timeout . 3600)
        (home-page . ,%guix-home-page-url)
        (maintainers . ("bug-guix@gnu.org")))))

  (define (->job test)
    (let ((name (string->symbol
                 (string-append "test." (system-test-name test)
                                "." system))))
      (cons name (test->thunk test))))

  (if (and (member system %guixsd-supported-systems)

           ;; XXX: Our build farm has too few ARMv7 machines and they are very
           ;; slow, so skip system tests there.
           (not (string=? system "armhf-linux")))
      ;; Override the value of 'current-guix' used by system tests.  Using a
      ;; channel instance makes tests that rely on 'current-guix' less
      ;; expensive.  It also makes sure we get a valid Guix package when this
      ;; code is not running from a checkout.
      (parameterize ((current-guix-package
                      (channel-instance->package instance)))
        (map ->job (all-system-tests)))
      '()))

(define (tarball-jobs store system)
  "Return Hydra jobs to build the self-contained Guix binary tarball."
  (define (->alist drv)
    `((derivation . ,(derivation-file-name drv))
      (description . "Stand-alone binary Guix tarball")
      (long-description . "This is a tarball containing binaries of Guix and
all its dependencies, and ready to be installed on \"foreign\" distributions.")
      (license . ,(license-name gpl3+))
      (home-page . ,%guix-home-page-url)
      (maintainers . ("bug-guix@gnu.org"))))

  (define (->job name drv)
    (let ((name (symbol-append name (string->symbol ".")
                               (string->symbol system))))
      `(,name . ,(lambda ()
                   (parameterize ((%graft? #f))
                     (->alist drv))))))

  ;; XXX: Add a job for the stable Guix?
  (list (->job 'binary-tarball
               (run-with-store store
                 (mbegin %store-monad
                   (set-guile-for-build (default-guile))
                   (>>= (profile-derivation (packages->manifest (list guix)))
                        (lambda (profile)
                          (self-contained-tarball "guix-binary" profile
                                                  #:localstatedir? #t
                                                  #:compressor
                                                  (lookup-compressor "xz")))))
                 #:system system))))

(define job-name
  ;; Return the name of a package's job.
  (compose string->symbol
           (cut package-full-name <> "-")))

(define package->job
  (let ((base-packages
         (delete-duplicates
          (append-map (match-lambda
                       ((_ package _ ...)
                        (match (package-transitive-inputs package)
                          (((_ inputs _ ...) ...)
                           inputs))))
                      (%final-inputs)))))
    (lambda (store package system)
      "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
valid."
      (cond ((member package base-packages)
             (package-job store (symbol-append 'base. (job-name package))
                          package system))
            ((supported-package? package system)
             (let ((drv (package-derivation store package system
                                            #:graft? #f)))
               (and (substitutable-derivation? drv)
                    (package-job store (job-name package)
                                 package system))))
            (else
             #f)))))

(define (all-packages)
  "Return the list of packages to build."
  (define (adjust package result)
    (cond ((package-replacement package)
           ;; XXX: If PACKAGE and its replacement have the same name/version,
           ;; then both Cuirass jobs will have the same name, which
           ;; effectively means that the second one will be ignored.  Thus,
           ;; return the replacement first.
           (cons* (package-replacement package)   ;build both
                  package
                  result))
          ((package-superseded package)
           result)                                ;don't build it
          (else
           (cons package result))))

  (fold-packages adjust
                 (fold adjust '()                 ;include base packages
                       (match (%final-inputs)
                         (((labels packages _ ...) ...)
                          packages)))
                 #:select? (const #t)))           ;include hidden packages

(define (arguments->manifests arguments)
  "Return the list of manifests extracted from ARGUMENTS."
  (map (match-lambda
         ((input-name . relative-path)
          (let* ((checkout (assq-ref arguments (string->symbol input-name)))
                 (base (assq-ref checkout 'file-name)))
            (in-vicinity base relative-path))))
       (assq-ref arguments 'manifests)))

(define (manifests->packages store manifests)
  "Return the list of packages found in MANIFESTS."
  (define (load-manifest manifest)
    (save-module-excursion
     (lambda ()
       (set-current-module (make-user-module '((guix profiles) (gnu))))
       (primitive-load manifest))))

  (delete-duplicates!
   (map manifest-entry-item
        (append-map (compose manifest-entries
                             load-manifest)
                    manifests))))


;;;
;;; Hydra entry point.
;;;

(define (hydra-jobs store arguments)
  "Return Hydra jobs."
  (define subset
    (match (assoc-ref arguments 'subset)
      ("core" 'core)                              ; only build core packages
      ("hello" 'hello)                            ; only build hello
      (((? string?) (? string?) ...) 'list)       ; only build selected list of packages
      ("manifests" 'manifests)                    ; only build packages in the list of manifests
      (_ 'all)))                                  ; build everything

  (define systems
    (match (assoc-ref arguments 'systems)
      (#f              %hydra-supported-systems)
      ((lst ...)       lst)
      ((? string? str) (call-with-input-string str read))))

  (define checkout
    ;; Extract metadata about the 'guix' checkout.  Its key in ARGUMENTS may
    ;; vary, so pick up the first one that's neither 'subset' nor 'systems'.
    (any (match-lambda
           ((key . value)
            (and (not (memq key '(systems subset)))
                 value)))
         arguments))

  (define commit
    (assq-ref checkout 'revision))

  (define source
    (assq-ref checkout 'file-name))

  (define (cross-jobs system)
    (define (from-32-to-64? target)
      ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.  This hack
      ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
      ;; mips64el-linux-gnuabi64.
      (and (or (string-prefix? "i686-" system)
               (string-prefix? "i586-" system)
               (string-prefix? "armhf-" system))
           (string-contains target "64")))    ;x86_64, mips64el, aarch64, etc.

    (define (same? target)
      ;; Return true if SYSTEM and TARGET are the same thing.  This is so we
      ;; don't try to cross-compile to 'mips64el-linux-gnu' from
      ;; 'mips64el-linux'.
      (or (string-contains target system)
          (and (string-prefix? "armhf" system)    ;armhf-linux
               (string-prefix? "arm" target))))   ;arm-linux-gnueabihf

    (define (pointless? target)
      ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
      (match system
        ((or "x86_64-linux" "i686-linux")
         (if (string-contains target "mingw")
             (not (string=? "x86_64-linux" system))
             #f))
        (_
         ;; Don't try to cross-compile from non-Intel platforms: this isn't
         ;; very useful and these are often brittle configurations.
         #t)))

    (define (either proc1 proc2 proc3)
      (lambda (x)
        (or (proc1 x) (proc2 x) (proc3 x))))

    (append-map (lambda (target)
                  (map (lambda (package)
                         (package-cross-job store (job-name package)
                                            package target system))
                       %packages-to-cross-build))
                (remove (either from-32-to-64? same? pointless?)
                        %cross-targets)))

  ;; Turn off grafts.  Grafting is meant to happen on the user's machines.
  (parameterize ((%graft? #f))
    ;; Return one job for each package, except bootstrap packages.
    (append-map (lambda (system)
                  (format (current-error-port)
                          "evaluating for '~a' (heap size: ~a MiB)...~%"
                          system
                          (round
                           (/ (assoc-ref (gc-stats) 'heap-size)
                              (expt 2. 20))))
                  (invalidate-derivation-caches!)
                  (case subset
                    ((all)
                     ;; Build everything, including replacements.
                     (let ((all (all-packages))
                           (job (lambda (package)
                                  (package->job store package
                                                system))))
                       (append (filter-map job all)
                               (qemu-jobs store system)
                               (system-test-jobs store system
                                                 #:source source
                                                 #:commit commit)
                               (tarball-jobs store system)
                               (cross-jobs system))))
                    ((core)
                     ;; Build core packages only.
                     (append (map (lambda (package)
                                    (package-job store (job-name package)
                                                 package system))
                                  %core-packages)
                             (cross-jobs system)))
                    ((hello)
                     ;; Build hello package only.
                     (if (string=? system (%current-system))
                         (let ((hello (specification->package "hello")))
                           (list (package-job store (job-name hello) hello system)))
                         '()))
                    ((list)
                     ;; Build selected list of packages only.
                     (if (string=? system (%current-system))
                         (let* ((names (assoc-ref arguments 'subset))
                                (packages (map specification->package names)))
                           (map (lambda (package)
                                    (package-job store (job-name package)
                                                 package system))
                                  packages))
                         '()))
                    ((manifests)
                     ;; Build packages in the list of manifests.
                     (let* ((manifests (arguments->manifests arguments))
                            (packages (manifests->packages store manifests)))
                       (map (lambda (package)
                              (package-job store (job-name package)
                                           package system))
                            packages)))
                    (else
                     (error "unknown subset" subset))))
                systems)))