code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix docker)
  #:use-module (gcrypt hash)
  #:use-module (guix base16)
  #:use-module (guix build pack)
  #:use-module ((guix build utils)
                #:select (mkdir-p
                          delete-file-recursively
                          with-directory-excursion
                          invoke))
  #:use-module (gnu build install)
  #:use-module (json)                             ;guile-json
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module ((texinfo string-utils)
                #:select (escape-special-chars))
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:export (build-docker-image))

;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
(define docker-id
  (compose bytevector->base16-string sha256 string->utf8))

(define (layer-diff-id layer)
  "Generate a layer DiffID for the given LAYER archive."
  (string-append "sha256:" (bytevector->base16-string (file-sha256 layer))))

;; This is the semantic version of the JSON metadata schema according to
;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md
;; It is NOT the version of the image specification.
(define schema-version "1.0")

(define (image-description id time)
  "Generate a simple image description."
  `((id . ,id)
    (created . ,time)
    (container_config . #nil)))

(define (canonicalize-repository-name name)
  "\"Repository\" names are restricted to roughly [a-z0-9_.-].
Return a version of TAG that follows these rules."
  ;; Refer to https://docs.docker.com/docker-hub/repos/.
  (define min-length 2)
  (define padding-character #\a)
  (define max-length 255)

  (define ascii-letters
    (string->char-set "abcdefghijklmnopqrstuvwxyz"))

  (define separators
    (string->char-set "_-."))

  (define repo-char-set
    (char-set-union char-set:digit ascii-letters separators))

  (define normalized-name
    (string-map (lambda (chr)
                  (if (char-set-contains? repo-char-set chr)
                      chr
                      #\.))
                (string-trim (string-downcase name) separators)))

  (let ((l (string-length normalized-name)))
    (match l
      ((? (cut > <> max-length))
       (string-take normalized-name max-length))
      ((? (cut < <> min-length))
       (string-append normalized-name
                      (make-string (- min-length l) padding-character)))
      (_ normalized-name))))

(define* (manifest path id #:optional (tag "guix"))
  "Generate a simple image manifest."
  (let ((tag (canonicalize-repository-name tag)))
    `#(((Config . "config.json")
        (RepoTags . #(,(string-append tag ":latest")))
        (Layers . #(,(string-append id "/layer.tar")))))))

;; According to the specifications this is required for backwards
;; compatibility.  It duplicates information provided by the manifest.
(define* (repositories path id #:optional (tag "guix"))
  "Generate a repositories file referencing PATH and the image ID."
  `((,(canonicalize-repository-name tag) . ((latest . ,id)))))

;; See https://github.com/opencontainers/image-spec/blob/master/config.md
(define* (config layer time arch #:key entry-point (environment '()))
  "Generate a minimal image configuration for the given LAYER file."
  ;; "architecture" must be values matching "platform.arch" in the
  ;; runtime-spec at
  ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
  `((architecture . ,arch)
    (comment . "Generated by GNU Guix")
    (created . ,time)
    (config . ,`((env . ,(list->vector
                          (map (match-lambda
                                 ((name . value)
                                  (string-append name "=" value)))
                               environment)))
                 ,@(if entry-point
                       `((entrypoint . ,(list->vector entry-point)))
                       '())))
    (container_config . #nil)
    (os . "linux")
    (rootfs . ((type . "layers")
               (diff_ids . #(,(layer-diff-id layer)))))))

(define directive-file
  ;; Return the file or directory created by a 'evaluate-populate-directive'
  ;; directive.
  (match-lambda
    ((source '-> target)
     (string-trim source #\/))
    (('directory name _ ...)
     (string-trim name #\/))))

(define* (build-docker-image image paths prefix
                             #:key
                             (repository "guix")
                             (extra-files '())
                             (transformations '())
                             (system (utsname:machine (uname)))
                             database
                             entry-point
                             (environment '())
                             compressor
                             (creation-time (current-time time-utc)))
  "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
must be a store path that is a prefix of any store paths in PATHS.  REPOSITORY
is a descriptive name that will show up in \"REPOSITORY\" column of the output
of \"docker images\".

When DATABASE is true, copy it to /var/guix/db in the image and create
/var/guix/gcroots and friends.

When ENTRY-POINT is true, it must be a list of strings; it is stored as the
entry point in the Docker image JSON structure.

ENVIRONMENT must be a list of name/value pairs.  It specifies the environment
variables that must be defined in the resulting image.

EXTRA-FILES must be a list of directives for 'evaluate-populate-directive'
describing non-store files that must be created in the image.

TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
transform the PATHS.  Any path in PATHS that begins with OLD will be rewritten
in the Docker image so that it begins with NEW instead.  If a path is a
non-empty directory, then its contents will be recursively added, as well.

SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
PATHS are for; it is used to produce metadata in the image.  Use COMPRESSOR, a
command such as '(\"gzip\" \"-9n\"), to compress IMAGE.  Use CREATION-TIME, a
SRFI-19 time-utc object, as the creation time in metadata."
  (define (sanitize path-fragment)
    (escape-special-chars
     ;; GNU tar strips the leading slash off of absolute paths before applying
     ;; the transformations, so we need to do the same, or else our
     ;; replacements won't match any paths.
     (string-trim path-fragment #\/)
     ;; Escape the basic regexp special characters (see: "(sed) BRE syntax").
     ;; We also need to escape "/" because we use it as a delimiter.
     "/*.^$[]\\"
     #\\))
  (define transformation->replacement
    (match-lambda
      ((old '-> new)
       ;; See "(tar) transform" for details on the expression syntax.
       (string-append "s/^" (sanitize old) "/" (sanitize new) "/"))))
  (define (transformations->expression transformations)
    (let ((replacements (map transformation->replacement transformations)))
      (string-append
       ;; Avoid transforming link targets, since that would break some links
       ;; (e.g., symlinks that point to an absolute store path).
       "flags=rSH;"
       (string-join replacements ";")
       ;; Some paths might still have a leading path delimiter even after tar
       ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so
       ;; strip any leading path delimiters that remain.
       ";s,^//*,,")))
  (define transformation-options
    (if (eq? '() transformations)
        '()
        `("--transform" ,(transformations->expression transformations))))
  (let* ((directory "/tmp/docker-image") ;temporary working directory
         (id (docker-id prefix))
         (time (date->string (time-utc->date creation-time) "~4"))
         (arch (let-syntax ((cond* (syntax-rules ()
                                     ((_ (pattern clause) ...)
                                      (cond ((string-prefix? pattern system)
                                             clause)
                                            ...
                                            (else
                                             (error "unsupported system"
                                                    system)))))))
                 (cond* ("x86_64" "amd64")
                        ("i686"   "386")
                        ("arm"    "arm")
                        ("mips64" "mips64le")))))
    ;; Make sure we start with a fresh, empty working directory.
    (mkdir directory)
    (with-directory-excursion directory
      (mkdir id)
      (with-directory-excursion id
        (with-output-to-file "VERSION"
          (lambda () (display schema-version)))
        (with-output-to-file "json"
          (lambda () (scm->json (image-description id time))))

        ;; Create a directory for the non-store files that need to go into the
        ;; archive.
        (mkdir "extra")

        (with-directory-excursion "extra"
          ;; Create non-store files.
          (for-each (cut evaluate-populate-directive <> "./")
                    extra-files)

          (when database
            ;; Initialize /var/guix, assuming PREFIX points to a profile.
            (install-database-and-gc-roots "." database prefix))

          (apply invoke "tar" "-cf" "../layer.tar"
                 `(,@transformation-options
                   ,@(tar-base-options)
                   ,@paths
                   ,@(scandir "."
                              (lambda (file)
                                (not (member file '("." ".."))))))))

        ;; It is possible for "/" to show up in the archive, especially when
        ;; applying transformations.  For example, the transformation
        ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform
        ;; the path "/a" into "/".  The presence of "/" in the archive is
        ;; probably benign, but it is definitely safe to remove it, so let's
        ;; do that.  This fails when "/" is not in the archive, so use system*
        ;; instead of invoke to avoid an exception in that case, and redirect
        ;; stderr to the bit bucket to avoid "Exiting with failure status"
        ;; error messages.
        (with-error-to-port (%make-void-port "w")
          (lambda ()
            (system* "tar" "--delete" "/" "-f" "layer.tar")))

        (delete-file-recursively "extra"))

      (with-output-to-file "config.json"
        (lambda ()
          (scm->json (config (string-append id "/layer.tar")
                             time arch
                             #:environment environment
                             #:entry-point entry-point))))
      (with-output-to-file "manifest.json"
        (lambda ()
          (scm->json (manifest prefix id repository))))
      (with-output-to-file "repositories"
        (lambda ()
          (scm->json (repositories prefix id repository)))))

    (apply invoke "tar" "-cf" image "-C" directory
           `(,@(tar-base-options #:compressor compressor)
             "."))
    (delete-file-recursively directory)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2019 Guy Fleury Iteriteka <hoonandon@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix download)
  #:use-module (ice-9 match)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix store)
  #:autoload   (guix build download) (url-fetch)
  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module (web uri)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%mirrors
            %disarchive-mirrors
            (url-fetch* . url-fetch)
            url-fetch/executable
            url-fetch/tarbomb
            url-fetch/zipbomb
            download-to-store))

;;; Commentary:
;;;
;;; Produce fixed-output derivations with data fetched over HTTP or FTP.
;;;
;;; Code:

(define %mirrors
  ;; Mirror lists used when `mirror://' URLs are passed.
  (let* ((gnu-mirrors
          '(;; This one redirects to a (supposedly) nearby and (supposedly)
            ;; up-to-date mirror.
            "https://ftpmirror.gnu.org/gnu/"

            "ftp://ftp.cs.tu-berlin.de/pub/gnu/"
            "ftp://ftp.funet.fi/pub/mirrors/ftp.gnu.org/gnu/"

            ;; This one is the master repository, and thus it's always
            ;; up-to-date.
            "http://ftp.gnu.org/pub/gnu/")))
    `((gnu ,@gnu-mirrors)
      (gcc
       "ftp://ftp.nluug.nl/mirror/languages/gcc/"
       "ftp://ftp.fu-berlin.de/unix/languages/gcc/"
       "ftp://ftp.irisa.fr/pub/mirrors/gcc.gnu.org/gcc/"
       "ftp://gcc.gnu.org/pub/gcc/"
       ,@(map (cut string-append <> "/gcc") gnu-mirrors))
      (gnupg
       "http://artfiles.org/gnupg.org"
       "http://www.crysys.hu/"
       "https://gnupg.org/ftp/gcrypt/"
       "ftp://mirrors.dotsrc.org/gcrypt/"
       "ftp://mirror.cict.fr/gnupg/"
       "ftp://ftp.franken.de/pub/crypt/mirror/ftp.gnupg.org/gcrypt/"
       "ftp://ftp.freenet.de/pub/ftp.gnupg.org/gcrypt/"
       "ftp://ftp.hi.is/pub/mirrors/gnupg/"
       "ftp://ftp.heanet.ie/mirrors/ftp.gnupg.org/gcrypt/"
       "ftp://ftp.bit.nl/mirror/gnupg/"
       "ftp://ftp.surfnet.nl/pub/security/gnupg/"
       "ftp://ftp.iasi.roedu.net/pub/mirrors/ftp.gnupg.org/"
       "ftp://ftp.sunet.se/pub/security/gnupg/"
       "ftp://mirror.switch.ch/mirror/gnupg/"
       "ftp://mirror.tje.me.uk/pub/mirrors/ftp.gnupg.org/"
       "ftp://ftp.mirrorservice.org/sites/ftp.gnupg.org/gcrypt/"
       "ftp://ftp.ring.gr.jp/pub/net/gnupg/"
       "ftp://ftp.gnupg.org/gcrypt/")
      (gnome
       "http://ftp.belnet.be/ftp.gnome.org/"
       "http://ftp.linux.org.uk/mirrors/ftp.gnome.org/"
       "http://ftp.gnome.org/pub/GNOME/"
       "https://download.gnome.org/"
       "http://mirror.yandex.ru/mirrors/ftp.gnome.org/")
      (hackage
       "http://hackage.haskell.org/")
      (savannah           ; http://download0.savannah.gnu.org/mirmon/savannah/
       "http://download.savannah.gnu.org/releases/"
       "http://nongnu.freemirror.org/nongnu/"
       "http://ftp.cc.uoc.gr/mirrors/nongnu.org/"
       "http://ftp.twaren.net/Unix/NonGNU/"
       "http://mirror.csclub.uwaterloo.ca/nongnu/"
       "http://nongnu.askapache.com/"
       "http://savannah.c3sl.ufpr.br/"
       "http://download.savannah.gnu.org/releases-noredirect/"
       "http://download-mirror.savannah.gnu.org/releases/"
       "ftp://ftp.twaren.net/Unix/NonGNU/"
       "ftp://mirror.csclub.uwaterloo.ca/nongnu/"
       "ftp://mirror.publicns.net/pub/nongnu/"
       "ftp://savannah.c3sl.ufpr.br/")
      (sourceforge ; https://sourceforge.net/p/forge/documentation/Mirrors/
       "http://downloads.sourceforge.net/project/"
       "http://ufpr.dl.sourceforge.net/project/"
       "http://heanet.dl.sourceforge.net/project/"
       "http://freefr.dl.sourceforge.net/project/"
       "http://internode.dl.sourceforge.net/project/"
       "http://jaist.dl.sourceforge.net/project/"
       "http://kent.dl.sourceforge.net/project/"
       "http://liquidtelecom.dl.sourceforge.net/project/"
       ;; "http://nbtelecom.dl.sourceforge.net/project/"  ;never returns 404s
       "http://nchc.dl.sourceforge.net/project/"
       "http://ncu.dl.sourceforge.net/project/"
       "http://netcologne.dl.sourceforge.net/project/"
       "http://netix.dl.sourceforge.net/project/"
       "http://pilotfiber.dl.sourceforge.net/project/"
       "http://superb-sea2.dl.sourceforge.net/project/"
       "http://tenet.dl.sourceforge.net/project/"
       "http://vorboss.dl.sourceforge.net/project/"
       "http://netassist.dl.sourceforge.net/project/")
      (netfilter.org ; https://www.netfilter.org/mirrors.html
       "http://ftp.netfilter.org/pub/"
       "ftp://ftp.es.netfilter.org/mirrors/netfilter/"
       "ftp://ftp.hu.netfilter.org/"
       "ftp://www.lt.netfilter.org/pub/")
      (kernel.org
       "http://linux-kernel.uio.no/pub/"
       "http://kernel.osuosl.org/pub/"
       "http://ftp.be.debian.org/pub/"
       "http://mirror.linux.org.au/"
       "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/")
      (apache             ; from http://www.apache.org/mirrors/dist.html
       "http://www.eu.apache.org/dist/"
       "http://www.us.apache.org/dist/"
       "https://ftp.nluug.nl/internet/apache/"
       "http://apache.mirror.iweb.ca/"
       "http://mirrors.ircam.fr/pub/apache/"
       "http://apache.mirrors.ovh.net/ftp.apache.org/dist/"
       "http://apache-mirror.rbc.ru/pub/apache/"
       "ftp://ftp.osuosl.org/pub/apache/"
       "http://mirrors.ibiblio.org/apache/"

       ;; As a last resort, try the archive.
       "http://archive.apache.org/dist/")
      (xorg               ; from http://www.x.org/wiki/Releases/Download
       "http://www.x.org/releases/" ; main mirrors
       "http://mirror.csclub.uwaterloo.ca/x.org/" ; North America
       "http://xorg.mirrors.pair.com/"
       "http://mirror.us.leaseweb.net/xorg/"
       "ftp://mirror.csclub.uwaterloo.ca/x.org/"
       "ftp://xorg.mirrors.pair.com/"
       "ftp://artfiles.org/x.org/" ; Europe
       "ftp://ftp.chg.ru/pub/X11/x.org/"
       "ftp://ftp.fu-berlin.de/unix/X11/FTP.X.ORG/"
       "ftp://ftp.gwdg.de/pub/x11/x.org/"
       "ftp://ftp.mirrorservice.org/sites/ftp.x.org/"
       "ftp://ftp.ntua.gr/pub/X11/"
       "ftp://ftp.piotrkosoft.net/pub/mirrors/ftp.x.org/"
       "ftp://ftp.portal-to-web.de/pub/mirrors/x.org/"
       "ftp://ftp.solnet.ch/mirror/x.org/"
       "ftp://mi.mirror.garr.it/mirrors/x.org/"
       "ftp://mirror.cict.fr/x.org/"
       "ftp://mirror.switch.ch/mirror/X11/"
       "ftp://mirrors.ircam.fr/pub/x.org/"
       "ftp://x.mirrors.skynet.be/pub/ftp.x.org/"
       "http://x.cs.pu.edu.tw/" ; East Asia
       "ftp://ftp.cs.cuhk.edu.hk/pub/X11"
       "ftp://ftp.u-aizu.ac.jp/pub/x11/x.org/"
       "ftp://ftp.yz.yamagata-u.ac.jp/pub/X11/x.org/"
       "ftp://ftp.kaist.ac.kr/x.org/"
       "ftp://mirrors.go-part.com/xorg/"
       "ftp://ftp.is.co.za/pub/x.org")            ; South Africa
      (cpan
       "http://www.cpan.org/"
       "http://cpan.metacpan.org/"
       ;; A selection of HTTP mirrors from http://www.cpan.org/SITES.html.
       ;; Europe.
       "http://ftp.belnet.be/mirror/ftp.cpan.org/"
       "http://mirrors.nic.cz/CPAN/"
       "http://mirror.ibcp.fr/pub/CPAN/"
       "http://ftp.ntua.gr/pub/lang/perl/"
       "http://mirror.as43289.net/pub/CPAN/"
       "http://cpan.cs.uu.nl/"
       "http://cpan.uib.no/"
       "http://cpan-mirror.rbc.ru/pub/CPAN/"
       "http://mirror.sbb.rs/CPAN/"
       "http://cpan.lnx.sk/"
       "http://ftp.rediris.es/mirror/CPAN/"
       "http://mirror.ox.ac.uk/sites/www.cpan.org/"
       ;; Africa.
       "http://mirror.liquidtelecom.com/CPAN/"
       "http://cpan.mirror.ac.za/"
       "http://mirror.is.co.za/pub/cpan/"
       "http://cpan.saix.net/"
       "http://mirror.ucu.ac.ug/cpan/"
       ;; North America.
       "http://mirrors.gossamer-threads.com/CPAN/"
       "http://mirror.csclub.uwaterloo.ca/CPAN/"
       "http://mirrors.ucr.ac.cr/CPAN/"
       "http://www.msg.com.mx/CPAN/"
       "http://mirrors.namecheap.com/CPAN/"
       "http://mirror.uic.edu/CPAN/"
       "http://mirror.datapipe.net/CPAN/"
       "http://mirror.cc.columbia.edu/pub/software/cpan/"
       "http://mirror.uta.edu/CPAN/"
       ;; South America.
       "http://cpan.mmgdesigns.com.ar/"
       "http://mirror.nbtelecom.com.br/CPAN/"
       "http://linorg.usp.br/CPAN/"
       "http://cpan.dcc.uchile.cl/"
       "http://mirror.cedia.org.ec/CPAN/"
       ;; Oceania.
       "http://cpan.mirror.serversaustralia.com.au/"
       "http://mirror.waia.asn.au/pub/cpan/"
       "http://mirror.as24220.net/pub/cpan/"
       "http://cpan.lagoon.nc/pub/CPAN/"
       "http://cpan.inspire.net.nz/"
       ;; Asia.
       "http://mirror.dhakacom.com/CPAN/"
       "http://mirrors.ustc.edu.cn/CPAN/"
       "http://ftp.cuhk.edu.hk/pub/packages/perl/CPAN/"
       "http://kambing.ui.ac.id/cpan/"
       "http://cpan.hostiran.ir/"
       "http://ftp.nara.wide.ad.jp/pub/CPAN/"
       "http://mirror.neolabs.kz/CPAN/"
       "http://cpan.nctu.edu.tw/"
       "http://cpan.ulak.net.tr/"
       "http://mirrors.vinahost.vn/CPAN/")
      (cran
       ;; Arbitrary mirrors from http://cran.r-project.org/mirrors.html
       ;; This one automatically redirects to servers worldwide
       "http://cran.r-project.org/"
       "http://cran.rstudio.com/"
       "http://cran.univ-lyon1.fr/"
       "http://cran.ism.ac.jp/"
       "http://cran.stat.auckland.ac.nz/"
       "http://cran.mirror.ac.za/"
       "http://cran.csie.ntu.edu.tw/")
      (imagemagick
       ;; from http://www.imagemagick.org/script/download.php
       ;; (without mirrors that are unavailable or not up to date)
       "https://sunsite.icm.edu.pl/packages/ImageMagick/releases"
       "http://mirror.checkdomain.de/imagemagick/releases"
       "ftp://ftp.u-aizu.ac.jp/pub/graphics/image/ImageMagick/imagemagick.org/releases"
       "ftp://ftp.nluug.nl/pub/ImageMagick/"
       "http://www.imagemagick.org/download/releases/"
       ;; Try this if all else fails (normally contains just the latest version).
       "http://www.imagemagick.org/download/")
      (debian
       "http://ftp.de.debian.org/debian/"
       "http://ftp.fr.debian.org/debian/"
       "http://ftp.debian.org/debian/"
       "http://archive.debian.org/debian/")
      (kde
       "http://download.kde.org"
       "http://download.kde.org/Attic" ; for when it gets archived.
       ;; Mirrors from http://files.kde.org/extra/mirrors.html
       ;; Europe
       "http://mirror.easyname.at/kde"
       "http://mirror.karneval.cz/pub/kde"
       "http://ftp.fi.muni.cz/pub/kde/"
       "http://mirror.oss.maxcdn.com/kde/"
       "http://ftp5.gwdg.de/pub/linux/kde/"
       "http://ftp-stud.fht-esslingen.de/Mirrors/ftp.kde.org/pub/kde/"
       "http://mirror.klaus-uwe.me/kde/ftp/"
       "http://kde.beta.mirror.ga/"
       "http://kde.alpha.mirror.ga/"
       "http://mirror.netcologne.de/kde"
       "http://vesta.informatik.rwth-aachen.de/ftp/pub/mirror/kde/"
       "http://ftp.rz.uni-wuerzburg.de/pub/unix/kde/"
       "http://mirrors.dotsrc.org/kde/"
       "http://ftp.funet.fi/pub/mirrors/ftp.kde.org/pub/kde/"
       "http://kde-mirror.freenux.org/"
       "http://mirrors.ircam.fr/pub/KDE/"
       "http://www-ftp.lip6.fr/pub/X11/kde/"
       "http://fr2.rpmfind.net/linux/KDE/"
       "http://kde.mirror.anlx.net/"
       "http://www.mirrorservice.org/sites/ftp.kde.org/pub/kde/"
       "http://ftp.heanet.ie/mirrors/ftp.kde.org/"
       "http://ftp.nluug.nl/pub/windowing/kde/"
       "http://ftp.surfnet.nl/windowing/kde/"
       "http://ftp.icm.edu.pl/pub/unix/kde/"
       "http://ftp.pbone.net/pub/kde/"
       "http://piotrkosoft.net/pub/mirrors/ftp.kde.org/"
       "http://mirrors.fe.up.pt/pub/kde/"
       "http://ftp.iasi.roedu.net/pub/mirrors/ftp.kde.org/"
       "http://ftp.acc.umu.se/mirror/kde.org/ftp/"
       "http://kde.ip-connect.vn.ua/"
       ;; North America
       "http://mirror.its.dal.ca/kde/"
       "http://mirror.csclub.uwaterloo.ca/kde/"
       "http://mirror.cc.columbia.edu/pub/software/kde/"
       "http://kde.mirrors.hoobly.com/"
       "http://ftp.ussg.iu.edu/kde/"
       "http://mirrors.mit.edu/kde/"
       "http://kde.mirrors.tds.net/pub/kde/"
       ;; Oceania
       "http://ftp.kddlabs.co.jp/pub/X11/kde/"
       "http://kde.mirror.uber.com.au/")
      (openbsd
       "https://ftp.openbsd.org/pub/OpenBSD/"
       ;; Anycast CDN redirecting to your friendly local mirror.
       "https://mirrors.evowise.com/pub/OpenBSD/"
       ;; Other HTTPS mirrors from https://www.openbsd.org/ftp.html
       "https://mirror.aarnet.edu.au/pub/OpenBSD/"
       "https://ftp2.eu.openbsd.org/pub/OpenBSD/"
       "https://openbsd.c3sl.ufpr.br/pub/OpenBSD/"
       "https://openbsd.ipacct.com/pub/OpenBSD/"
       "https://ftp.OpenBSD.org/pub/OpenBSD/"
       "https://openbsd.cs.toronto.edu/pub/OpenBSD/"
       "https://openbsd.delfic.org/pub/OpenBSD/"
       "https://openbsd.mirror.netelligent.ca/pub/OpenBSD/"
       "https://mirrors.ucr.ac.cr/pub/OpenBSD/"
       "https://mirrors.dotsrc.org/pub/OpenBSD/"
       "https://mirror.one.com/pub/OpenBSD/"
       "https://ftp.fr.openbsd.org/pub/OpenBSD/"
       "https://ftp2.fr.openbsd.org/pub/OpenBSD/"
       "https://mirrors.ircam.fr/pub/OpenBSD/"
       "https://ftp.spline.de/pub/OpenBSD/"
       "https://mirror.hs-esslingen.de/pub/OpenBSD/"
       "https://ftp.halifax.rwth-aachen.de/openbsd/"
       "https://ftp.hostserver.de/pub/OpenBSD/"
       "https://ftp.fau.de/pub/OpenBSD/"
       "https://ftp.cc.uoc.gr/pub/OpenBSD/"
       "https://openbsd.hk/pub/OpenBSD/"
       "https://ftp.heanet.ie/pub/OpenBSD/"
       "https://openbsd.mirror.garr.it/pub/OpenBSD/"
       "https://mirror.litnet.lt/pub/OpenBSD/"
       "https://mirror.meerval.net/pub/OpenBSD/"
       "https://ftp.nluug.nl/pub/OpenBSD/"
       "https://ftp.bit.nl/pub/OpenBSD/"
       "https://mirrors.dalenys.com/pub/OpenBSD/"
       "https://ftp.icm.edu.pl/pub/OpenBSD/"
       "https://ftp.rnl.tecnico.ulisboa.pt/pub/OpenBSD/"
       "https://mirrors.pidginhost.com/pub/OpenBSD/"
       "https://mirror.yandex.ru/pub/OpenBSD/"
       "https://ftp.eu.openbsd.org/pub/OpenBSD/"
       "https://ftp.yzu.edu.tw/pub/OpenBSD/"
       "https://www.mirrorservice.org/pub/OpenBSD/"
       "https://anorien.csc.warwick.ac.uk/pub/OpenBSD/"
       "https://mirror.bytemark.co.uk/pub/OpenBSD/"
       "https://mirrors.sonic.net/pub/OpenBSD/"
       "https://ftp3.usa.openbsd.org/pub/OpenBSD/"
       "https://mirrors.syringanetworks.net/pub/OpenBSD/"
       "https://openbsd.mirror.constant.com/pub/OpenBSD/"
       "https://ftp4.usa.openbsd.org/pub/OpenBSD/"
       "https://ftp5.usa.openbsd.org/pub/OpenBSD/"
       "https://mirror.esc7.net/pub/OpenBSD/")
      (mate
       "https://pub.mate-desktop.org/releases/"
       "http://pub.mate-desktop.org/releases/"))))

(define %mirror-file
  ;; Copy of the list of mirrors to a file.  This allows us to keep a single
  ;; copy in the store, and computing it here avoids repeated calls to
  ;; 'object->string'.
  (plain-file "mirrors" (object->string %mirrors)))

(define %content-addressed-mirrors
  ;; List of content-addressed mirrors.  Each mirror is represented as a
  ;; procedure that takes a file name, an algorithm (symbol) and a hash
  ;; (bytevector), and returns a URL or #f.
  '(begin
     (use-modules (guix base32))

     (define (guix-publish host)
       (lambda (file algo hash)
         ;; Files served by 'guix publish' are accessible under a single
         ;; hash algorithm.
         (string-append "https://" host "/file/"
                        file "/" (symbol->string algo) "/"
                        (bytevector->nix-base32-string hash))))

     ;; XXX: (guix base16) appeared in March 2017 (and thus 0.13.0) so old
     ;; installations of the daemon might lack it.  Thus, load it lazily to
     ;; avoid gratuitous errors.  See <https://bugs.gnu.org/33542>.
     (module-autoload! (current-module)
                       '(guix base16) '(bytevector->base16-string))

     (list (guix-publish "ci.guix.gnu.org")
           (lambda (file algo hash)
             ;; 'tarballs.nixos.org' supports several algorithms.
             (string-append "https://tarballs.nixos.org/"
                            (symbol->string algo) "/"
                            (bytevector->nix-base32-string hash)))
           (lambda (file algo hash)
             ;; Software Heritage usually archives VCS history rather than
             ;; tarballs, but tarballs are sometimes available (and can be
             ;; explicitly stored there.)  For example, see
             ;; <https://archive.softwareheritage.org/api/1/content/sha256:92d0fa1c311cacefa89853bdb53c62f4110cdfda3820346b59cbd098f40f955e/>.
             (string-append "https://archive.softwareheritage.org/api/1/content/"
                            (symbol->string algo) ":"
                            (bytevector->base16-string hash) "/raw/")))))

(define %content-addressed-mirror-file
  ;; Content-addressed mirrors stored in a file.
  (plain-file "content-addressed-mirrors"
              (object->string %content-addressed-mirrors)))

(define %disarchive-mirrors
  '("https://disarchive.ngyro.com/"))

(define %disarchive-mirror-file
  (plain-file "disarchive-mirrors" (object->string %disarchive-mirrors)))

(define built-in-builders*
  (store-lift built-in-builders))

(define* (built-in-download file-name url
                            #:key system hash-algo hash
                            mirrors content-addressed-mirrors
                            disarchive-mirrors
                            executable?
                            (guile 'unused))
  "Download FILE-NAME from URL using the built-in 'download' builder.  When
EXECUTABLE? is true, make the downloaded file executable.

This is an \"out-of-band\" download in that the returned derivation does not
explicitly depend on Guile, GnuTLS, etc.  Instead, the daemon performs the
download by itself using its own dependencies."
  (mlet %store-monad ((mirrors (lower-object mirrors))
                      (content-addressed-mirrors
                       (lower-object content-addressed-mirrors))
                      (disarchive-mirrors (lower-object disarchive-mirrors)))
    (raw-derivation file-name "builtin:download" '()
                    #:system system
                    #:hash-algo hash-algo
                    #:hash hash
                    #:recursive? executable?
                    #:sources (list mirrors
                                    content-addressed-mirrors
                                    disarchive-mirrors)

                    ;; Honor the user's proxy and locale settings.
                    #:leaked-env-vars '("http_proxy" "https_proxy"
                                        "LC_ALL" "LC_MESSAGES" "LANG"
                                        "COLUMNS")

                    #:env-vars `(("url" . ,(object->string url))
                                 ("mirrors" . ,mirrors)
                                 ("content-addressed-mirrors"
                                  . ,content-addressed-mirrors)
                                 ("disarchive-mirrors" . ,disarchive-mirrors)
                                 ,@(if executable?
                                       '(("executable" . "1"))
                                       '()))

                    ;; Do not offload this derivation because we cannot be
                    ;; sure that the remote daemon supports the 'download'
                    ;; built-in.  We may remove this limitation when support
                    ;; for that built-in is widespread.
                    #:local-build? #t)))

(define* (url-fetch* url hash-algo hash
                     #:optional name
                     #:key (system (%current-system))
                     (guile (default-guile))
                     executable?)
  "Return a fixed-output derivation that fetches data from URL (a string, or a
list of strings denoting alternate URLs), which is expected to have hash HASH
of type HASH-ALGO (a symbol).  By default, the file name is the base name of
URL; optionally, NAME can specify a different file name.  When EXECUTABLE? is
true, make the downloaded file executable.

When one of the URL starts with mirror://, then its host part is
interpreted as the name of a mirror scheme, taken from %MIRROR-FILE.

Alternatively, when URL starts with file://, return the corresponding file
name in the store."
  (define file-name
    (match url
      ((head _ ...)
       (basename head))
      (_
       (basename url))))

  (let ((uri (and (string? url) (string->uri url))))
    (if (or (and (string? url) (not uri))
            (and uri (memq (uri-scheme uri) '(#f file))))
        (interned-file (if uri (uri-path uri) url)
                       (or name file-name))
        (mlet %store-monad ((builtins (built-in-builders*)))
          ;; The "download" built-in builder was added in guix-daemon in
          ;; Nov. 2016 and made it in the 0.12.0 release of Dec. 2016.  We now
          ;; require it.
          (unless (member "download" builtins)
            (error "'guix-daemon' is too old, please upgrade" builtins))

          (built-in-download (or name file-name) url
                             #:guile guile
                             #:system system
                             #:hash-algo hash-algo
                             #:hash hash
                             #:executable? executable?
                             #:mirrors %mirror-file
                             #:content-addressed-mirrors
                             %content-addressed-mirror-file
                             #:disarchive-mirrors
                             %disarchive-mirror-file)))))

(define* (url-fetch/executable url hash-algo hash
                               #:optional name
                               #:key (system (%current-system))
                               (guile (default-guile)))
  "Like 'url-fetch', but make the downloaded file executable."
  (url-fetch* url hash-algo hash name
              #:system system
              #:guile guile
              #:executable? #t))

(define* (url-fetch/tarbomb url hash-algo hash
                            #:optional name
                            #:key (system (%current-system))
                            (guile (default-guile)))
  "Similar to 'url-fetch' but unpack the file from URL in a directory of its
own.  This helper makes it easier to deal with \"tar bombs\"."
  (define file-name
    (match url
      ((head _ ...)
       (basename head))
      (_
       (basename url))))
  (define gzip
    (module-ref (resolve-interface '(gnu packages compression)) 'gzip))
  (define tar
    (module-ref (resolve-interface '(gnu packages base)) 'tar))

  (mlet %store-monad ((drv (url-fetch* url hash-algo hash
                                       (string-append "tarbomb-"
                                                      (or name file-name))
                                       #:system system
                                       #:guile guile))
                      (guile (package->derivation guile system)))
    ;; Take the tar bomb, and simply unpack it as a directory.
    ;; Use ungrafted tar/gzip so that the resulting tarball doesn't depend on
    ;; whether grafts are enabled.
    (gexp->derivation (or name file-name)
                      (with-imported-modules '((guix build utils))
                        #~(begin
                            (use-modules (guix build utils))
                            (mkdir #$output)
                            (setenv "PATH" (string-append #+gzip "/bin"))
                            (chdir #$output)
                            (invoke (string-append #+tar "/bin/tar")
                                    "xf" #$drv)))
                      #:system system
                      #:guile-for-build guile
                      #:graft? #f
                      #:local-build? #t)))

(define* (url-fetch/zipbomb url hash-algo hash
                            #:optional name
                            #:key (system (%current-system))
                            (guile (default-guile)))
  "Similar to 'url-fetch' but unpack the zip file at URL in a directory of its
own.  This helper makes it easier to deal with \"zip bombs\"."
  (define file-name
    (match url
      ((head _ ...)
       (basename head))
      (_
       (basename url))))
  (define unzip
    (module-ref (resolve-interface '(gnu packages compression)) 'unzip))

  (mlet %store-monad ((drv (url-fetch* url hash-algo hash
                                       (string-append "zipbomb-"
                                                      (or name file-name))
                                       #:system system
                                       #:guile guile))
                      (guile (package->derivation guile system)))
    ;; Take the zip bomb, and simply unpack it as a directory.
    ;; Use ungrafted unzip so that the resulting tarball doesn't depend on
    ;; whether grafts are enabled.
    (gexp->derivation (or name file-name)
                      (with-imported-modules '((guix build utils))
                        #~(begin
                            (use-modules (guix build utils))
                            (mkdir #$output)
                            (chdir #$output)
                            (invoke (string-append #+unzip "/bin/unzip")
                                    #$drv)))
                      #:system system
                      #:guile-for-build guile
                      #:graft? #f
                      #:local-build? #t)))

(define* (download-to-store store url #:optional (name (basename url))
                            #:key (log (current-error-port)) recursive?
                            (verify-certificate? #t))
  "Download from URL to STORE, either under NAME or URL's basename if
omitted.  Write progress reports to LOG.  RECURSIVE? has the same effect as
the same-named parameter of 'add-to-store'.  VERIFY-CERTIFICATE? determines
whether or not to validate HTTPS server certificates."
  (define uri
    (string->uri url))

  (if (or (not uri) (memq (uri-scheme uri) '(file #f)))
      (add-to-store store name recursive? "sha256"
                    (if uri (uri-path uri) url))
      (call-with-temporary-output-file
       (lambda (temp port)
         (let ((result
                (parameterize ((current-output-port log))
                  (url-fetch url temp
                             #:mirrors %mirrors
                             #:verify-certificate? verify-certificate?))))
           (close port)
           (and result
                (add-to-store store name recursive? "sha256" temp)))))))

;;; download.scm ends here

repo_name: maximed/guix

license: mit


code:
;;; Guile ELF reader and writer

;; Copyright (C)  2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:
;;;
;;; This file was taken from the Guile 2.1 branch, where it is known as
;;; (system vm elf), and renamed to (guix elf).  It will be unneeded when Guix
;;; switches to Guile 2.1/2.2.
;;;
;;; A module to read and write Executable and Linking Format (ELF)
;;; files.
;;;
;;; This module exports a number of record types that represent the
;;; various parts that make up ELF files.  Fundamentally this is the
;;; main header, the segment headers (program headers), and the section
;;; headers.  It also exports bindings for symbolic constants and
;;; utilities to parse and write special kinds of ELF sections.
;;;
;;; See elf(5) for more information on ELF.
;;;
;;; Code:

(define-module (guix elf)
  #:use-module (rnrs bytevectors)
  #:use-module (system foreign)
  #:use-module (system base target)
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 vlist)
  #:export (has-elf-header?

            (make-elf* . make-elf)
            elf?
            elf-bytes elf-word-size elf-byte-order
            elf-abi elf-type elf-machine-type
            elf-entry elf-phoff elf-shoff elf-flags elf-ehsize
            elf-phentsize elf-phnum elf-shentsize elf-shnum elf-shstrndx

            ELFOSABI_NONE ELFOSABI_HPUX ELFOSABI_NETBSD ELFOSABI_GNU
            ELFOSABI_SOLARIS ELFOSABI_AIX ELFOSABI_IRIX ELFOSABI_FREEBSD
            ELFOSABI_TRU64 ELFOSABI_MODESTO ELFOSABI_OPENBSD
            ELFOSABI_ARM_AEABI ELFOSABI_ARM ELFOSABI_STANDALONE

            ET_NONE ET_REL ET_EXEC ET_DYN ET_CORE

            EM_NONE EM_SPARC EM_386 EM_MIPS EM_PPC EM_PPC64 EM_ARM EM_SH
            EM_SPARCV9 EM_IA_64 EM_X86_64

            elf-header-len elf-header-shoff-offset
            write-elf-header

            (make-elf-segment* . make-elf-segment)
            elf-segment?
            elf-segment-index
            elf-segment-type elf-segment-offset elf-segment-vaddr
            elf-segment-paddr elf-segment-filesz elf-segment-memsz
            elf-segment-flags elf-segment-align

            elf-program-header-len write-elf-program-header

            PT_NULL PT_LOAD PT_DYNAMIC PT_INTERP PT_NOTE PT_SHLIB
            PT_PHDR PT_TLS PT_NUM PT_LOOS PT_GNU_EH_FRAME PT_GNU_STACK
            PT_GNU_RELRO

            PF_R PF_W PF_X

            (make-elf-section* . make-elf-section)
            elf-section?
            elf-section-index
            elf-section-name elf-section-type elf-section-flags
            elf-section-addr elf-section-offset elf-section-size
            elf-section-link elf-section-info elf-section-addralign
            elf-section-entsize

            elf-section-header-len elf-section-header-addr-offset
            elf-section-header-offset-offset
            write-elf-section-header

            (make-elf-symbol* . make-elf-symbol)
            elf-symbol?
            elf-symbol-name elf-symbol-value elf-symbol-size
            elf-symbol-info elf-symbol-other elf-symbol-shndx
            elf-symbol-binding elf-symbol-type elf-symbol-visibility

            elf-symbol-len elf-symbol-value-offset write-elf-symbol

            SHN_UNDEF

            SHT_NULL SHT_PROGBITS SHT_SYMTAB SHT_STRTAB SHT_RELA
            SHT_HASH SHT_DYNAMIC SHT_NOTE SHT_NOBITS SHT_REL SHT_SHLIB
            SHT_DYNSYM SHT_INIT_ARRAY SHT_FINI_ARRAY SHT_PREINIT_ARRAY
            SHT_GROUP SHT_SYMTAB_SHNDX SHT_NUM SHT_LOOS SHT_HIOS
            SHT_LOPROC SHT_HIPROC SHT_LOUSER SHT_HIUSER

            SHF_WRITE SHF_ALLOC SHF_EXECINSTR SHF_MERGE SHF_STRINGS
            SHF_INFO_LINK SHF_LINK_ORDER SHF_OS_NONCONFORMING SHF_GROUP
            SHF_TLS

            DT_NULL DT_NEEDED DT_PLTRELSZ DT_PLTGOT DT_HASH DT_STRTAB
            DT_SYMTAB DT_RELA DT_RELASZ DT_RELAENT DT_STRSZ DT_SYMENT
            DT_INIT DT_FINI DT_SONAME DT_RPATH DT_SYMBOLIC DT_REL
            DT_RELSZ DT_RELENT DT_PLTREL DT_DEBUG DT_TEXTREL DT_JMPREL
            DT_BIND_NOW DT_INIT_ARRAY DT_FINI_ARRAY DT_INIT_ARRAYSZ
            DT_FINI_ARRAYSZ DT_RUNPATH DT_FLAGS DT_ENCODING
            DT_PREINIT_ARRAY DT_PREINIT_ARRAYSZ DT_NUM DT_LOGUILE
            DT_GUILE_GC_ROOT DT_GUILE_GC_ROOT_SZ DT_GUILE_ENTRY
            DT_GUILE_VM_VERSION DT_GUILE_FRAME_MAPS DT_HIGUILE
            DT_LOOS DT_HIOS DT_LOPROC DT_HIPROC

            string-table-ref

            STB_LOCAL STB_GLOBAL STB_WEAK STB_NUM STB_LOOS STB_GNU
            STB_HIOS STB_LOPROC STB_HIPROC

            STT_NOTYPE STT_OBJECT STT_FUNC STT_SECTION STT_FILE
            STT_COMMON STT_TLS STT_NUM STT_LOOS STT_GNU STT_HIOS
            STT_LOPROC STT_HIPROC

            STV_DEFAULT STV_INTERNAL STV_HIDDEN STV_PROTECTED

            NT_GNU_ABI_TAG NT_GNU_HWCAP NT_GNU_BUILD_ID NT_GNU_GOLD_VERSION

            parse-elf
            elf-segment elf-segments
            elf-section elf-sections elf-section-by-name elf-sections-by-name
            elf-symbol-table-len elf-symbol-table-ref

            parse-elf-note
            elf-note-name elf-note-desc elf-note-type))

;; #define EI_NIDENT 16

;; typedef struct {
;;     unsigned char e_ident[EI_NIDENT];
;;     uint16_t      e_type;
;;     uint16_t      e_machine;
;;     uint32_t      e_version;
;;     ElfN_Addr     e_entry;
;;     ElfN_Off      e_phoff;
;;     ElfN_Off      e_shoff;
;;     uint32_t      e_flags;
;;     uint16_t      e_ehsize;
;;     uint16_t      e_phentsize;
;;     uint16_t      e_phnum;
;;     uint16_t      e_shentsize;
;;     uint16_t      e_shnum;
;;     uint16_t      e_shstrndx;
;; } ElfN_Ehdr;

(define elf32-header-len 52)
(define elf64-header-len 64)
(define (elf-header-len word-size)
  (case word-size
    ((4) elf32-header-len)
    ((8) elf64-header-len)
    (else (error "invalid word size" word-size))))
(define (elf-header-shoff-offset word-size)
  (case word-size
    ((4) 32)
    ((8) 40)
    (else (error "bad word size" word-size))))

(define ELFCLASS32      1)              ; 32-bit objects
(define ELFCLASS64      2)              ; 64-bit objects

(define ELFDATA2LSB     1)              ; 2's complement, little endian
(define ELFDATA2MSB     2)              ; 2's complement, big endian

(define EV_CURRENT      1)              ; Current version

(define ELFOSABI_NONE		0)	; UNIX System V ABI */
(define ELFOSABI_HPUX		1)	; HP-UX
(define ELFOSABI_NETBSD		2)	; NetBSD.
(define ELFOSABI_GNU		3)	; Object uses GNU ELF extensions.
(define ELFOSABI_SOLARIS	6)	; Sun Solaris.
(define ELFOSABI_AIX		7)	; IBM AIX.
(define ELFOSABI_IRIX		8)	; SGI Irix.
(define ELFOSABI_FREEBSD	9)	; FreeBSD.
(define ELFOSABI_TRU64		10)	; Compaq TRU64 UNIX.
(define ELFOSABI_MODESTO	11)	; Novell Modesto.
(define ELFOSABI_OPENBSD	12)	; OpenBSD.
(define ELFOSABI_ARM_AEABI	64)	; ARM EABI
(define ELFOSABI_ARM		97)	; ARM
(define ELFOSABI_STANDALONE     255)    ; Standalone (embedded) application

(define ET_NONE		0)		; No file type
(define ET_REL		1)		; Relocatable file
(define ET_EXEC		2)		; Executable file
(define ET_DYN		3)		; Shared object file
(define ET_CORE		4)		; Core file

;;
;; Machine types
;;
;; Just a sampling of these values.  We could include more, but the
;; important thing is to recognize architectures for which we have a
;; native compiler.  Recognizing more common machine types is icing on
;; the cake.
;;
(define EM_NONE          0)             ; No machine
(define EM_SPARC         2)             ; SUN SPARC
(define EM_386           3)             ; Intel 80386
(define EM_MIPS          8)             ; MIPS R3000 big-endian
(define EM_PPC          20)             ; PowerPC
(define EM_PPC64        21)             ; PowerPC 64-bit
(define EM_ARM          40)             ; ARM
(define EM_SH           42)             ; Hitachi SH
(define EM_SPARCV9      43)             ; SPARC v9 64-bit
(define EM_IA_64        50)             ; Intel Merced
(define EM_X86_64       62)             ; AMD x86-64 architecture

(define cpu-mapping (make-hash-table))
(for-each (lambda (pair)
            (hashq-set! cpu-mapping (car pair) (cdr pair)))
          `((none . ,EM_NONE)
            (sparc . ,EM_SPARC) ; FIXME: map 64-bit to SPARCV9 ?
            (i386 . ,EM_386)
            (mips . ,EM_MIPS)
            (ppc . ,EM_PPC)
            (ppc64 . ,EM_PPC64)
            (arm . ,EM_ARM) ; FIXME: there are more arm cpu variants
            (sh . ,EM_SH) ; FIXME: there are more sh cpu variants
            (ia64 . ,EM_IA_64)
            (x86_64 . ,EM_X86_64)))

(define SHN_UNDEF 0)

(define host-machine-type
  (hashq-ref cpu-mapping
             (string->symbol (car (string-split %host-type #\-)))
             EM_NONE))

(define host-word-size
  (sizeof '*))

(define host-byte-order
  (native-endianness))

(define (has-elf-header? bv)
  (and
   ;; e_ident
   (>= (bytevector-length bv) 16)
   (= (bytevector-u8-ref bv 0) #x7f)
   (= (bytevector-u8-ref bv 1) (char->integer #\E))
   (= (bytevector-u8-ref bv 2) (char->integer #\L))
   (= (bytevector-u8-ref bv 3) (char->integer #\F))
   (cond
    ((= (bytevector-u8-ref bv 4) ELFCLASS32)
     (>= (bytevector-length bv) elf32-header-len))
    ((= (bytevector-u8-ref bv 4) ELFCLASS64)
     (>= (bytevector-length bv) elf64-header-len))
    (else #f))
   (or (= (bytevector-u8-ref bv 5) ELFDATA2LSB)
       (= (bytevector-u8-ref bv 5) ELFDATA2MSB))
   (= (bytevector-u8-ref bv 6) EV_CURRENT)
   ;; Look at ABI later.
   (= (bytevector-u8-ref bv 8) 0)       ; ABI version
   ;; The rest of the e_ident is padding.

   ;; e_version
   (let ((byte-order (if (= (bytevector-u8-ref bv 5) ELFDATA2LSB)
                         (endianness little)
                         (endianness big))))
     (= (bytevector-u32-ref bv 20 byte-order) EV_CURRENT))))

(define-record-type <elf>
  (make-elf bytes word-size byte-order abi type machine-type
            entry phoff shoff flags ehsize
            phentsize phnum shentsize shnum shstrndx)
  elf?
  (bytes elf-bytes)
  (word-size elf-word-size)
  (byte-order elf-byte-order)
  (abi elf-abi)
  (type elf-type)
  (machine-type elf-machine-type)
  (entry elf-entry)
  (phoff elf-phoff)
  (shoff elf-shoff)
  (flags elf-flags)
  (ehsize elf-ehsize)
  (phentsize elf-phentsize)
  (phnum elf-phnum)
  (shentsize elf-shentsize)
  (shnum elf-shnum)
  (shstrndx elf-shstrndx))

(define* (make-elf* #:key (bytes #f)
                    (byte-order (target-endianness))
                    (word-size (target-word-size))
                    (abi ELFOSABI_STANDALONE)
                    (type ET_DYN)
                    (machine-type EM_NONE)
                    (entry 0)
                    (phoff (elf-header-len word-size))
                    (shoff -1)
                    (flags 0)
                    (ehsize (elf-header-len word-size))
                    (phentsize (elf-program-header-len word-size))
                    (phnum 0)
                    (shentsize (elf-section-header-len word-size))
                    (shnum 0)
                    (shstrndx SHN_UNDEF))
  (make-elf bytes word-size byte-order abi type machine-type
            entry phoff shoff flags ehsize
            phentsize phnum shentsize shnum shstrndx))

(define (parse-elf32 bv byte-order)
  (make-elf bv 4 byte-order
            (bytevector-u8-ref bv 7)
            (bytevector-u16-ref bv 16 byte-order)
            (bytevector-u16-ref bv 18 byte-order)
            (bytevector-u32-ref bv 24 byte-order)
            (bytevector-u32-ref bv 28 byte-order)
            (bytevector-u32-ref bv 32 byte-order)
            (bytevector-u32-ref bv 36 byte-order)
            (bytevector-u16-ref bv 40 byte-order)
            (bytevector-u16-ref bv 42 byte-order)
            (bytevector-u16-ref bv 44 byte-order)
            (bytevector-u16-ref bv 46 byte-order)
            (bytevector-u16-ref bv 48 byte-order)
            (bytevector-u16-ref bv 50 byte-order)))

(define (write-elf-ident bv class data abi)
  (bytevector-u8-set! bv 0 #x7f)
  (bytevector-u8-set! bv 1 (char->integer #\E))
  (bytevector-u8-set! bv 2 (char->integer #\L))
  (bytevector-u8-set! bv 3 (char->integer #\F))
  (bytevector-u8-set! bv 4 class)
  (bytevector-u8-set! bv 5 data)
  (bytevector-u8-set! bv 6 EV_CURRENT)
  (bytevector-u8-set! bv 7 abi)
  (bytevector-u8-set! bv 8 0) ; ABI version
  (bytevector-u8-set! bv 9 0) ; Pad to 16 bytes.
  (bytevector-u8-set! bv 10 0)
  (bytevector-u8-set! bv 11 0)
  (bytevector-u8-set! bv 12 0)
  (bytevector-u8-set! bv 13 0)
  (bytevector-u8-set! bv 14 0)
  (bytevector-u8-set! bv 15 0))

(define (write-elf32-header bv elf)
  (let ((byte-order (elf-byte-order elf)))
    (write-elf-ident bv ELFCLASS32
                     (case byte-order
                       ((little) ELFDATA2LSB)
                       ((big) ELFDATA2MSB)
                       (else (error "unknown endianness" byte-order)))
                     (elf-abi elf))
    (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
    (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
    (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
    (bytevector-u32-set! bv 24 (elf-entry elf) byte-order)
    (bytevector-u32-set! bv 28 (elf-phoff elf) byte-order)
    (bytevector-u32-set! bv 32 (elf-shoff elf) byte-order)
    (bytevector-u32-set! bv 36 (elf-flags elf) byte-order)
    (bytevector-u16-set! bv 40 (elf-ehsize elf) byte-order)
    (bytevector-u16-set! bv 42 (elf-phentsize elf) byte-order)
    (bytevector-u16-set! bv 44 (elf-phnum elf) byte-order)
    (bytevector-u16-set! bv 46 (elf-shentsize elf) byte-order)
    (bytevector-u16-set! bv 48 (elf-shnum elf) byte-order)
    (bytevector-u16-set! bv 50 (elf-shstrndx elf) byte-order)))

(define (parse-elf64 bv byte-order)
  (make-elf bv 8 byte-order
            (bytevector-u8-ref bv 7)
            (bytevector-u16-ref bv 16 byte-order)
            (bytevector-u16-ref bv 18 byte-order)
            (bytevector-u64-ref bv 24 byte-order)
            (bytevector-u64-ref bv 32 byte-order)
            (bytevector-u64-ref bv 40 byte-order)
            (bytevector-u32-ref bv 48 byte-order)
            (bytevector-u16-ref bv 52 byte-order)
            (bytevector-u16-ref bv 54 byte-order)
            (bytevector-u16-ref bv 56 byte-order)
            (bytevector-u16-ref bv 58 byte-order)
            (bytevector-u16-ref bv 60 byte-order)
            (bytevector-u16-ref bv 62 byte-order)))

(define (write-elf64-header bv elf)
  (let ((byte-order (elf-byte-order elf)))
    (write-elf-ident bv ELFCLASS64
                     (case byte-order
                       ((little) ELFDATA2LSB)
                       ((big) ELFDATA2MSB)
                       (else (error "unknown endianness" byte-order)))
                     (elf-abi elf))
    (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
    (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
    (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
    (bytevector-u64-set! bv 24 (elf-entry elf) byte-order)
    (bytevector-u64-set! bv 32 (elf-phoff elf) byte-order)
    (bytevector-u64-set! bv 40 (elf-shoff elf) byte-order)
    (bytevector-u32-set! bv 48 (elf-flags elf) byte-order)
    (bytevector-u16-set! bv 52 (elf-ehsize elf) byte-order)
    (bytevector-u16-set! bv 54 (elf-phentsize elf) byte-order)
    (bytevector-u16-set! bv 56 (elf-phnum elf) byte-order)
    (bytevector-u16-set! bv 58 (elf-shentsize elf) byte-order)
    (bytevector-u16-set! bv 60 (elf-shnum elf) byte-order)
    (bytevector-u16-set! bv 62 (elf-shstrndx elf) byte-order)))

(define (parse-elf bv)
  (cond
   ((has-elf-header? bv)
    (let ((class (bytevector-u8-ref bv 4))
          (byte-order (let ((data (bytevector-u8-ref bv 5)))
                        (cond
                         ((= data ELFDATA2LSB) (endianness little))
                         ((= data ELFDATA2MSB) (endianness big))
                         (else (error "unhandled byte order" data))))))
      (cond
       ((= class ELFCLASS32) (parse-elf32 bv byte-order))
       ((= class ELFCLASS64) (parse-elf64 bv byte-order))
       (else (error "unhandled class" class)))))
   (else
    (error "Invalid ELF" bv))))

(define* (write-elf-header bv elf)
  ((case (elf-word-size elf)
     ((4) write-elf32-header)
     ((8) write-elf64-header)
     (else (error "unknown word size" (elf-word-size elf))))
   bv elf))

;;
;; Segment types
;;
(define PT_NULL         0)              ; Program header table entry unused
(define PT_LOAD         1)              ; Loadable program segment
(define PT_DYNAMIC      2)              ; Dynamic linking information
(define PT_INTERP       3)              ; Program interpreter
(define PT_NOTE         4)              ; Auxiliary information
(define PT_SHLIB        5)              ; Reserved
(define PT_PHDR         6)              ; Entry for header table itself
(define PT_TLS          7)              ; Thread-local storage segment
(define PT_NUM          8)              ; Number of defined types
(define PT_LOOS         #x60000000)     ; Start of OS-specific
(define PT_GNU_EH_FRAME #x6474e550)     ; GCC .eh_frame_hdr segment
(define PT_GNU_STACK    #x6474e551)     ; Indicates stack executability
(define PT_GNU_RELRO    #x6474e552)     ; Read-only after relocation

;;
;; Segment flags
;;
(define PF_X            (ash 1 0))      ; Segment is executable
(define PF_W            (ash 1 1))      ; Segment is writable
(define PF_R            (ash 1 2))      ; Segment is readable

(define-record-type <elf-segment>
  (make-elf-segment index type offset vaddr paddr filesz memsz flags align)
  elf-segment?
  (index elf-segment-index)
  (type elf-segment-type)
  (offset elf-segment-offset)
  (vaddr elf-segment-vaddr)
  (paddr elf-segment-paddr)
  (filesz elf-segment-filesz)
  (memsz elf-segment-memsz)
  (flags elf-segment-flags)
  (align elf-segment-align))

(define* (make-elf-segment* #:key (index -1) (type PT_LOAD) (offset 0) (vaddr 0)
                            (paddr 0) (filesz 0) (memsz filesz)
                            (flags (logior PF_W PF_R))
                            (align 8))
  (make-elf-segment index type offset vaddr paddr filesz memsz flags align))

;; typedef struct {
;;     uint32_t   p_type;
;;     Elf32_Off  p_offset;
;;     Elf32_Addr p_vaddr;
;;     Elf32_Addr p_paddr;
;;     uint32_t   p_filesz;
;;     uint32_t   p_memsz;
;;     uint32_t   p_flags;
;;     uint32_t   p_align;
;; } Elf32_Phdr;

(define (parse-elf32-program-header index bv offset byte-order)
  (if (<= (+ offset 32) (bytevector-length bv))
      (make-elf-segment index
                        (bytevector-u32-ref bv offset byte-order)
                        (bytevector-u32-ref bv (+ offset 4) byte-order)
                        (bytevector-u32-ref bv (+ offset 8) byte-order)
                        (bytevector-u32-ref bv (+ offset 12) byte-order)
                        (bytevector-u32-ref bv (+ offset 16) byte-order)
                        (bytevector-u32-ref bv (+ offset 20) byte-order)
                        (bytevector-u32-ref bv (+ offset 24) byte-order)
                        (bytevector-u32-ref bv (+ offset 28) byte-order))
      (error "corrupt ELF (offset out of range)" offset)))

(define (write-elf32-program-header bv offset byte-order seg)
  (bytevector-u32-set! bv offset (elf-segment-type seg) byte-order)
  (bytevector-u32-set! bv (+ offset 4) (elf-segment-offset seg) byte-order)
  (bytevector-u32-set! bv (+ offset 8) (elf-segment-vaddr seg) byte-order)
  (bytevector-u32-set! bv (+ offset 12) (elf-segment-paddr seg) byte-order)
  (bytevector-u32-set! bv (+ offset 16) (elf-segment-filesz seg) byte-order)
  (bytevector-u32-set! bv (+ offset 20) (elf-segment-memsz seg) byte-order)
  (bytevector-u32-set! bv (+ offset 24) (elf-segment-flags seg) byte-order)
  (bytevector-u32-set! bv (+ offset 28) (elf-segment-align seg) byte-order))

;; typedef struct {
;;     uint32_t   p_type;
;;     uint32_t   p_flags;
;;     Elf64_Off  p_offset;
;;     Elf64_Addr p_vaddr;
;;     Elf64_Addr p_paddr;
;;     uint64_t   p_filesz;
;;     uint64_t   p_memsz;
;;     uint64_t   p_align;
;; } Elf64_Phdr;

;; NB: position of `flags' is different!

(define (parse-elf64-program-header index bv offset byte-order)
  (if (<= (+ offset 56) (bytevector-length bv))
      (make-elf-segment index
                        (bytevector-u32-ref bv offset byte-order)
                        (bytevector-u64-ref bv (+ offset 8) byte-order)
                        (bytevector-u64-ref bv (+ offset 16) byte-order)
                        (bytevector-u64-ref bv (+ offset 24) byte-order)
                        (bytevector-u64-ref bv (+ offset 32) byte-order)
                        (bytevector-u64-ref bv (+ offset 40) byte-order)
                        (bytevector-u32-ref bv (+ offset 4) byte-order)
                        (bytevector-u64-ref bv (+ offset 48) byte-order))
      (error "corrupt ELF (offset out of range)" offset)))

(define (write-elf64-program-header bv offset byte-order seg)
  (bytevector-u32-set! bv offset (elf-segment-type seg) byte-order)
  (bytevector-u64-set! bv (+ offset 8) (elf-segment-offset seg) byte-order)
  (bytevector-u64-set! bv (+ offset 16) (elf-segment-vaddr seg) byte-order)
  (bytevector-u64-set! bv (+ offset 24) (elf-segment-paddr seg) byte-order)
  (bytevector-u64-set! bv (+ offset 32) (elf-segment-filesz seg) byte-order)
  (bytevector-u64-set! bv (+ offset 40) (elf-segment-memsz seg) byte-order)
  (bytevector-u32-set! bv (+ offset 4) (elf-segment-flags seg) byte-order)
  (bytevector-u64-set! bv (+ offset 48) (elf-segment-align seg) byte-order))

(define (write-elf-program-header bv offset byte-order word-size seg)
  ((case word-size
     ((4) write-elf32-program-header)
     ((8) write-elf64-program-header)
     (else (error "invalid word size" word-size)))
   bv offset byte-order seg))

(define (elf-program-header-len word-size)
  (case word-size
    ((4) 32)
    ((8) 56)
    (else (error "bad word size" word-size))))

(define (elf-segment elf n)
  (if (not (< -1 n (elf-phnum elf)))
      (error "bad segment number" n))
  ((case (elf-word-size elf)
     ((4) parse-elf32-program-header)
     ((8) parse-elf64-program-header)
     (else (error "unhandled pointer size")))
   n
   (elf-bytes elf)
   (+ (elf-phoff elf) (* n (elf-phentsize elf)))
   (elf-byte-order elf)))

(define (elf-segments elf)
  (let lp ((n (elf-phnum elf)) (out '()))
    (if (zero? n)
        out
        (lp (1- n) (cons (elf-segment elf (1- n)) out)))))

(define-record-type <elf-section>
  (make-elf-section index name type flags
                    addr offset size link info addralign entsize)
  elf-section?
  (index elf-section-index)
  (name elf-section-name)
  (type elf-section-type)
  (flags elf-section-flags)
  (addr elf-section-addr)
  (offset elf-section-offset)
  (size elf-section-size)
  (link elf-section-link)
  (info elf-section-info)
  (addralign elf-section-addralign)
  (entsize elf-section-entsize))

(define* (make-elf-section* #:key (index SHN_UNDEF) (name 0) (type SHT_PROGBITS)
                            (flags SHF_ALLOC) (addr 0) (offset 0) (size 0)
                            (link 0) (info 0) (addralign 8) (entsize 0))
  (make-elf-section index name type flags addr offset size link info addralign
                    entsize))

;; typedef struct {
;;     uint32_t   sh_name;
;;     uint32_t   sh_type;
;;     uint32_t   sh_flags;
;;     Elf32_Addr sh_addr;
;;     Elf32_Off  sh_offset;
;;     uint32_t   sh_size;
;;     uint32_t   sh_link;
;;     uint32_t   sh_info;
;;     uint32_t   sh_addralign;
;;     uint32_t   sh_entsize;
;; } Elf32_Shdr;

(define (parse-elf32-section-header index bv offset byte-order)
  (if (<= (+ offset 40) (bytevector-length bv))
      (make-elf-section index
                        (bytevector-u32-ref bv offset byte-order)
                        (bytevector-u32-ref bv (+ offset 4) byte-order)
                        (bytevector-u32-ref bv (+ offset 8) byte-order)
                        (bytevector-u32-ref bv (+ offset 12) byte-order)
                        (bytevector-u32-ref bv (+ offset 16) byte-order)
                        (bytevector-u32-ref bv (+ offset 20) byte-order)
                        (bytevector-u32-ref bv (+ offset 24) byte-order)
                        (bytevector-u32-ref bv (+ offset 28) byte-order)
                        (bytevector-u32-ref bv (+ offset 32) byte-order)
                        (bytevector-u32-ref bv (+ offset 36) byte-order))
      (error "corrupt ELF (offset out of range)" offset)))

(define (write-elf32-section-header bv offset byte-order sec)
  (bytevector-u32-set! bv offset (elf-section-name sec) byte-order)
  (bytevector-u32-set! bv (+ offset 4) (elf-section-type sec) byte-order)
  (bytevector-u32-set! bv (+ offset 8) (elf-section-flags sec) byte-order)
  (bytevector-u32-set! bv (+ offset 12) (elf-section-addr sec) byte-order)
  (bytevector-u32-set! bv (+ offset 16) (elf-section-offset sec) byte-order)
  (bytevector-u32-set! bv (+ offset 20) (elf-section-size sec) byte-order)
  (bytevector-u32-set! bv (+ offset 24) (elf-section-link sec) byte-order)
  (bytevector-u32-set! bv (+ offset 28) (elf-section-info sec) byte-order)
  (bytevector-u32-set! bv (+ offset 32) (elf-section-addralign sec) byte-order)
  (bytevector-u32-set! bv (+ offset 36) (elf-section-entsize sec) byte-order))

;; typedef struct {
;;     uint32_t   sh_name;
;;     uint32_t   sh_type;
;;     uint64_t   sh_flags;
;;     Elf64_Addr sh_addr;
;;     Elf64_Off  sh_offset;
;;     uint64_t   sh_size;
;;     uint32_t   sh_link;
;;     uint32_t   sh_info;
;;     uint64_t   sh_addralign;
;;     uint64_t   sh_entsize;
;; } Elf64_Shdr;

(define (elf-section-header-len word-size)
  (case word-size
    ((4) 40)
    ((8) 64)
    (else (error "bad word size" word-size))))

(define (elf-section-header-addr-offset word-size)
  (case word-size
    ((4) 12)
    ((8) 16)
    (else (error "bad word size" word-size))))

(define (elf-section-header-offset-offset word-size)
  (case word-size
    ((4) 16)
    ((8) 24)
    (else (error "bad word size" word-size))))

(define (parse-elf64-section-header index bv offset byte-order)
  (if (<= (+ offset 64) (bytevector-length bv))
      (make-elf-section index
                        (bytevector-u32-ref bv offset byte-order)
                        (bytevector-u32-ref bv (+ offset 4) byte-order)
                        (bytevector-u64-ref bv (+ offset 8) byte-order)
                        (bytevector-u64-ref bv (+ offset 16) byte-order)
                        (bytevector-u64-ref bv (+ offset 24) byte-order)
                        (bytevector-u64-ref bv (+ offset 32) byte-order)
                        (bytevector-u32-ref bv (+ offset 40) byte-order)
                        (bytevector-u32-ref bv (+ offset 44) byte-order)
                        (bytevector-u64-ref bv (+ offset 48) byte-order)
                        (bytevector-u64-ref bv (+ offset 56) byte-order))
      (error "corrupt ELF (offset out of range)" offset)))

(define (write-elf64-section-header bv offset byte-order sec)
  (bytevector-u32-set! bv offset (elf-section-name sec) byte-order)
  (bytevector-u32-set! bv (+ offset 4) (elf-section-type sec) byte-order)
  (bytevector-u64-set! bv (+ offset 8) (elf-section-flags sec) byte-order)
  (bytevector-u64-set! bv (+ offset 16) (elf-section-addr sec) byte-order)
  (bytevector-u64-set! bv (+ offset 24) (elf-section-offset sec) byte-order)
  (bytevector-u64-set! bv (+ offset 32) (elf-section-size sec) byte-order)
  (bytevector-u32-set! bv (+ offset 40) (elf-section-link sec) byte-order)
  (bytevector-u32-set! bv (+ offset 44) (elf-section-info sec) byte-order)
  (bytevector-u64-set! bv (+ offset 48) (elf-section-addralign sec) byte-order)
  (bytevector-u64-set! bv (+ offset 56) (elf-section-entsize sec) byte-order))

(define (elf-section elf n)
  (if (not (< -1 n (elf-shnum elf)))
      (error "bad section number" n))
  ((case (elf-word-size elf)
     ((4) parse-elf32-section-header)
     ((8) parse-elf64-section-header)
     (else (error "unhandled pointer size")))
   n
   (elf-bytes elf)
   (+ (elf-shoff elf) (* n (elf-shentsize elf)))
   (elf-byte-order elf)))

(define (write-elf-section-header bv offset byte-order word-size sec)
  ((case word-size
     ((4) write-elf32-section-header)
     ((8) write-elf64-section-header)
     (else (error "invalid word size" word-size)))
   bv offset byte-order sec))

(define (elf-sections elf)
  (let lp ((n (elf-shnum elf)) (out '()))
    (if (zero? n)
        out
        (lp (1- n) (cons (elf-section elf (1- n)) out)))))

;;
;; Section Types
;;
(define SHT_NULL          0)            ; Section header table entry unused
(define SHT_PROGBITS      1)            ; Program data
(define SHT_SYMTAB        2)            ; Symbol table
(define SHT_STRTAB        3)            ; String table
(define SHT_RELA          4)            ; Relocation entries with addends
(define SHT_HASH          5)            ; Symbol hash table
(define SHT_DYNAMIC       6)            ; Dynamic linking information
(define SHT_NOTE          7)            ; Notes
(define SHT_NOBITS        8)            ; Program space with no data (bss)
(define SHT_REL           9)            ; Relocation entries, no addends
(define SHT_SHLIB         10)           ; Reserved
(define SHT_DYNSYM        11)           ; Dynamic linker symbol table
(define SHT_INIT_ARRAY    14)           ; Array of constructors
(define SHT_FINI_ARRAY    15)           ; Array of destructors
(define SHT_PREINIT_ARRAY 16)           ; Array of pre-constructors
(define SHT_GROUP         17)           ; Section group
(define SHT_SYMTAB_SHNDX  18)           ; Extended section indeces
(define SHT_NUM           19)           ; Number of defined types.
(define SHT_LOOS          #x60000000)   ; Start OS-specific.
(define SHT_HIOS          #x6fffffff)   ; End OS-specific type
(define SHT_LOPROC        #x70000000)   ; Start of processor-specific
(define SHT_HIPROC        #x7fffffff)   ; End of processor-specific
(define SHT_LOUSER        #x80000000)   ; Start of application-specific
(define SHT_HIUSER        #x8fffffff)   ; End of application-specific

;;
;; Section Flags
;;
(define SHF_WRITE            (ash 1 0)) ; Writable
(define SHF_ALLOC            (ash 1 1)) ; Occupies memory during execution
(define SHF_EXECINSTR        (ash 1 2)) ; Executable
(define SHF_MERGE            (ash 1 4)) ; Might be merged
(define SHF_STRINGS          (ash 1 5)) ; Contains nul-terminated strings
(define SHF_INFO_LINK        (ash 1 6)) ; `sh_info' contains SHT index
(define SHF_LINK_ORDER       (ash 1 7)) ; Preserve order after combining
(define SHF_OS_NONCONFORMING (ash 1 8)) ; Non-standard OS specific handling required
(define SHF_GROUP            (ash 1 9)) ; Section is member of a group.
(define SHF_TLS              (ash 1 10)) ; Section hold thread-local data.

;;
;; Dynamic entry types.  The DT_GUILE types are non-standard.
;;
(define DT_NULL		0)		; Marks end of dynamic section
(define DT_NEEDED	1)		; Name of needed library
(define DT_PLTRELSZ	2)		; Size in bytes of PLT relocs
(define DT_PLTGOT	3)		; Processor defined value
(define DT_HASH		4)		; Address of symbol hash table
(define DT_STRTAB	5)		; Address of string table
(define DT_SYMTAB	6)		; Address of symbol table
(define DT_RELA		7)		; Address of Rela relocs
(define DT_RELASZ	8)		; Total size of Rela relocs
(define DT_RELAENT	9)		; Size of one Rela reloc
(define DT_STRSZ	10)		; Size of string table
(define DT_SYMENT	11)		; Size of one symbol table entry
(define DT_INIT		12)		; Address of init function
(define DT_FINI		13)		; Address of termination function
(define DT_SONAME	14)		; Name of shared object
(define DT_RPATH	15)		; Library search path (deprecated)
(define DT_SYMBOLIC	16)		; Start symbol search here
(define DT_REL		17)		; Address of Rel relocs
(define DT_RELSZ	18)		; Total size of Rel relocs
(define DT_RELENT	19)		; Size of one Rel reloc
(define DT_PLTREL	20)		; Type of reloc in PLT
(define DT_DEBUG	21)		; For debugging ; unspecified
(define DT_TEXTREL	22)		; Reloc might modify .text
(define DT_JMPREL	23)		; Address of PLT relocs
(define	DT_BIND_NOW	24)		; Process relocations of object
(define	DT_INIT_ARRAY	25)		; Array with addresses of init fct
(define	DT_FINI_ARRAY	26)		; Array with addresses of fini fct
(define	DT_INIT_ARRAYSZ	27)		; Size in bytes of DT_INIT_ARRAY
(define	DT_FINI_ARRAYSZ	28)		; Size in bytes of DT_FINI_ARRAY
(define DT_RUNPATH	29)		; Library search path
(define DT_FLAGS	30)		; Flags for the object being loaded
(define DT_ENCODING	32)		; Start of encoded range
(define DT_PREINIT_ARRAY 32)		; Array with addresses of preinit fc
(define DT_PREINIT_ARRAYSZ 33)		; size in bytes of DT_PREINIT_ARRAY
(define	DT_NUM		34)		; Number used
(define DT_LOGUILE      #x37146000)     ; Start of Guile-specific
(define DT_GUILE_GC_ROOT    #x37146000) ; Offset of GC roots
(define DT_GUILE_GC_ROOT_SZ #x37146001) ; Size in machine words of GC roots
(define DT_GUILE_ENTRY      #x37146002) ; Address of entry thunk
(define DT_GUILE_VM_VERSION #x37146003) ; Bytecode version
(define DT_GUILE_FRAME_MAPS #x37146004) ; Offset of .guile.frame-maps
(define DT_HIGUILE      #x37146fff)     ; End of Guile-specific
(define DT_LOOS		#x6000000d)	; Start of OS-specific
(define DT_HIOS		#x6ffff000)	; End of OS-specific
(define DT_LOPROC	#x70000000)	; Start of processor-specific
(define DT_HIPROC	#x7fffffff)	; End of processor-specific

(define (string-table-ref bv offset)
  (let lp ((end offset))
    (if (zero? (bytevector-u8-ref bv end))
        (let ((out (make-bytevector (- end offset))))
          (bytevector-copy! bv offset out 0 (- end offset))
          (utf8->string out))
        (lp (1+ end)))))

(define (elf-section-by-name elf name)
  (let ((off (elf-section-offset (elf-section elf (elf-shstrndx elf)))))
    (let lp ((n (elf-shnum elf)))
      (and (> n 0)
           (let ((section (elf-section elf (1- n))))
             (if (equal? (string-table-ref (elf-bytes elf)
                                           (+ off (elf-section-name section)))
                         name)
                 section
                 (lp (1- n))))))))

(define (elf-sections-by-name elf)
  (let* ((sections (elf-sections elf))
         (off (elf-section-offset (list-ref sections (elf-shstrndx elf)))))
    (map (lambda (section)
           (cons (string-table-ref (elf-bytes elf)
                                   (+ off (elf-section-name section)))
                 section))
         sections)))

(define-record-type <elf-symbol>
  (make-elf-symbol name value size info other shndx)
  elf-symbol?
  (name elf-symbol-name)
  (value elf-symbol-value)
  (size elf-symbol-size)
  (info elf-symbol-info)
  (other elf-symbol-other)
  (shndx elf-symbol-shndx))

(define* (make-elf-symbol* #:key (name 0) (value 0) (size 0)
                           (binding STB_LOCAL) (type STT_NOTYPE)
                           (info (logior (ash binding 4) type))
                           (visibility STV_DEFAULT) (other visibility)
                           (shndx SHN_UNDEF))
  (make-elf-symbol name value size info other shndx))

;; typedef struct {
;;     uint32_t      st_name;
;;     Elf32_Addr    st_value;
;;     uint32_t      st_size;
;;     unsigned char st_info;
;;     unsigned char st_other;
;;     uint16_t      st_shndx;
;; } Elf32_Sym;

(define (elf-symbol-len word-size)
  (case word-size
    ((4) 16)
    ((8) 24)
    (else (error "bad word size" word-size))))

(define (elf-symbol-value-offset word-size)
  (case word-size
    ((4) 4)
    ((8) 8)
    (else (error "bad word size" word-size))))

(define (parse-elf32-symbol bv offset stroff byte-order)
  (if (<= (+ offset 16) (bytevector-length bv))
      (make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
                         (if stroff
                             (string-table-ref bv (+ stroff name))
                             name))
                       (bytevector-u32-ref bv (+ offset 4) byte-order)
                       (bytevector-u32-ref bv (+ offset 8) byte-order)
                       (bytevector-u8-ref bv (+ offset 12))
                       (bytevector-u8-ref bv (+ offset 13))
                       (bytevector-u16-ref bv (+ offset 14) byte-order))
      (error "corrupt ELF (offset out of range)" offset)))

(define (write-elf32-symbol bv offset byte-order sym)
  (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
  (bytevector-u32-set! bv (+ offset 4) (elf-symbol-value sym) byte-order)
  (bytevector-u32-set! bv (+ offset 8) (elf-symbol-size sym) byte-order)
  (bytevector-u8-set! bv (+ offset 12) (elf-symbol-info sym))
  (bytevector-u8-set! bv (+ offset 13) (elf-symbol-other sym))
  (bytevector-u16-set! bv (+ offset 14) (elf-symbol-shndx sym) byte-order))

;; typedef struct {
;;     uint32_t      st_name;
;;     unsigned char st_info;
;;     unsigned char st_other;
;;     uint16_t      st_shndx;
;;     Elf64_Addr    st_value;
;;     uint64_t      st_size;
;; } Elf64_Sym;

(define (parse-elf64-symbol bv offset stroff byte-order)
  (if (<= (+ offset 24) (bytevector-length bv))
      (make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
                         (if stroff
                             (string-table-ref bv (+ stroff name))
                             name))
                       (bytevector-u64-ref bv (+ offset 8) byte-order)
                       (bytevector-u64-ref bv (+ offset 16) byte-order)
                       (bytevector-u8-ref bv (+ offset 4))
                       (bytevector-u8-ref bv (+ offset 5))
                       (bytevector-u16-ref bv (+ offset 6) byte-order))
      (error "corrupt ELF (offset out of range)" offset)))

(define (write-elf64-symbol bv offset byte-order sym)
  (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
  (bytevector-u8-set! bv (+ offset 4) (elf-symbol-info sym))
  (bytevector-u8-set! bv (+ offset 5) (elf-symbol-other sym))
  (bytevector-u16-set! bv (+ offset 6) (elf-symbol-shndx sym) byte-order)
  (bytevector-u64-set! bv (+ offset 8) (elf-symbol-value sym) byte-order)
  (bytevector-u64-set! bv (+ offset 16) (elf-symbol-size sym) byte-order))

(define (write-elf-symbol bv offset byte-order word-size sym)
  ((case word-size
     ((4) write-elf32-symbol)
     ((8) write-elf64-symbol)
     (else (error "invalid word size" word-size)))
   bv offset byte-order sym))

(define (elf-symbol-table-len section)
  (let ((len (elf-section-size section))
        (entsize (elf-section-entsize section)))
    (unless (and (not (zero? entsize)) (zero? (modulo len entsize)))
      (error "bad symbol table" section))
    (/ len entsize)))

(define* (elf-symbol-table-ref elf section n #:optional strtab)
  (let ((bv (elf-bytes elf))
        (byte-order (elf-byte-order elf))
        (stroff (and strtab (elf-section-offset strtab)))
        (base (elf-section-offset section))
        (len (elf-section-size section))
        (entsize (elf-section-entsize section)))
    (unless (<= (* (1+ n) entsize) len)
      (error "out of range symbol table access" section n))
    (case (elf-word-size elf)
      ((4)
       (unless (<= 16 entsize)
         (error "bad entsize for symbol table" section))
       (parse-elf32-symbol bv (+ base (* n entsize)) stroff byte-order))
      ((8)
       (unless (<= 24 entsize)
         (error "bad entsize for symbol table" section))
       (parse-elf64-symbol bv (+ base (* n entsize)) stroff byte-order))
      (else (error "bad word size" elf)))))

;; Legal values for ST_BIND subfield of st_info (symbol binding).

(define STB_LOCAL	0)		; Local symbol
(define STB_GLOBAL	1)		; Global symbol
(define STB_WEAK	2)		; Weak symbol
(define STB_NUM		3)		; Number of defined types.
(define STB_LOOS	10)		; Start of OS-specific
(define STB_GNU_UNIQUE	10)		; Unique symbol.
(define STB_HIOS	12)		; End of OS-specific
(define STB_LOPROC	13)		; Start of processor-specific
(define STB_HIPROC	15)		; End of processor-specific

;; Legal values for ST_TYPE subfield of st_info (symbol type).

(define STT_NOTYPE	0)		; Symbol type is unspecified
(define STT_OBJECT	1)		; Symbol is a data object
(define STT_FUNC	2)		; Symbol is a code object
(define STT_SECTION	3)		; Symbol associated with a section
(define STT_FILE	4)		; Symbol's name is file name
(define STT_COMMON	5)		; Symbol is a common data object
(define STT_TLS		6)		; Symbol is thread-local data objec
(define STT_NUM		7)		; Number of defined types.
(define STT_LOOS	10)		; Start of OS-specific
(define STT_GNU_IFUNC	10)		; Symbol is indirect code object
(define STT_HIOS	12)		; End of OS-specific
(define STT_LOPROC	13)		; Start of processor-specific
(define STT_HIPROC	15)		; End of processor-specific

;; Symbol visibility specification encoded in the st_other field.

(define STV_DEFAULT	0)		; Default symbol visibility rules
(define STV_INTERNAL	1)		; Processor specific hidden class
(define STV_HIDDEN	2)		; Sym unavailable in other modules
(define STV_PROTECTED	3)		; Not preemptible, not exported

(define (elf-symbol-binding sym)
  (ash (elf-symbol-info sym) -4))

(define (elf-symbol-type sym)
  (logand (elf-symbol-info sym) #xf))

(define (elf-symbol-visibility sym)
  (logand (elf-symbol-other sym) #x3))

(define NT_GNU_ABI_TAG 1)
(define NT_GNU_HWCAP 2)
(define NT_GNU_BUILD_ID 3)
(define NT_GNU_GOLD_VERSION 4)

(define-record-type <elf-note>
  (make-elf-note name desc type)
  elf-note?
  (name elf-note-name)
  (desc elf-note-desc)
  (type elf-note-type))

(define (parse-elf-note elf section)
  (let ((bv (elf-bytes elf))
        (byte-order (elf-byte-order elf))
        (offset (elf-section-offset section)))
    (unless (<= (+ offset 12) (bytevector-length bv))
      (error "corrupt ELF (offset out of range)" offset))
    (let ((namesz (bytevector-u32-ref bv offset byte-order))
          (descsz (bytevector-u32-ref bv (+ offset 4) byte-order))
          (type (bytevector-u32-ref bv (+ offset 8) byte-order)))
      (unless (<= (+ offset 12 namesz descsz) (bytevector-length bv))
        (error "corrupt ELF (offset out of range)" offset))
      (let ((name (make-bytevector (1- namesz)))
            (desc (make-bytevector descsz)))
        (bytevector-copy! bv (+ offset 12) name 0 (1- namesz))
        (bytevector-copy! bv (+ offset 12 namesz) desc 0 descsz)
        (make-elf-note (utf8->string name) desc type)))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2019 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 ftp-client)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-31)
  #:use-module (ice-9 binary-ports)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:export (ftp-connection?
            ftp-connection-addrinfo

            connect*
            ftp-open
            ftp-close
            ftp-chdir
            ftp-size
            ftp-list
            ftp-retr))

;;; Commentary:
;;;
;;; Simple FTP client (RFC 959).
;;;
;;; Code:

;; TODO: Use SRFI-3{4,5} error conditions.

(define-record-type <ftp-connection>
  (%make-ftp-connection socket addrinfo)
  ftp-connection?
  (socket    ftp-connection-socket)
  (addrinfo  ftp-connection-addrinfo))

(define %ftp-ready-rx
  (make-regexp "^([0-9]{3}) (.+)$"))

(define (%ftp-listen port)
  (let loop ((line (read-line port)))
    (cond ((eof-object? line) (values line #f))
          ((regexp-exec %ftp-ready-rx line)
           =>
           (lambda (match)
             (values (string->number (match:substring match 1))
                     (match:substring match 2))))
          (else
           (loop (read-line port))))))

(define (%ftp-command command expected-code port)
  (format port "~A~A~A" command (string #\return) (string #\newline))
  (let-values (((code message) (%ftp-listen port)))
    (if (eqv? code expected-code)
        message
        (throw 'ftp-error port command code message))))

(define (%ftp-login user pass port)
  (let ((command (string-append "USER " user
                                (string #\return) (string #\newline))))
    (display command port)
    (let-values (((code message) (%ftp-listen port)))
      (case code
        ((230)  #t)
        ((331) (%ftp-command (string-append "PASS " pass) 230 port))
        (else  (throw 'ftp-error port command code message))))))

(define-syntax-rule (catch-EINPROGRESS body ...)
  (catch 'system-error
    (lambda ()
      body ...)
    (lambda args
      (unless (= (system-error-errno args) EINPROGRESS)
        (apply throw args)))))

;; XXX: For lack of a better place.
(define* (connect* s sockaddr #:optional timeout)
  "When TIMEOUT is omitted or #f, this procedure is equivalent to 'connect'.
When TIMEOUT is a number, it is the (possibly inexact) maximum number of
seconds to wait for the connection to succeed."
  (define (raise-error errno)
    (throw 'system-error 'connect* "~A"
           (list (strerror errno))
           (list errno)))

  (if timeout
      (let ((flags (fcntl s F_GETFL)))
        (fcntl s F_SETFL (logior flags O_NONBLOCK))
        (catch-EINPROGRESS (connect s sockaddr))
        (match (select '() (list s) (list s) timeout)
          ((() () ())
           ;; Time is up!
           (raise-error ETIMEDOUT))
          ((() (write) ())
           ;; Check for ECONNREFUSED and the likes.
           (fcntl s F_SETFL flags)
           (let ((errno (getsockopt s SOL_SOCKET SO_ERROR)))
             (unless (zero? errno)
               (raise-error errno))))
          ((() () (except))
           ;; Seems like this cannot really happen, but who knows.
           (let ((errno (getsockopt s SOL_SOCKET SO_ERROR)))
             (raise-error errno)))))
      (connect s sockaddr)))

(define* (ftp-open host #:optional (port "ftp")
                        #:key timeout
                              (username "anonymous")
                              (password "guix@example.com"))
  "Open an FTP connection to HOST on PORT (a service-identifying string,
or a TCP port number), and return it.

When TIMEOUT is not #f, it must be a (possibly inexact) number denoting the
maximum duration in seconds to wait for the connection to complete; passed
TIMEOUT, an ETIMEDOUT error is raised."
  ;; Using "ftp" for PORT instead of 21 allows 'getaddrinfo' to return only
  ;; TCP/IP addresses (otherwise it would return SOCK_DGRAM and SOCK_RAW
  ;; addresses as well.)  With our bootstrap Guile, which includes a
  ;; statically-linked NSS, resolving "ftp" works well, as long as
  ;; /etc/services is available.

  (define addresses
    (getaddrinfo host
                 (if (number? port) (number->string port) port)
                 (if (number? port)
                     (logior AI_ADDRCONFIG AI_NUMERICSERV)
                     AI_ADDRCONFIG)))

  (let loop ((addresses addresses))
    (match addresses
      ((ai rest ...)
       (let ((s (socket (addrinfo:fam ai)
                        ;; TCP/IP only
                        SOCK_STREAM IPPROTO_IP)))

         (catch 'system-error
           (lambda ()
             (connect* s (addrinfo:addr ai) timeout)
             (setvbuf s 'line)
             (let-values (((code message) (%ftp-listen s)))
               (if (eqv? code 220)
                   (begin
                     ;;(%ftp-command "OPTS UTF8 ON" 200 s)
                     (%ftp-login username password s)
                     (%make-ftp-connection s ai))
                   (begin
                     (close s)
                     (throw 'ftp-error s "log-in" code message)))))

           (lambda args
             ;; Connection failed, so try one of the other addresses.
             (close s)
             (if (null? rest)
                 (apply throw args)
                 (loop rest)))))))))

(define (ftp-close conn)
  (close (ftp-connection-socket conn)))

(define %char-set:not-slash
  (char-set-complement (char-set #\/)))

(define (ftp-chdir conn dir)
  "Change to directory DIR."

  ;; On ftp.gnupg.org, "PASV" right after "CWD /gcrypt/gnupg" hangs.  Doing
  ;; CWD in two steps works, so just do this.
  (let ((components (string-tokenize dir %char-set:not-slash)))
    (fold (lambda (dir result)
            (%ftp-command (string-append "CWD " dir) 250
                          (ftp-connection-socket conn)))
          #f
          (if (string-prefix? "/" dir)
              (cons "/" components)
              components))))

(define (ftp-size conn file)
  "Return the size in bytes of FILE."

  ;; Ask for "binary mode", otherwise some servers, such as sourceware.org,
  ;; fail with 550 ("SIZE not allowed in ASCII mode").
  (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))

  (let ((message (%ftp-command (string-append "SIZE " file) 213
                               (ftp-connection-socket conn))))
    (string->number (string-trim-both message))))

(define (ftp-pasv conn)
  (define %pasv-rx
    (make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))

  (let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
    (cond ((regexp-exec %pasv-rx message)
           =>
           (lambda (match)
             (+ (* (string->number (match:substring match 5)) 256)
                (string->number (match:substring match 6)))))
          (else
           (throw 'ftp-error conn "PASV" 227 message)))))

(define (ftp-epsv conn)
  (let* ((message (%ftp-command "EPSV" 229 (ftp-connection-socket conn))))
    (string->number
     (match:substring (string-match "\\(...([0-9]+).\\)" message) 1))))

(define (ftp-passive conn)
  "Enter passive mode using EPSV or PASV, return a data connection port on
success."
  ;; IPv6 only works with EPSV, so try it first.
  (or (false-if-exception (ftp-epsv conn)) (ftp-pasv conn)))

(define (address-with-port sa port)
  "Return a socket-address object based on SA, but with PORT."
  (let ((fam  (sockaddr:fam sa))
        (addr (sockaddr:addr sa)))
    (cond ((= fam AF_INET)
           (make-socket-address fam addr port))
          ((= fam AF_INET6)
           (make-socket-address fam addr port
                                (sockaddr:flowinfo sa)
                                (sockaddr:scopeid sa)))
          (else #f))))

(define* (ftp-list conn #:optional directory #:key timeout)
  (if directory
      (ftp-chdir conn directory))

  (let* ((port (ftp-passive conn))
         (ai   (ftp-connection-addrinfo conn))
         (s    (socket (addrinfo:fam ai) (addrinfo:socktype ai)
                       (addrinfo:protocol ai))))
    (connect* s (address-with-port (addrinfo:addr ai) port) timeout)
    (setvbuf s 'line)

    (dynamic-wind
      (lambda () #t)
      (lambda ()
        (%ftp-command "LIST" 150 (ftp-connection-socket conn))

        (let loop ((line   (read-line s))
                   (result '()))
          (cond ((eof-object? line) (reverse result))
                ((regexp-exec %ftp-ready-rx line)
                 =>
                 (lambda (match)
                   (let ((code (string->number (match:substring match 1))))
                     (if (= 126 code)
                         (reverse result)
                         (throw 'ftp-error conn "LIST" code)))))
                (else
                 (loop (read-line s)
                       (match (reverse (string-tokenize line))
                         ((file _ ... permissions)
                          (let ((type (case (string-ref permissions 0)
                                        ((#\d) 'directory)
                                        (else 'file))))
                            (cons (list file type) result)))
                         ((file _ ...)
                          (cons (cons file 'file) result))))))))
      (lambda ()
        (close s)
        (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
          (or (eqv? code 226)
              (throw 'ftp-error conn "LIST" code message)))))))

(define* (ftp-retr conn file #:optional directory
                   #:key timeout)
  "Retrieve FILE from DIRECTORY (or, if omitted, the current directory) from
FTP connection CONN.  Return a binary port to that file.  The returned port
must be closed before CONN can be used for other purposes."
  (if directory
      (ftp-chdir conn directory))

  ;; Ask for "binary mode".
  (%ftp-command "TYPE I" 200 (ftp-connection-socket conn))

  (let* ((port (ftp-passive conn))
         (ai   (ftp-connection-addrinfo conn))
         (s    (with-fluids ((%default-port-encoding #f))
                 (socket (addrinfo:fam ai) (addrinfo:socktype ai)
                         (addrinfo:protocol ai)))))
    (define (terminate)
      (close s)
      (let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
        (or (eqv? code 226)
            (throw 'ftp-error conn "LIST" code message))))

    (connect* s (address-with-port (addrinfo:addr ai) port) timeout)
    (setvbuf s 'line)

    (%ftp-command (string-append "RETR " file)
                  150 (ftp-connection-socket conn))

    (make-custom-binary-input-port "FTP RETR port"
                                   (rec (read! bv start count)
                                        (match (get-bytevector-n! s bv
                                                                  start count)
                                          ((? eof-object?) 0)
                                          (0
                                           ;; Nothing available yet, so try
                                           ;; again.  This is important because
                                           ;; the return value of `read!' makes
                                           ;; it impossible to distinguish
                                           ;; between "not yet" and "EOF".
                                           (read! bv start count))
                                          (read read)))
                                   #f #f          ; no get/set position
                                   terminate)))

;;; ftp-client.scm ends here