From 04268bfc1a64c2c69f25977d76af8af34f7e0024 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 | 210 +++++++++++++++++++++++++++++++++++ guix/scripts/import.scm | 2 +- guix/scripts/import/opam.scm | 92 +++++++++++++++ 4 files changed, 305 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..92bcef292 --- /dev/null +++ b/guix/import/opam.scm @@ -0,0 +1,210 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson +;;; Copyright © 2015 Cyril Roelandt +;;; Copyright © 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2017 Mathieu Othacehe +;;; +;;; 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 binary-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 regex) + #: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 (web uri) + #:use-module (guix http-client) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module ((guix build utils) + #:select ((package-name->name+version + . hyphen-package-name->name+version))) + #: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 (opam-urls + urls->htable + opam->guix-package + %opam-updater)) + +(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) #f 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) #f 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..ab8bbcb5b --- /dev/null +++ b/guix/scripts/import/opam.scm @@ -0,0 +1,92 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson +;;; +;;; 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