guix/scripts/import/crate.scm

   1
   2 ;;; GNU Guix --- Functional package management for GNU
   3 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
   4 ;;; Copyright © 2016 David Craven <david@craven.ch>
   5 ;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (guix scripts import crate)
  23   #:use-module (guix ui)
  24   #:use-module (guix utils)
  25   #:use-module (guix scripts)
  26   #:use-module (guix import crate)
  27   #:use-module (guix scripts import)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-11)
  30   #:use-module (srfi srfi-37)
  31   #:use-module (ice-9 match)
  32   #:use-module (ice-9 format)
  33   #:export (guix-import-crate))
  34
  35 \f
  36 ;;;
  37 ;;; Command-line options.
  38 ;;;
  39
  40 (define %default-options
  41   '())
  42
  43 (define (show-help)
  44   (display (G_ "Usage: guix import crate PACKAGE-NAME
  45 Import and convert the crate.io package for PACKAGE-NAME.\n"))
  46   (display (G_ "
  47   -r, --recursive        import packages recursively"))
  48   (newline)
  49   (display (G_ "
  50   -h, --help             display this help and exit"))
  51   (display (G_ "
  52   -V, --version          display version information and exit"))
  53   (newline)
  54   (show-bug-report-information))
  55
  56 (define %options
  57   ;; Specification of the command-line options.
  58   (cons* (option '(#\h "help") #f #f
  59                  (lambda args
  60                    (show-help)
  61                    (exit 0)))
  62          (option '(#\V "version") #f #f
  63                  (lambda args
  64                    (show-version-and-exit "guix import crate")))
  65          (option '(#\r "recursive") #f #f
  66                  (lambda (opt name arg result)
  67                    (alist-cons 'recursive #t result)))
  68          %standard-import-options))
  69
  70 \f
  71 ;;;
  72 ;;; Entry point.
  73 ;;;
  74
  75 (define (guix-import-crate . args)
  76   (define (parse-options)
  77     ;; Return the alist of option values.
  78     (args-fold* args %options
  79                 (lambda (opt name arg result)
  80                   (leave (G_ "~A: unrecognized option~%") name))
  81                 (lambda (arg result)
  82                   (alist-cons 'argument arg result))
  83                 %default-options))
  84
  85
  86   (let* ((opts (parse-options))
  87          (args (filter-map (match-lambda
  88                              (('argument . value)
  89                               value)
  90                              (_ #f))
  91                            (reverse opts))))
  92     (match args
  93       ((spec)
  94        (define-values (name version)
  95          (package-name->name+version spec))
  96
  97        (if (assoc-ref opts 'recursive)
  98            (map (match-lambda
  99                   ((and ('package ('name name) . rest) pkg)
 100                    `(define-public ,(string->symbol name)
 101                       ,pkg))
 102                   (_ #f))
 103                 (crate-recursive-import name))
 104            (let ((sexp (crate->guix-package name version)))
 105              (unless sexp
 106                (leave (G_ "failed to download meta-data for package '~a'~%")
 107                       (if version
 108                           (string-append name "@" version)
 109                           name)))
 110              sexp)))
 111       (()
 112        (leave (G_ "too few arguments~%")))
 113       ((many ...)
 114        (leave (G_ "too many arguments~%"))))))