guix-kreyren/guix/import/opam.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 opam)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module (srfi srfi-1)
  #:use-module (web uri)
  #:use-module (guix http-client)
  #:use-module (guix utils)
  #:use-module (guix import utils)
  #:use-module ((guix licenses) #:prefix license:)
  #:export (opam->guix-package))

(define (opam-urls)
  "Fetch the urls.txt file from the opam repository and returns the list of
URLs it contains."
  (let ((port (http-fetch/cached (string->uri "https://opam.ocaml.org/urls.txt"))))
    (let loop ((result '()))
      (let ((line (read-line port)))
        (if (eof-object? line)
          (begin
            (close port)
            result)
          (loop (cons line result)))))))

(define (vhash-ref hashtable key default)
  (match (vhash-assoc key hashtable)
    (#f default)
    ((_ . x) x)))

(define (hashtable-update hashtable line)
  "Parse @var{line} to get the name and version of the package and adds them
to the hashtable."
  (let* ((line (string-split line #\ )))
    (match line
      ((url foo ...)
       (if (equal? url "repo")
         hashtable
         (match (string-split url #\/)
           ((type name1 versionstr foo ...)
            (if (equal? type "packages")
              (match (string-split versionstr #\.)
                ((name2 versions ...)
                 (let ((version (string-join versions ".")))
                   (if (equal? name1 name2)
                     (let ((curr (vhash-ref hashtable name1 '())))
                       (vhash-cons name1 (cons version curr) hashtable))
                     hashtable)))
                (_ hashtable))
              hashtable))
           (_ hashtable))))
      (_ hashtable))))

(define (urls->hashtable urls)
  "Transform urls.txt in a hashtable whose keys are package names and values
the list of available versions."
  (let ((hashtable vlist-null))
    (let loop ((urls urls) (hashtable hashtable))
      (match urls
        (() hashtable)
        ((url rest ...) (loop rest (hashtable-update hashtable url)))))))

(define (latest-version versions)
  "Find the most recent version from a list of versions."
  (match versions
    ((first rest ...)
     (let loop ((versions rest) (m first))
       (match versions
         (() m)
         ((first rest ...)
          (loop rest (if (version>? m first) m first))))))))

(define (fetch-package-url uri)
  "Fetch and parse the url file.  Return the URL the package can be downloaded
from."
  (let ((port (http-fetch uri)))
    (let loop ((result #f))
      (let ((line (read-line port)))
        (if (eof-object? line)
          (begin
            (close port)
            result)
          (let* ((line (string-split line #\ )))
            (match line
              ((key value rest ...)
               (if (member key '("archive:" "http:"))
                 (loop (string-trim-both value #\"))
                 (loop result))))))))))

(define (fetch-package-metadata uri)
  "Fetch and parse the opam file.  Return an association list containing the
homepage, the license and the list of inputs."
  (let ((port (http-fetch uri)))
    (let loop ((result '()) (dependencies? #f))
      (let ((line (read-line port)))
        (if (eof-object? line)
          (begin
            (close port)
            result)
          (let* ((line (string-split line #\ )))
            (match line
               ((key value ...)
                (let ((dependencies?
                        (if dependencies?
                          (not (equal? key "]"))
                          (equal? key "depends:")))
                      (val (string-trim-both (string-join value "") #\")))
                  (cond
                    ((equal? key "homepage:")
                     (loop (cons `("homepage" . ,val) result) dependencies?))
                    ((equal? key "license:")
                     (loop (cons `("license" . ,val) result) dependencies?))
                    ((and dependencies? (not (equal? val "[")))
                     (match (string-split val #\{)
                       ((val rest ...)
                        (let ((curr (assoc-ref result "inputs"))
                              (new (string-trim-both
                                     val (list->char-set '(#\] #\[ #\")))))
                          (loop (cons `("inputs" . ,(cons new (if curr curr '()))) result)
                                (if (string-contains val "]") #f dependencies?))))))
                    (else (loop result dependencies?))))))))))))

(define (string->license str)
  (cond
    ((equal? str "MIT") '(license:expat))
    ((equal? str "GPL2") '(license:gpl2))
    ((equal? str "LGPLv2") '(license:lgpl2))
    (else `())))

(define (ocaml-name->guix-name name)
  (cond
    ((equal? name "ocamlfind") "ocaml-findlib")
    ((string-prefix? "ocaml" name) name)
    ((string-prefix? "conf-" name) (substring name 5))
    (else (string-append "ocaml-" name))))

(define (dependencies->inputs dependencies)
  "Transform the list of dependencies in a list of inputs."
  (if (not dependencies)
    '()
    (map (lambda (input)
           (list input (list 'unquote (string->symbol input))))
         (map ocaml-name->guix-name dependencies))))

(define (opam->guix-package name)
  (let* ((hashtable (urls->hashtable (opam-urls)))
         (versions (vhash-ref hashtable name #f)))
    (unless (eq? versions #f)
      (let* ((version (latest-version versions))
             (package-url (string-append "https://opam.ocaml.org/packages/" name
                                         "/" name "." version "/"))
             (url-url (string-append package-url "url"))
             (opam-url (string-append package-url "opam"))
             (source-url (fetch-package-url url-url))
             (metadata (fetch-package-metadata opam-url))
             (dependencies (assoc-ref metadata "inputs"))
             (inputs (dependencies->inputs dependencies)))
        (call-with-temporary-output-file
          (lambda (temp port)
            (and (url-fetch source-url temp)
                 `(package
                    (name ,(ocaml-name->guix-name name))
                    (version ,version)
                    (source
                      (origin
                        (method url-fetch)
                        (uri ,source-url)
                        (sha256 (base32 ,(guix-hash-url temp)))))
                    (build-system ocaml-build-system)
                    ,@(if (null? inputs)
                        '()
                        `((inputs ,(list 'quasiquote inputs))))
                    (home-page ,(assoc-ref metadata "homepage"))
                    (synopsis "")
                    (description "")
                    (license ,@(string->license (assoc-ref metadata "license")))))))))))