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 | 37 | (define* (json-fetch url |
9a47fd56 PM |
38 | #:key |
39 | (http-fetch http-fetch) | |
2766282f LC |
40 | ;; Note: many websites returns 403 if we omit a |
41 | ;; 'User-Agent' header. | |
9a47fd56 PM |
42 | (headers `((user-agent . "GNU Guile") |
43 | (Accept . "application/json")))) | |
3edf0d53 | 44 | "Return a representation of the JSON resource URL (a list or hash table), or |
2766282f | 45 | #f if URL returns 403 or 404. HEADERS is a list of HTTP headers to pass in |
9a47fd56 PM |
46 | the query. HTTP-FETCH is called to perform the request: for example, to |
47 | enable caching, supply 'http-fetch/cached'." | |
63773200 | 48 | (guard (c ((and (http-get-error? c) |
3edf0d53 JL |
49 | (let ((error (http-get-error-code c))) |
50 | (or (= 403 error) | |
51 | (= 404 error)))) | |
52 | #f)) | |
2766282f | 53 | (let* ((port (http-fetch url #:headers headers)) |
3edf0d53 | 54 | (result (json->scm port))) |
63773200 EB |
55 | (close-port port) |
56 | result))) | |
16dd7646 RW |
57 | |
58 | (define (json->code file-name) | |
7cef499b RW |
59 | "Read FILE-NAME containing one ore more JSON package definitions and return |
60 | a list of S-expressions, or return #F when the JSON is invalid." | |
16dd7646 RW |
61 | (catch 'json-invalid |
62 | (lambda () | |
63 | (let ((json (json-string->scm | |
64 | (with-input-from-file file-name read-string)))) | |
7cef499b RW |
65 | (match json |
66 | (#(packages ...) | |
67 | ;; To allow definitions to refer to one another, collect references | |
68 | ;; to local definitions and tell alist->package to ignore them. | |
69 | (second | |
70 | (memq #:result | |
71 | (fold | |
72 | (lambda (pkg names+result) | |
73 | (match names+result | |
74 | ((#:names names #:result result) | |
75 | (list #:names | |
76 | (cons (assoc-ref pkg "name") names) | |
77 | #:result | |
78 | (append result | |
79 | (list | |
80 | (package->code (alist->package pkg names)) | |
81 | (string->symbol (assoc-ref pkg "name")))))))) | |
82 | (list #:names '() | |
83 | #:result '()) | |
84 | packages)))) | |
85 | (package | |
86 | (list (package->code (alist->package json)) | |
87 | (string->symbol (assoc-ref json "name"))))))) | |
16dd7646 RW |
88 | (const #f))) |
89 | ||
90 | (define (json->scheme-file file) | |
91 | "Convert the FILE containing a JSON package definition to a Scheme | |
92 | representation and return the new file name (or #F on error)." | |
7cef499b | 93 | (and-let* ((sexprs (json->code file)) |
16dd7646 RW |
94 | (file* (let* ((tempdir (or (getenv "TMPDIR") "/tmp")) |
95 | (template (string-append tempdir "/guix-XXXXXX")) | |
96 | (port (mkstemp! template))) | |
97 | (close-port port) | |
98 | template))) | |
99 | (call-with-output-file file* | |
100 | (lambda (port) | |
101 | (write '(use-modules (gnu) | |
102 | (guix) | |
103 | ((guix licenses) #:prefix license:)) | |
104 | port) | |
7cef499b | 105 | (for-each (cut write <> port) sexprs))) |
16dd7646 | 106 | file*)) |