From 3e9b4fa12811432fdd7a4d6330f9093dcc72d25a Mon Sep 17 00:00:00 2001 From: Rouby Pierre-Antoine Date: Thu, 26 Apr 2018 15:05:23 +0200 Subject: [PATCH] import: Add gopkg importer. * guix/import/gopkg.scm: New file. * guix/scripts/import/gopkg.scm: New file. * guix/scripts/import.scm: Add 'gopkg'. * Makefile.am: Add 'gopkg' importer in modules list. --- Makefile.am | 1 + guix/import/gopkg.scm | 384 ++++++++++++++++++++++++++++++++++ guix/scripts/import.scm | 2 +- guix/scripts/import/gopkg.scm | 99 +++++++++ 4 files changed, 485 insertions(+), 1 deletion(-) create mode 100644 guix/import/gopkg.scm create mode 100644 guix/scripts/import/gopkg.scm diff --git a/Makefile.am b/Makefile.am index 9f134c970..e103517fc 100644 --- a/Makefile.am +++ b/Makefile.am @@ -183,6 +183,7 @@ MODULES = \ guix/import/hackage.scm \ guix/import/elpa.scm \ guix/import/texlive.scm \ + guix/import/gopkg.scm \ guix/scripts.scm \ guix/scripts/download.scm \ guix/scripts/perform-download.scm \ diff --git a/guix/import/gopkg.scm b/guix/import/gopkg.scm new file mode 100644 index 000000000..200d9ffd3 --- /dev/null +++ b/guix/import/gopkg.scm @@ -0,0 +1,384 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Pierre-Antoine Rouby +;;; +;;; 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 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 (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)) + +;; +;; Directory. +;; + +(define (get-new-tmp-dir) + "Return new temp directory." + (let ((tmp "/tmp/guix-import-gopkg")) + (define (new num) + (let ((new-dir (string-append tmp "-" (number->string num)))) + (if (file-exists? new-dir) + (new (+ num 1)) + new-dir))) + (if (file-exists? tmp) + (new 0) + tmp))) + +(define tmp-dir (get-new-tmp-dir)) + +;; +;; Git. +;; + +(define (vcs-file? file stat) + (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? file)) + (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." + ;; Disable TLS certificate verification. The hash of the checkout is known + ;; in advance anyway. + (setenv "GIT_SSL_NO_VERIFY" "true") + + (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->path url) + "Return directory path corresponding to URL." + (string-replace-substring + (string-append tmp-dir "/" + (cut-url url)) + "." "-")) + +(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 + revision commit + constraint? is-dep?) + "Return packages and dependencies with new package sexp corresponding to +URL." + (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 + (url->path git-url))) + (commit-hash (if (< (string-length commit) 40) + (git-ref->commit (url->path + (url->git-url url)) + 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 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 ((output (url->path url)) + (name (url->package-name (cut-url url))) + (version "0.0.0") + (revision "0")) + (git-fetch url branch output #:recursive? #f) + + (let-values (((packages dependencies) + (gopkg-dep->packages+dependencies + (string-append output + "/Gopkg.toml")))) + (let-values (((packages dependencies) + (create-package->packages+dependencies packages dependencies + (cut-url url) version + revision branch + #f #f))) + (values packages))))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 67bc7a755..3c55bfaff 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" "gopkg")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/gopkg.scm b/guix/scripts/import/gopkg.scm new file mode 100644 index 000000000..f513779ed --- /dev/null +++ b/guix/scripts/import/gopkg.scm @@ -0,0 +1,99 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Pierre-Antoine Rouby +;;; +;;; 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 gopkg) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import gopkg) + #: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-gopkg)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import gopkg PACKAGE-URL BRANCH +Import and convert the git repo with toml file to guix package using +PACKAGE-URL and matching BRANCH.\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 gopkg"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-gopkg . 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-url branch) + (let ((sexp (gopkg->guix-package package-url branch))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-url)) + sexp)) + ((package-url) + (let ((sexp (gopkg->guix-package package-url "master"))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-url)) + sexp)) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) -- 2.17.0