Commit | Line | Data |
---|---|---|
1ff2619b EB |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2014 David Thompson <davet@gnu.org> | |
63773200 | 3 | ;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org> |
81c3dc32 | 4 | ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
16dd7646 | 5 | ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> |
1ff2619b EB |
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 | ||
22 | (define-module (guix import json) | |
23 | #:use-module (json) | |
63773200 | 24 | #:use-module (guix http-client) |
1ff2619b | 25 | #:use-module (guix import utils) |
16dd7646 | 26 | #:use-module (guix import print) |
7cef499b | 27 | #:use-module (ice-9 match) |
16dd7646 | 28 | #:use-module (ice-9 rdelim) |
7cef499b | 29 | #:use-module (srfi srfi-1) |
16dd7646 | 30 | #:use-module (srfi srfi-2) |
7cef499b | 31 | #:use-module (srfi srfi-26) |
63773200 | 32 | #:use-module (srfi srfi-34) |
16dd7646 | 33 | #:export (json-fetch |
c8934323 | 34 | json->code |
16dd7646 | 35 | json->scheme-file)) |
1ff2619b | 36 | |
2766282f LC |
37 | (define* (json-fetch url |
38 | ;; Note: many websites returns 403 if we omit a | |
39 | ;; 'User-Agent' header. | |
40 | #:key (headers `((user-agent . "GNU Guile") | |
41 | (Accept . "application/json")))) | |
3edf0d53 | 42 | "Return a representation of the JSON resource URL (a list or hash table), or |
2766282f LC |
43 | #f if URL returns 403 or 404. HEADERS is a list of HTTP headers to pass in |
44 | the query." | |
63773200 | 45 | (guard (c ((and (http-get-error? c) |
3edf0d53 JL |
46 | (let ((error (http-get-error-code c))) |
47 | (or (= 403 error) | |
48 | (= 404 error)))) | |
49 | #f)) | |
2766282f | 50 | (let* ((port (http-fetch url #:headers headers)) |
3edf0d53 | 51 | (result (json->scm port))) |
63773200 EB |
52 | (close-port port) |
53 | result))) | |
16dd7646 RW |
54 | |
55 | (define (json->code file-name) | |
7cef499b RW |
56 | "Read FILE-NAME containing one ore more JSON package definitions and return |
57 | a list of S-expressions, or return #F when the JSON is invalid." | |
16dd7646 RW |
58 | (catch 'json-invalid |
59 | (lambda () | |
60 | (let ((json (json-string->scm | |
61 | (with-input-from-file file-name read-string)))) | |
7cef499b RW |
62 | (match json |
63 | (#(packages ...) | |
64 | ;; To allow definitions to refer to one another, collect references | |
65 | ;; to local definitions and tell alist->package to ignore them. | |
66 | (second | |
67 | (memq #:result | |
68 | (fold | |
69 | (lambda (pkg names+result) | |
70 | (match names+result | |
71 | ((#:names names #:result result) | |
72 | (list #:names | |
73 | (cons (assoc-ref pkg "name") names) | |
74 | #:result | |
75 | (append result | |
76 | (list | |
77 | (package->code (alist->package pkg names)) | |
78 | (string->symbol (assoc-ref pkg "name")))))))) | |
79 | (list #:names '() | |
80 | #:result '()) | |
81 | packages)))) | |
82 | (package | |
83 | (list (package->code (alist->package json)) | |
84 | (string->symbol (assoc-ref json "name"))))))) | |
16dd7646 RW |
85 | (const #f))) |
86 | ||
87 | (define (json->scheme-file file) | |
88 | "Convert the FILE containing a JSON package definition to a Scheme | |
89 | representation and return the new file name (or #F on error)." | |
7cef499b | 90 | (and-let* ((sexprs (json->code file)) |
16dd7646 RW |
91 | (file* (let* ((tempdir (or (getenv "TMPDIR") "/tmp")) |
92 | (template (string-append tempdir "/guix-XXXXXX")) | |
93 | (port (mkstemp! template))) | |
94 | (close-port port) | |
95 | template))) | |
96 | (call-with-output-file file* | |
97 | (lambda (port) | |
98 | (write '(use-modules (gnu) | |
99 | (guix) | |
100 | ((guix licenses) #:prefix license:)) | |
101 | port) | |
7cef499b | 102 | (for-each (cut write <> port) sexprs))) |
16dd7646 | 103 | file*)) |