;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 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 composer) #:use-module (ice-9 match) #:use-module (json) #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix build git) #:use-module (guix build utils) #:use-module (guix build-system) #:use-module (guix import json) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix packages) #:use-module (guix serialization) #:use-module (guix upstream) #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:export (composer->guix-package %composer-updater composer-recursive-import)) ;; XXX adapted from (guix scripts hash) (define (file-hash file select? recursive?) ;; Compute the hash of FILE. (if recursive? (let-values (((port get-hash) (open-sha256-port))) (write-file file port #:select? select?) (force-output port) (get-hash)) (call-with-input-file file port-sha256))) ;; XXX taken from (guix scripts hash) (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 (latest-version versions) (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions)) (define (fix-version version) "Return a fixed version from a version string. For instance, v10.1 -> 10.1" (cond ((string-prefix? "version" version) (if (char-set-contains? char-set:digit (string-ref version 7)) (substring version 7) (substring version 8))) ((string-prefix? "v" version) (substring version 1)) (else version))) (define* (composer-fetch name #:optional version) "Return an alist representation of the Composer metadata for the package NAME, or #f on failure." (let ((package (json-fetch (string-append "https://repo.packagist.org/p/" name ".json")))) (if package (let* ((packages (assoc-ref package "packages")) (package (assoc-ref packages name)) (versions (filter (lambda (version) (and (not (string-contains version "dev")) (not (string-contains version "beta")))) (map car package))) (versions (map (lambda (version) (cons (fix-version version) version)) versions)) (version (or (if (null? version) #f version) (latest-version (map car versions))))) (assoc-ref package (assoc-ref versions version))) #f))) (define (php-package-name name) "Given the NAME of a package on Packagist, return a Guix-compliant name for the package." (let ((name (string-join (string-split name #\/) "-"))) (if (string-prefix? "php-" name) (snake-case name) (string-append "php-" (snake-case name))))) (define (make-php-sexp name version home-page description dependencies dev-dependencies licenses source) "Return the `package' s-expression for a PHP package with the given NAME, VERSION, HOME-PAGE, DESCRIPTION, DEPENDENCIES, LICENSES and SOURCE." (let ((git? (equal? (assoc-ref source "type") "git"))) ((if git? call-with-temporary-directory call-with-temporary-output-file) (lambda* (temp #:optional port) (and (if git? (begin (mkdir-p temp) (git-fetch (assoc-ref source "url") (assoc-ref source "reference") temp)) (url-fetch (assoc-ref source "url") temp)) `(package (name ,(php-package-name name)) (version ,version) (source (origin ,@(if git? `((method git-fetch) (uri (git-reference (url ,(assoc-ref source "url")) (commit ,(assoc-ref source "reference")))) (file-name (git-file-name name version)) (sha256 (base32 ,(bytevector->nix-base32-string (file-hash temp (negate vcs-file?) #t))))) `((method url-fetch) (uri ,(assoc-ref source "url")) (sha256 (base32 ,(guix-hash-url temp))))))) (build-system composer-build-system) ,@(if (null? dependencies) '() `((inputs (,'list ,@(map (lambda (name) `,(string->symbol name)) dependencies))))) ,@(if (null? dev-dependencies) '() `((native-inputs (,'list ,@(map (lambda (name) `,(string->symbol name)) dev-dependencies))))) (synopsis "") (description ,description) (home-page ,home-page) (license ,(match licenses (() #f) ((license) (license->symbol license)) (_ `(list ,@(map license->symbol licenses))))))))))) (define* (composer->guix-package package-name #:optional version) "Fetch the metadata for PACKAGE-NAME from packagist.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let ((package (composer-fetch package-name version))) (and package (let* ((name (assoc-ref package "name")) (version (fix-version (assoc-ref package "version"))) (description (beautify-description (assoc-ref package "description"))) (home-page (assoc-ref package "homepage")) (dependencies-names (filter (lambda (dep) (string-contains dep "/")) (map car (assoc-ref package "require")))) (dependencies (map php-package-name dependencies-names)) (require-dev (assoc-ref package "require-dev")) (dev-dependencies-names (if require-dev (filter (lambda (dep) (string-contains dep "/")) (map car require-dev)) '())) (dev-dependencies (map php-package-name dev-dependencies-names)) (licenses (map string->license (vector->list (assoc-ref package "license"))))) (values (make-php-sexp name version home-page description dependencies dev-dependencies licenses (assoc-ref package "source")) (append dependencies-names dev-dependencies-names)))))) (define (guix-name->composer-name name) "Given a guix package name, return the name of the package in Packagist." (if (string-prefix? "php-" name) (let ((components (string-split (substring name 4) #\-))) (match components ((namespace name ...) (string-append namespace "/" (string-join name "-"))))) name)) (define (guix-package->composer-name package) "Given a Composer PACKAGE built from Packagist, return the name of the package in Packagist." (let ((upstream-name (assoc-ref (package-properties package) 'upstream-name)) (name (package-name package))) (if upstream-name upstream-name (guix-name->composer-name name)))) (define (string->license str) "Convert the string STR into a license object." (match str ("GNU LGPL" license:lgpl2.0) ("GPL" license:gpl3) ((or "BSD" "BSD License" "BSD-3-Clause") license:bsd-3) ((or "MIT" "MIT license" "Expat license") license:expat) ("Public domain" license:public-domain) ((or "Apache License, Version 2.0" "Apache 2.0") license:asl2.0) (_ #f))) (define (php-package? package) "Return true if PACKAGE is a PHP package from Packagist." (and (eq? (build-system-name (package-build-system package)) 'composer) (string-prefix? "php-" (package-name package)))) (define (latest-release package) "Return an for the latest release of PACKAGE." (let* ((php-name (guix-package->composer-name package)) (metadata (composer-fetch php-name)) (version (fix-version (assoc-ref metadata "version"))) (url (assoc-ref (assoc-ref metadata "source") "url"))) (upstream-source (package (package-name package)) (version version) (urls (list url))))) (define %composer-updater (upstream-updater (name 'composer) (description "Updater for Composer packages") (pred php-package?) (import latest-release))) (define* (composer-recursive-import package-name #:optional version) (recursive-import package-name '() #:repo->guix-package composer->guix-package #:guix-name php-package-name))