Merge remote-tracking branch 'origin/master' into staging

3 files changed, 131 insertions, 42 deletions

diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index aaa1caf035..15163bd165 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -125,7 +125,7 @@ package definition."
     ((package-inputs ...)
      `((,type (,'quasiquote ,(format-inputs package-inputs)))))))
 
-(define %cran-url "http://cran.r-project.org/web/packages/")
+(define %cran-url "https://cran.r-project.org/web/packages/")
 (define %bioconductor-url "https://bioconductor.org/packages/")
 
 ;; The latest Bioconductor release is 3.8.  Bioconductor packages should be
@@ -161,6 +161,12 @@ bioconductor package NAME, or #F if the package is unknown."
                (bioconductor-packages-list))
          (cut assoc-ref <> "Version")))
 
+;; Little helper to download URLs only once.
+(define download
+  (memoize
+   (lambda (url)
+     (with-store store (download-to-store store url)))))
+
 (define (fetch-description repository name)
   "Return an alist of the contents of the DESCRIPTION file for the R package
 NAME in the given REPOSITORY, or #f in case of failure.  NAME is
@@ -183,7 +189,7 @@ from ~s: ~a (~s)~%"
      ;; download the source tarball, and then extract the DESCRIPTION file.
      (and-let* ((version (latest-bioconductor-package-version name))
                 (url     (car (bioconductor-uri name version)))
-                (tarball (with-store store (download-to-store store url))))
+                (tarball (download url)))
        (call-with-temporary-directory
         (lambda (dir)
           (parameterize ((current-error-port (%make-void-port "rw+"))
@@ -299,7 +305,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
                        ((url rest ...) url)
                        ((? string? url) url)
                        (_ #f)))
-         (tarball    (with-store store (download-to-store store source-url)))
+         (tarball    (download source-url))
          (sysdepends (append
                       (if (needs-zlib? tarball) '("zlib") '())
                       (map string-downcase (listify meta "SystemRequirements"))))
@@ -352,9 +358,10 @@ s-expression corresponding to that package, or #f on failure."
                 (eq? repo 'bioconductor))
            ;; Retry import from CRAN
            (cran->guix-package package-name 'cran)
-           (description->package repo description))))))
+           (and description
+                (description->package repo description)))))))
 
-(define* (cran-recursive-import package-name #:optional (repo 'gnu))
+(define* (cran-recursive-import package-name #:optional (repo 'cran))
   (recursive-import package-name repo
                     #:repo->guix-package cran->guix-package
                     #:guix-name cran-guix-name))
diff --git a/guix/import/github.scm b/guix/import/github.scm
index af9f56e1dc..ad662e7b02 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
 ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,6 +25,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (guix utils)
   #:use-module ((guix download) #:prefix download:)
+  #:use-module ((guix git-download) #:prefix download:)
   #:use-module (guix import utils)
   #:use-module (guix import json)
   #:use-module (guix packages)
@@ -52,6 +54,7 @@ false if none is recognized"
                                       (github-user-slash-repository url)))
               (repo    (github-repository url)))
           (cond
+           ((string-suffix? ".git" url) url)
            ((string-suffix? (string-append "/tarball/v" version) url)
             (string-append prefix "/tarball/v" new-version))
            ((string-suffix? (string-append "/tarball/" version) url)
@@ -86,26 +89,29 @@ false if none is recognized"
            (#t #f))) ; Some URLs are not recognised.
         #f))
 
-  (let ((source-url (and=> (package-source old-package) origin-uri))
+  (let ((source-uri (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)))
+    (cond
+     ((eq? fetch-method download:url-fetch)
+      (match source-uri
+             ((? string?)
+              (updated-url source-uri))
+             ((source-uri ...)
+              (find updated-url source-uri))))
+     ((eq? fetch-method download:git-fetch)
+      (updated-url (download:git-reference-url source-uri)))
+     (else #f))))
 
 (define (github-package? package)
   "Return true if PACKAGE is a package from GitHub, else false."
-  (not (eq? #f (updated-github-url package "dummy"))))
+  (->bool (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))))
+     (string-append (basename project ".git")))))
 
 (define (github-user-slash-repository url)
   "Return a string e.g. arq5x/bedtools2 of the owner and the name of the
@@ -113,7 +119,7 @@ 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))))
+     (string-append owner "/" (basename project ".git")))))
 
 (define %github-token
   ;; Token to be passed to Github.com to avoid the 60-request per hour
@@ -213,6 +219,8 @@ https://github.com/settings/tokens"))
     (match (origin-uri origin)
       ((? string? url)
        url)                                       ;surely a github.com URL
+      ((? download:git-reference? ref)
+       (download:git-reference-url ref))
       ((urls ...)
        (find (cut string-contains <> "github.com") urls))))
 
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
index c42a5d767d..c254db5f2c 100644
--- a/guix/import/opam.scm
+++ b/guix/import/opam.scm
@@ -27,16 +27,23 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (web uri)
+  #:use-module (guix build-system)
+  #:use-module (guix build-system ocaml)
   #:use-module (guix http-client)
   #:use-module (guix git)
   #:use-module (guix ui)
+  #:use-module (guix packages)
+  #:use-module (guix upstream)
   #:use-module (guix utils)
   #:use-module (guix import utils)
   #:use-module ((guix licenses) #:prefix license:)
-  #:export (opam->guix-package))
+  #:export (opam->guix-package
+            opam-recursive-import
+            %opam-updater))
 
 ;; Define a PEG parser for the opam format
-(define-peg-pattern SP none (or " " "\n"))
+(define-peg-pattern comment none (and "#" (* STRCHR) "\n"))
+(define-peg-pattern SP none (or " " "\n" comment))
 (define-peg-pattern SP2 body (or " " "\n"))
 (define-peg-pattern QUOTE none "\"")
 (define-peg-pattern QUOTE2 body "\"")
@@ -128,7 +135,6 @@ path to the repository."
     (else (string-append "ocaml-" name))))
 
 (define (metadata-ref file lookup)
-  (pk 'file file 'lookup lookup)
   (fold (lambda (record acc)
           (match record
             ((record key val)
@@ -166,6 +172,21 @@ path to the repository."
     (('conditional-value val condition)
      (if (native? condition) (dependency->input val) ""))))
 
+(define (dependency->name dependency)
+  (match dependency
+    (('string-pat str) str)
+    (('conditional-value val condition)
+     (dependency->name val))))
+
+(define (dependency-list->names lst)
+  (filter
+    (lambda (name)
+      (not (or
+             (string-prefix? "conf-" name)
+             (equal? name "ocaml")
+             (equal? name "findlib"))))
+    (map dependency->name lst)))
+
 (define (ocaml-names->guix-names names)
   (map ocaml-name->guix-name
        (remove (lambda (name)
@@ -190,35 +211,88 @@ path to the repository."
       (list dependency (list 'unquote (string->symbol dependency))))
     (ocaml-names->guix-names lst)))
 
-(define (opam->guix-package name)
+(define (opam-fetch name)
   (and-let* ((repository (get-opam-repository))
              (version (find-latest-version name repository))
-             (file (string-append repository "/packages/" name "/" name "." (pk 'version version) "/opam"))
-             (opam-content (get-metadata file))
-             (url-dict (metadata-ref (pk 'metadata opam-content) "url"))
+             (file (string-append repository "/packages/" name "/" name "." version "/opam")))
+    `(("metadata" ,@(get-metadata file))
+      ("version" . ,version))))
+
+(define (opam->guix-package name)
+  (and-let* ((opam-file (opam-fetch name))
+             (version (assoc-ref opam-file "version"))
+             (opam-content (assoc-ref opam-file "metadata"))
+             (url-dict (metadata-ref opam-content "url"))
              (source-url (metadata-ref url-dict "src"))
              (requirements (metadata-ref opam-content "depends"))
+             (dependencies (dependency-list->names requirements))
              (inputs (dependency-list->inputs (depends->inputs requirements)))
              (native-inputs (dependency-list->inputs (depends->native-inputs requirements))))
         (call-with-temporary-output-file
           (lambda (temp port)
             (and (url-fetch source-url temp)
-                 `(package
-                    (name ,(ocaml-name->guix-name name))
-                    (version ,(metadata-ref opam-content "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))))
-                    ,@(if (null? native-inputs)
-                        '()
-                        `((native-inputs ,(list 'quasiquote native-inputs))))
-                    (home-page ,(metadata-ref opam-content "homepage"))
-                    (synopsis ,(metadata-ref opam-content "synopsis"))
-                    (description ,(metadata-ref opam-content "description"))
-                    (license #f)))))))
+                 (values
+                  `(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))))
+                     ,@(if (null? native-inputs)
+                         '()
+                         `((native-inputs ,(list 'quasiquote native-inputs))))
+                     (home-page ,(metadata-ref opam-content "homepage"))
+                     (synopsis ,(metadata-ref opam-content "synopsis"))
+                     (description ,(metadata-ref opam-content "description"))
+                     (license #f))
+                  dependencies))))))
+
+(define (opam-recursive-import package-name)
+  (recursive-import package-name #f
+                    #:repo->guix-package (lambda (name repo)
+                                           (opam->guix-package name))
+                    #:guix-name ocaml-name->guix-name))
+
+(define (guix-package->opam-name package)
+  "Given an OCaml PACKAGE built from OPAM, return the name of the
+package in OPAM."
+  (let ((upstream-name (assoc-ref
+                         (package-properties package)
+                         'upstream-name))
+        (name (package-name package)))
+    (cond
+      (upstream-name upstream-name)
+      ((string-prefix? "ocaml-" name) (substring name 6))
+      (else name))))
+
+(define (opam-package? package)
+  "Return true if PACKAGE is an OCaml package from OPAM"
+  (and
+    (equal? (build-system-name (package-build-system package)) 'ocaml)
+    (not (string-prefix? "ocaml4" (package-name package)))))
+
+(define (latest-release package)
+  "Return an <upstream-source> for the latest release of PACKAGE."
+  (and-let* ((opam-name (guix-package->opam-name package))
+             (opam-file (opam-fetch opam-name))
+             (version (assoc-ref opam-file "version"))
+             (opam-content (assoc-ref opam-file "metadata"))
+             (url-dict (metadata-ref opam-content "url"))
+             (source-url (metadata-ref url-dict "src")))
+    (upstream-source
+      (package (package-name package))
+      (version version)
+      (urls (list source-url)))))
+
+(define %opam-updater
+  (upstream-updater
+    (name 'opam)
+    (description "Updater for OPAM packages")
+    (pred opam-package?)
+    (latest latest-release)))