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.
 
 
 
 
 
 

435 lines
17 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2018 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
  4. ;;; Copyright © 2016 David Craven <david@craven.ch>
  5. ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
  6. ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
  7. ;;;
  8. ;;; This file is part of GNU Guix.
  9. ;;;
  10. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11. ;;; under the terms of the GNU General Public License as published by
  12. ;;; the Free Software Foundation; either version 3 of the License, or (at
  13. ;;; your option) any later version.
  14. ;;;
  15. ;;; GNU Guix is distributed in the hope that it will be useful, but
  16. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  18. ;;; GNU General Public License for more details.
  19. ;;;
  20. ;;; You should have received a copy of the GNU General Public License
  21. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  22. (define-module (guix import utils)
  23. #:use-module (guix base32)
  24. #:use-module ((guix build download) #:prefix build:)
  25. #:use-module (gcrypt hash)
  26. #:use-module (guix http-client)
  27. #:use-module ((guix licenses) #:prefix license:)
  28. #:use-module (guix utils)
  29. #:use-module (guix packages)
  30. #:use-module (guix discovery)
  31. #:use-module (guix build-system)
  32. #:use-module (guix gexp)
  33. #:use-module (guix store)
  34. #:use-module (guix download)
  35. #:use-module (gnu packages)
  36. #:use-module (ice-9 match)
  37. #:use-module (ice-9 rdelim)
  38. #:use-module (ice-9 receive)
  39. #:use-module (ice-9 regex)
  40. #:use-module (srfi srfi-1)
  41. #:use-module (srfi srfi-11)
  42. #:use-module (srfi srfi-26)
  43. #:use-module (srfi srfi-41)
  44. #:export (factorize-uri
  45. hash-table->alist
  46. flatten
  47. assoc-ref*
  48. url-fetch
  49. guix-hash-url
  50. maybe-inputs
  51. maybe-native-inputs
  52. package->definition
  53. spdx-string->license
  54. license->symbol
  55. snake-case
  56. beautify-description
  57. alist->package
  58. read-lines
  59. chunk-lines
  60. guix-name
  61. recursive-import))
  62. (define (factorize-uri uri version)
  63. "Factorize URI, a package tarball URI as a string, such that any occurrences
  64. of the string VERSION is replaced by the symbol 'version."
  65. (let ((version-rx (make-regexp (regexp-quote version))))
  66. (match (regexp-exec version-rx uri)
  67. (#f
  68. uri)
  69. (_
  70. (let ((indices (fold-matches version-rx uri
  71. '((0))
  72. (lambda (m result)
  73. (match result
  74. (((start) rest ...)
  75. `((,(match:end m))
  76. (,start . ,(match:start m))
  77. ,@rest)))))))
  78. (fold (lambda (index result)
  79. (match index
  80. ((start)
  81. (cons (substring uri start)
  82. result))
  83. ((start . end)
  84. (cons* (substring uri start end)
  85. 'version
  86. result))))
  87. '()
  88. indices))))))
  89. (define (hash-table->alist table)
  90. "Return an alist represenation of TABLE."
  91. (map (match-lambda
  92. ((key . (lst ...))
  93. (cons key
  94. (map (lambda (x)
  95. (if (hash-table? x)
  96. (hash-table->alist x)
  97. x))
  98. lst)))
  99. ((key . (? hash-table? table))
  100. (cons key (hash-table->alist table)))
  101. (pair pair))
  102. (hash-map->list cons table)))
  103. (define (flatten lst)
  104. "Return a list that recursively concatenates all sub-lists of LST."
  105. (fold-right
  106. (match-lambda*
  107. (((sub-list ...) memo)
  108. (append (flatten sub-list) memo))
  109. ((elem memo)
  110. (cons elem memo)))
  111. '() lst))
  112. (define (assoc-ref* alist key . rest)
  113. "Return the value for KEY from ALIST. For each additional key specified,
  114. recursively apply the procedure to the sub-list."
  115. (if (null? rest)
  116. (assoc-ref alist key)
  117. (apply assoc-ref* (assoc-ref alist key) rest)))
  118. (define (url-fetch url file-name)
  119. "Save the contents of URL to FILE-NAME. Return #f on failure."
  120. (parameterize ((current-output-port (current-error-port)))
  121. (build:url-fetch url file-name)))
  122. (define (guix-hash-url filename)
  123. "Return the hash of FILENAME in nix-base32 format."
  124. (bytevector->nix-base32-string (file-sha256 filename)))
  125. (define (spdx-string->license str)
  126. "Convert STR, a SPDX formatted license identifier, to a license object.
  127. Return #f if STR does not match any known identifiers."
  128. ;; https://spdx.org/licenses/
  129. ;; The psfl, gfl1.0, nmap, repoze
  130. ;; licenses doesn't have SPDX identifiers
  131. (match str
  132. ("AGPL-1.0" 'license:agpl-1.0)
  133. ("AGPL-3.0" 'license:agpl-3.0)
  134. ("Apache-1.1" 'license:asl1.1)
  135. ("Apache-2.0" 'license:asl2.0)
  136. ("BSL-1.0" 'license:boost1.0)
  137. ("BSD-2-Clause-FreeBSD" 'license:bsd-2)
  138. ("BSD-3-Clause" 'license:bsd-3)
  139. ("BSD-4-Clause" 'license:bsd-4)
  140. ("CC0-1.0" 'license:cc0)
  141. ("CC-BY-2.0" 'license:cc-by2.0)
  142. ("CC-BY-3.0" 'license:cc-by3.0)
  143. ("CC-BY-SA-2.0" 'license:cc-by-sa2.0)
  144. ("CC-BY-SA-3.0" 'license:cc-by-sa3.0)
  145. ("CC-BY-SA-4.0" 'license:cc-by-sa4.0)
  146. ("CDDL-1.0" 'license:cddl1.0)
  147. ("CECILL-C" 'license:cecill-c)
  148. ("Artistic-2.0" 'license:artistic2.0)
  149. ("ClArtistic" 'license:clarified-artistic)
  150. ("CPL-1.0" 'license:cpl1.0)
  151. ("EPL-1.0" 'license:epl1.0)
  152. ("MIT" 'license:expat)
  153. ("FTL" 'license:freetype)
  154. ("GFDL-1.1" 'license:fdl1.1+)
  155. ("GFDL-1.2" 'license:fdl1.2+)
  156. ("GFDL-1.3" 'license:fdl1.3+)
  157. ("Giftware" 'license:giftware)
  158. ("GPL-1.0" 'license:gpl1)
  159. ("GPL-1.0+" 'license:gpl1+)
  160. ("GPL-2.0" 'license:gpl2)
  161. ("GPL-2.0+" 'license:gpl2+)
  162. ("GPL-3.0" 'license:gpl3)
  163. ("GPL-3.0+" 'license:gpl3+)
  164. ("ISC" 'license:isc)
  165. ("IJG" 'license:ijg)
  166. ("Imlib2" 'license:imlib2)
  167. ("IPA" 'license:ipa)
  168. ("IPL-1.0" 'license:ibmpl1.0)
  169. ("LGPL-2.0" 'license:lgpl2.0)
  170. ("LGPL-2.0+" 'license:lgpl2.0+)
  171. ("LGPL-2.1" 'license:lgpl2.1)
  172. ("LGPL-2.1+" 'license:lgpl2.1+)
  173. ("LGPL-3.0" 'license:lgpl3.0)
  174. ("LGPL-3.0+" 'license:lgpl3.0+)
  175. ("MPL-1.0" 'license:mpl1.0)
  176. ("MPL-1.1" 'license:mpl1.1)
  177. ("MPL-2.0" 'license:mpl2.0)
  178. ("MS-PL" 'license:ms-pl)
  179. ("NCSA" 'license:ncsa)
  180. ("OpenSSL" 'license:openssl)
  181. ("OLDAP-2.8" 'license:openldap2.8)
  182. ("CUA-OPL-1.0" 'license:opl1.0)
  183. ("QPL-1.0" 'license:qpl)
  184. ("Ruby" 'license:ruby)
  185. ("SGI-B-2.0" 'license:sgifreeb2.0)
  186. ("OFL-1.1" 'license:silofl1.1)
  187. ("Sleepycat" 'license:sleepycat)
  188. ("TCL" 'license:tcl/tk)
  189. ("Unlicense" 'license:unlicense)
  190. ("Vim" 'license:vim)
  191. ("X11" 'license:x11)
  192. ("ZPL-2.1" 'license:zpl2.1)
  193. ("Zlib" 'license:zlib)
  194. (_ #f)))
  195. (define (license->symbol license)
  196. "Convert license to a symbol representing the variable the object is bound
  197. to in the (guix licenses) module, or #f if there is no such known license."
  198. (define licenses
  199. (module-map (lambda (sym var) `(,(variable-ref var) . ,sym))
  200. (resolve-interface '(guix licenses) #:prefix 'license:)))
  201. (assoc-ref licenses license))
  202. (define (snake-case str)
  203. "Return a downcased version of the string STR where underscores are replaced
  204. with dashes."
  205. (string-join (string-split (string-downcase str) #\_) "-"))
  206. (define (beautify-description description)
  207. "Improve the package DESCRIPTION by turning a beginning sentence fragment
  208. into a proper sentence and by using two spaces between sentences."
  209. (let ((cleaned (if (string-prefix? "A " description)
  210. (string-append "This package provides a"
  211. (substring description 1))
  212. description)))
  213. ;; Use double spacing between sentences
  214. (regexp-substitute/global #f "\\. \\b"
  215. cleaned 'pre ". " 'post)))
  216. (define* (package-names->package-inputs names #:optional (output #f))
  217. (map (lambda (input)
  218. (cons* input (list 'unquote (string->symbol input))
  219. (or (and output (list output))
  220. '())))
  221. names))
  222. (define* (maybe-inputs package-names #:optional (output #f))
  223. "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
  224. package definition."
  225. (match (package-names->package-inputs package-names output)
  226. (()
  227. '())
  228. ((package-inputs ...)
  229. `((inputs (,'quasiquote ,package-inputs))))))
  230. (define* (maybe-native-inputs package-names #:optional (output #f))
  231. "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
  232. package definition."
  233. (match (package-names->package-inputs package-names output)
  234. (()
  235. '())
  236. ((package-inputs ...)
  237. `((native-inputs (,'quasiquote ,package-inputs))))))
  238. (define (package->definition guix-package)
  239. (match guix-package
  240. (('package ('name (? string? name)) _ ...)
  241. `(define-public ,(string->symbol name)
  242. ,guix-package))))
  243. (define (build-system-modules)
  244. (all-modules (map (lambda (entry)
  245. `(,entry . "guix/build-system"))
  246. %load-path)))
  247. (define (lookup-build-system-by-name name)
  248. "Return a <build-system> value for the symbol NAME, representing the name of
  249. the build system."
  250. (fold-module-public-variables (lambda (obj result)
  251. (if (and (build-system? obj)
  252. (eq? name (build-system-name obj)))
  253. obj result))
  254. #f
  255. (build-system-modules)))
  256. (define (specs->package-lists specs)
  257. "Convert each string in the SPECS list to a list of a package label and a
  258. package value."
  259. (map (lambda (spec)
  260. (let-values (((pkg out) (specification->package+output spec)))
  261. (match out
  262. (("out") (list (package-name pkg) pkg))
  263. (_ (list (package-name pkg) pkg out)))))
  264. specs))
  265. (define (source-spec->object source)
  266. "Generate an <origin> object from a SOURCE specification. The SOURCE can
  267. either be a simple URL string, #F, or an alist containing entries for each of
  268. the expected fields of an <origin> object."
  269. (match source
  270. ((? string? source-url)
  271. (let ((tarball (with-store store (download-to-store store source-url))))
  272. (origin
  273. (method url-fetch)
  274. (uri source-url)
  275. (sha256 (base32 (guix-hash-url tarball))))))
  276. (#f #f)
  277. (orig (let ((sha (match (assoc-ref orig "sha256")
  278. ((("base32" . value))
  279. (base32 value))
  280. (_ #f))))
  281. (origin
  282. (method (match (assoc-ref orig "method")
  283. ("url-fetch" (@ (guix download) url-fetch))
  284. ("git-fetch" (@ (guix git-download) git-fetch))
  285. ("svn-fetch" (@ (guix svn-download) svn-fetch))
  286. ("hg-fetch" (@ (guix hg-download) hg-fetch))
  287. (_ #f)))
  288. (uri (assoc-ref orig "uri"))
  289. (sha256 sha))))))
  290. (define (alist->package meta)
  291. (package
  292. (name (assoc-ref meta "name"))
  293. (version (assoc-ref meta "version"))
  294. (source (source-spec->object (assoc-ref meta "source")))
  295. (build-system
  296. (lookup-build-system-by-name
  297. (string->symbol (assoc-ref meta "build-system"))))
  298. (native-inputs
  299. (specs->package-lists (or (assoc-ref meta "native-inputs") '())))
  300. (inputs
  301. (specs->package-lists (or (assoc-ref meta "inputs") '())))
  302. (propagated-inputs
  303. (specs->package-lists (or (assoc-ref meta "propagated-inputs") '())))
  304. (home-page
  305. (assoc-ref meta "home-page"))
  306. (synopsis
  307. (assoc-ref meta "synopsis"))
  308. (description
  309. (assoc-ref meta "description"))
  310. (license
  311. (match (assoc-ref meta "license")
  312. (#f #f)
  313. (l
  314. (or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:)
  315. (spdx-string->license l))
  316. (license:fsdg-compatible l)))))))
  317. (define* (read-lines #:optional (port (current-input-port)))
  318. "Read lines from PORT and return them as a list."
  319. (let loop ((line (read-line port))
  320. (lines '()))
  321. (if (eof-object? line)
  322. (reverse lines)
  323. (loop (read-line port)
  324. (cons line lines)))))
  325. (define* (chunk-lines lines #:optional (pred string-null?))
  326. "Return a list of chunks, each of which is a list of lines. The chunks are
  327. separated by PRED."
  328. (let loop ((rest lines)
  329. (parts '()))
  330. (receive (before after)
  331. (break pred rest)
  332. (let ((res (cons before parts)))
  333. (if (null? after)
  334. (reverse res)
  335. (loop (cdr after) res))))))
  336. (define (guix-name prefix name)
  337. "Return a Guix package name for a given package name."
  338. (string-append prefix (string-map (match-lambda
  339. (#\_ #\-)
  340. (#\. #\-)
  341. (chr (char-downcase chr)))
  342. name)))
  343. (define* (recursive-import package-name repo
  344. #:key repo->guix-package guix-name
  345. #:allow-other-keys)
  346. "Generate a stream of package expressions for PACKAGE-NAME and all its
  347. dependencies."
  348. (receive (package . dependencies)
  349. (repo->guix-package package-name repo)
  350. (if (not package)
  351. stream-null
  352. ;; Generate a lazy stream of package expressions for all unknown
  353. ;; dependencies in the graph.
  354. (let* ((make-state (lambda (queue done)
  355. (cons queue done)))
  356. (next (match-lambda
  357. (((next . rest) . done) next)))
  358. (imported (match-lambda
  359. ((queue . done) done)))
  360. (done? (match-lambda
  361. ((queue . done)
  362. (zero? (length queue)))))
  363. (unknown? (lambda* (dependency #:optional (done '()))
  364. (and (not (member dependency
  365. done))
  366. (null? (find-packages-by-name
  367. (guix-name dependency))))))
  368. (update (lambda (state new-queue)
  369. (match state
  370. (((head . tail) . done)
  371. (make-state (lset-difference
  372. equal?
  373. (lset-union equal? new-queue tail)
  374. done)
  375. (cons head done)))))))
  376. (stream-cons
  377. package
  378. (stream-unfold
  379. ;; map: produce a stream element
  380. (lambda (state)
  381. (repo->guix-package (next state) repo))
  382. ;; predicate
  383. (negate done?)
  384. ;; generator: update the queue
  385. (lambda (state)
  386. (receive (package . dependencies)
  387. (repo->guix-package (next state) repo)
  388. (if package
  389. (update state (filter (cut unknown? <>
  390. (cons (next state)
  391. (imported state)))
  392. (car dependencies)))
  393. ;; TODO: Try the other archives before giving up
  394. (update state (imported state)))))
  395. ;; initial state
  396. (make-state (filter unknown? (car dependencies))
  397. (list package-name))))))))