code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;;
;;; 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 tests virtualization)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services dbus)
  #:use-module (gnu services networking)
  #:use-module (gnu services virtualization)
  #:use-module (gnu packages virtualization)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:export (%test-libvirt))

(define %libvirt-os
  (simple-operating-system
   (service dhcp-client-service-type)
   (dbus-service)
   (polkit-service)
   (service libvirt-service-type)))

(define (run-libvirt-test)
  "Run tests in %LIBVIRT-OS."
  (define os
    (marionette-operating-system
     %libvirt-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings '())))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (gnu build marionette))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "libvirt")

          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (match (start-service 'libvirtd)
                  (#f #f)
                  (('service response-parts ...)
                   (match (assq-ref response-parts 'running)
                     ((pid) (number? pid))))))
             marionette))

          (test-eq "fetch version"
            0
            (marionette-eval
             `(begin
                (system* ,(string-append #$libvirt "/bin/virsh")
                         "-c" "qemu:///system" "version"))
             marionette))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "libvirt-test" test))

(define %test-libvirt
  (system-test
   (name "libvirt")
   (description "Connect to the running LIBVIRT service.")
   (value (run-libvirt-test))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2019 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.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 (gnu tests web)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system shadow)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services web)
  #:use-module (gnu services databases)
  #:use-module (gnu services getmail)
  #:use-module (gnu services networking)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services mail)
  #:use-module (gnu packages databases)
  #:use-module (gnu packages patchutils)
  #:use-module (gnu packages python)
  #:use-module (gnu packages web)
  #:use-module (guix packages)
  #:use-module (guix modules)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (ice-9 match)
  #:export (%test-httpd
            %test-nginx
            %test-varnish
            %test-php-fpm
            %test-hpcguix-web
            %test-tailon
            %test-patchwork))

(define %index.html-contents
  ;; Contents of the /index.html file.
  "Hello, guix!")

(define %make-http-root
  ;; Create our server root in /srv.
  #~(begin
      (mkdir "/srv")
      (mkdir "/srv/http")
      (call-with-output-file "/srv/http/index.html"
        (lambda (port)
          (display #$%index.html-contents port)))))

(define* (run-webserver-test name test-os #:key (log-file #f) (http-port 8080))
  "Run tests in %NGINX-OS, which has nginx running and listening on
HTTP-PORT."
  (define os
    (marionette-operating-system
     test-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define forwarded-port 8080)

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings `((,http-port . ,forwarded-port)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (gnu build marionette)
                       (web uri)
                       (web client)
                       (web response))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin #$name)

          (test-assert #$(string-append name " service running")
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (match (start-service '#$(string->symbol name))
                  (#f #f)
                  (('service response-parts ...)
                   (match (assq-ref response-parts 'running)
                     ((#t) #t)
                     ((pid) (number? pid))))))
             marionette))

          (test-assert "HTTP port ready"
            (wait-for-tcp-port #$forwarded-port marionette))

          ;; Retrieve the index.html file we put in /srv.
          (test-equal "http-get"
            '(200 #$%index.html-contents)
            (let-values
                (((response text)
                  (http-get #$(simple-format
                               #f "http://localhost:~A/index.html" forwarded-port)
                            #:decode-body? #t)))
              (list (response-code response) text)))

          #$@(if log-file
                 `((test-assert ,(string-append "log file exists " log-file)
                     (marionette-eval
                      '(file-exists? ,log-file)
                      marionette)))
                 '())

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation (string-append name "-test") test))

;;;
;;; HTTPD
;;;

(define %httpd-os
  (simple-operating-system
   (service dhcp-client-service-type)
   (service httpd-service-type
            (httpd-configuration
             (config
              (httpd-config-file
               (listen '("8080"))))))
   (simple-service 'make-http-root activation-service-type
                   %make-http-root)))

(define %test-httpd
  (system-test
   (name "httpd")
   (description "Connect to a running HTTPD server.")
   (value (run-webserver-test name %httpd-os
                              #:log-file "/var/log/httpd/error_log"))))

;;;
;;; NGINX
;;;

(define %nginx-servers
  ;; Server blocks.
  (list (nginx-server-configuration
         (listen '("8080")))))

(define %nginx-os
  ;; Operating system under test.
  (simple-operating-system
   (service dhcp-client-service-type)
   (service nginx-service-type
            (nginx-configuration
             (log-directory "/var/log/nginx")
             (server-blocks %nginx-servers)))
   (simple-service 'make-http-root activation-service-type
                   %make-http-root)))

(define %test-nginx
  (system-test
   (name "nginx")
   (description "Connect to a running NGINX server.")
   (value (run-webserver-test name %nginx-os
                              #:log-file "/var/log/nginx/access.log"))))

;;;
;;; Varnish
;;;

(define %varnish-vcl
  (mixed-text-file
   "varnish-test.vcl"
   "vcl 4.0;
backend dummy { .host = \"127.1.1.1\"; }
sub vcl_recv { return(synth(200, \"OK\")); }
sub vcl_synth {
  synthetic(\"" %index.html-contents "\");
  set resp.http.Content-Type = \"text/plain\";
  return(deliver);
}"))

(define %varnish-os
  (simple-operating-system
   (service dhcp-client-service-type)
   ;; Pretend to be a web server that serves %index.html-contents.
   (service varnish-service-type
            (varnish-configuration
             (name "/tmp/server")
             ;; Use a small VSL buffer to fit in the test VM.
             (parameters '(("vsl_space" . "4M")))
             (vcl %varnish-vcl)))
   ;; Proxy the "server" using the builtin configuration.
   (service varnish-service-type
            (varnish-configuration
             (parameters '(("vsl_space" . "4M")))
             (backend "localhost:80")
             (listen '(":8080"))))))

(define %test-varnish
  (system-test
   (name "varnish")
   (description "Test the Varnish Cache server.")
   (value (run-webserver-test "varnish-default" %varnish-os))))

;;;
;;; PHP-FPM
;;;

(define %make-php-fpm-http-root
  ;; Create our server root in /srv.
  #~(begin
      (mkdir "/srv")
      (call-with-output-file "/srv/index.php"
        (lambda (port)
          (display "<?php
phpinfo();
echo(\"Computed by php:\".((string)(2+3)));
?>\n" port)))))

(define %php-fpm-nginx-server-blocks
  (list (nginx-server-configuration
         (root "/srv")
         (locations
          (list (nginx-php-location)))
         (listen '("8042"))
         (ssl-certificate #f)
         (ssl-certificate-key #f))))

(define %php-fpm-os
  ;; Operating system under test.
  (simple-operating-system
   (service dhcp-client-service-type)
   (service php-fpm-service-type)
   (service nginx-service-type
            (nginx-configuration
             (server-blocks %php-fpm-nginx-server-blocks)))
   (simple-service 'make-http-root activation-service-type
                   %make-php-fpm-http-root)))

(define* (run-php-fpm-test #:optional (http-port 8042))
  "Run tests in %PHP-FPM-OS, which has nginx running and listening on
HTTP-PORT, along with php-fpm."
  (define os
    (marionette-operating-system
     %php-fpm-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings `((8080 . ,http-port)))))

  (define test
    (with-imported-modules '((gnu build marionette)
                             (guix build utils))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (gnu build marionette)
                       (web uri)
                       (web client)
                       (web response))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "php-fpm")

          (test-assert "php-fpm running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (match (start-service 'php-fpm)
                  (#f #f)
                  (('service response-parts ...)
                   (match (assq-ref response-parts 'running)
                     ((pid) (number? pid))))))
             marionette))

          (test-assert "nginx running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'nginx))
             marionette))

          (test-equal "http-get"
            200
            (let-values (((response text)
                          (http-get "http://localhost:8080/index.php"
                                    #:decode-body? #t)))
              (response-code response)))

          (test-equal "php computed result is sent"
            "Computed by php:5"
            (let-values (((response text)
                          (http-get "http://localhost:8080/index.php"
                                    #:decode-body? #t)))
              (begin
                (use-modules (ice-9 regex))
                (let ((matches (string-match "Computed by php:5" text)))
                  (and matches
                       (match:substring matches 0))))))

          (test-end)

          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "php-fpm-test" test))

(define %test-php-fpm
  (system-test
   (name "php-fpm")
   (description "Test PHP-FPM through nginx.")
   (value (run-php-fpm-test))))

;;;
;;; hpcguix-web
;;;

(define* (run-hpcguix-web-server-test name test-os)
  "Run tests in %HPCGUIX-WEB-OS, which has hpcguix-web running."
  (define os
    (marionette-operating-system
     test-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings '((8080 . 5000)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (gnu build marionette)
                       (web uri)
                       (web client)
                       (web response))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin #$name)

          (test-assert "hpcguix-web running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (match (start-service 'hpcguix-web)
                  (#f #f)
                  (('service response-parts ...)
                   (match (assq-ref response-parts 'running)
                     ((pid) (number? pid))))))
             marionette))

          (test-equal "http-get"
            200
            (begin
              (wait-for-tcp-port 5000 marionette)
              (let-values (((response text)
                            (http-get "http://localhost:8080")))
                (response-code response))))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation (string-append name "-test") test))

(define %hpcguix-web-specs
  ;; Server config gexp.
  #~(define site-config
      (hpcweb-configuration
       (title-prefix "[TEST] HPCGUIX-WEB"))))

(define %hpcguix-web-os
  (simple-operating-system
   (service dhcp-client-service-type)
   (service hpcguix-web-service-type
            (hpcguix-web-configuration
             (specs %hpcguix-web-specs)))))

(define %test-hpcguix-web
  (system-test
   (name "hpcguix-web")
   (description "Connect to a running hpcguix-web server.")
   (value (run-hpcguix-web-server-test name %hpcguix-web-os))))

(define %tailon-os
  ;; Operating system under test.
  (simple-operating-system
   (service dhcp-client-service-type)
   (service tailon-service-type
            (tailon-configuration
             (config-file
              (tailon-configuration-file
               (bind "0.0.0.0:8080")))))))

(define* (run-tailon-test #:optional (http-port 8081))
  "Run tests in %TAILON-OS, which has tailon running and listening on
HTTP-PORT."
  (define os
    (marionette-operating-system
     %tailon-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings `((,http-port . 8080)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (ice-9 match)
                       (gnu build marionette)
                       (web uri)
                       (web client)
                       (web response))

          (define marionette
            ;; Forward the guest's HTTP-PORT, where tailon is listening, to
            ;; port 8080 in the host.
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "tailon")

          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'tailon))
             marionette))

          (define* (retry-on-error f #:key times delay)
            (let loop ((attempt 1))
              (match (catch
                      #t
                      (lambda ()
                        (cons #t
                              (f)))
                      (lambda args
                        (cons #f
                              args)))
                ((#t . return-value)
                 return-value)
                ((#f . error-args)
                 (if (>= attempt times)
                     error-args
                     (begin
                       (sleep delay)
                       (loop (+ 1 attempt))))))))

          (test-equal "http-get"
            200
            (retry-on-error
             (lambda ()
               (let-values (((response text)
                             (http-get #$(format
                                          #f
                                          "http://localhost:~A/"
                                          http-port)
                                       #:decode-body? #t)))
                 (response-code response)))
             #:times 10
             #:delay 5))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "tailon-test" test))

(define %test-tailon
  (system-test
   (name "tailon")
   (description "Connect to a running Tailon server.")
   (value (run-tailon-test))))

;;;
;;; Patchwork
;;;

(define (patchwork-initial-database-setup-service configuration)
  (define start-gexp
    #~(lambda ()
        (let ((pid (primitive-fork))
              (postgres (getpwnam "postgres")))
          (if (eq? pid 0)
              (dynamic-wind
                (const #t)
                (lambda ()
                  (setgid (passwd:gid postgres))
                  (setuid (passwd:uid postgres))
                  (primitive-exit
                   (if (and
                        (zero?
                         (system* #$(file-append postgresql "/bin/createuser")
                                  #$(patchwork-database-configuration-user
                                      configuration)))
                        (zero?
                         (system* #$(file-append postgresql "/bin/createdb")
                                  "-O"
                                  #$(patchwork-database-configuration-user
                                      configuration)
                                  #$(patchwork-database-configuration-name
                                      configuration))))
                       0
                       1)))
                (lambda ()
                  (primitive-exit 1)))
              (zero? (cdr (waitpid pid)))))))

  (shepherd-service
   (requirement '(postgres))
   (provision '(patchwork-postgresql-user-and-database))
   (start start-gexp)
   (stop #~(const #f))
   (respawn? #f)
   (documentation "Setup patchwork database.")))

(define (patchwork-os patchwork)
  (simple-operating-system
   (service dhcp-client-service-type)
   (service httpd-service-type
            (httpd-configuration
             (config
              (httpd-config-file
               (listen '("8080"))))))
   (service postgresql-service-type)
   (service patchwork-service-type
            (patchwork-configuration
             (patchwork patchwork)
             (domain "localhost")
             (settings-module
              (patchwork-settings-module
               (allowed-hosts (list domain))
               (default-from-email "")))
             (getmail-retriever-config
              (getmail-retriever-configuration
               (type "SimpleIMAPSSLRetriever")
               (server "imap.example.com")
               (port 993)
               (username "username")
               (password "password")
               (extra-parameters
                '((mailboxes . ("INBOX"))))))))
   (simple-service 'patchwork-database-setup
                   shepherd-root-service-type
                   (list
                    (patchwork-initial-database-setup-service
                     (patchwork-database-configuration))))))

(define (run-patchwork-test patchwork)
  "Run tests in %NGINX-OS, which has nginx running and listening on
HTTP-PORT."
  (define os
    (marionette-operating-system
     (patchwork-os patchwork)
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define forwarded-port 8080)

  (define vm
    (virtual-machine
     (operating-system os)
     (port-forwardings `((8080 . ,forwarded-port)))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (srfi srfi-11) (srfi srfi-64)
                       (gnu build marionette)
                       (web uri)
                       (web client)
                       (web response))

          (define marionette
            (make-marionette (list #$vm)))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "patchwork")

          (test-assert "patchwork-postgresql-user-and-service started"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (match (start-service 'patchwork-postgresql-user-and-database)
                  (#f #f)
                  (('service response-parts ...)
                   (match (assq-ref response-parts 'running)
                     ((#t) #t)
                     ((pid) (number? pid))))))
             marionette))

          (test-assert "httpd running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'httpd))
             marionette))

          (test-equal "http-get"
            200
            (let-values
                (((response text)
                  (http-get #$(simple-format
                               #f "http://localhost:~A/" forwarded-port)
                            #:decode-body? #t)))
              (response-code response)))

          (test-end)
          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

  (gexp->derivation "patchwork-test" test))

(define %test-patchwork
  (system-test
   (name "patchwork")
   (description "Connect to a running Patchwork service.")
   (value (run-patchwork-test patchwork))))

license: mit


code:
// GNU Guix --- Functional package management for GNU
// Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
//
// 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/>.

var outerRadius = Math.max(nodeArray.length * 15, 500) / 2,
    innerRadius = outerRadius - Math.min(nodeArray.length * 5, 200),
    width = outerRadius * 2,
    height = outerRadius * 2,
    colors = d3.scale.category20c(),
    matrix = [];

function neighborsOf (node) {
    return links.filter(function (e) {
        return e.source === node;
    }).map(function (e) {
       return e.target;
    });
}

function zoomed () {
    zoomer.attr("transform",
                "translate(" + d3.event.translate + ")" +
                "scale(" + d3.event.scale + ")");
}

function fade (opacity, root) {
    return function (g, i) {
        root.selectAll("g path.chord")
            .filter(function (d) {
                return d.source.index != i && d.target.index != i;
            })
            .transition()
            .style("opacity", opacity);
    };
}

// Now that we have all nodes in an object we can replace each reference
// with the actual node object.
links.forEach(function (link) {
  link.target = nodes[link.target];
  link.source = nodes[link.source];
});

// Construct a square matrix for package dependencies
nodeArray.forEach(function (d, index, arr) {
    var source = index,
        row = matrix[source];
    if (!row) {
        row = matrix[source] = [];
        for (var i = -1; ++i < arr.length;) row[i] = 0;
    }
    neighborsOf(d).forEach(function (d) { row[d.index]++; });
});

// chord layout
var chord = d3.layout.chord()
    .padding(0.01)
    .sortSubgroups(d3.descending)
    .sortChords(d3.descending)
    .matrix(matrix);

var arc = d3.svg.arc()
    .innerRadius(innerRadius)
    .outerRadius(innerRadius + 20);

var zoom = d3.behavior.zoom()
    .scaleExtent([0.1, 10])
    .on("zoom", zoomed);

var svg = d3.select("body").append("svg")
    .attr("width", "100%")
    .attr("height", "100%")
    .attr('viewBox', '0 0 ' + Math.min(width, height) + ' ' + Math.min(width, height))
    .attr('preserveAspectRatio', 'xMinYMin')
    .call(zoom);

var zoomer = svg.append("g");

var container = zoomer.append("g")
    .attr("transform", "translate(" + outerRadius + "," + outerRadius + ")");

// Group for arcs and labels
var g = container.selectAll(".group")
    .data(chord.groups)
    .enter().append("g")
    .attr("class", "group")
    .on("mouseout", fade(1, container))
    .on("mouseover", fade(0.1, container));

// Draw one segment per package
g.append("path")
    .style("fill",   function (d) { return colors(d.index); })
    .style("stroke", function (d) { return colors(d.index); })
    .attr("d", arc);

// Add circular labels
g.append("text")
    .each(function (d) { d.angle = (d.startAngle + d.endAngle) / 2; })
    .attr("dy", ".35em")
    .attr("transform", function (d) {
      return "rotate(" + (d.angle * 180 / Math.PI - 90) + ")"
          + "translate(" + (innerRadius + 26) + ")"
          + (d.angle > Math.PI ? "rotate(180)" : "");
    })
    .style("text-anchor", function (d) { return d.angle > Math.PI ? "end" : null; })
    .text(function (d) { return nodeArray[d.index].label; });

// Draw chords from source to target; color by source.
container.selectAll(".chord")
    .data(chord.chords)
    .enter().append("path")
    .attr("class", "chord")
    .style("stroke", function (d) { return d3.rgb(colors(d.source.index)).darker(); })
    .style("fill", function (d) { return colors(d.source.index); })
    .attr("d", d3.svg.chord().radius(innerRadius));


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2014 Ludovic Courtès <ludo@gnu.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 (guix))

;; The composite module that re-exports everything from the public modules.

(eval-when (eval load compile)
  (begin
    (define %public-modules
      '(base32
        build-system
        derivations
        download
        ftp-client
        gexp
        monads
        monad-repl
        packages
        store
        utils))

    (for-each (let ((i (module-public-interface (current-module))))
                (lambda (m)
                  (module-use! i (resolve-interface `(guix ,m)))))
              %public-modules)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.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 (guix android-repo-download)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (guix modules)
  #:autoload   (guix build-system gnu) (standard-packages)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (android-repo-reference
            android-repo-reference?
            android-repo-reference-manifest-url
            android-repo-reference-revision

            android-repo-fetch
            android-repo-version
            android-repo-file-name))

;;; Commentary:
;;;
;;; An <origin> method that fetches a specific commit from an Android repo
;;; repository.
;;; The repository's manifest (URL and revision) can be specified with a
;;; <android-repo-reference> object.
;;;
;;; Code:

(define-record-type* <android-repo-reference>
  android-repo-reference make-android-repo-reference
  android-repo-reference?
  (manifest-url        android-repo-reference-manifest-url)
  (manifest-revision   android-repo-reference-manifest-revision))

(define (git-repo-package)
  "Return the default git-repo package."
  (let ((distro (resolve-interface '(gnu packages android))))
    (module-ref distro 'git-repo)))

(define* (android-repo-fetch ref hash-algo hash
                             #:optional name
                             #:key (system (%current-system))
                             (guile (default-guile))
                             (git-repo (git-repo-package)))
  "Return a fixed-output derivation that fetches REF, an
<android-repo-reference> object.  The output is expected to have recursive
hash HASH of type HASH-ALGO (a symbol).  Use NAME as the file name, or a
generic name if unset."
  ;; TODO: Remove.
  (define inputs
    (standard-packages))

  (define zlib
    (module-ref (resolve-interface '(gnu packages compression)) 'zlib))

  (define gnutls
    (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))

  (define config.scm
    (scheme-file "config.scm"
                 #~(begin
                     (define-module (guix config)
                       #:export (%libz))

                     (define %libz
                       #+(file-append zlib "/lib/libz")))))

  (define modules
    (cons `((guix config) => ,config.scm)
          (delete '(guix config)
                  (source-module-closure '((guix build android-repo)
                                           (guix build utils)
                                           (guix build download-nar))))))

  (define build
    (with-imported-modules modules
      (with-extensions (list gnutls)
        #~(begin
            (use-modules (guix build android-repo)
                         (guix build utils)
                         (guix build download-nar)
                         (ice-9 match))

            ;; The 'git submodule' commands expects Coreutils, sed,
            ;; grep, etc. to be in $PATH.
            (set-path-environment-variable "PATH" '("bin")
                                           (match '#+inputs
                                             (((names dirs outputs ...) ...)
                                              dirs)))

            (setvbuf (current-output-port) 'line)
            (setvbuf (current-error-port) 'line)

            (or (android-repo-fetch (getenv "android-repo manifest-url")
                                    (getenv "android-repo manifest-revision")
                                    #$output
                                    #:git-repo-command
                                    (string-append #+git-repo "/bin/repo"))
                (download-nar #$output))))))

  (mlet %store-monad ((guile (package->derivation guile system)))
    (gexp->derivation (or name "android-repo-checkout") build

                      ;; Use environment variables and a fixed script name so
                      ;; there's only one script in store for all the
                      ;; downloads.
                      #:script-name "android-repo-download"
                      #:env-vars
                      `(("android-repo manifest-url" .
                         ,(android-repo-reference-manifest-url ref))
                        ("android-repo manifest-revision" .
                         ,(android-repo-reference-manifest-revision ref)))
                      #:leaked-env-vars '("http_proxy" "https_proxy"
                                          "LC_ALL" "LC_MESSAGES" "LANG"
                                          "COLUMNS")
                      #:system system
                      #:local-build? #t           ;don't offload repo cloning
                      #:hash-algo hash-algo
                      #:hash hash
                      #:recursive? #t
                      #:guile-for-build guile)))

(define (android-repo-version version revision)
  "Return the version string for packages using android-repo-download."
  (string-append version "-" (string-join (string-split revision #\/) "_")))

(define (android-repo-file-name name version)
  "Return the file-name for packages using android-repo-download."
  (string-append name "-" version "-checkout"))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2014, 2017 Ludovic Courtès <ludo@gnu.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 (guix base16)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-60)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 format)
  #:export (bytevector->base16-string
            base16-string->bytevector))

;;;
;;; Base 16.
;;;

(define (bytevector->base16-string bv)
  "Return the hexadecimal representation of BV's contents."
  (define len
    (bytevector-length bv))

  (let-syntax ((base16-chars (lambda (s)
                               (syntax-case s ()
                                 (_
                                  (let ((v (list->vector
                                            (unfold (cut > <> 255)
                                                    (lambda (n)
                                                      (format #f "~2,'0x" n))
                                                    1+
                                                    0))))
                                    v))))))
    (define chars base16-chars)
    (let loop ((i len)
               (r '()))
      (if (zero? i)
          (string-concatenate r)
          (let ((i (- i 1)))
            (loop i
                  (cons (vector-ref chars (bytevector-u8-ref bv i)) r)))))))

(define base16-string->bytevector
  (let ((chars->value (fold (lambda (i r)
                              (vhash-consv (string-ref (number->string i 16)
                                                       0)
                                           i r))
                            vlist-null
                            (iota 16))))
    (lambda (s)
      "Return the bytevector whose hexadecimal representation is string S."
      (define bv
        (make-bytevector (quotient (string-length s) 2) 0))

      (string-fold (lambda (chr i)
                     (let ((j (quotient i 2))
                           (v (and=> (vhash-assv chr chars->value) cdr)))
                       (if v
                           (if (zero? (logand i 1))
                               (bytevector-u8-set! bv j
                                                   (arithmetic-shift v 4))
                               (let ((w (bytevector-u8-ref bv j)))
                                 (bytevector-u8-set! bv j (logior v w))))
                           (error "invalid hexadecimal character" chr)))
                     (+ i 1))
                   0
                   s)
      bv)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2015, 2017 Ludovic Courtès <ludo@gnu.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 (guix base32)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-60)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 vlist)
  #:export (bytevector-quintet-length
            bytevector->base32-string
            bytevector->nix-base32-string
            base32-string->bytevector
            nix-base32-string->bytevector
            %nix-base32-charset
            %rfc4648-base32-charset
            &invalid-base32-character
            invalid-base32-character?
            invalid-base32-character-value
            invalid-base32-character-string))

;;; Commentary:
;;;
;;; A generic, customizable to convert bytevectors to/from a base32
;;; representation.
;;;
;;; Code:

(define bytevector-quintet-ref
  (let* ((ref  bytevector-u8-ref)
         (ref+ (lambda (bv offset)
                 (let ((o (+ 1 offset)))
                   (if (>= o (bytevector-length bv))
                       0
                       (bytevector-u8-ref bv o)))))
         (ref0 (lambda (bv offset)
                 (bit-field (ref bv offset) 3 8)))
         (ref1 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 3) 2)
                         (bit-field (ref+ bv offset) 6 8))))
         (ref2 (lambda (bv offset)
                 (bit-field (ref bv offset) 1 6)))
         (ref3 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 1) 4)
                         (bit-field (ref+ bv offset) 4 8))))
         (ref4 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 4) 1)
                         (bit-field (ref+ bv offset) 7 8))))
         (ref5 (lambda (bv offset)
                 (bit-field (ref bv offset) 2 7)))
         (ref6 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 2) 3)
                         (bit-field (ref+ bv offset) 5 8))))
         (ref7 (lambda (bv offset)
                 (bit-field (ref bv offset) 0 5)))
         (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
    (lambda (bv index)
      "Return the INDEXth quintet of BV."
      (let ((p (vector-ref refs (modulo index 8))))
        (p bv (quotient (* index 5) 8))))))

(define bytevector-quintet-ref-right
  (let* ((ref  bytevector-u8-ref)
         (ref+ (lambda (bv offset)
                 (let ((o (+ 1 offset)))
                   (if (>= o (bytevector-length bv))
                       0
                       (bytevector-u8-ref bv o)))))
         (ref0 (lambda (bv offset)
                 (bit-field (ref bv offset) 0 5)))
         (ref1 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 5 8)
                         (ash (bit-field (ref+ bv offset) 0 2) 3))))
         (ref2 (lambda (bv offset)
                 (bit-field (ref bv offset) 2 7)))
         (ref3 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 7 8)
                         (ash (bit-field (ref+ bv offset) 0 4) 1))))
         (ref4 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 4 8)
                         (ash (bit-field (ref+ bv offset) 0 1) 4))))
         (ref5 (lambda (bv offset)
                 (bit-field (ref bv offset) 1 6)))
         (ref6 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 6 8)
                         (ash (bit-field (ref+ bv offset) 0 3) 2))))
         (ref7 (lambda (bv offset)
                 (bit-field (ref bv offset) 3 8)))
         (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
    (lambda (bv index)
      "Return the INDEXth quintet of BV, assuming quintets start from the
least-significant bits, contrary to what RFC 4648 describes."
      (let ((p (vector-ref refs (modulo index 8))))
        (p bv (quotient (* index 5) 8))))))

(define (bytevector-quintet-length bv)
  "Return the number of quintets (including truncated ones) available in BV."
  (ceiling (/ (* (bytevector-length bv) 8) 5)))

(define (bytevector-quintet-fold proc init bv)
  "Return the result of applying PROC to each quintet of BV and the result of
the previous application or INIT."
  (define len
    (bytevector-quintet-length bv))

  (let loop ((i 0)
             (r init))
    (if (= i len)
        r
        (loop (1+ i) (proc (bytevector-quintet-ref bv i) r)))))

(define (bytevector-quintet-fold-right proc init bv)
  "Return the result of applying PROC to each quintet of BV and the result of
the previous application or INIT."
  (define len
    (bytevector-quintet-length bv))

  (let loop ((i len)
             (r init))
    (if (zero? i)
        r
        (let ((j (- i 1)))
          (loop j (proc (bytevector-quintet-ref-right bv j) r))))))

(define (make-bytevector->base32-string quintet-fold base32-chars)
  (lambda (bv)
    "Return a base32 encoding of BV using BASE32-CHARS as the alphabet."
    (let ((chars (quintet-fold (lambda (q r)
                                 (cons (vector-ref base32-chars q)
                                       r))
                               '()
                               bv)))
      (list->string (reverse chars)))))

(define %nix-base32-chars
  ;; See `libutil/hash.cc'.
  #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
    #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
    #\p #\q #\r #\s #\v #\w #\x #\y #\z))

(define %nix-base32-charset
  (list->char-set (vector->list %nix-base32-chars)))

(define %rfc4648-base32-chars
  #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
    #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
    #\2 #\3 #\4 #\5 #\6 #\7))

(define %rfc4648-base32-charset
  (list->char-set (vector->list %rfc4648-base32-chars)))

(define bytevector->base32-string
  (make-bytevector->base32-string bytevector-quintet-fold
                                  %rfc4648-base32-chars))

(define bytevector->nix-base32-string
  (make-bytevector->base32-string bytevector-quintet-fold-right
                                  %nix-base32-chars))

(define bytevector-quintet-set!
  (let* ((setq! (lambda (bv offset start stop value)
                  (let ((v (bytevector-u8-ref bv offset))
                        (w (arithmetic-shift value start))
                        (m (bitwise-xor (1- (expt 2 stop))
                                        (1- (expt 2 start)))))
                    (bytevector-u8-set! bv offset
                                        (bitwise-merge m w v)))))
         (set0! (lambda (bv offset value)
                  (setq! bv offset 3 8 value)))
         (set1! (lambda (bv offset value)
                  (setq! bv offset 0 3 (bit-field value 2 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2)))))
         (set2! (lambda (bv offset value)
                  (setq! bv offset 1 6 value)))
         (set3! (lambda (bv offset value)
                  (setq! bv offset 0 1 (bit-field value 4 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4)))))
         (set4! (lambda (bv offset value)
                  (setq! bv offset 0 4 (bit-field value 1 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 7 8  (bit-field value 0 1)))))
         (set5! (lambda (bv offset value)
                  (setq! bv offset 2 7 value)))
         (set6! (lambda (bv offset value)
                  (setq! bv offset 0 2 (bit-field value 3 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3)))))
         (set7! (lambda (bv offset value)
                  (setq! bv offset 0 5 value)))
         (sets  (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
    (lambda (bv index value)
      "Set the INDEXth quintet of BV to VALUE."
      (let ((p (vector-ref sets (modulo index 8))))
        (p bv (quotient (* index 5) 8) (logand value #x1f))))))

(define bytevector-quintet-set-right!
  (let* ((setq! (lambda (bv offset start stop value)
                  (let ((v (bytevector-u8-ref bv offset))
                        (w (arithmetic-shift value start))
                        (m (bitwise-xor (1- (expt 2 stop))
                                        (1- (expt 2 start)))))
                    (bytevector-u8-set! bv offset
                                        (bitwise-merge m w v)))))
         (set0! (lambda (bv offset value)
                  (setq! bv offset 0 5 value)))
         (set1! (lambda (bv offset value)
                  (setq! bv offset 5 8 (bit-field value 0 3))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5)))))
         (set2! (lambda (bv offset value)
                  (setq! bv offset 2 7 value)))
         (set3! (lambda (bv offset value)
                  (setq! bv offset 7 8 (bit-field value 0 1))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5)))))
         (set4! (lambda (bv offset value)
                  (setq! bv offset 4 8 (bit-field value 0 4))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5)))))
         (set5! (lambda (bv offset value)
                  (setq! bv offset 1 6 value)))
         (set6! (lambda (bv offset value)
                  (setq! bv offset 6 8 (bit-field value 0 2))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5)))))
         (set7! (lambda (bv offset value)
                  (setq! bv offset 3 8 value)))
         (sets  (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
    (lambda (bv index value)
      "Set the INDEXth quintet of BV to VALUE, assuming quintets start from
the least-significant bits."
      (let ((p (vector-ref sets (modulo index 8))))
        (p bv (quotient (* index 5) 8) (logand value #x1f))))))

(define (base32-string-unfold f s)
  "Given procedure F which, when applied to a character, returns the
corresponding quintet, return the bytevector corresponding to string S."
  (define len (string-length s))

  (let ((bv (make-bytevector (quotient (* len 5) 8))))
    (string-fold (lambda (chr index)
                   (bytevector-quintet-set! bv index (f chr))
                   (+ 1 index))
                 0
                 s)
    bv))

(define (base32-string-unfold-right f s)
  "Given procedure F which, when applied to a character, returns the
corresponding quintet, return the bytevector corresponding to string S,
starting from the right of S."
  (define len (string-length s))

  (let ((bv (make-bytevector (quotient (* len 5) 8))))
    (string-fold-right (lambda (chr index)
                         (bytevector-quintet-set-right! bv index (f chr))
                         (+ 1 index))
                       0
                       s)
    bv))

;; Invalid base32 character error condition when decoding base32.
(define-condition-type &invalid-base32-character &error
  invalid-base32-character?
  (character invalid-base32-character-value)
  (string    invalid-base32-character-string))

(define (make-base32-string->bytevector base32-string-unfold base32-chars)
  (let ((char->value (let loop ((i 0)
                                (v vlist-null))
                       (if (= i (vector-length base32-chars))
                           v
                           (loop (+ 1 i)
                                 (vhash-consv (vector-ref base32-chars i)
                                              i v))))))
    (lambda (s)
      "Return the binary representation of base32 string S as a bytevector."
      (base32-string-unfold (lambda (chr)
                              (or (and=> (vhash-assv chr char->value) cdr)
                                  (raise (condition
                                          (&invalid-base32-character
                                           (character chr)
                                           (string s))))))
                            s))))

(define base32-string->bytevector
  (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars))

(define nix-base32-string->bytevector
  (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars))

;;; base32.scm ends here


code:
;; -*- mode: scheme; coding: utf-8 -*-
;;
;; This module was renamed from (weinholt text base64 (1 0 20100612)) to
;; (guix base64) by Nikita Karetnikov <nikita@karetnikov.org> on
;; February 12, 2014.
;;
;; Some optimizations made by Ludovic Courtès <ludo@gnu.org>, 2015.
;; Turned into a Guile module (instead of R6RS).
;;
;; This program 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.
;;
;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; This file incorporates work covered by the following copyright and
;; permission notice:
;;
;;   Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se>
;;
;;   Permission is hereby granted, free of charge, to any person obtaining a
;;   copy of this software and associated documentation files (the "Software"),
;;   to deal in the Software without restriction, including without limitation
;;   the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;   and/or sell copies of the Software, and to permit persons to whom the
;;   Software is furnished to do so, subject to the following conditions:
;;
;;   The above copyright notice and this permission notice shall be included in
;;   all copies or substantial portions of the Software.
;;
;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;   DEALINGS IN THE SOFTWARE.

;; RFC 4648 Base-N Encodings

(define-module (guix base64)
  #:export (base64-encode
            base64-decode
            base64-alphabet
            base64url-alphabet
            get-delimited-base64
            put-delimited-base64)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-60)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports))

(define-syntax define-alias
  (syntax-rules ()
    ((_ new old)
     (define-syntax new (identifier-syntax old)))))

;; Force the use of Guile's own primitives to avoid the overhead of its 'fx'
;; procedures.

(define-alias fxbit-field bit-field)
(define-alias fxarithmetic-shift ash)
(define-alias fxarithmetic-shift-left ash)
(define-alias fxand logand)
(define-alias fxior logior)
(define-alias fxxor logxor)
(define-alias fx=? =)
(define-alias fx+ +)
(define-alias mod modulo)

(define-syntax-rule (assert exp)
  (unless exp
    (throw 'assertion-failure 'exp)))

(define base64-alphabet
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")

(define base64url-alphabet
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")

(define base64-encode
  (case-lambda
    ;; Simple interface. Returns a string containing the canonical
    ;; base64 representation of the given bytevector.
    ((bv)
     (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
    ((bv start)
     (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
    ((bv start end)
     (base64-encode bv start end #f #f base64-alphabet #f))
    ((bv start end line-length)
     (base64-encode bv start end line-length #f base64-alphabet #f))
    ((bv start end line-length no-padding)
     (base64-encode bv start end line-length no-padding base64-alphabet #f))
    ((bv start end line-length no-padding alphabet)
     (base64-encode bv start end line-length no-padding alphabet #f))
    ;; Base64 encodes the bytes [start,end[ in the given bytevector.
    ;; Lines are limited to line-length characters (unless #f),
    ;; which must be a multiple of four. To omit the padding
    ;; characters (#\=) set no-padding to a true value. If port is
    ;; #f, returns a string.
    ((bv start end line-length no-padding alphabet port)
     (assert (or (not line-length) (zero? (mod line-length 4))))
     (let-values (((p extract) (if port
                                   (values port (lambda () (values)))
                                   (open-string-output-port))))
       (letrec ((put (if line-length
                         (let ((chars 0))
                           (lambda (p c)
                             (when (fx=? chars line-length)
                               (set! chars 0)
                               (put-char p #\linefeed))
                             (set! chars (fx+ chars 1))
                             (put-char p c)))
                         put-char)))
         (let lp ((i start))
           (cond ((= i end))
                 ((<= (+ i 3) end)
                  (let ((x (bytevector-uint-ref bv i (endianness big) 3)))
                    (put p (string-ref alphabet (fxbit-field x 18 24)))
                    (put p (string-ref alphabet (fxbit-field x 12 18)))
                    (put p (string-ref alphabet (fxbit-field x 6 12)))
                    (put p (string-ref alphabet (fxbit-field x 0 6)))
                    (lp (+ i 3))))
                 ((<= (+ i 2) end)
                  (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8)))
                    (put p (string-ref alphabet (fxbit-field x 18 24)))
                    (put p (string-ref alphabet (fxbit-field x 12 18)))
                    (put p (string-ref alphabet (fxbit-field x 6 12)))
                    (unless no-padding
                      (put p #\=))))
                 (else
                  (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16)))
                    (put p (string-ref alphabet (fxbit-field x 18 24)))
                    (put p (string-ref alphabet (fxbit-field x 12 18)))
                    (unless no-padding
                      (put p #\=)
                      (put p #\=)))))))
       (extract)))))

  ;; Decodes a base64 string. The string must contain only pure
  ;; unpadded base64 data.

(define base64-decode
  (case-lambda
    ((str)
     (base64-decode str base64-alphabet #f))
    ((str alphabet)
     (base64-decode str alphabet #f))
    ((str alphabet port)
     (unless (zero? (mod (string-length str) 4))
       (error 'base64-decode
              "input string must be a multiple of four characters"))
     (let-values (((p extract) (if port
                                   (values port (lambda () (values)))
                                   (open-bytevector-output-port))))
       (do ((i 0 (+ i 4)))
           ((= i (string-length str))
            (extract))
         (let ((c1 (string-ref str i))
               (c2 (string-ref str (+ i 1)))
               (c3 (string-ref str (+ i 2)))
               (c4 (string-ref str (+ i 3))))
           ;; TODO: be more clever than string-index
           (let ((i1 (string-index alphabet c1))
                 (i2 (string-index alphabet c2))
                 (i3 (string-index alphabet c3))
                 (i4 (string-index alphabet c4)))
             (cond ((and i1 i2 i3 i4)
                    (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                    (fxarithmetic-shift-left i2 12)
                                    (fxarithmetic-shift-left i3 6)
                                    i4)))
                      (put-u8 p (fxbit-field x 16 24))
                      (put-u8 p (fxbit-field x 8 16))
                      (put-u8 p (fxbit-field x 0 8))))
                   ((and i1 i2 i3 (char=? c4 #\=)
                         (= i (- (string-length str) 4)))
                    (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                    (fxarithmetic-shift-left i2 12)
                                    (fxarithmetic-shift-left i3 6))))
                      (put-u8 p (fxbit-field x 16 24))
                      (put-u8 p (fxbit-field x 8 16))))
                   ((and i1 i2 (char=? c3 #\=) (char=? c4 #\=)
                         (= i (- (string-length str) 4)))
                    (let ((x (fxior (fxarithmetic-shift-left i1 18)
                                    (fxarithmetic-shift-left i2 12))))
                      (put-u8 p (fxbit-field x 16 24))))
                   (else
                    (error 'base64-decode "invalid input"
                           (list c1 c2 c3 c4)))))))))))

(define (get-line-comp f port)
  (if (port-eof? port)
      (eof-object)
      (f (get-line port))))

  ;; Reads the common -----BEGIN/END type----- delimited format from
  ;; the given port. Returns two values: a string with the type and a
  ;; bytevector containing the base64 decoded data. The second value
  ;; is the eof object if there is an eof before the BEGIN delimiter.

(define (get-delimited-base64 port)
  (define (get-first-data-line port)
    ;; Some MIME data has header fields in the same format as mail
    ;; or http. These are ignored.
    (let ((line (get-line-comp string-trim-both port)))
      (cond ((eof-object? line) line)
            ((string-index line #\:)
             (let lp ()                           ;read until empty line
               (let ((line (get-line-comp string-trim-both port)))
                 (if (string=? line "")
                     (get-line-comp string-trim-both port)
                     (lp)))))
            (else line))))
  (let ((line (get-line-comp string-trim-both port)))
    (cond ((eof-object? line)
           (values "" (eof-object)))
          ((string=? line "")
           (get-delimited-base64 port))
          ((and (string-prefix? "-----BEGIN " line)
                (string-suffix? "-----" line))
           (let* ((type (substring line 11 (- (string-length line) 5)))
                  (endline (string-append "-----END " type "-----")))
             (let-values (((outp extract) (open-bytevector-output-port)))
               (let lp ((line (get-first-data-line port)))
                 (cond ((eof-object? line)
                        (error 'get-delimited-base64
                               "unexpected end of file"))
                       ((string-prefix? "-" line)
                        (unless (string=? line endline)
                          (error 'get-delimited-base64
                                 "bad end delimiter" type line))
                        (values type (extract)))
                       (else
                        (unless (and (= (string-length line) 5)
                                     (string-prefix? "=" line)) ;Skip Radix-64 checksum
                          (base64-decode line base64-alphabet outp))
                        (lp (get-line-comp string-trim-both port))))))))
          (else     ;skip garbage (like in openssl x509 -in foo -text output).
           (get-delimited-base64 port)))))

(define put-delimited-base64
  (case-lambda
    ((port type bv line-length)
     (display (string-append "-----BEGIN " type "-----\n") port)
     (base64-encode bv 0 (bytevector-length bv)
                    line-length #f base64-alphabet port)
     (display (string-append "\n-----END " type "-----\n") port))
    ((port type bv)
     (put-delimited-base64 port type bv 76))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.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 (guix build-system)
  #:use-module (guix records)
  #:use-module (ice-9 match)
  #:export (build-system
            build-system?
            build-system-name
            build-system-description
            build-system-lower

            bag
            bag?
            bag-name
            bag-system
            bag-target
            bag-build-inputs
            bag-host-inputs
            bag-target-inputs
            bag-outputs
            bag-arguments
            bag-build

            make-bag))

(define-record-type* <build-system> build-system make-build-system
  build-system?
  (name        build-system-name)         ; symbol
  (description build-system-description)  ; short description
  (lower       build-system-lower))       ; args ... -> bags

;; "Bags" are low-level representations of "packages".  The system and target
;; of a bag is fixed when it's created.  This is because build systems may
;; choose inputs as a function of the system and target.
(define-record-type* <bag> bag %make-bag
  bag?
  (name          bag-name)               ;string

  (system        bag-system)             ;string
  (target        bag-target              ;string | #f
                 (default #f))

  ;; Here we use build/host/target in the sense of the GNU tool chain (info
  ;; "(autoconf) Specifying Target Triplets").
  (build-inputs  bag-build-inputs        ;list of packages
                 (default '()))
  (host-inputs   bag-host-inputs         ;list of packages
                 (default '()))

  ;; "Target inputs" are packages that are built natively, but that are used
  ;; by target programs in a cross-compilation environment.  Thus, they act
  ;; like 'inputs' as far as search paths are concerned.  The only example of
  ;; that is the cross-libc: it is an input of 'cross-gcc', thus built
  ;; natively; yet, we want it to be considered as a target input for the
  ;; purposes of $CPATH, $LIBRARY_PATH, etc.
  (target-inputs bag-target-inputs
                 (default '()))

  (outputs       bag-outputs             ;list of strings
                 (default '("out")))
  (arguments     bag-arguments           ;list
                 (default '()))
  (build         bag-build))             ;bag -> derivation

(define* (make-bag build-system name
                   #:key source (inputs '()) (native-inputs '())
                   (outputs '()) (arguments '())
                   system target)
  "Ask BUILD-SYSTEM to return a 'bag' for NAME, with the given SOURCE,
INPUTS, NATIVE-INPUTS, OUTPUTS, and additional ARGUMENTS.  If TARGET is not
#f, it must be a string with the GNU triplet of a cross-compilation target.

This is the mechanism by which a package is \"lowered\" to a bag, which is the
intermediate representation just above derivations."
  (match build-system
    (($ <build-system> _ description lower)
     (apply lower name
            #:system system
            #:source source
            #:inputs inputs
            #:native-inputs native-inputs
            #:outputs outputs
            #:target target
            arguments))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.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 (guix build-system android-ndk)
  #:use-module (guix search-paths)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-26)
  #:export (android-ndk-build-system))

(define %android-ndk-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build android-ndk-build-system)
    (guix build syscalls)
    ,@%gnu-build-system-modules))

(define* (android-ndk-build store name inputs
                      #:key
                      (tests? #t)
                      (test-target #f)
                      (phases '(@ (guix build android-ndk-build-system)
                                  %standard-phases))
                      (outputs '("out"))
                      (make-flags ''())
                      (search-paths '())
                      (system (%current-system))
                      (guile #f)
                      (imported-modules %android-ndk-build-system-modules)
                      (modules '((guix build android-ndk-build-system)
                                 (guix build utils))))
  "Build SOURCE using Android NDK, and with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (android-ndk-build #:name ,name
                    #:source ,(match (assoc-ref inputs "source")
                                (((? derivation? source))
                                 (derivation->output-path source))
                                ((source)
                                 source)
                                (source
                                 source))
                    #:system ,system
                    #:test-target ,test-target
                    #:tests? ,tests?
                    #:phases ,phases
                    #:make-flags (cons* "-f"
                                         ,(string-append
                                          (derivation->output-path
                                           (car (assoc-ref inputs "android-build")))
                                          "/share/android/build/core/main.mk")
                                         ,make-flags)
                    #:outputs %outputs
                    #:search-paths ',(map search-path-specification->sexp
                                          search-paths)
                    #:inputs %build-inputs)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                                         ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:inputs inputs
                                #:system system
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."

  (define private-keywords
    '(#:source #:target #:inputs #:native-inputs #:outputs))

  (and (not target) ;; TODO: support cross-compilation
       (bag
         (name name)
         (system system)
         (target target)
         (host-inputs `(,@(if source
                              `(("source" ,source))
                              '())
                        ,@inputs

                        ;; Keep the standard inputs of 'gnu-build-system'
                        ,@(standard-packages)))
         (build-inputs `(("android-build" ,(module-ref (resolve-interface '(gnu packages android)) 'android-make-stub))
                         ("android-googletest" ,(module-ref (resolve-interface '(gnu packages android)) 'android-googletest))
                         ,@native-inputs))
         (outputs outputs)
         (build android-ndk-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define android-ndk-build-system
  (build-system
    (name 'android-ndk)
    (description
     "Android NDK build system, to build Android NDK packages")
    (lower lower)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 (guix build-system ant)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-26)
  #:export (%ant-build-system-modules
            ant-build
            ant-build-system))

;; Commentary:
;;
;; Standard build procedure for Java packages using Ant.
;;
;; Code:

(define %ant-build-system-modules
  ;; Build-side modules imported by default.
  `((guix build ant-build-system)
    (guix build maven java)
    (guix build maven plugin)
    (guix build maven pom)
    (guix build java-utils)
    (guix build syscalls)
    ,@%gnu-build-system-modules))

(define (default-jdk)
  "Return the default JDK package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((jdk-mod (resolve-interface '(gnu packages java))))
    (module-ref jdk-mod 'icedtea)))

(define (default-ant)
  "Return the default Ant package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((jdk-mod (resolve-interface '(gnu packages java))))
    (module-ref jdk-mod 'ant)))

(define (default-zip)
  "Return the default ZIP package."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((zip-mod (resolve-interface '(gnu packages compression))))
    (module-ref zip-mod 'zip)))

(define* (lower name
                #:key source inputs native-inputs outputs system target
                (jdk (default-jdk))
                (ant (default-ant))
                (zip (default-zip))
                #:allow-other-keys
                #:rest arguments)
  "Return a bag for NAME."
  (define private-keywords
    '(#:source #:target #:jdk #:ant #:zip #:inputs #:native-inputs))

  (and (not target)                               ;XXX: no cross-compilation
       (bag
         (name name)
         (system system)
         (host-inputs `(,@(if source
                              `(("source" ,source))
                              '())
                        ,@inputs

                        ;; Keep the standard inputs of 'gnu-build-system'.
                        ,@(standard-packages)))
         (build-inputs `(("jdk" ,jdk "jdk")
                         ("ant" ,ant)
                         ("zip" ,zip)
                         ,@native-inputs))
         (outputs outputs)
         (build ant-build)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (ant-build store name inputs
                    #:key
                    (tests? #t)
                    (test-target "check")
                    (configure-flags ''())
                    (make-flags ''())
                    (build-target "jar")
                    (jar-name #f)
                    (main-class #f)
                    (test-include (list "**/*Test.java"))
                    (test-exclude (list "**/Abstract*.java"))
                    (source-dir "src")
                    (test-dir "src/test")
                    (phases '(@ (guix build ant-build-system)
                                %standard-phases))
                    (outputs '("out"))
                    (search-paths '())
                    (system (%current-system))
                    (guile #f)
                    (imported-modules %ant-build-system-modules)
                    (modules '((guix build ant-build-system)
                               (guix build java-utils)
                               (guix build utils))))
  "Build SOURCE with INPUTS."
  (define builder
    `(begin
       (use-modules ,@modules)
       (ant-build #:name ,name
                  #:source ,(match (assoc-ref inputs "source")
                              (((? derivation? source))
                               (derivation->output-path source))
                              ((source)
                               source)
                              (source
                               source))
                  #:make-flags ,make-flags
                  #:configure-flags ,configure-flags
                  #:system ,system
                  #:tests? ,tests?
                  #:test-target ,test-target
                  #:build-target ,build-target
                  #:jar-name ,jar-name
                  #:main-class ,main-class
                  #:test-include (list ,@test-include)
                  #:test-exclude (list ,@test-exclude)
                  #:source-dir ,source-dir
                  #:test-dir ,test-dir
                  #:phases ,phases
                  #:outputs %outputs
                  #:search-paths ',(map search-path-specification->sexp
                                        search-paths)
                  #:inputs %build-inputs)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f                               ; the default
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile  (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:inputs inputs
                                #:system system
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

(define ant-build-system
  (build-system
    (name 'ant)
    (description "The standard Ant build system")
    (lower lower)))

;;; ant.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
;;;
;;; 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 (guix build-system asdf)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix memoization)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix search-paths)
  #:use-module ((guix build utils)
                #:select ((package-name->name+version
                           . hyphen-separated-name->name+version)))
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (gnu packages)
  #:export (%asdf-build-system-modules
            %asdf-build-modules
            asdf-build
            asdf-build-system/sbcl
            asdf-build-system/ecl
            asdf-build-system/source
            sbcl-package->cl-source-package
            sbcl-package->ecl-package))

;; Commentary:
;;
;; Standard build procedure for asdf packages.  This is implemented as an
;; extension of 'gnu-build-system'.
;;
;; Code:

(define %asdf-build-system-modules
  ;; Imported build-side modules
  `((guix build asdf-build-system)
    (guix build lisp-utils)
    ,@%gnu-build-system-modules))

(define %asdf-build-modules
  ;; Used (visible) build-side modules
  '((guix build asdf-build-system)
    (guix build utils)
    (guix build lisp-utils)))

(define (default-lisp implementation)
  "Return the default package for the lisp IMPLEMENTATION."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((lisp-module (resolve-interface '(gnu packages lisp))))
    (module-ref lisp-module implementation)))

(define* (lower/source name
                       #:key source inputs outputs native-inputs system target
                       #:allow-other-keys
                       #:rest arguments)
  "Return a bag for NAME"
  (define private-keywords
    '(#:target #:inputs #:native-inputs))

  (and (not target)
       (bag
         (name name)
         (system system)
         (host-inputs `(,@(if source
                              `(("source" ,source))
                              '())
                        ,@inputs
                        ,@(standard-packages)))
         (build-inputs native-inputs)
         (outputs outputs)
         (build asdf-build/source)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (asdf-build/source store name inputs
                            #:key source outputs
                            (phases '(@ (guix build asdf-build-system)
                                        %standard-phases/source))
                            (search-paths '())
                            (system (%current-system))
                            (guile #f)
                            (imported-modules %asdf-build-system-modules)
                            (modules %asdf-build-modules))
  (define builder
    `(begin
       (use-modules ,@modules)
       (asdf-build/source #:name ,name
                          #:source ,(match (assoc-ref inputs "source")
                                      (((? derivation? source))
                                       (derivation->output-path source))
                                      ((source) source)
                                      (source source))
                          #:system ,system
                          #:phases ,phases
                          #:outputs %outputs
                          #:search-paths ',(map search-path-specification->sexp
                                                search-paths)
                          #:inputs %build-inputs)))

  (define guile-for-build
    (match guile
      ((? package?)
       (package-derivation store guile system #:graft? #f))
      (#f
       (let* ((distro (resolve-interface '(gnu packages commencement)))
              (guile (module-ref distro 'guile-final)))
         (package-derivation store guile system #:graft? #f)))))

  (build-expression->derivation store name builder
                                #:inputs inputs
                                #:system system
                                #:modules imported-modules
                                #:outputs outputs
                                #:guile-for-build guile-for-build))

(define* (package-with-build-system from-build-system to-build-system
                                    from-prefix to-prefix
                                    #:key variant-property
                                    phases-transformer)
  "Return a precedure which takes a package PKG which uses FROM-BUILD-SYSTEM,
and returns one using TO-BUILD-SYSTEM.  If PKG was prefixed by FROM-PREFIX,
the resulting package will be prefixed by TO-PREFIX.  Inputs of PKG are
recursively transformed using the same rule.  The result's #:phases argument
will be modified by PHASES-TRANSFORMER, an S-expression which evaluates on the
build side to a procedure of one argument.

VARIANT-PROPERTY can be added to a package's properties to indicate that the
corresponding package promise should be used as the result of this
transformation.  This allows the result to differ from what the transformation
would otherwise produce.

If TO-BUILD-SYSTEM is asdf-build-system/source, the resulting package will be
set up using CL source package conventions."
  (define target-is-source? (eq? asdf-build-system/source to-build-system))

  (define (transform-package-name name)
    (if (string-prefix? from-prefix name)
        (let ((new-name (string-drop name (string-length from-prefix))))
          (if (string-prefix? to-prefix new-name)
              new-name
              (string-append to-prefix new-name)))
        name))

  (define (has-from-build-system? pkg)
    (eq? from-build-system (package-build-system pkg)))

  (define (find-input-package pkg)
    (let* ((name (package-name pkg))
           (new-name (transform-package-name name))
           (pkgs (find-packages-by-name new-name)))
      (if (null? pkgs) #f (list-ref pkgs 0))))

  (define transform
    (mlambda (pkg)
      (define rewrite
        (match-lambda
          ((name content . rest)
           (let* ((is-package? (package? content))
                  (new-content (if is-package?
                                   (or (find-input-package content)
                                       (transform content))
                                   content)))
             `(,name ,new-content ,@rest)))))

      ;; Special considerations for source packages: CL inputs become
      ;; propagated, and un-handled arguments are removed.

      (define (new-propagated-inputs)
        (if target-is-source?
            (map rewrite
                 (append
                  (filter (match-lambda
                            ((_ input . _)
                             (has-from-build-system? input)))
                          (append (package-inputs pkg)
                                  ;; The native inputs might be needed just
                                  ;; to load the system.
                                  (package-native-inputs pkg)))
                  (package-propagated-inputs pkg)))

            (map rewrite (package-propagated-inputs pkg))))

      (define (new-inputs inputs-getter)
        (if target-is-source?
            (map rewrite
                 (filter (match-lambda
                           ((_ input . _)
                            (not (has-from-build-system? input))))
                         (inputs-getter pkg)))
            (map rewrite (inputs-getter pkg))))

      (define base-arguments
        (if target-is-source?
            (strip-keyword-arguments
             '(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file)
             (package-arguments pkg))
            (package-arguments pkg)))

      (cond
       ((and variant-property
             (assoc-ref (package-properties pkg) variant-property))
        => force)

       ((has-from-build-system? pkg)
        (package
          (inherit pkg)
          (location (package-location pkg))
          (name (transform-package-name (package-name pkg)))
          (build-system to-build-system)
          (arguments
           (substitute-keyword-arguments base-arguments
             ((#:phases phases) (list phases-transformer phases))))
          (inputs (new-inputs package-inputs))
          (propagated-inputs (new-propagated-inputs))
          (native-inputs (append (if target-is-source?
                                     (list (list (package-name pkg) pkg))
                                     '())
                                 (new-inputs package-native-inputs)))
          (outputs (if target-is-source?
                       '("out")
                       (package-outputs pkg)))))
       (else pkg))))

  transform)

(define (strip-variant-as-necessary variant pkg)
  (define properties (package-properties pkg))
  (if (assoc variant properties)
      (package
        (inherit pkg)
        (properties (alist-delete variant properties)))
      pkg))

(define (lower lisp-type)
  (lambda* (name
            #:key source inputs outputs native-inputs system target
            (lisp (default-lisp (string->symbol lisp-type)))
            #:allow-other-keys
            #:rest arguments)
    "Return a bag for NAME"
    (define private-keywords
      '(#:target #:inputs #:native-inputs #:lisp))

    (and (not target)
         (bag
           (name name)
           (system system)
           (host-inputs `(,@(if source
                                `(("source" ,source))
                                '())
                          ,@inputs
                          ,@(standard-packages)))
           (build-inputs `((,lisp-type ,lisp)
                           ,@native-inputs))
           (outputs outputs)
           (build (asdf-build lisp-type))
           (arguments (strip-keyword-arguments private-keywords arguments))))))

(define (asdf-build lisp-type)
  (lambda* (store name inputs
                  #:key source outputs
                  (tests? #t)
                  (asd-file #f)
                  (asd-system-name #f)
                  (test-asd-file #f)
                  (phases '(@ (guix build asdf-build-system)
                              %standard-phases))
                  (search-paths '())
                  (system (%current-system))
                  (guile #f)
                  (imported-modules %asdf-build-system-modules)
                  (modules %asdf-build-modules))

    (define system-name
      (or asd-system-name
          (string-drop
           ;; NAME is the value returned from `package-full-name'.
           (hyphen-separated-name->name+version name)
           (1+ (string-length lisp-type))))) ; drop the "<lisp>-" prefix.

    (define builder
      `(begin
         (use-modules ,@modules)
         (parameterize ((%lisp (string-append
                                (assoc-ref %build-inputs ,lisp-type)
                                "/bin/" ,lisp-type))
                        (%lisp-type ,lisp-type))
           (asdf-build #:name ,name
                       #:source ,(match (assoc-ref inputs "source")
                                   (((? derivation? source))
                                    (derivation->output-path source))
                                   ((source) source)
                                   (source source))
                       #:asd-file ,(or asd-file (string-append system-name ".asd"))
                       #:asd-system-name ,system-name
                       #:test-asd-file ,test-asd-file
                       #:system ,system
                       #:tests? ,tests?
                       #:phases ,phases
                       #:outputs %outputs
                       #:search-paths ',(map search-path-specification->sexp
                                             search-paths)
                       #:inputs %build-inputs))))

    (define guile-for-build
      (match guile
        ((? package?)
         (package-derivation store guile system #:graft? #f))
        (#f
         (let* ((distro (resolve-interface '(gnu packages commencement)))
                (guile (module-ref distro 'guile-final)))
           (package-derivation store guile system #:graft? #f)))))

    (build-expression->derivation store name builder
                                  #:inputs inputs
                                  #:system system
                                  #:modules imported-modules
                                  #:outputs outputs
                                  #:guile-for-build guile-for-build)))

(define asdf-build-system/sbcl
  (build-system
    (name 'asdf/sbcl)
    (description "The build system for ASDF binary packages using SBCL")
    (lower (lower "sbcl"))))

(define asdf-build-system/ecl
  (build-system
    (name 'asdf/ecl)
    (description "The build system for ASDF binary packages using ECL")
    (lower (lower "ecl"))))

(define asdf-build-system/source
  (build-system
    (name 'asdf/source)
    (description "The build system for ASDF source packages")
    (lower lower/source)))

(define sbcl-package->cl-source-package
  (let* ((property 'cl-source-variant)
         (transformer
          (package-with-build-system asdf-build-system/sbcl
                                     asdf-build-system/source
                                     "sbcl-"
                                     "cl-"
                                     #:variant-property property
                                     #:phases-transformer
                                     '(const %standard-phases/source))))
    (lambda (pkg)
      (transformer
       (strip-variant-as-necessary property pkg)))))

(define sbcl-package->ecl-package
  (let* ((property 'ecl-variant)
         (transformer
          (package-with-build-system asdf-build-system/sbcl
                                     asdf-build-system/ecl
                                     "sbcl-"
                                     "ecl-"
                                     #:variant-property property
                                     #:phases-transformer
                                     'identity)))
    (lambda (pkg)
      (transformer
       (strip-variant-as-necessary property pkg)))))

;;; asdf.scm ends here