aboutsummaryrefslogtreecommitdiff
path: root/tests/offload.scm
blob: 5a5de4e8b92d1fb539bdd551701c29ab800e2856 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; 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 (tests offload)
  #:use-module (guix scripts offload)
  #:use-module (srfi srfi-64))


(test-begin "offload")

(define-syntax-rule (expose-internal-definitions s1 s2 ...)
  (begin
    (define s1 (@@ (guix scripts offload) s1))
    (define s2 (@@ (guix scripts offload) s2)) ...))

(expose-internal-definitions machine-matches?
                             build-requirements-system
                             build-requirements-features
                             build-machine-system
                             build-machine-systems
                             %build-machine-system
                             %build-machine-systems
                             build-machine-features)

(define (deprecated-build-machine system)
  (build-machine
   (name "m1")
   (user "dummy")
   (host-key "some-key")
   (system system)))

(define (new-build-machine systems)
  (build-machine
   (name "m1")
   (user "dummy")
   (host-key "some-key")
   (systems systems)))

;;; Test that deprecated build-machine definitions still work.
(test-assert (machine-matches? (deprecated-build-machine "i686-linux")
                               (build-requirements
                                (system "i686-linux"))))


(test-assert (machine-matches? (new-build-machine '("i686-linux"))
                               (build-requirements
                                (system "i686-linux"))))

;;; A build machine can act as more than one system type, thanks to QEMU
;;; emulation.
(test-assert (machine-matches? (new-build-machine '("armhf-linux"
                                                    "aarch64-linux"
                                                    "i686-linux"
                                                    "x86_64-linux"))
                               (build-requirements
                                (system "armhf-linux"))))
;bar/foo-2.tar.gz\">version 2</a> <a href=\"bar/foo-1.tar.gz.sig\">version 1 signature</a> <a href=\"bar/foo-2.tar.gz.sig\">version 2 signature</a> </body> </html>")) (let () (define package (dummy-package "foo" (source (dummy-origin (uri (string-append (%local-url) "/foo-1.tar.gz")))) (properties `((release-monitoring-url . ,(%local-url)))))) (define update ((upstream-updater-import %generic-html-updater) package)) (define expected-new-url (string-append (%local-url) "/foo-2.tar.gz")) (define expected-signature-url (string-append (%local-url) "/foo-2.tar.gz.sig")) (and (pk 'u update) (equal? (upstream-source-version update) "2") (equal? (list expected-new-url) (upstream-source-urls update)) (equal? (list expected-signature-url) (upstream-source-signature-urls update)))))) (test-equal "rewrite-url, to-version specified" "https://download.qt.io/official_releases/qt/6.5/6.5.2/\ submodules/qtbase-everywhere-src-6.5.2.tar.xz" (rewrite-url "https://download.qt.io/official_releases/qt/6.3/6.3.2/\ submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2")) (test-equal "rewrite-url, without to-version" "http://dist.libuv.example.org/dist/v1.46.0/libuv-v1.46.0.tar.gz" (with-http-server ;; First reply, crawling http://dist.libuv.example.org/dist/. `((200 "\ <!DOCTYPE html> <html> <head><title>Index of dist</title></head> <body> <a href=\"../\">../</a> <a href=\"v1.44.0/\" title=\"v1.44.0/\">v1.44.0/</a> <a href=\"v1.44.1/\" title=\"v1.44.1/\">v1.44.1/</a> <a href=\"v1.44.2/\" title=\"v1.44.2/\">v1.44.2/</a> <a href=\"v1.45.0/\" title=\"v1.45.0/\">v1.45.0/</a> <a href=\"v1.46.0/\" title=\"v1.46.0/\">v1.46.0/</a> </body> </html>") ;; Second reply, crawling http://dist.libuv.example.org/dist/v1.46.0/. (200 "\ <!DOCTYPE html> <html> <head><title>Index of dist/v1.46.0</title></head> <body> <a href=\"../\">../</a> <a href=\"libuv-v1.46.0-dist.tar.gz\" title=\"libuv-v1.46.0-dist.tar.gz\"> libuv-v1.46.0-dist.tar.gz</a> <a href=\"libuv-v1.46.0-dist.tar.gz.sign\" title=\"libuv-v1.46.0-dist.tar.gz.sign\">libuv-v1.46.0-dist.tar.gz.sign</a> <a href=\"libuv-v1.46.0.tar.gz\" title=\"libuv-v1.46.0.tar.gz\"> libuv-v1.46.0.tar.gz</a> <a href=\"libuv-v1.46.0.tar.gz.sign\" title=\"libuv-v1.46.0.tar.gz.sign\"> libuv-v1.46.0.tar.gz.sign</a> </body> </html>")) (parameterize ((current-http-proxy (%local-url))) (rewrite-url "http://dist.libuv.example.org/dist/v1.45.0/libuv-v1.45.0.tar.gz" "1.45.0")))) (test-end)