guix/import/opam.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix import opam)
  20   #:use-module (ice-9 ftw)
  21   #:use-module (ice-9 match)
  22   #:use-module (ice-9 peg)
  23   #:use-module (ice-9 receive)
  24   #:use-module ((ice-9 rdelim) #:select (read-line))
  25   #:use-module (ice-9 textual-ports)
  26   #:use-module (ice-9 vlist)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-2)
  29   #:use-module (web uri)
  30   #:use-module (guix build-system)
  31   #:use-module (guix build-system ocaml)
  32   #:use-module (guix http-client)
  33   #:use-module (guix git)
  34   #:use-module (guix ui)
  35   #:use-module (guix packages)
  36   #:use-module (guix upstream)
  37   #:use-module (guix utils)
  38   #:use-module (guix import utils)
  39   #:use-module ((guix licenses) #:prefix license:)
  40   #:export (opam->guix-package
  41             opam-recursive-import
  42             %opam-updater
  43
  44             ;; The following patterns are exported for testing purposes.
  45             string-pat
  46             multiline-string
  47             list-pat
  48             dict
  49             condition))
  50
  51 ;; Define a PEG parser for the opam format
  52 (define-peg-pattern comment none (and "#" (* STRCHR) "\n"))
  53 (define-peg-pattern SP none (or " " "\n" comment))
  54 (define-peg-pattern SP2 body (or " " "\n"))
  55 (define-peg-pattern QUOTE none "\"")
  56 (define-peg-pattern QUOTE2 body "\"")
  57 (define-peg-pattern COLON none ":")
  58 ;; A string character is any character that is not a quote, or a quote preceded by a backslash.
  59 (define-peg-pattern STRCHR body
  60                     (or " " "!" "\n" (and (ignore "\\") "\"")
  61                         (and (ignore "\\") "\\") (range #\# #\頋)))
  62 (define-peg-pattern operator all (or "=" "!" "<" ">"))
  63
  64 (define-peg-pattern records body (* (and (or record weird-record) (* SP))))
  65 (define-peg-pattern record all (and key COLON (* SP) value))
  66 (define-peg-pattern weird-record all (and key (* SP) dict))
  67 (define-peg-pattern key body (+ (or (range #\a #\z) "-")))
  68 (define-peg-pattern value body (and (or conditional-value ground-value operator) (* SP)))
  69 (define-peg-pattern choice-pat all (and (ignore "(") (* SP) choice (* SP)  (ignore ")")))
  70 (define-peg-pattern choice body
  71   (or (and (or conditional-value ground-value) (* SP) (ignore "|") (* SP) choice)
  72       conditional-value
  73       ground-value))
  74 (define-peg-pattern ground-value body (and (or multiline-string string-pat choice-pat list-pat var) (* SP)))
  75 (define-peg-pattern conditional-value all (and ground-value (* SP) condition))
  76 (define-peg-pattern string-pat all (and QUOTE (* STRCHR) QUOTE))
  77 (define-peg-pattern list-pat all (and (ignore "[") (* SP) (* (and value (* SP))) (ignore "]")))
  78 (define-peg-pattern var all (+ (or (range #\a #\z) "-")))
  79 (define-peg-pattern multiline-string all
  80                     (and QUOTE QUOTE QUOTE (* SP)
  81                          (* (or SP2 STRCHR (and QUOTE2 (not-followed-by QUOTE))
  82                                 (and QUOTE2 QUOTE2 (not-followed-by QUOTE))))
  83                          QUOTE QUOTE QUOTE))
  84 (define-peg-pattern dict all (and (ignore "{") (* SP) records (* SP) (ignore "}")))
  85
  86 (define-peg-pattern condition body (and (ignore "{") condition-form (ignore "}")))
  87
  88 (define-peg-pattern condition-form body
  89                     (and
  90                       (* SP)
  91                       (or condition-and condition-or condition-form2)
  92                       (* SP)))
  93 (define-peg-pattern condition-form2 body
  94                     (and (* SP) (or condition-greater-or-equal condition-greater
  95                                     condition-lower-or-equal condition-lower
  96                                     condition-neq condition-eq condition-not
  97                                     condition-content) (* SP)))
  98
  99 ;(define-peg-pattern condition-operator all (and (ignore operator) (* SP) condition-string))
 100 (define-peg-pattern condition-greater-or-equal all (and (ignore (and ">" "=")) (* SP) condition-string))
 101 (define-peg-pattern condition-greater all (and (ignore ">") (* SP) condition-string))
 102 (define-peg-pattern condition-lower-or-equal all (and (ignore (and "<" "=")) (* SP) condition-string))
 103 (define-peg-pattern condition-lower all (and (ignore "<") (* SP) condition-string))
 104 (define-peg-pattern condition-and all (and condition-form2 (* SP) (? (ignore "&")) (* SP) condition-form))
 105 (define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form))
 106 (define-peg-pattern condition-eq all (and (? condition-content) (* SP) (ignore "=") (* SP) condition-content))
 107 (define-peg-pattern condition-neq all (and (? condition-content) (* SP) (ignore (and "!" "=")) (* SP) condition-content))
 108 (define-peg-pattern condition-not all (and (ignore (and "!")) (* SP) condition-content))
 109 (define-peg-pattern condition-content body (or condition-paren condition-string condition-var))
 110 (define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!"))))
 111 (define-peg-pattern condition-paren body (and "(" condition-form ")"))
 112 (define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE))
 113 (define-peg-pattern condition-var all (+ (or (range #\a #\z) "-" ":")))
 114
 115 (define (get-opam-repository)
 116   "Update or fetch the latest version of the opam repository and return the
 117 path to the repository."
 118   (receive (location commit _)
 119     (update-cached-checkout "https://github.com/ocaml/opam-repository")
 120     location))
 121
 122 (define (latest-version versions)
 123   "Find the most recent version from a list of versions."
 124   (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions))
 125
 126 (define (find-latest-version package repository)
 127   "Get the latest version of a package as described in the given repository."
 128   (let* ((dir (string-append repository "/packages/" package))
 129          (versions (scandir dir (lambda (name) (not (string-prefix? "." name))))))
 130     (if versions
 131       (let ((versions (map
 132                         (lambda (dir)
 133                           (string-join (cdr (string-split dir #\.)) "."))
 134                         versions)))
 135         ;; Workaround for janestreet re-versionning
 136         (let ((v-versions (filter (lambda (version) (string-prefix? "v" version)) versions)))
 137           (if (null? v-versions)
 138             (latest-version versions)
 139             (string-append "v" (latest-version (map (lambda (version) (substring version 1)) v-versions))))))
 140       (begin
 141         (format #t (G_ "Package not found in opam repository: ~a~%") package)
 142         #f))))
 143
 144 (define (get-metadata opam-file)
 145   (with-input-from-file opam-file
 146     (lambda _
 147       (peg:tree (match-pattern records (get-string-all (current-input-port)))))))
 148
 149 (define (substitute-char str what with)
 150   (string-join (string-split str what) with))
 151
 152 (define (ocaml-name->guix-name name)
 153   (substitute-char
 154     (cond
 155       ((equal? name "ocamlfind") "ocaml-findlib")
 156       ((string-prefix? "ocaml" name) name)
 157       ((string-prefix? "conf-" name) (substring name 5))
 158       (else (string-append "ocaml-" name)))
 159     #\_ "-"))
 160
 161 (define (metadata-ref file lookup)
 162   (fold (lambda (record acc)
 163           (match record
 164             ((record key val)
 165              (if (equal? key lookup)
 166                (match val
 167                  (('list-pat . stuff) stuff)
 168                  (('string-pat stuff) stuff)
 169                  (('multiline-string stuff) stuff)
 170                  (('dict records ...) records))
 171                acc))))
 172         #f file))
 173
 174 (define (native? condition)
 175   (match condition
 176     (('condition-var var)
 177      (match var
 178        ("with-test" #t)
 179        ("test" #t)
 180        ("build" #t)
 181        (_ #f)))
 182     ((or ('condition-or cond-left cond-right) ('condition-and cond-left cond-right))
 183      (or (native? cond-left)
 184          (native? cond-right)))
 185     (_ #f)))
 186
 187 (define (dependency->input dependency)
 188   (match dependency
 189     (('string-pat str) str)
 190     ;; Arbitrary select the first dependency
 191     (('choice-pat choice ...) (dependency->input (car choice)))
 192     (('conditional-value val condition)
 193      (if (native? condition) "" (dependency->input val)))))
 194
 195 (define (dependency->native-input dependency)
 196   (match dependency
 197     (('string-pat str) "")
 198     ;; Arbitrary select the first dependency
 199     (('choice-pat choice ...) (dependency->input (car choice)))
 200     (('conditional-value val condition)
 201      (if (native? condition) (dependency->input val) ""))))
 202
 203 (define (dependency->name dependency)
 204   (match dependency
 205     (('string-pat str) str)
 206     ;; Arbitrary select the first dependency
 207     (('choice-pat choice ...) (dependency->input (car choice)))
 208     (('conditional-value val condition)
 209      (dependency->name val))))
 210
 211 (define (dependency-list->names lst)
 212   (filter
 213     (lambda (name)
 214       (not (or
 215              (string-prefix? "conf-" name)
 216              (equal? name "ocaml")
 217              (equal? name "findlib"))))
 218     (map dependency->name lst)))
 219
 220 (define (ocaml-names->guix-names names)
 221   (map ocaml-name->guix-name
 222        (remove (lambda (name)
 223                  (or (equal? "" name))
 224                      (equal? "ocaml" name))
 225                names)))
 226
 227 (define (depends->inputs depends)
 228   (filter (lambda (name)
 229             (and (not (equal? "" name))
 230                  (not (equal? "ocaml" name))
 231                  (not (equal? "ocamlfind" name))))
 232     (map dependency->input depends)))
 233
 234 (define (depends->native-inputs depends)
 235   (filter (lambda (name) (not (equal? "" name)))
 236     (map dependency->native-input depends)))
 237
 238 (define (dependency-list->inputs lst)
 239   (map
 240     (lambda (dependency)
 241       (list dependency (list 'unquote (string->symbol dependency))))
 242     (ocaml-names->guix-names lst)))
 243
 244 (define* (opam-fetch name #:optional (repository (get-opam-repository)))
 245   (and-let* ((repository repository)
 246              (version (find-latest-version name repository))
 247              (file (string-append repository "/packages/" name "/" name "." version "/opam")))
 248     `(("metadata" ,@(get-metadata file))
 249       ("version" . ,(if (string-prefix? "v" version)
 250                         (substring version 1)
 251                         version)))))
 252
 253 (define* (opam->guix-package name #:key (repository (get-opam-repository)))
 254   "Import OPAM package NAME from REPOSITORY (a directory name) or, if
 255 REPOSITORY is #f, from the official OPAM repository.  Return a 'package' sexp
 256 or #f on failure."
 257   (and-let* ((opam-file (opam-fetch name repository))
 258              (version (assoc-ref opam-file "version"))
 259              (opam-content (assoc-ref opam-file "metadata"))
 260              (url-dict (metadata-ref opam-content "url"))
 261              (source-url (metadata-ref url-dict "src"))
 262              (requirements (metadata-ref opam-content "depends"))
 263              (dependencies (dependency-list->names requirements))
 264              (native-dependencies (depends->native-inputs requirements))
 265              (inputs (dependency-list->inputs (depends->inputs requirements)))
 266              (native-inputs (dependency-list->inputs
 267                               ;; Do not add dune nor jbuilder since they are
 268                               ;; implicit inputs of the dune-build-system.
 269                               (filter
 270                                 (lambda (name)
 271                                   (not (member name '("dune" "jbuilder"))))
 272                                 native-dependencies))))
 273         ;; If one of these are required at build time, it means we
 274         ;; can use the much nicer dune-build-system.
 275         (let ((use-dune? (or (member "dune" (append dependencies native-dependencies))
 276                         (member "jbuilder" (append dependencies native-dependencies)))))
 277           (call-with-temporary-output-file
 278             (lambda (temp port)
 279               (and (url-fetch source-url temp)
 280                    (values
 281                     `(package
 282                        (name ,(ocaml-name->guix-name name))
 283                        (version ,(if (string-prefix? "v" version)
 284                                    (substring version 1)
 285                                    version))
 286                        (source
 287                          (origin
 288                            (method url-fetch)
 289                            (uri ,source-url)
 290                            (sha256 (base32 ,(guix-hash-url temp)))))
 291                        (build-system ,(if use-dune?
 292                                           'dune-build-system
 293                                           'ocaml-build-system))
 294                        ,@(if (null? inputs)
 295                            '()
 296                            `((propagated-inputs ,(list 'quasiquote inputs))))
 297                        ,@(if (null? native-inputs)
 298                            '()
 299                            `((native-inputs ,(list 'quasiquote native-inputs))))
 300                        ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name)))
 301                            '()
 302                            `((properties
 303                                ,(list 'quasiquote `((upstream-name . ,name))))))
 304                        (home-page ,(metadata-ref opam-content "homepage"))
 305                        (synopsis ,(metadata-ref opam-content "synopsis"))
 306                        (description ,(metadata-ref opam-content "description"))
 307                        (license #f))
 308                     (filter
 309                       (lambda (name)
 310                         (not (member name '("dune" "jbuilder"))))
 311                       dependencies))))))))
 312
 313 (define (opam-recursive-import package-name)
 314   (recursive-import package-name #f
 315                     #:repo->guix-package (lambda (name repo)
 316                                            (opam->guix-package name))
 317                     #:guix-name ocaml-name->guix-name))
 318
 319 (define (guix-name->opam-name name)
 320   (if (string-prefix? "ocaml-" name)
 321     (substring name 6)
 322     name))
 323
 324 (define (guix-package->opam-name package)
 325   "Given an OCaml PACKAGE built from OPAM, return the name of the
 326 package in OPAM."
 327   (let ((upstream-name (assoc-ref
 328                          (package-properties package)
 329                          'upstream-name))
 330         (name (package-name package)))
 331     (if upstream-name
 332       upstream-name
 333       (guix-name->opam-name name))))
 334
 335 (define (opam-package? package)
 336   "Return true if PACKAGE is an OCaml package from OPAM"
 337   (and
 338     (member (build-system-name (package-build-system package)) '(dune ocaml))
 339     (not (string-prefix? "ocaml4" (package-name package)))))
 340
 341 (define (latest-release package)
 342   "Return an <upstream-source> for the latest release of PACKAGE."
 343   (and-let* ((opam-name (guix-package->opam-name package))
 344              (opam-file (opam-fetch opam-name))
 345              (version (assoc-ref opam-file "version"))
 346              (opam-content (assoc-ref opam-file "metadata"))
 347              (url-dict (metadata-ref opam-content "url"))
 348              (source-url (metadata-ref url-dict "src")))
 349     (upstream-source
 350       (package (package-name package))
 351       (version version)
 352       (urls (list source-url)))))
 353
 354 (define %opam-updater
 355   (upstream-updater
 356     (name 'opam)
 357     (description "Updater for OPAM packages")
 358     (pred opam-package?)
 359     (latest latest-release)))