From a5250186722305961f0a5d77cb8f7f36cdae0da0 Mon Sep 17 00:00:00 2001
From: Julien Lepiller
Date: Wed, 6 Jun 2018 19:14:39 +0200
Subject: [PATCH] guix: Add opam importer.
* guix/scripts/import.scm (importers): Add opam.
* guix/scripts/import/opam.scm: New file.
* guix/import/opam.scm: New file.
* Makefile.am: Add them.
---
Makefile.am | 2 +
guix/import/opam.scm | 188 +++++++++++++++++++++++++++++++++++
guix/scripts/import.scm | 2 +-
guix/scripts/import/opam.scm | 92 +++++++++++++++++
4 files changed, 283 insertions(+), 1 deletion(-)
create mode 100644 guix/import/opam.scm
create mode 100644 guix/scripts/import/opam.scm
diff --git a/Makefile.am b/Makefile.am
index 7898a3648..6bf077d1b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -230,11 +230,13 @@ MODULES += \
guix/import/github.scm \
guix/import/gnome.scm \
guix/import/json.scm \
+ guix/import/opam.scm \
guix/import/pypi.scm \
guix/import/stackage.scm \
guix/scripts/import/crate.scm \
guix/scripts/import/gem.scm \
guix/scripts/import/json.scm \
+ guix/scripts/import/opam.scm \
guix/scripts/import/pypi.scm \
guix/scripts/import/stackage.scm \
guix/scripts/weather.scm
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
new file mode 100644
index 000000000..608f8b449
--- /dev/null
+++ b/guix/import/opam.scm
@@ -0,0 +1,188 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Julien Lepiller
+;;;
+;;; 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 .
+
+(define-module (guix import opam)
+ #:use-module (ice-9 match)
+ #: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 (htable-update htable line)
+ "Parse @var{line} to get the name and version of the package and adds them
+to the hashtable."
+ (let* ((line (string-split line #\ ))
+ (url (car line)))
+ (unless (equal? url "repo")
+ (let ((sp (string-split url #\/)))
+ (when (equal? (car sp) "packages")
+ (let* ((versionstr (car (cdr (cdr sp))))
+ (name1 (car (cdr sp)))
+ (name2 (car (string-split versionstr #\.)))
+ (version (string-join (cdr (string-split versionstr #\.)) ".")))
+ (when (equal? name1 name2)
+ (let ((curr (hash-ref htable name1 '())))
+ (hash-set! htable name1 (cons version curr))))))))))
+
+(define (urls->htable urls)
+ "Transform urls.txt in a hashtable whose keys are package names and values
+the list of available versions."
+ (let ((htable (make-hash-table)))
+ (let loop ((urls urls))
+ (if (eq? (length urls) 0)
+ htable
+ (begin
+ (htable-update htable (car urls))
+ (loop (cdr urls)))))))
+
+(define (latest-version versions)
+ "Find the most recent version from a list of versions."
+ (let loop ((versions (cdr versions)) (m (car versions)))
+ (if (eq? (length versions) 0)
+ m
+ (loop (cdr versions) (if (version>? m (car versions)) m (car versions))))))
+
+(define (fetch-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 #\ ))
+ (key (car line)))
+ (if (equal? key "archive:")
+ (loop (string-trim-both (car (cdr line)) #\"))
+ (loop result))))))))
+
+(define (fetch-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 '()) (deps? #f))
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ (begin
+ (close port)
+ result)
+ (let* ((line (string-split line #\ ))
+ (key (car line))
+ (deps? (if deps? (not (equal? key "]")) (equal? key "depends:")))
+ (val (string-trim-both (string-join (cdr line) "") #\")))
+ (cond
+ ((equal? key "homepage:")
+ (loop (cons `("homepage" . ,val) result) deps?))
+ ((equal? key "license:")
+ (loop (cons `("license" . ,val) result) deps?))
+ ((and deps? (not (equal? val "[")))
+ (let ((curr (assoc-ref result "inputs"))
+ (new (string-trim-both (car (string-split val #\{)) (list->char-set '(#\] #\[ #\")))))
+ (loop (cons `("inputs" . ,(cons new (if curr curr '()))) result)
+ (if (string-contains val "]") #f deps?))))
+ (else (loop result deps?)))))))))
+
+(define (string->license str)
+ (cond
+ ((equal? str "MIT") '(license:expat))
+ ((equal? str "GPL2") '(license:gpl2))
+ ((equal? str "LGPLv2") '(license:lgpl2))
+ (else `())))
+
+(define (deps->inputs deps)
+ "Transform the list of dependencies in a list of inputs. Filter out anything
+that looks like a native-input."
+ (if (eq? deps #f)
+ '()
+ (let ((inputs
+ (map (lambda (input)
+ (list input (list 'unquote (string->symbol input))))
+ (map (lambda (input)
+ (cond
+ ((equal? input "ocamlfind") "ocaml-findlib")
+ ((string-prefix? "ocaml" input) input)
+ (else (string-append "ocaml-" input))))
+ (filter (lambda (input) (not (string-prefix? "conf-" input))) deps)))))
+ (if (eq? (length inputs) 0) '() inputs))))
+
+(define (deps->native-inputs deps)
+ "Transform the list of dependencies in a list of native-inputs. Filter out
+anything that doesn't look like a native-input."
+ (if (eq? deps #f)
+ '()
+ (let ((inputs
+ (map (lambda (input)
+ (list input (list 'unquote (string->symbol input))))
+ (map (lambda (input) (substring input 5))
+ (filter (lambda (input) (string-prefix? "conf-" input)) deps)))))
+ (if (eq? (length inputs) 0) '() inputs))))
+
+(define (opam->guix-package name)
+ (let* ((htable (urls->htable (opam-urls)))
+ (versions (hash-ref htable name)))
+ (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-url url-url))
+ (metadata (fetch-metadata opam-url))
+ (deps (assoc-ref metadata "inputs"))
+ (native-inputs (deps->native-inputs deps))
+ (inputs (deps->inputs deps)))
+ (call-with-temporary-output-file
+ (lambda (temp port)
+ (and (url-fetch source-url temp)
+ `(package
+ (name ,name)
+ (version ,version)
+ (source
+ (origin
+ (method url-fetch)
+ (uri ,source-url)
+ (sha256 (base32 ,(guix-hash-url temp)))))
+ (build-system ocaml-build-system)
+ ,@(if (eq? (length inputs) 0)
+ '()
+ `((inputs ,(list 'quasiquote inputs))))
+ ,@(if (eq? (length native-inputs) 0)
+ '()
+ `((native-inputs ,(list 'quasiquote native-inputs))))
+ (home-page ,(assoc-ref metadata "homepage"))
+ (synopsis "")
+ (description "")
+ (license ,@(string->license (assoc-ref metadata "license")))))))))))
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 67bc7a755..bc03179e5 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -74,7 +74,7 @@ rather than \\n."
;;;
(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "stackage" "elpa" "gem"
- "cran" "crate" "texlive" "json"))
+ "cran" "crate" "texlive" "json" "opam"))
(define (resolve-importer name)
(let ((module (resolve-interface
diff --git a/guix/scripts/import/opam.scm b/guix/scripts/import/opam.scm
new file mode 100644
index 000000000..b54987874
--- /dev/null
+++ b/guix/scripts/import/opam.scm
@@ -0,0 +1,92 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Julien Lepiller
+;;;
+;;; 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 .
+
+(define-module (guix scripts import opam)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix scripts)
+ #:use-module (guix import opam)
+ #:use-module (guix scripts import)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:export (guix-import-opam))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ '())
+
+(define (show-help)
+ (display (G_ "Usage: guix import opam PACKAGE-NAME
+Import and convert the opam package for PACKAGE-NAME.\n"))
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specification of the command-line options.
+ (cons* (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix import opam")))
+ %standard-import-options))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-import-opam . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold* args %options
+ (lambda (opt name arg result)
+ (leave (G_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (alist-cons 'argument arg result))
+ %default-options))
+
+ (let* ((opts (parse-options))
+ (args (filter-map (match-lambda
+ (('argument . value)
+ value)
+ (_ #f))
+ (reverse opts))))
+ (match args
+ ((package-name)
+ (let ((sexp (opam->guix-package package-name)))
+ (unless sexp
+ (leave (G_ "failed to download meta-data for package '~a'~%")
+ package-name))
+ sexp))
+ (()
+ (leave (G_ "too few arguments~%")))
+ ((many ...)
+ (leave (G_ "too many arguments~%"))))))
--
2.17.1