code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
;;; Copyright © 2017, 2018 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 import github)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (guix utils)
  #:use-module ((guix download) #:prefix download:)
  #:use-module (guix import utils)
  #:use-module (guix import json)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module (guix http-client)
  #:use-module (web uri)
  #:export (%github-updater))

(define (find-extension url)
  "Return the extension of the archive e.g. '.tar.gz' given a URL, or
false if none is recognized"
  (find (lambda (x) (string-suffix? x url))
        (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar"
              ".tgz" ".tbz" ".love")))

(define (updated-github-url old-package new-version)
  ;; Return a url for the OLD-PACKAGE with NEW-VERSION.  If no source url in
  ;; the OLD-PACKAGE is a GitHub url, then return false.

  (define (updated-url url)
    (if (string-prefix? "https://github.com/" url)
        (let ((ext     (or (find-extension url) ""))
              (name    (package-name old-package))
              (version (package-version old-package))
              (prefix  (string-append "https://github.com/"
                                      (github-user-slash-repository url)))
              (repo    (github-repository url)))
          (cond
           ((string-suffix? (string-append "/tarball/v" version) url)
            (string-append prefix "/tarball/v" new-version))
           ((string-suffix? (string-append "/tarball/" version) url)
            (string-append prefix "/tarball/" new-version))
           ((string-suffix? (string-append "/archive/v" version ext) url)
            (string-append prefix "/archive/v" new-version ext))
           ((string-suffix? (string-append "/archive/" version ext) url)
            (string-append prefix "/archive/" new-version ext))
           ((string-suffix? (string-append "/archive/" name "-" version ext)
                            url)
            (string-append prefix "/archive/" name "-" new-version ext))
           ((string-suffix? (string-append "/releases/download/v" version "/"
                                           name "-" version ext)
                            url)
            (string-append prefix "/releases/download/v" new-version "/" name
                           "-" new-version ext))
           ((string-suffix? (string-append "/releases/download/" version "/"
                                           name "-" version ext)
                            url)
            (string-append prefix "/releases/download/" new-version "/" name
                           "-" new-version ext))
           ((string-suffix? (string-append "/releases/download/" version "/"
                                           repo "-" version ext)
                            url)
            (string-append prefix "/releases/download/" new-version "/" repo
                           "-" new-version ext))
           ((string-suffix? (string-append "/releases/download/" repo "-"
                                           version "/" repo "-" version ext)
                            url)
            (string-append "/releases/download/" repo "-" version "/" repo "-"
                           version ext))
           (#t #f))) ; Some URLs are not recognised.
        #f))

  (let ((source-url (and=> (package-source old-package) origin-uri))
        (fetch-method (and=> (package-source old-package) origin-method)))
    (if (eq? fetch-method download:url-fetch)
        (match source-url
          ((? string?)
           (updated-url source-url))
          ((source-url ...)
           (find updated-url source-url)))
        #f)))

(define (github-package? package)
  "Return true if PACKAGE is a package from GitHub, else false."
  (not (eq? #f (updated-github-url package "dummy"))))

(define (github-repository url)
  "Return a string e.g. bedtools2 of the name of the repository, from a string
URL of the form 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'"
  (match (string-split (uri-path (string->uri url)) #\/)
    ((_ owner project . rest)
     (string-append project))))

(define (github-user-slash-repository url)
  "Return a string e.g. arq5x/bedtools2 of the owner and the name of the
repository separated by a forward slash, from a string URL of the form
'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'"
  (match (string-split (uri-path (string->uri url)) #\/)
    ((_ owner project . rest)
     (string-append owner "/" project))))

(define %github-token
  ;; Token to be passed to Github.com to avoid the 60-request per hour
  ;; limit, or #f.
  (make-parameter (getenv "GUIX_GITHUB_TOKEN")))

(define (fetch-releases-or-tags url)
  "Fetch the list of \"releases\" or, if it's empty, the list of tags for the
repository at URL.  Return the corresponding JSON dictionaries (hash tables),
or #f if the information could not be retrieved.

We look at both /releases and /tags because the \"release\" feature of GitHub
is little used; often, people simply provide a tag.  What's confusing is that
tags show up in the \"Releases\" tab of the web UI.  For instance,
'https://github.com/aconchillo/guile-json/releases' shows a number of
\"releases\" (really: tags), whereas
'https://api.github.com/repos/aconchillo/guile-json/releases' returns the
empty list."
  (define release-url
    (string-append "https://api.github.com/repos/"
                   (github-user-slash-repository url)
                   "/releases"))
  (define tag-url
    (string-append "https://api.github.com/repos/"
                   (github-user-slash-repository url)
                   "/tags"))

  (define headers
    ;; Ask for version 3 of the API as suggested at
    ;; <https://developer.github.com/v3/>.
    `((Accept . "application/vnd.github.v3+json")
      (user-agent . "GNU Guile")))

  (define (decorate url)
    (if (%github-token)
        (string-append url "?access_token=" (%github-token))
        url))

  (match (json-fetch (decorate release-url) #:headers headers)
    (()
     ;; We got the empty list, presumably because the user didn't use GitHub's
     ;; "release" mechanism, but hopefully they did use Git tags.
     (json-fetch (decorate tag-url) #:headers headers))
    (x x)))

(define (latest-released-version url package-name)
  "Return a string of the newest released version name given a string URL like
'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of
the package e.g. 'bedtools2'.  Return #f if there is no releases"
  (let* ((json (fetch-releases-or-tags url)))
    (if (eq? json #f)
        (if (%github-token)
            (error "Error downloading release information through the GitHub
API when using a GitHub token")
            (error "Error downloading release information through the GitHub
API. This may be fixed by using an access token and setting the environment
variable GUIX_GITHUB_TOKEN, for instance one procured from
https://github.com/settings/tokens"))
        (let loop ((releases
                    (filter
                     (lambda (x)
                       ;; example pre-release:
                       ;; https://github.com/wwood/OrfM/releases/tag/v0.5.1
                       ;; or an all-prerelease set
                       ;; https://github.com/powertab/powertabeditor/releases
                       (not (hash-ref x "prerelease")))
                     json)))
          (match releases
            (()                                   ;empty release list
             #f)
            ((release . rest)                     ;one or more releases
             (let ((tag (or (hash-ref release "tag_name") ;a "release"
                            (hash-ref release "name")))   ;a tag
                   (name-length (string-length package-name)))
               ;; some tags include the name of the package e.g. "fdupes-1.51"
               ;; so remove these
               (if (and (< name-length (string-length tag))
                        (string=? (string-append package-name "-")
                                  (substring tag 0 (+ name-length 1))))
                   (substring tag (+ name-length 1))
                   ;; some tags start with a "v" e.g. "v0.25.0"
                   ;; where some are just the version number
                   (if (string-prefix? "v" tag)
                       (substring tag 1)

                       ;; Finally, reject tags that don't start with a digit:
                       ;; they may not represent a release.
                       (if (and (not (string-null? tag))
                                (char-set-contains? char-set:digit
                                                    (string-ref tag 0)))
                           tag
                           (loop rest)))))))))))

(define (latest-release pkg)
  "Return an <upstream-source> for the latest release of PKG."
  (define (origin-github-uri origin)
    (match (origin-uri origin)
      ((? string? url)
       url)                                       ;surely a github.com URL
      ((urls ...)
       (find (cut string-contains <> "github.com") urls))))

  (let* ((source-uri (origin-github-uri (package-source pkg)))
         (name (package-name pkg))
         (newest-version (latest-released-version source-uri name)))
    (if newest-version
        (upstream-source
         (package name)
         (version newest-version)
         (urls (list (updated-github-url pkg newest-version))))
        #f))) ; On GitHub but no proper releases

(define %github-updater
  (upstream-updater
   (name 'github)
   (description "Updater for GitHub packages")
   (pred github-package?)
   (latest latest-release)))


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

(define-module (guix import gnome)
  #:use-module (guix upstream)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (guix http-client)
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (web uri)
  #:use-module (ice-9 match)
  #:export (%gnome-updater))

;;; Commentary:
;;;
;;; This package provides not an actual importer but simply an updater for
;;; GNOME packages.  It grabs package meta-data from 'cache.json' files
;;; available on ftp.gnome.org.
;;;
;;; Code:

(define (jsonish->upstream-source name jsonish)
  "Return an <upstream-source> object for package NAME, using JSONISH as the
source for metadata."
  (match jsonish
    ((version . dictionary)
     (upstream-source
      (package name)
      (version version)
      (urls (filter-map (lambda (extension)
                          (match (hash-ref dictionary extension)
                            (#f
                             #f)
                            ((? string? relative-url)
                             (string-append "mirror://gnome/sources/"
                                            name "/" relative-url))))
                        '("tar.lz" "tar.xz" "tar.bz2" "tar.gz")))))))

(define (latest-gnome-release package)
  "Return the latest release of PACKAGE, a GNOME package, or #f if it could
not be determined."
  (define %not-dot
    (char-set-complement (char-set #\.)))

  (define (even-minor-version? version)
    (match (string-tokenize version %not-dot)
      (((= string->number major) (= string->number minor) . rest)
       (and minor (even? minor)))
      (_
       #t)))                                      ;cross fingers

  (define upstream-name
    ;; Some packages like "NetworkManager" have camel-case names.
    (package-upstream-name package))

  (guard (c ((http-get-error? c)
             (if (= 404 (http-get-error-code c))
                 #f
                 (raise c))))
    (let* ((port (http-fetch/cached
                  (string->uri (string-append
                                "https://ftp.gnome.org/pub/gnome/sources/"
                                upstream-name "/cache.json"))

                  ;; ftp.gnome.org supports 'if-Modified-Since', so the local
                  ;; cache can expire early.
                  #:ttl (* 60 10)))
           (json (json->scm port)))
      (close-port port)
      (match json
        ((4 (? hash-table? releases) _ ...)
         (let* ((releases (hash-ref releases upstream-name))
                (latest   (hash-fold (lambda (key value result)
                                       (cond ((even-minor-version? key)
                                              (match result
                                                (#f
                                                 (cons key value))
                                                ((newest . _)
                                                 (if (version>? key newest)
                                                     (cons key value)
                                                     result))))
                                             (else
                                              result)))
                                     #f
                                     releases)))
           (and latest
                (jsonish->upstream-source upstream-name latest))))))))

(define %gnome-updater
  (upstream-updater
   (name 'gnome)
   (description "Updater for GNOME packages")
   (pred (url-prefix-predicate "mirror://gnome/"))
   (latest latest-gnome-release)))

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 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 import gnu)
  #:use-module (guix gnu-maintenance)
  #:use-module (guix import utils)
  #:use-module (guix utils)
  #:use-module (guix store)
  #:use-module (gcrypt hash)
  #:use-module (guix base32)
  #:use-module (guix upstream)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (web uri)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:export (gnu->guix-package))

;;; Commentary:
;;;
;;; Generate a package declaration template for the latest version of a GNU
;;; package, using meta-data available upstream for the package.
;;;
;;; Code:

(define (qualified-url url)
  "Return a fully-qualified URL based on URL."
  (if (string-prefix? "/" url)
      (string-append "http://www.gnu.org" url)
      url))

(define (preferred-archive-type release)
  "Return the preferred type of archive for downloading RELEASE."
  (find (cute member <> (upstream-source-archive-types release))
        '("xz" "lz" "bz2" "tbz2" "gz" "tgz" "Z")))

(define* (gnu-package->sexp package release
                            #:key (key-download 'interactive))
  "Return the 'package' sexp for the RELEASE (a <gnu-release>) of PACKAGE (a
<gnu-package>), or #f upon failure.  Use KEY-DOWNLOAD as the OpenPGP key
download policy (see 'download-tarball' for details.)"
  (define name
    (gnu-package-name package))

  (define url-base
    ;; XXX: We assume that RELEASE's directory starts with "/gnu".
    (string-append "mirror:/"
                   (match (upstream-source-urls release)
                     ((url rest ...)
                      (dirname (uri-path (string->uri url)))))
                   "/" name "-"))

  (define archive-type
    (preferred-archive-type release))

  (define url
    (find (cut string-suffix? archive-type <>)
          (upstream-source-urls release)))

  (define sig-url
    (find (cute string-suffix? (string-append archive-type ".sig") <>)
          (upstream-source-signature-urls release)))

  (with-store store
    (match (download-tarball store url sig-url
                             #:key-download key-download)
      ((? string? tarball)
       `(package
          (name ,name)
          (version ,(upstream-source-version release))
          (source (origin
                    (method url-fetch)
                    (uri (string-append ,url-base version
                                        ,(string-append ".tar." archive-type)))
                    (sha256
                     (base32
                      ,(bytevector->nix-base32-string
                        (file-sha256 tarball))))))
          (build-system gnu-build-system)
          (synopsis ,(gnu-package-doc-summary package))
          (description ,(gnu-package-doc-description package))
          (home-page ,(match (gnu-package-doc-urls package)
                        ((head . tail) (qualified-url head))))
          (license find-by-yourself!)))
      (#f                     ;failure to download or authenticate the tarball
       #f))))

(define* (gnu->guix-package name
                            #:key (key-download 'interactive))
  "Return the package declaration for NAME as an s-expression.  Use
KEY-DOWNLOAD as the OpenPGP key download policy (see 'download-tarball' for
details.)"
  (match (latest-release name)
    ((? upstream-source? release)
     (let ((version (upstream-source-version release)))
       (match (find-package name)
         (#f
          (raise (condition
                  (&message
                   (message "couldn't find meta-data for GNU package")))))
         (info
          (gnu-package->sexp info release #:key-download key-download)))))
    (_
     (raise (condition
             (&message
              (message
               "failed to determine latest release of GNU package")))))))

;;; gnu.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
;;;
;;; 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 import gopkg)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module (srfi srfi-11)
  #:use-module (texinfo string-utils) ; transform-string
  #:use-module (gcrypt hash)
  ;; #:use-module (guix hash)
  #:use-module (guix base32)
  #:use-module (guix serialization)
  #:use-module (guix utils)
  #:use-module (guix build utils)
  #:use-module ((guix licenses) #:prefix license:)
  #:export (gopkg->guix-package))

(define (vcs-file? file stat)
  ;; TODO: Factorize
  (case (stat:type stat)
    ((directory)
     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
    ((regular)
     ;; Git sub-modules have a '.git' file that is a regular text file.
     (string=? (basename file) ".git"))
    (else
     #f)))

(define (file->hash-base32 file)
  "Return hash of FILE in nix base32 sha256 format.  If FILE is a directory,
exclude vcs files."
  (let-values (((port get-hash) (open-sha256-port)))
    (write-file file port #:select? (negate vcs-file?))
    (force-output port)
    (bytevector->nix-base32-string (get-hash))))

(define (git->hash url commit file)
  "Clone git repository and return FILE hash in nix base32 sha256 format."
  (if (not (file-exists? (string-append file "/.git")))
      (git-fetch url commit file #:recursive? #f))
  (file->hash-base32 file))

(define (git-ref->commit path tag)
  "Return commit number coresponding to git TAG.  Return \"XXX\" if tag is not
found."
  (define (loop port)
    (let ((line (read-line port)))
      (cond
       ((eof-object? line)              ; EOF
        (begin
          (close-port port)
          "XXX"))
       ((string-match tag line)         ; Match tag
        (let ((commit (car (string-split (transform-string line #\tab " ")
                                         #\ ))))
          commit))
       (else                            ; Else
        (loop port)))))

  (let ((file (if (file-exists? (string-append path "/.git/packed-refs"))
                  (string-append path "/.git/packed-refs")
                  (string-append path "/.git/FETCH_HEAD"))))
    (loop (open-input-file file))))

(define* (git-fetch url commit directory
                    #:key (git-command "git") recursive?)
  "Fetch COMMIT from URL into DIRECTORY.  COMMIT must be a valid Git commit
identifier.  When RECURSIVE? is true, all the sub-modules of URL are fetched,
recursively.  Return #t on success, #f otherwise."
  (mkdir-p directory)

  (with-directory-excursion directory
    (invoke git-command "init")
    (invoke git-command "remote" "add" "origin" url)
    (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit))
        (invoke git-command "checkout" "FETCH_HEAD")
        (begin
          (invoke git-command "fetch" "origin")
          (if (not (zero? (system* git-command "checkout" commit)))
              (let ((commit-hash (git-ref->commit directory commit)))
                (invoke git-command "checkout" "master")
                (if (not (equal? "XXX" commit-hash)) ;HACK else stay on master
                    (zero? (system* git-command "checkout" commit-hash))))
              #t)))))

;;
;; Append attributes.
;;

(define (append-inputs inputs name)
  "Return list with new input corresponding to package NAME."
  (let ((unquote-name (list 'unquote (string->symbol name))))
    (append inputs (list (list name unquote-name)))))

;;
;; Parse attributes.
;;

(define (url->package-name url)
  "Compute URL and return package name."
  (let* ((url-no-slash (string-replace-substring url "/" "-"))
         (url-no-slash-no-dot (string-replace-substring url-no-slash
                                                        "." "-")))
    (string-downcase (string-append "go-" url-no-slash-no-dot))))

(define (cut-url url)
  "Return URL without protocol prefix and git file extension."
  (string-replace-substring
   (cond
    ((string-match "http://"  url)
     (string-replace-substring url "http://" ""))
    ((string-match "https://" url)
     (string-replace-substring url "https://" ""))
    ((string-match "git://"   url)
     (string-replace-substring url "git://" ""))
    (else
     url))
   ".git" ""))

(define (url->dn url)
  "Return the web site DN form url 'gnu.org/software/guix' --> 'gnu.org'"
  (car (string-split url #\/)))

(define (url->git-url url)
  (string-append "https://" url ".git"))

(define (comment? line)
  "Return #t if LINE start with comment delimiter, else return #f."
  (eq? (string-ref (string-trim line) 0) #\#))

(define (empty-line? line)
  "Return #t if LINE is empty, else #f."
  (string-null? (string-trim line)))

(define (attribute? line attribute)
  "Return #t if LINE contain ATTRIBUTE."
  (equal? (string-trim-right
           (string-trim
            (car (string-split line #\=)))) attribute))

(define (attribute-by-name line name)
  "Return attribute value corresponding to NAME."
  (let* ((line-no-attribut-name (string-replace-substring
                                 line
                                 (string-append name " = ") ""))
         (value-no-double-quote (string-replace-substring
                                 line-no-attribut-name
                                 "\"" "")))
    (string-trim value-no-double-quote)))

;;
;; Packages functions.
;;

(define (make-go-sexp->package packages dependencies
                               name url version revision
                               commit str-license home-page
                               git-url is-dep? hash)
  "Create Guix sexp package for Go software NAME. Return new package sexp."
  (define (package-inputs)
    (if (not is-dep?)
        `((native-inputs ,(list 'quasiquote dependencies)))
        '()))

  (values
   `(define-public ,(string->symbol name)
      (let ((commit ,commit)
            (revision ,revision))
        (package
          (name ,name)
          (version (git-version ,version revision commit))
          (source (origin
                    (method git-fetch)
                    (uri (git-reference
                          (url ,git-url)
                          (commit commit)))
                    (file-name (git-file-name name version))
                    (sha256
                     (base32
                      ,hash))))
          (build-system go-build-system)
          (arguments
           '(#:import-path ,url))
          ,@(package-inputs)
          (home-page ,home-page)
          (synopsis "XXX")
          (description "XXX")
          (license #f))))))

(define (create-package->packages+dependencies packages dependencies
                                               url version directory
                                               revision commit
                                               constraint? is-dep?)
  "Return packages and dependencies with new package sexp corresponding to
URL."
  (call-with-temporary-directory
   (lambda (dir)
     (let ((name      (url->package-name url))
           (home-page (string-append "https://" url))
           (git-url   (url->git-url url))
           (synopsis    "XXX")
           (description "XXX")
           (license     "XXX"))
       (let ((hash (git->hash (url->git-url url)
                              commit
                              dir))
             (commit-hash (if (< (string-length commit) 40)
                              (git-ref->commit dir
                                               commit)
                              commit)))
         (values
          (append packages
                  (list
                   (make-go-sexp->package packages dependencies
                                          name url version
                                          revision commit-hash
                                          license home-page
                                          git-url is-dep? hash)))
          (if constraint?
              (append-inputs dependencies name)
              dependencies)))))))

(define (parse-dependencies->packages+dependencies port constraint?
                                                   packages dependencies)
  "Parse one dependencies in PORT, and return packages and dependencies list."
  (let ((url "XXX")
        (version "0.0.0")
        (revision "0")
        (commit "XXX"))
    (define (loop port url commit packages dependencies)
      (let ((line (read-line port)))
        (cond
         ((eof-object? line)            ; EOF
          (values packages dependencies))
         ((empty-line? line)                               ; Empty line
          (if (not (or (equal? "k8s.io" (url->dn url))     ; HACK bypass k8s
                       (equal? "golang.org" (url->dn url)) ; HACK bypass golang
                       (equal? "cloud.google.com" (url->dn url)))) ; HACK bypass cloud.google
              (create-package->packages+dependencies packages dependencies
                                                     url version port revision
                                                     commit
                                                     constraint? #t)
              (values packages dependencies)))
         ((comment? line)               ; Comment
          (loop port url commit
                packages dependencies))
         ((attribute? line "name")      ; Name
          (loop port
                (attribute-by-name line "name")
                commit
                packages dependencies))
         ((attribute? line "revision")  ; Revision
          (loop port
                url
                (attribute-by-name line "revision")
                packages dependencies))
         ((attribute? line "version")   ; Version
          (loop port
                url
                (attribute-by-name line "version")
                packages dependencies))
         ((attribute? line "branch")    ; Branch
          (loop port
                url
                (attribute-by-name line "branch")
                packages dependencies))
         ((string-match "=" line)       ; Other options
          (loop port url commit
                packages dependencies))
         (else (loop port url commit
                     packages dependencies)))))
    (loop port url commit
          packages dependencies)))

(define (parse-toml->packages+dependencies port packages dependencies)
  "Read toml file on PORT and return all dependencies packages sexp and list
of constraint dependencies."
  (define (loop port packages dependencies)
    (let ((line (read-line port)))
      (cond
       ((eof-object? line)              ; EOF
        (values packages dependencies))
       ((empty-line? line)              ; Empty line
        (loop port packages dependencies))
       ((comment? line)                 ; Comment
        (loop port packages dependencies))
       ((equal? line "[prune]")         ; Ignored
        (loop port packages dependencies))
       ((equal? "[[constraint]]" line)  ; Direct dependencies
        (let-values (((packages dependencies)
                      (parse-dependencies->packages+dependencies port #t
                                                                 packages
                                                                 dependencies)))
          (loop port packages dependencies)))
       ((equal? "[[override]]" line)    ; Dependencies of dependencies
        (let-values (((packages dependencies)
                      (parse-dependencies->packages+dependencies port #f
                                                                 packages
                                                                 dependencies)))
          (loop port packages dependencies)))
       (else (loop port packages dependencies)))))
  (loop port packages dependencies))

(define (gopkg-dep->packages+dependencies path)
  "Open toml file if exist and parse it and return packages sexp and
dependencies list. Or return two empty list if file not found."
  (if (file-exists? path)
      (let ((port (open-input-file path)))
        (let-values (((packages dependencies)
                      (parse-toml->packages+dependencies port
                                                         '() '())))
          (close-port port)
          (values packages dependencies)))
      (values '() '())))

;;
;; Entry point.
;;

(define (gopkg->guix-package url branch)
  "Create package for git repository dans branch verison and all dependencies
sexp packages with Gopkg.toml file."
  (let ((name (url->package-name (cut-url url)))
        (version "0.0.0")
        (revision "0"))
    (call-with-temporary-directory
     (lambda (directory)
       (git-fetch url branch directory #:recursive? #f)

       (let-values (((packages dependencies)
                     (gopkg-dep->packages+dependencies
                      (string-append directory
                                     "/Gopkg.toml"))))
         (let-values (((packages dependencies)
                       (create-package->packages+dependencies packages dependencies
                                                              (cut-url url) version
                                                              directory
                                                              revision branch
                                                              #f #f)))
           (values packages)))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Nils Gillmann <ng0@n0.is>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import hackage)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-1)
  #:use-module ((guix download) #:select (download-to-store url-fetch))
  #:use-module ((guix utils) #:select (package-name->name+version
                                       canonical-newline-port))
  #:use-module (guix http-client)
  #:use-module ((guix import utils) #:select (factorize-uri recursive-import))
  #:use-module (guix import cabal)
  #:use-module (guix store)
  #:use-module (gcrypt hash)
  #:use-module (guix base32)
  #:use-module (guix memoization)
  #:use-module (guix upstream)
  #:use-module (guix packages)
  #:use-module ((guix utils) #:select (call-with-temporary-output-file))
  #:export (hackage->guix-package
            hackage-recursive-import
            %hackage-updater

            guix-package->hackage-name
            hackage-name->package-name
            hackage-fetch
            hackage-source-url
            hackage-cabal-url
            hackage-package?))

(define ghc-standard-libraries
  ;; List of libraries distributed with ghc (7.10.2). We include GHC itself as
  ;; some packages list it.
  '("array"
    "base"
    "bin-package-db"
    "binary"
    "bytestring"
    "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but
            ;; hackage-name->package-name takes this into account.
    "containers"
    "deepseq"
    "directory"
    "filepath"
    "ghc"
    "ghc-prim"
    "haskeline"
    "hoopl"
    "hpc"
    "integer-gmp"
    "pretty"
    "process"
    "rts"
    "template-haskell"
    "terminfo"
    "time"
    "transformers"
    "unix"
    "win32"
    "xhtml"))

(define package-name-prefix "ghc-")

(define (hackage-source-url name version)
  "Given a Hackage package NAME and VERSION, return a url to the source
tarball."
  (string-append "https://hackage.haskell.org/package/" name
                 "/" name "-" version ".tar.gz"))

(define* (hackage-cabal-url name #:optional version)
  "Given a Hackage package NAME and VERSION, return a url to the corresponding
.cabal file on Hackage.  If VERSION is #f or missing, the url for the latest
version is returned."
  (if version
      (string-append "https://hackage.haskell.org/package/"
                     name "-" version "/" name ".cabal")
      (string-append "https://hackage.haskell.org/package/"
                     name "/" name ".cabal")))

(define (hackage-name->package-name name)
  "Given the NAME of a Cabal package, return the corresponding Guix name."
  (if (string-prefix? package-name-prefix name)
      (string-downcase name)
      (string-append package-name-prefix (string-downcase name))))

(define guix-package->hackage-name
  (let ((uri-rx (make-regexp "https?://hackage.haskell.org/package/([^/]+)/.*"))
        (name-rx (make-regexp "(.*)-[0-9\\.]+")))
    (lambda (package)
      "Given a Guix package name, return the corresponding Hackage name."
      (let* ((source-url (and=> (package-source package) origin-uri))
             (name (match:substring (regexp-exec uri-rx source-url) 1)))
        (match (regexp-exec name-rx name)
          (#f name)
          (m (match:substring m 1)))))))

(define (hackage-fetch name-version)
  "Return the Cabal file for the package NAME-VERSION, or #f on failure.  If
the version part is omitted from the package name, then return the latest
version."
  (guard (c ((and (http-get-error? c)
                  (= 404 (http-get-error-code c)))
             #f))                       ;"expected" if package is unknown
    (let-values (((name version) (package-name->name+version name-version)))
      (let* ((url (hackage-cabal-url name version))
             (port (http-fetch url))
             (result (read-cabal (canonical-newline-port port))))
        (close-port port)
        result))))

(define string->license
  ;; List of valid values from
  ;; https://www.haskell.org
  ;; /cabal/release/cabal-latest/doc/API/Cabal/Distribution-License.html.
  (match-lambda
   ("GPL-2" 'gpl2)
   ("GPL-3" 'gpl3)
   ("GPL" "'gpl??")
   ("AGPL-3" 'agpl3)
   ("AGPL" "'agpl??")
   ("LGPL-2.1" 'lgpl2.1)
   ("LGPL-3" 'lgpl3)
   ("LGPL" "'lgpl??")
   ("BSD2" 'bsd-2)
   ("BSD3" 'bsd-3)
   ("MIT" 'expat)
   ("ISC" 'isc)
   ("MPL" 'mpl2.0)
   ("Apache-2.0" 'asl2.0)
   ((x) (string->license x))
   ((lst ...) `(list ,@(map string->license lst)))
   (_ #f)))

(define (cabal-dependencies->names cabal)
  "Return the list of dependencies names from the CABAL package object,
not including test suite dependencies or custom-setup dependencies."
  (let* ((lib (cabal-package-library cabal))
         (lib-deps (if (pair? lib)
                       (map cabal-dependency-name
                            (append-map cabal-library-dependencies lib))
                       '()))
         (exe (cabal-package-executables cabal))
         (exe-deps (if (pair? exe)
                       (map cabal-dependency-name
                            (append-map cabal-executable-dependencies exe))
                       '())))
    (delete-duplicates (append lib-deps exe-deps))))

(define (cabal-test-dependencies->names cabal)
  "Return the list of test suite dependencies from the CABAL package
object."
  (let* ((ts (cabal-package-test-suites cabal))
         (ts-deps (if (pair? ts)
                      (map cabal-dependency-name
                           (append-map cabal-test-suite-dependencies ts))
                      '())))
    ts-deps))

(define (cabal-custom-setup-dependencies->names cabal)
  "Return the list of custom-setup dependencies from the CABAL package
object."
  (let* ((custom-setup-dependencies (or (and=> (cabal-package-custom-setup cabal)
                                               cabal-custom-setup-dependencies)
                                        '())))
    (map cabal-dependency-name custom-setup-dependencies)))

(define (filter-dependencies dependencies own-name)
  "Filter the dependencies included with the GHC compiler from DEPENDENCIES, a
list with the names of dependencies.  OWN-NAME is the name of the Cabal
package being processed and is used to filter references to itself."
  (filter (lambda (d) (not (member (string-downcase d)
                                   (cons own-name ghc-standard-libraries))))
          dependencies))

(define* (hackage-module->sexp cabal #:key (include-test-dependencies? #t))
  "Return the `package' S-expression for a Cabal package.  CABAL is the
representation of a Cabal file as produced by 'read-cabal'."

  (define name
    (cabal-package-name cabal))

  (define version
    (cabal-package-version cabal))

  (define source-url
    (hackage-source-url name version))

  (define hackage-dependencies
    ((compose (cut filter-dependencies <>
                   (cabal-package-name cabal))
              (cut cabal-dependencies->names <>))
     cabal))

  (define hackage-native-dependencies
    ((compose (cut filter-dependencies <>
                   (cabal-package-name cabal))
              ;; FIXME: Check include-test-dependencies?
              (lambda (cabal)
                (append (if include-test-dependencies?
                            (cabal-test-dependencies->names cabal)
                            '())
                        (cabal-custom-setup-dependencies->names cabal))))
     cabal))

  (define dependencies
    (map (lambda (name)
           (list name (list 'unquote (string->symbol name))))
         (map hackage-name->package-name
              hackage-dependencies)))

  (define native-dependencies
    (map (lambda (name)
           (list name (list 'unquote (string->symbol name))))
         (map hackage-name->package-name
              hackage-native-dependencies)))

  (define (maybe-inputs input-type inputs)
    (match inputs
      (()
       '())
      ((inputs ...)
       (list (list input-type
                   (list 'quasiquote inputs))))))

  (define (maybe-arguments)
    (if (not include-test-dependencies?)
        '((arguments `(#:tests? #f)))
        '()))

  (let ((tarball (with-store store
                   (download-to-store store source-url))))
    (values
     `(package
        (name ,(hackage-name->package-name name))
        (version ,version)
        (source (origin
                  (method url-fetch)
                  (uri (string-append ,@(factorize-uri source-url version)))
                  (sha256
                   (base32
                    ,(if tarball
                         (bytevector->nix-base32-string (file-sha256 tarball))
                         "failed to download tar archive")))))
        (build-system haskell-build-system)
        ,@(maybe-inputs 'inputs dependencies)
        ,@(maybe-inputs 'native-inputs native-dependencies)
        ,@(maybe-arguments)
        (home-page ,(cabal-package-home-page cabal))
        (synopsis ,(cabal-package-synopsis cabal))
        (description ,(cabal-package-description cabal))
        (license ,(string->license (cabal-package-license cabal))))
     (append hackage-dependencies hackage-native-dependencies))))

(define hackage->guix-package
  (memoize
   (lambda* (package-name #:key
                          (include-test-dependencies? #t)
                          (port #f)
                          (cabal-environment '()))
     "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the
called with keyword parameter PORT, from PORT.  Return the `package'
S-expression corresponding to that package, or #f on failure.
CABAL-ENVIRONMENT is an alist defining the environment in which the Cabal
conditionals are evaluated.  The accepted keys are: \"os\", \"arch\", \"impl\"
and the name of a flag.  The value associated with a flag has to be either the
symbol 'true' or 'false'.  The value associated with other keys has to conform
to the Cabal file format definition.  The default value associated with the
keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\"
respectively."
     (let ((cabal-meta (if port
                           (read-cabal (canonical-newline-port port))
                           (hackage-fetch package-name))))
       (and=> cabal-meta (compose (cut hackage-module->sexp <>
                                       #:include-test-dependencies?
                                       include-test-dependencies?)
                                  (cut eval-cabal <> cabal-environment)))))))

(define* (hackage-recursive-import package-name . args)
  (recursive-import package-name #f
                    #:repo->guix-package (lambda (name repo)
                                           (apply hackage->guix-package (cons name args)))
                    #:guix-name hackage-name->package-name))

(define (hackage-package? package)
  "Return #t if PACKAGE is a Haskell package from Hackage."

  (define haskell-url?
    (let ((hackage-rx (make-regexp "https?://hackage.haskell.org")))
      (lambda (url)
        (regexp-exec hackage-rx url))))

  (let ((source-url (and=> (package-source package) origin-uri))
        (fetch-method (and=> (package-source package) origin-method)))
    (and (eq? fetch-method url-fetch)
         (match source-url
           ((? string?)
            (haskell-url? source-url))
           ((source-url ...)
            (any haskell-url? source-url))))))

(define (latest-release package)
  "Return an <upstream-source> for the latest release of PACKAGE."
  (let* ((hackage-name (guix-package->hackage-name package))
         (cabal-meta (hackage-fetch hackage-name)))
    (match cabal-meta
      (#f
       (format (current-error-port)
               "warning: failed to parse ~a~%"
               (hackage-cabal-url hackage-name))
       #f)
      ((_ *** ("version" (version)))
       (let ((url (hackage-source-url hackage-name version)))
         (upstream-source
          (package (package-name package))
          (version version)
          (urls (list url))))))))

(define %hackage-updater
  (upstream-updater
   (name 'hackage)
   (description "Updater for Hackage packages")
   (pred hackage-package?)
   (latest latest-release)))

;;; cabal.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2018 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 import json)
  #:use-module (json)
  #:use-module (guix http-client)
  #:use-module (guix import utils)
  #:use-module (srfi srfi-34)
  #:export (json-fetch
            json-fetch-alist))

(define* (json-fetch url
                     ;; Note: many websites returns 403 if we omit a
                     ;; 'User-Agent' header.
                     #:key (headers `((user-agent . "GNU Guile")
                                      (Accept . "application/json"))))
  "Return a representation of the JSON resource URL (a list or hash table), or
#f if URL returns 403 or 404.  HEADERS is a list of HTTP headers to pass in
the query."
  (guard (c ((and (http-get-error? c)
                  (let ((error (http-get-error-code c)))
                    (or (= 403 error)
                        (= 404 error))))
             #f))
    (let* ((port   (http-fetch url #:headers headers))
           (result (json->scm port)))
      (close-port port)
      result)))

(define (json-fetch-alist url)
  "Return an alist representation of the JSON resource URL, or #f if URL
returns 403 or 404."
  (hash-table->alist (json-fetch url)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 import opam)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module (srfi srfi-1)
  #:use-module (web uri)
  #:use-module (guix http-client)
  #:use-module (guix utils)
  #:use-module (guix import utils)
  #:use-module ((guix licenses) #:prefix license:)
  #:export (opam->guix-package))

(define (opam-urls)
  "Fetch the urls.txt file from the opam repository and returns the list of
URLs it contains."
  (let ((port (http-fetch/cached (string->uri "https://opam.ocaml.org/urls.txt"))))
    (let loop ((result '()))
      (let ((line (read-line port)))
        (if (eof-object? line)
          (begin
            (close port)
            result)
          (loop (cons line result)))))))

(define (vhash-ref hashtable key default)
  (match (vhash-assoc key hashtable)
    (#f default)
    ((_ . x) x)))

(define (hashtable-update hashtable line)
  "Parse @var{line} to get the name and version of the package and adds them
to the hashtable."
  (let* ((line (string-split line #\ )))
    (match line
      ((url foo ...)
       (if (equal? url "repo")
         hashtable
         (match (string-split url #\/)
           ((type name1 versionstr foo ...)
            (if (equal? type "packages")
              (match (string-split versionstr #\.)
                ((name2 versions ...)
                 (let ((version (string-join versions ".")))
                   (if (equal? name1 name2)
                     (let ((curr (vhash-ref hashtable name1 '())))
                       (vhash-cons name1 (cons version curr) hashtable))
                     hashtable)))
                (_ hashtable))
              hashtable))
           (_ hashtable))))
      (_ hashtable))))

(define (urls->hashtable urls)
  "Transform urls.txt in a hashtable whose keys are package names and values
the list of available versions."
  (let ((hashtable vlist-null))
    (let loop ((urls urls) (hashtable hashtable))
      (match urls
        (() hashtable)
        ((url rest ...) (loop rest (hashtable-update hashtable url)))))))

(define (latest-version versions)
  "Find the most recent version from a list of versions."
  (match versions
    ((first rest ...)
     (let loop ((versions rest) (m first))
       (match versions
         (() m)
         ((first rest ...)
          (loop rest (if (version>? m first) m first))))))))

(define (fetch-package-url uri)
  "Fetch and parse the url file.  Return the URL the package can be downloaded
from."
  (let ((port (http-fetch uri)))
    (let loop ((result #f))
      (let ((line (read-line port)))
        (if (eof-object? line)
          (begin
            (close port)
            result)
          (let* ((line (string-split line #\ )))
            (match line
              ((key value rest ...)
               (if (member key '("archive:" "http:"))
                 (loop (string-trim-both value #\"))
                 (loop result))))))))))

(define (fetch-package-metadata uri)
  "Fetch and parse the opam file.  Return an association list containing the
homepage, the license and the list of inputs."
  (let ((port (http-fetch uri)))
    (let loop ((result '()) (dependencies? #f))
      (let ((line (read-line port)))
        (if (eof-object? line)
          (begin
            (close port)
            result)
          (let* ((line (string-split line #\ )))
            (match line
               ((key value ...)
                (let ((dependencies?
                        (if dependencies?
                          (not (equal? key "]"))
                          (equal? key "depends:")))
                      (val (string-trim-both (string-join value "") #\")))
                  (cond
                    ((equal? key "homepage:")
                     (loop (cons `("homepage" . ,val) result) dependencies?))
                    ((equal? key "license:")
                     (loop (cons `("license" . ,val) result) dependencies?))
                    ((and dependencies? (not (equal? val "[")))
                     (match (string-split val #\{)
                       ((val rest ...)
                        (let ((curr (assoc-ref result "inputs"))
                              (new (string-trim-both
                                     val (list->char-set '(#\] #\[ #\")))))
                          (loop (cons `("inputs" . ,(cons new (if curr curr '()))) result)
                                (if (string-contains val "]") #f dependencies?))))))
                    (else (loop result dependencies?))))))))))))

(define (string->license str)
  (cond
    ((equal? str "MIT") '(license:expat))
    ((equal? str "GPL2") '(license:gpl2))
    ((equal? str "LGPLv2") '(license:lgpl2))
    (else `())))

(define (ocaml-name->guix-name name)
  (cond
    ((equal? name "ocamlfind") "ocaml-findlib")
    ((string-prefix? "ocaml" name) name)
    ((string-prefix? "conf-" name) (substring name 5))
    (else (string-append "ocaml-" name))))

(define (dependencies->inputs dependencies)
  "Transform the list of dependencies in a list of inputs."
  (if (not dependencies)
    '()
    (map (lambda (input)
           (list input (list 'unquote (string->symbol input))))
         (map ocaml-name->guix-name dependencies))))

(define (opam->guix-package name)
  (let* ((hashtable (urls->hashtable (opam-urls)))
         (versions (vhash-ref hashtable name #f)))
    (unless (eq? versions #f)
      (let* ((version (latest-version versions))
             (package-url (string-append "https://opam.ocaml.org/packages/" name
                                         "/" name "." version "/"))
             (url-url (string-append package-url "url"))
             (opam-url (string-append package-url "opam"))
             (source-url (fetch-package-url url-url))
             (metadata (fetch-package-metadata opam-url))
             (dependencies (assoc-ref metadata "inputs"))
             (inputs (dependencies->inputs dependencies)))
        (call-with-temporary-output-file
          (lambda (temp port)
            (and (url-fetch source-url temp)
                 `(package
                    (name ,(ocaml-name->guix-name name))
                    (version ,version)
                    (source
                      (origin
                        (method url-fetch)
                        (uri ,source-url)
                        (sha256 (base32 ,(guix-hash-url temp)))))
                    (build-system ocaml-build-system)
                    ,@(if (null? inputs)
                        '()
                        `((inputs ,(list 'quasiquote inputs))))
                    (home-page ,(assoc-ref metadata "homepage"))
                    (synopsis "")
                    (description "")
                    (license ,@(string->license (assoc-ref metadata "license")))))))))))


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

(define-module (guix import print)
  #:use-module (guix base32)
  #:use-module (guix utils)
  #:use-module (guix licenses)
  #:use-module (guix packages)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (gnu packages)
  #:use-module (srfi srfi-1)
  #:use-module (guix import utils)
  #:use-module (ice-9 control)
  #:use-module (ice-9 match)
  #:export (package->code))

;; FIXME: the quasiquoted arguments field may contain embedded package
;; objects, e.g. in #:disallowed-references; they will just be printed with
;; their usual #<package ...> representation, not as variable names.
(define (package->code package)
  "Return an S-expression representing the source code that produces PACKAGE
when evaluated."
  ;; The module in which the package PKG is defined
  (define (package-module-name pkg)
    (map string->symbol
         (string-split (string-drop-right
                        (location-file (package-location pkg)) 4)
                       #\/)))

  ;; Return the first candidate variable name that is bound to VAL.
  (define (variable-name val mod)
    (match (let/ec return
             (module-for-each (lambda (sym var)
                                (if (eq? val (variable-ref var))
                                    (return sym)
                                    #f))
                              (resolve-interface mod)))
      ((? symbol? sym) sym)
      (_ #f)))

  ;; Print either license variable name or the code for a license object
  (define (license->code lic)
    (let ((var (variable-name lic '(guix licenses))))
      (or var
          `(license
            (name ,(license-name lic))
            (uri ,(license-uri lic))
            (comment ,(license-comment lic))))))

  (define (search-path-specification->code spec)
    `(search-path-specification
      (variable ,(search-path-specification-variable spec))
      (files (list ,@(search-path-specification-files spec)))
      (separator ,(search-path-specification-separator spec))
      (file-type (quote ,(search-path-specification-file-type spec)))
      (file-pattern ,(search-path-specification-file-pattern spec))))

  (define (source->code source version)
    (let ((uri       (origin-uri source))
          (method    (origin-method source))
          (sha256    (origin-sha256 source))
          (file-name (origin-file-name source))
          (patches   (origin-patches source)))
      `(origin
         (method ,(procedure-name method))
         (uri (string-append ,@(factorize-uri uri version)))
         (sha256
          (base32
           ,(format #f "~a" (bytevector->nix-base32-string sha256))))
         ;; FIXME: in order to be able to throw away the directory prefix,
         ;; we just assume that the patch files can be found with
         ;; "search-patches".
         ,@(if (null? patches) '()
               `((patches (search-patches ,@(map basename patches))))))))

  (define (package-lists->code lsts)
    (list 'quasiquote
          (map (match-lambda
                 ((label pkg . out)
                  (let ((mod (package-module-name pkg)))
                    (list label
                          ;; FIXME: using '@ certainly isn't pretty, but it
                          ;; avoids having to import the individual package
                          ;; modules.
                          (list 'unquote
                                (list '@ mod (variable-name pkg mod)))))))
               lsts)))

  (let ((name                (package-name package))
        (version             (package-version package))
        (source              (package-source package))
        (build-system        (package-build-system package))
        (arguments           (package-arguments package))
        (inputs              (package-inputs package))
        (propagated-inputs   (package-propagated-inputs package))
        (native-inputs       (package-native-inputs package))
        (outputs             (package-outputs package))
        (native-search-paths (package-native-search-paths package))
        (search-paths        (package-search-paths package))
        (replacement         (package-replacement package))
        (synopsis            (package-synopsis package))
        (description         (package-description package))
        (license             (package-license package))
        (home-page           (package-home-page package))
        (supported-systems   (package-supported-systems package))
        (properties          (package-properties package)))
    `(package
       (name ,name)
       (version ,version)
       (source ,(source->code source version))
       ,@(match properties
           (() '())
           (_  `((properties ,properties))))
       ,@(if replacement
             `((replacement ,replacement))
             '())
       (build-system ,(symbol-append (build-system-name build-system)
                                     '-build-system))
       ,@(match arguments
           (() '())
           (args `((arguments ,(list 'quasiquote args)))))
       ,@(match outputs
           (("out") '())
           (outs `((outputs (list ,@outs)))))
       ,@(match native-inputs
           (() '())
           (pkgs `((native-inputs ,(package-lists->code pkgs)))))
       ,@(match inputs
           (() '())
           (pkgs `((inputs ,(package-lists->code pkgs)))))
       ,@(match propagated-inputs
           (() '())
           (pkgs `((propagated-inputs ,(package-lists->code pkgs)))))
       ,@(if (lset= string=? supported-systems %supported-systems)
             '()
             `((supported-systems (list ,@supported-systems))))
       ,@(match (map search-path-specification->code native-search-paths)
           (() '())
           (paths `((native-search-paths (list ,@paths)))))
       ,@(match (map search-path-specification->code search-paths)
           (() '())
           (paths `((search-paths (list ,@paths)))))
       (home-page ,home-page)
       (synopsis ,synopsis)
       (description ,description)
       (license ,(if (list? license)
                     `(list ,@(map license->code license))
                     (license->code license))))))


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

(define-module (guix import pypi)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 receive)
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (rnrs bytevectors)
  #:use-module (json)
  #:use-module (web uri)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module ((guix build utils)
                #:select ((package-name->name+version
                           . hyphen-package-name->name+version)
                          find-files))
  #:use-module (guix import utils)
  #:use-module ((guix download) #:prefix download:)
  #:use-module (guix import json)
  #:use-module (guix packages)
  #:use-module (guix upstream)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix build-system python)
  #:export (guix-package->pypi-name
            pypi-recursive-import
            pypi->guix-package
            %pypi-updater))

(define (pypi-fetch name)
  "Return an alist representation of the PyPI metadata for the package NAME,
or #f on failure."
  (json-fetch-alist (string-append "https://pypi.org/pypi/" name "/json")))

;; For packages found on PyPI that lack a source distribution.
(define-condition-type &missing-source-error &error
  missing-source-error?
  (package  missing-source-error-package))

(define (latest-source-release pypi-package)
  "Return the latest source release for PYPI-PACKAGE."
  (let ((releases (assoc-ref* pypi-package "releases"
                              (assoc-ref* pypi-package "info" "version"))))
    (or (find (lambda (release)
                (string=? "sdist" (assoc-ref release "packagetype")))
              releases)
        (raise (condition (&missing-source-error
                           (package pypi-package)))))))

(define (latest-wheel-release pypi-package)
  "Return the url of the wheel for the latest release of pypi-package,
or #f if there isn't any."
  (let ((releases (assoc-ref* pypi-package "releases"
                              (assoc-ref* pypi-package "info" "version"))))
    (or (find (lambda (release)
                (string=? "bdist_wheel" (assoc-ref release "packagetype")))
              releases)
        #f)))

(define (python->package-name name)
  "Given the NAME of a package on PyPI, return a Guix-compliant name for the
package."
  (if (string-prefix? "python-" name)
      (snake-case name)
      (string-append "python-" (snake-case name))))

(define (guix-package->pypi-name package)
  "Given a Python PACKAGE built from pypi.org, return the name of the
package on PyPI."
  (define (url->pypi-name url)
    (hyphen-package-name->name+version
     (basename (file-sans-extension url))))

  (match (and=> (package-source package) origin-uri)
    ((? string? url)
     (url->pypi-name url))
    ((lst ...)
     (any url->pypi-name lst))
    (#f #f)))

(define (wheel-url->extracted-directory wheel-url)
  (match (string-split (basename wheel-url) #\-)
    ((name version _ ...)
     (string-append name "-" version ".dist-info"))))

(define (maybe-inputs package-inputs)
  "Given a list of PACKAGE-INPUTS, tries to generate the 'inputs' field of a
package definition."
  (match package-inputs
    (()
     '())
    ((package-inputs ...)
     `((propagated-inputs (,'quasiquote ,package-inputs))))))

(define (guess-requirements source-url wheel-url tarball)
  "Given SOURCE-URL, WHEEL-URL and a TARBALL of the package, return a list
of the required packages specified in the requirements.txt file.  TARBALL will
be extracted in a temporary directory."

  (define (tarball-directory url)
    ;; Given the URL of the package's tarball, return the name of the directory
    ;; that will be created upon decompressing it. If the filetype is not
    ;; supported, return #f.
    ;; TODO: Support more archive formats.
    (let ((basename (substring url (+ 1 (string-rindex url #\/)))))
      (cond
       ((string-suffix? ".tar.gz" basename)
        (string-drop-right basename 7))
       ((string-suffix? ".tar.bz2" basename)
        (string-drop-right basename 8))
       (else
        (begin
          (warning (G_ "Unsupported archive format: \
cannot determine package dependencies"))
          #f)))))

  (define (clean-requirement s)
    ;; Given a requirement LINE, as can be found in a Python requirements.txt
    ;; file, remove everything other than the actual name of the required
    ;; package, and return it.
    (string-take s
      (or (string-index s (lambda (chr) (member chr '(#\space #\> #\= #\<))))
          (string-length s))))

  (define (comment? line)
    ;; Return #t if the given LINE is a comment, #f otherwise.
    (eq? (string-ref (string-trim line) 0) #\#))

  (define (read-requirements requirements-file)
    ;; Given REQUIREMENTS-FILE, a Python requirements.txt file, return a list
    ;; of name/variable pairs describing the requirements.
    (call-with-input-file requirements-file
      (lambda (port)
        (let loop ((result '()))
          (let ((line (read-line port)))
            (if (eof-object? line)
                result
                (cond
                 ((or (string-null? line) (comment? line))
                  (loop result))
                 (else
                  (loop (cons (clean-requirement line)
                              result))))))))))

  (define (read-wheel-metadata wheel-archive)
    ;; Given WHEEL-ARCHIVE, a ZIP Python wheel archive, return the package's
    ;; requirements.
    (let* ((dirname (wheel-url->extracted-directory wheel-url))
           (json-file (string-append dirname "/metadata.json")))
      (and (zero? (system* "unzip" "-q" wheel-archive json-file))
           (dynamic-wind
             (const #t)
             (lambda ()
               (call-with-input-file json-file
                 (lambda (port)
                   (let* ((metadata (json->scm port))
                          (run_requires (hash-ref metadata "run_requires"))
                          (requirements (if run_requires
                                            (hash-ref (list-ref run_requires 0)
                                                       "requires")
                                            '())))
                     (map clean-requirement requirements)))))
             (lambda ()
               (delete-file json-file)
               (rmdir dirname))))))

  (define (guess-requirements-from-wheel)
    ;; Return the package's requirements using the wheel, or #f if an error
    ;; occurs.
    (call-with-temporary-output-file
     (lambda (temp port)
       (if wheel-url
         (and (url-fetch wheel-url temp)
              (read-wheel-metadata temp))
         #f))))

  (define (guess-requirements-from-source)
    ;; Return the package's requirements by guessing them from the source.
    (let ((dirname (tarball-directory source-url)))
      (if (string? dirname)
          (call-with-temporary-directory
           (lambda (dir)
             (let* ((pypi-name (string-take dirname (string-rindex dirname #\-)))
                    (req-files (list (string-append dirname "/requirements.txt")
                                     (string-append dirname "/" pypi-name ".egg-info"
                                                    "/requires.txt")))
                    (exit-codes (map (lambda (file-name)
                                       (parameterize ((current-error-port (%make-void-port "rw+"))
                                                      (current-output-port (%make-void-port "rw+")))
                                         (system* "tar" "xf" tarball "-C" dir file-name)))
                                     req-files)))
               ;; Only one of these files needs to exist.
               (if (any zero? exit-codes)
                   (match (find-files dir)
                     ((file . _)
                      (read-requirements file))
                     (()
                      (warning (G_ "No requirements file found.\n"))))
                   (begin
                     (warning (G_ "Failed to extract requirements files\n"))
                     '())))))
          '())))

  ;; First, try to compute the requirements using the wheel, since that is the
  ;; most reliable option. If a wheel is not provided for this package, try
  ;; getting them by reading either the "requirements.txt" file or the
  ;; "requires.txt" from the egg-info directory from the source tarball. Note
  ;; that "requirements.txt" is not mandatory, so this is likely to fail.
  (or (guess-requirements-from-wheel)
      (guess-requirements-from-source)))

(define (compute-inputs source-url wheel-url tarball)
  "Given the SOURCE-URL of an already downloaded TARBALL, return a list of
name/variable pairs describing the required inputs of this package.  Also
return the unaltered list of upstream dependency names."
  (let ((dependencies
         (remove (cut string=? "argparse" <>)
                 (guess-requirements source-url wheel-url tarball))))
    (values (sort
             (map (lambda (input)
                    (let ((guix-name (python->package-name input)))
                      (list guix-name (list 'unquote (string->symbol guix-name)))))
                  dependencies)
             (lambda args
               (match args
                 (((a _ ...) (b _ ...))
                  (string-ci<? a b)))))
            dependencies)))

(define (make-pypi-sexp name version source-url wheel-url home-page synopsis
                        description license)
  "Return the `package' s-expression for a python package with the given NAME,
VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
  (call-with-temporary-output-file
   (lambda (temp port)
     (and (url-fetch source-url temp)
          (receive (input-package-names upstream-dependency-names)
              (compute-inputs source-url wheel-url temp)
            (values
             `(package
                (name ,(python->package-name name))
                (version ,version)
                (source (origin
                          (method url-fetch)

                          ;; Sometimes 'pypi-uri' doesn't quite work due to mixed
                          ;; cases in NAME, for instance, as is the case with
                          ;; "uwsgi".  In that case, fall back to a full URL.
                          (uri (pypi-uri ,(string-downcase name) version))
                          (sha256
                           (base32
                            ,(guix-hash-url temp)))))
                (build-system python-build-system)
                ,@(maybe-inputs input-package-names)
                (home-page ,home-page)
                (synopsis ,synopsis)
                (description ,description)
                (license ,(license->symbol license)))
             upstream-dependency-names))))))

(define pypi->guix-package
  (memoize
   (lambda* (package-name)
     "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the
`package' s-expression corresponding to that package, or #f on failure."
     (let ((package (pypi-fetch package-name)))
       (and package
            (guard (c ((missing-source-error? c)
                       (let ((package (missing-source-error-package c)))
                         (leave (G_ "no source release for pypi package ~a ~a~%")
                                (assoc-ref* package "info" "name")
                                (assoc-ref* package "info" "version")))))
              (let ((name (assoc-ref* package "info" "name"))
                    (version (assoc-ref* package "info" "version"))
                    (release (assoc-ref (latest-source-release package) "url"))
                    (wheel (assoc-ref (latest-wheel-release package) "url"))
                    (synopsis (assoc-ref* package "info" "summary"))
                    (description (assoc-ref* package "info" "summary"))
                    (home-page (assoc-ref* package "info" "home_page"))
                    (license (string->license (assoc-ref* package "info" "license"))))
                (make-pypi-sexp name version release wheel home-page synopsis
                                description license))))))))

(define (pypi-recursive-import package-name)
  (recursive-import package-name #f
                    #:repo->guix-package (lambda (name repo)
                                           (pypi->guix-package name))
                    #:guix-name python->package-name))

(define (string->license str)
  "Convert the string STR into a license object."
  (match str
    ("GNU LGPL" license:lgpl2.0)
    ("GPL" license:gpl3)
    ((or "BSD" "BSD License") license:bsd-3)
    ((or "MIT" "MIT license" "Expat license") license:expat)
    ("Public domain" license:public-domain)
    ((or "Apache License, Version 2.0" "Apache 2.0") license:asl2.0)
    (_ #f)))

(define (pypi-package? package)
  "Return true if PACKAGE is a Python package from PyPI."

  (define (pypi-url? url)
    (or (string-prefix? "https://pypi.org/" url)
        (string-prefix? "https://pypi.python.org/" url)
        (string-prefix? "https://pypi.io/packages" url)))

  (let ((source-url (and=> (package-source package) origin-uri))
        (fetch-method (and=> (package-source package) origin-method)))
    (and (eq? fetch-method download:url-fetch)
         (match source-url
           ((? string?)
            (pypi-url? source-url))
           ((source-url ...)
            (any pypi-url? source-url))))))

(define (latest-release package)
  "Return an <upstream-source> for the latest release of PACKAGE."
  (let* ((pypi-name    (guix-package->pypi-name package))
         (pypi-package (pypi-fetch pypi-name)))
    (and pypi-package
         (guard (c ((missing-source-error? c) #f))
           (let* ((metadata pypi-package)
                  (version (assoc-ref* metadata "info" "version"))
                  (url (assoc-ref (latest-source-release metadata) "url")))
             (upstream-source
              (package (package-name package))
              (version version)
              (urls (list url))))))))

(define %pypi-updater
  (upstream-updater
   (name 'pypi)
   (description "Updater for PyPI packages")
   (pred pypi-package?)
   (latest latest-release)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 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 import snix)
  #:use-module (sxml ssax)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 format)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)

  ;; Use the 'package-name->name+version' procedure that works with
  ;; hyphen-separate name/version, not the one that works with '@'-separated
  ;; name/version.  Subtle!
  #:use-module ((guix utils) #:hide (package-name->name+version))
  #:use-module ((guix build utils) #:select (package-name->name+version))

  #:use-module (guix import utils)
  #:use-module (guix base16)
  #:use-module (guix base32)
  #:use-module (guix config)
  #:use-module (guix gnu-maintenance)
  #:export (open-nixpkgs
            xml->snix
            nixpkgs->guix-package))

;;; Commentary:
;;;
;;; Converting Nix code to s-expressions, and then to Guix `package'
;;; declarations, using the XML output of `nix-instantiate'.
;;;
;;; Code:

;;;
;;; SNix.
;;;

;; Nix object types visible in the XML output of `nix-instantiate' and
;; mapping to S-expressions (we map to sexps, not records, so that we
;; can do pattern matching):
;;
;;   at               (at varpat attrspat)
;;   attr             (attribute loc name value)
;;   attrs            (attribute-set attributes)
;;   attrspat         (attribute-set-pattern patterns)
;;   bool             #f|#t
;;   derivation       (derivation drv-path out-path attributes)
;;   ellipsis         '...
;;   expr             (snix loc body ...)
;;   function         (function loc at|attrspat|varpat)
;;   int              int
;;   list             list
;;   null             'null
;;   path             string
;;   string           string
;;   unevaluated      'unevaluated
;;   varpat           (varpat name)
;;
;; Initially ATTRIBUTES in `derivation' and `attribute-set' was a promise;
;; however, handling `repeated' nodes makes it impossible to do anything
;; lazily because the whole SXML tree has to be traversed to maintain the
;; list of known derivations.

(define (xml-element->snix elem attributes body derivations)
  "Return an SNix element corresponding to XML element ELEM."

  (define (loc)
    (location (assq-ref attributes 'path)
              (assq-ref attributes 'line)
              (assq-ref attributes 'column)))

  (case elem
    ((at)
     (values `(at ,(car body) ,(cadr body)) derivations))
    ((attr)
     (let ((name (assq-ref attributes 'name)))
       (cond ((null? body)
              (values `(attribute-pattern ,name) derivations))
             ((and (pair? body) (null? (cdr body)))
              (values `(attribute ,(loc) ,name ,(car body))
                      derivations))
             (else
              (error "invalid attribute body" name (loc) body)))))
    ((attrs)
     (values `(attribute-set ,(reverse body)) derivations))
    ((attrspat)
     (values `(attribute-set-pattern ,body) derivations))
    ((bool)
     (values (string-ci=? "true" (assq-ref attributes 'value))
             derivations))
    ((derivation)
     (let ((drv-path (assq-ref attributes 'drvPath))
           (out-path (assq-ref attributes 'outPath)))
       (if (equal? body '(repeated))
           (let ((body (vhash-assoc drv-path derivations)))
             (if (pair? body)
                 (values `(derivation ,drv-path ,out-path ,(cdr body))
                         derivations)

                 ;; DRV-PATH hasn't been encountered yet but may be later
                 ;; (see <http://article.gmane.org/gmane.linux.distributions.nixos/5946>.)
                 ;; Return an `unresolved' node.
                 (values `(unresolved
                           ,(lambda (derivations)
                              (let ((body (vhash-assoc drv-path derivations)))
                                (if (pair? body)
                                    `(derivation ,drv-path ,out-path
                                                 ,(cdr body))
                                    (error "no previous occurrence of derivation"
                                           drv-path)))))
                         derivations)))
           (values `(derivation ,drv-path ,out-path ,body)
                   (vhash-cons drv-path body derivations)))))
    ((ellipsis)
     (values '... derivations))
    ((expr)
     (values `(snix ,(loc) ,@body) derivations))
    ((function)
     (values `(function ,(loc) ,body) derivations))
    ((int)
     (values (string->number (assq-ref attributes 'value))
             derivations))
    ((list)
     (values body derivations))
    ((null)
     (values 'null derivations))
    ((path)
     (values (assq-ref attributes 'value) derivations))
    ((repeated)
     (values 'repeated derivations))
    ((string)
     (values (assq-ref attributes 'value) derivations))
    ((unevaluated)
     (values 'unevaluated derivations))
    ((varpat)
     (values `(varpat ,(assq-ref attributes 'name)) derivations))
    (else (error "unhandled Nix XML element" elem))))

(define (resolve snix derivations)
  "Return a new SNix tree where `unresolved' nodes from SNIX have been
replaced by the result of their application to DERIVATIONS, a vhash."
  (let loop ((node snix)
             (seen vlist-null))
    (if (vhash-assq node seen)
        (values node seen)
        (match node
          (('unresolved proc)
           (let ((n (proc derivations)))
             (values n seen)))
          ((tag body ...)
           (let ((body+seen (fold (lambda (n body+seen)
                                    (call-with-values
                                        (lambda ()
                                          (loop n (cdr body+seen)))
                                      (lambda (n* seen)
                                        (cons (cons n* (car body+seen))
                                              (vhash-consq n #t seen)))))
                                  (cons '() (vhash-consq node #t seen))
                                  body)))
             (values (cons tag (reverse (car body+seen)))
                     (vhash-consq node #t (cdr body+seen)))))
          (anything
           (values anything seen))))))

(define xml->snix
  (let ((parse
         (ssax:make-parser NEW-LEVEL-SEED
                           (lambda (elem-gi attributes namespaces expected-content
                                    seed)
                             (cons '() (cdr seed)))

                           FINISH-ELEMENT
                           (lambda (elem-gi attributes namespaces parent-seed
                                            seed)
                             (let ((snix        (car seed))
                                   (derivations (cdr seed)))
                               (let-values (((snix derivations)
                                             (xml-element->snix elem-gi
                                                                attributes
                                                                snix
                                                                derivations)))
                                 (cons (cons snix (car parent-seed))
                                       derivations))))

                           CHAR-DATA-HANDLER
                           (lambda (string1 string2 seed)
                             ;; Discard inter-node strings, which are blanks.
                             seed))))
    (lambda (port)
      "Return the SNix represention of TREE, an SXML tree as returned by
parsing the XML output of `nix-instantiate' on Nixpkgs."
      (match (parse port (cons '() vlist-null))
        (((snix) . derivations)
         (resolve snix derivations))))))

(define (attribute-value attribute)
  "Return the value of ATTRIBUTE."
  (match attribute
    (('attribute _ _ value) value)))

(define (derivation-source derivation)
  "Return the \"src\" attribute of DERIVATION or #f if not found."
  (match derivation
    (('derivation _ _ (attributes ...))
     (find-attribute-by-name "src" attributes))))

(define (derivation-output-path derivation)
  "Return the output path of DERIVATION."
  (match derivation
    (('derivation _ out-path _)
     out-path)
    (_ #f)))

(define (source-output-path src)
  "Return the output path of SRC, the \"src\" attribute of a derivation."
  (derivation-output-path (attribute-value src)))

(define (source-urls src)
  "Return the URLs of SRC, the \"src\" attribute of a derivation."
  (match src
    (('attribute _ _ ('derivation _ _ (attributes ...)))
     (match (find-attribute-by-name "urls" attributes)
       (('attribute _ _ value)
        value)))
    (_ #f)))

(define (source-sha256 src)
  "Return the sha256 of SRC, the \"src\" attribute of a derivation, as a
bytevector."
  (match src
    (('attribute _ _ ('derivation _ _ (attributes ...)))
     (match (find-attribute-by-name "outputHash" attributes)
       (('attribute _ _ value)
        (match value
          ((= string-length 52)
           (nix-base32-string->bytevector value))
          ((= string-length 64)
           (base16-string->bytevector value))
          (_
           (error "unsupported hash format" value))))))
    (_ #f)))

(define (derivation-source-output-path derivation)
  "Return the output path of the \"src\" attribute of DERIVATION or #f
if DERIVATION lacks an \"src\" attribute."
  (and=> (derivation-source derivation) source-output-path))

(define* (open-nixpkgs nixpkgs #:optional attribute)
  "Return an input pipe to the XML representation of Nixpkgs.  When
ATTRIBUTE is true, only that attribute is considered."
  (with-fluids ((%default-port-encoding "UTF-8"))
    (let ((cross-system (format #f "{
  config = \"i686-guix-linux-gnu\";
  libc = \"glibc\";
  arch = \"guix\";
  withTLS = true;
  float = \"hard\";
  openssl.system = \"linux-generic32\";
  platform = (import ~a/pkgs/top-level/platforms.nix).sheevaplug;
}" nixpkgs)))
      (apply open-pipe* OPEN_READ
             "nix-instantiate" "--strict" "--eval-only" "--xml"

             ;; Pass a dummy `crossSystem' argument so that `buildInputs' and
             ;; `nativeBuildInputs' are not coalesced.
             ;; XXX: This is hacky and has other problems.
             ;"--arg" "crossSystem" cross-system

             `(,@(if attribute
                     `("-A" ,attribute)
                     '())
               ,nixpkgs)))))

(define (pipe-failed? pipe)
  "Close pipe and return its status if it failed."
  (let ((status (close-pipe pipe)))
    (if (or (status:term-sig status)
            (not (= (status:exit-val status) 0)))
        status
        #f)))

(define (find-attribute-by-name name attributes)
  "Return attribute NAME in ATTRIBUTES, an attribute set or list of SNix
attributes, or #f if NAME cannot be found."
  (find (lambda (a)
          (match a
            (('attribute _ (? (cut string=? <> name)) _)
             a)
            (_ #f)))
        (match attributes
          (('attribute-set (attributes ...))
           attributes)
          (_
           attributes))))

(define (license-variable license)
  "Return the name of the (guix licenses) variable for LICENSE."
  (match license
    ("GPLv2+"    'gpl2+)
    ("GPLv3+"    'gpl3+)
    ("LGPLv2+"   'lgpl2.1+)
    ("LGPLv2.1+" 'lgpl2.1+)
    ("LGPLv3+"   'lgpl3+)
    (('attribute-set _ ...)
     ;; At some point in 2013, Nixpkgs switched to attribute sets to represent
     ;; licenses.  These are listed in lib/licenses.nix.
     (match (and=> (find-attribute-by-name "shortName" license)
                   attribute-value)
       ("agpl3Plus"  'agpl3+)
       ("gpl2Plus"   'gpl2+)
       ("gpl3Plus"   'gpl3+)
       ("lgpl2Plus"  'lgpl2.0+)
       ("lgpl21Plus" 'lgpl2.1+)
       ("lgpl3Plus"  'lgpl3+)
       ((? string? x) x)
       (_             license)))
    (_           license)))

(define (package-source-output-path package)
  "Return the output path of the \"src\" derivation of PACKAGE."
  (derivation-source-output-path (attribute-value package)))

;;;
;;; Conversion of "Nix expressions" to "Guix expressions".
;;;

(define (snix-derivation->guix-package derivation)
  "Return the `package' s-expression corresponding to SNix DERIVATION, a
Nixpkgs `stdenv.mkDerivation'-style derivation, and the original source
location of DERIVATION."
  (match derivation
    (('derivation _ _ (attributes ...))
     (let*-values (((full-name loc)
                    (match (find-attribute-by-name "name" attributes)
                      (('attribute loc _ value)
                       (values value loc))
                      (_
                       (values #f #f))))
                   ((name version)
                    (package-name->name+version full-name)))
       (define (convert-inputs type)
         ;; Convert the derivation's input from a list of SNix derivations to
         ;; a list of name/variable pairs.
         (match (and=> (find-attribute-by-name type attributes)
                       attribute-value)
           (#f
            '())
           ((inputs ...)
            ;; Inputs can be either derivations or the null value.
            (filter-map (match-lambda
                         (('derivation _ _ (attributes ...))
                          (let* ((full-name
                                  (attribute-value
                                   (find-attribute-by-name "name" attributes)))
                                 (name (package-name->name+version full-name)))
                            (list name
                                  (list 'unquote (string->symbol name)))))
                         ('null #f))
                        inputs))))

       (define (maybe-inputs guix-name inputs)
         (match inputs
           (()
            '())
           ((inputs ...)
            (list (list guix-name
                        (list 'quasiquote inputs))))))

       (define (pretty-uri uri version)
         (if version
             (match (factorize-uri uri version)
               ((items ...)
                `(string-append ,@items))
               (x x))
             uri))

       (let* ((source  (find-attribute-by-name "src" attributes))
              (urls    (source-urls source))
              (sha256  (source-sha256 source))
              (meta    (and=> (find-attribute-by-name "meta" attributes)
                              attribute-value)))
         (values
          `(package
             (name ,name)
             (version ,version)
             (source (origin
                      (method url-fetch)
                      (uri ,(pretty-uri (car urls) version))
                      (sha256
                       (base32
                        ,(bytevector->nix-base32-string sha256)))))
             (build-system gnu-build-system)

             ;; When doing a native Nixpkgs build, `buildInputs' is empty and
             ;; everything is in `nativeBuildInputs'.  So we can't distinguish
             ;; between both, here.
             ;;
             ;; Note that `nativeBuildInputs' was renamed from
             ;; `buildNativeInputs' in Nixpkgs sometime around March 2013.
             ,@(maybe-inputs 'inputs
                             (convert-inputs "nativeBuildInputs"))
             ,@(maybe-inputs 'propagated-inputs
                             (convert-inputs "propagatedNativeBuildInputs"))

             (home-page ,(and=> (find-attribute-by-name "homepage" meta)
                                attribute-value))
             (synopsis
              ;; For GNU packages, prefer the official synopsis.
              ,(or (false-if-exception
                    (and=> (find (lambda (gnu-package)
                                   (equal? (gnu-package-name gnu-package)
                                           name))
                                 (official-gnu-packages))
                           gnu-package-doc-summary))
                   (and=> (find-attribute-by-name "description" meta)
                          attribute-value)))
             (description
              ;; Likewise, prefer the official description of GNU packages.
              ,(or (false-if-exception
                    (and=> (find (lambda (gnu-package)
                                   (equal? (gnu-package-name gnu-package)
                                           name))
                                 (official-gnu-packages))
                           gnu-package-doc-description))
                   (and=> (find-attribute-by-name "longDescription" meta)
                          attribute-value)))
             (license ,(and=> (find-attribute-by-name "license" meta)
                              (compose license-variable attribute-value))))
          loc))))))

(define (nixpkgs->guix-package nixpkgs attribute)
  "Evaluate ATTRIBUTE in NIXPKGS, the file name of a Nixpkgs checkout,
and return the `package' s-expression corresponding to that package."
  (let ((port (open-nixpkgs nixpkgs attribute)))
    (match (xml->snix port)
      (('snix loc (and drv ('derivation _ ...)))
       (and (not (pipe-failed? port))
            (snix-derivation->guix-package drv)))
      (_
       (not (pipe-failed? port))))))

;;; snix.scm ends here