diff options
Diffstat (limited to 'guix/import/gopkg.scm')
-rw-r--r-- | guix/import/gopkg.scm | 356 |
1 files changed, 356 insertions, 0 deletions
diff --git a/guix/import/gopkg.scm b/guix/import/gopkg.scm new file mode 100644 index 0000000000..204bf18abb --- /dev/null +++ b/guix/import/gopkg.scm @@ -0,0 +1,356 @@ +;;; 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))))))) |