guix/import/opam.scm

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