You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

319 lines
12 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
  3. ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
  4. ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
  5. ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
  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. (define-module (guix import cpan)
  22. #:use-module (ice-9 match)
  23. #:use-module (ice-9 regex)
  24. #:use-module ((ice-9 popen) #:select (open-pipe* close-pipe))
  25. #:use-module ((ice-9 rdelim) #:select (read-line))
  26. #:use-module (srfi srfi-1)
  27. #:use-module (srfi srfi-26)
  28. #:use-module (json)
  29. #:use-module (gcrypt hash)
  30. #:use-module (guix store)
  31. #:use-module (guix utils)
  32. #:use-module (guix base32)
  33. #:use-module (guix ui)
  34. #:use-module ((guix download) #:select (download-to-store url-fetch))
  35. #:use-module ((guix import utils) #:select (factorize-uri
  36. flatten assoc-ref*))
  37. #:use-module (guix import json)
  38. #:use-module (guix packages)
  39. #:use-module (guix upstream)
  40. #:use-module (guix derivations)
  41. #:export (cpan->guix-package
  42. %cpan-updater))
  43. ;;; Commentary:
  44. ;;;
  45. ;;; Generate a package declaration template for the latest version of a CPAN
  46. ;;; module, using meta-data from metacpan.org.
  47. ;;;
  48. ;;; Code:
  49. (define string->license
  50. (match-lambda
  51. ;; List of valid values from https://metacpan.org/pod/CPAN::Meta::Spec.
  52. ;; Some licenses are excluded based on their absense from (guix licenses).
  53. ("agpl_3" 'agpl3)
  54. ;; apache_1_1
  55. ("apache_2_0" 'asl2.0)
  56. ;; artistic_1
  57. ("artistic_2" 'artistic2.0)
  58. ("bsd" 'bsd-3)
  59. ("freebsd" 'bsd-2)
  60. ;; gfdl_1_2
  61. ("gfdl_1_3" 'fdl1.3+)
  62. ("gpl_1" 'gpl1)
  63. ("gpl_2" 'gpl2)
  64. ("gpl_3" 'gpl3)
  65. ("lgpl_2_1" 'lgpl2.1)
  66. ("lgpl_3_0" 'lgpl3)
  67. ("mit" 'x11)
  68. ;; mozilla_1_0
  69. ("mozilla_1_1" 'mpl1.1)
  70. ("openssl" 'openssl)
  71. ("perl_5" 'perl-license) ;GPL1+ and Artistic 1
  72. ("qpl_1_0" 'qpl)
  73. ;; ssleay
  74. ;; sun
  75. ("zlib" 'zlib)
  76. ((x) (string->license x))
  77. ((lst ...) `(list ,@(map string->license lst)))
  78. (_ #f)))
  79. (define (module->name module)
  80. "Transform a 'module' name into a 'release' name"
  81. (regexp-substitute/global #f "::" module 'pre "-" 'post))
  82. (define (module->dist-name module)
  83. "Return the base distribution module for a given module. E.g. the 'ok'
  84. module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would
  85. return \"Test-Simple\""
  86. (assoc-ref (json-fetch-alist (string-append
  87. "https://fastapi.metacpan.org/v1/module/"
  88. module
  89. "?fields=distribution"))
  90. "distribution"))
  91. (define (package->upstream-name package)
  92. "Return the CPAN name of PACKAGE."
  93. (let* ((properties (package-properties package))
  94. (upstream-name (and=> properties
  95. (cut assoc-ref <> 'upstream-name))))
  96. (or upstream-name
  97. (match (package-source package)
  98. ((? origin? origin)
  99. (match (origin-uri origin)
  100. ((or (? string? url) (url _ ...))
  101. (match (string-match (string-append "([^/]*)-v?[0-9\\.]+") url)
  102. (#f #f)
  103. (m (match:substring m 1))))
  104. (_ #f)))
  105. (_ #f)))))
  106. (define (cpan-fetch name)
  107. "Return an alist representation of the CPAN metadata for the perl module MODULE,
  108. or #f on failure. MODULE should be e.g. \"Test::Script\""
  109. ;; This API always returns the latest release of the module.
  110. (json-fetch-alist (string-append "https://fastapi.metacpan.org/v1/release/" name)))
  111. (define (cpan-home name)
  112. (string-append "https://metacpan.org/release/" name))
  113. (define (cpan-source-url meta)
  114. "Return the download URL for a module's source tarball."
  115. (regexp-substitute/global #f "http[s]?://cpan.metacpan.org"
  116. (assoc-ref meta "download_url")
  117. 'pre "mirror://cpan" 'post))
  118. (define (cpan-version meta)
  119. "Return the version number from META."
  120. (match (assoc-ref meta "version")
  121. ((? number? version)
  122. ;; version is sometimes not quoted in the module json, so it gets
  123. ;; imported into Guile as a number, so convert it to a string.
  124. (number->string version))
  125. (version
  126. ;; Sometimes we get a "v" prefix. Strip it.
  127. (if (string-prefix? "v" version)
  128. (string-drop version 1)
  129. version))))
  130. (define (perl-package)
  131. "Return the 'perl' package. This is a lazy reference so that we don't
  132. depend on (gnu packages perl)."
  133. (module-ref (resolve-interface '(gnu packages perl)) 'perl))
  134. (define %corelist
  135. (delay
  136. (let* ((perl (with-store store
  137. (derivation->output-path
  138. (package-derivation store (perl-package)))))
  139. (core (string-append perl "/bin/corelist")))
  140. (and (access? core X_OK)
  141. core))))
  142. (define core-module?
  143. (let ((rx (make-regexp
  144. (string-append "released with perl v?([0-9\\.]*)"
  145. "(.*and removed from v?([0-9\\.]*))?"))))
  146. (lambda (name)
  147. (define perl-version
  148. (package-version (perl-package)))
  149. (define (version-between? lower version upper)
  150. (and (version>=? version lower)
  151. (or (not upper)
  152. (version>? upper version))))
  153. (and (force %corelist)
  154. (parameterize ((current-error-port (%make-void-port "w")))
  155. (let* ((corelist (open-pipe* OPEN_READ (force %corelist) name)))
  156. (let loop ()
  157. (let ((line (read-line corelist)))
  158. (if (eof-object? line)
  159. (begin (close-pipe corelist) #f)
  160. (or (and=> (regexp-exec rx line)
  161. (lambda (m)
  162. (let ((first (match:substring m 1))
  163. (last (match:substring m 3)))
  164. (version-between?
  165. first perl-version last))))
  166. (loop)))))))))))
  167. (define (cpan-module->sexp meta)
  168. "Return the `package' s-expression for a CPAN module from the metadata in
  169. META."
  170. (define name
  171. (assoc-ref meta "distribution"))
  172. (define (guix-name name)
  173. (if (string-prefix? "perl-" name)
  174. (string-downcase name)
  175. (string-append "perl-" (string-downcase name))))
  176. (define version (cpan-version meta))
  177. (define source-url (cpan-source-url meta))
  178. (define (convert-inputs phases)
  179. ;; Convert phase dependencies into a list of name/variable pairs.
  180. (match (flatten
  181. (map (lambda (ph)
  182. (filter-map (lambda (t)
  183. (assoc-ref* meta "metadata" "prereqs" ph t))
  184. '("requires" "recommends" "suggests")))
  185. phases))
  186. (#f
  187. '())
  188. ((inputs ...)
  189. (sort
  190. (delete-duplicates
  191. ;; Listed dependencies may include core modules. Filter those out.
  192. (filter-map (match-lambda
  193. (("perl" . _) ;implicit dependency
  194. #f)
  195. ((module . _)
  196. (and (not (core-module? module))
  197. (let ((name (guix-name (module->dist-name module))))
  198. (list name
  199. (list 'unquote (string->symbol name)))))))
  200. inputs))
  201. (lambda args
  202. (match args
  203. (((a _ ...) (b _ ...))
  204. (string<? a b))))))))
  205. (define (maybe-inputs guix-name inputs)
  206. (match inputs
  207. (()
  208. '())
  209. ((inputs ...)
  210. (list (list guix-name
  211. (list 'quasiquote inputs))))))
  212. (let ((tarball (with-store store
  213. (download-to-store store source-url))))
  214. `(package
  215. (name ,(guix-name name))
  216. (version ,version)
  217. (source (origin
  218. (method url-fetch)
  219. (uri (string-append ,@(factorize-uri source-url version)))
  220. (sha256
  221. (base32
  222. ,(bytevector->nix-base32-string (file-sha256 tarball))))))
  223. (build-system perl-build-system)
  224. ,@(maybe-inputs 'native-inputs
  225. ;; "runtime" may also be needed here. See
  226. ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
  227. ;; which says they are required during building. We
  228. ;; have not yet had a need for cross-compiled perl
  229. ;; modules, however, so we leave it out.
  230. (convert-inputs '("configure" "build" "test")))
  231. ,@(maybe-inputs 'propagated-inputs
  232. (convert-inputs '("runtime")))
  233. (home-page ,(cpan-home name))
  234. (synopsis ,(assoc-ref meta "abstract"))
  235. (description fill-in-yourself!)
  236. (license ,(string->license (assoc-ref meta "license"))))))
  237. (define (cpan->guix-package module-name)
  238. "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the
  239. `package' s-expression corresponding to that package, or #f on failure."
  240. (let ((module-meta (cpan-fetch (module->name module-name))))
  241. (and=> module-meta cpan-module->sexp)))
  242. (define (cpan-package? package)
  243. "Return #t if PACKAGE is a package from CPAN."
  244. (define cpan-url?
  245. (let ((cpan-rx (make-regexp (string-append "("
  246. "mirror://cpan" "|"
  247. "https?://www.cpan.org" "|"
  248. "https?://cpan.metacpan.org"
  249. ")"))))
  250. (lambda (url)
  251. (regexp-exec cpan-rx url))))
  252. (let ((source-url (and=> (package-source package) origin-uri))
  253. (fetch-method (and=> (package-source package) origin-method)))
  254. (and (eq? fetch-method url-fetch)
  255. (match source-url
  256. ((? string?)
  257. (cpan-url? source-url))
  258. ((source-url ...)
  259. (any cpan-url? source-url))))))
  260. (define (latest-release package)
  261. "Return an <upstream-source> for the latest release of PACKAGE."
  262. (match (cpan-fetch (package->upstream-name package))
  263. (#f #f)
  264. (meta
  265. (let ((core-inputs
  266. (match (package-direct-inputs package)
  267. (((_ inputs _ ...) ...)
  268. (filter-map (match-lambda
  269. ((and (? package?)
  270. (? cpan-package?)
  271. (= package->upstream-name
  272. (? core-module? name)))
  273. name)
  274. (else #f))
  275. inputs)))))
  276. ;; Warn about inputs that are part of perl's core
  277. (unless (null? core-inputs)
  278. (for-each (lambda (module)
  279. (warning (G_ "input '~a' of ~a is in Perl core~%")
  280. module (package-name package)))
  281. core-inputs)))
  282. (let ((version (cpan-version meta))
  283. (url (cpan-source-url meta)))
  284. (upstream-source
  285. (package (package-name package))
  286. (version version)
  287. (urls (list url)))))))
  288. (define %cpan-updater
  289. (upstream-updater
  290. (name 'cpan)
  291. (description "Updater for CPAN packages")
  292. (pred cpan-package?)
  293. (latest latest-release)))