projects/guix·blob javascript-team · refs

126 lines · 4.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2021 Mathieu Othacehe <[email protected]>
3;;;
4;;; This file is part of GNU Guix.
5;;;
6;;; GNU Guix is free software; you can redistribute it and/or modify it
7;;; under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 3 of the License, or (at
9;;; your option) any later version.
10;;;
11;;; GNU Guix is distributed in the hope that it will be useful, but
12;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
19(define-module (gnu installer dump)
20 #:use-module (gnu installer utils)
21 #:use-module (guix build utils)
22 #:use-module (srfi srfi-11)
23 #:use-module (ice-9 iconv)
24 #:use-module (ice-9 match)
25 #:use-module (ice-9 popen)
26 #:use-module (ice-9 textual-ports)
27 #:use-module (web client)
28 #:use-module (web http)
29 #:use-module (web response)
30 #:use-module (webutils multipart)
31 #:export (%core-dump
32 prepare-dump
33 make-dump
34 send-dump-report))
35
36;; The installer crash dump type.
37(define %dump-type "installer-dump")
38
39;; The core dump file.
40(define %core-dump "/tmp/installer-core-dump")
41
42(define (result->list result)
43 "Return the alist for the given RESULT."
44 (hash-map->list (lambda (k v)
45 (cons k v))
46 result))
47
48(define* (prepare-dump key args #:key result)
49 "Create a crash dump directory. KEY and ARGS represent the thrown error.
50RESULT is the installer result hash table. Returns the created directory path."
51 (define now (localtime (current-time)))
52 (define dump-dir
53 (format #f "/tmp/dump.~a"
54 (strftime "%F.%H.%M.%S" now)))
55 (mkdir-p dump-dir)
56 (with-directory-excursion dump-dir
57 ;; backtrace
58 (call-with-output-file "installer-backtrace"
59 (lambda (port)
60 (display-backtrace (make-stack #t) port)
61 (print-exception port
62 (stack-ref (make-stack #t) 1)
63 key args)))
64
65 ;; installer result
66 (call-with-output-file "installer-result"
67 (lambda (port)
68 (write (result->list result) port)))
69
70 ;; syslog
71 (copy-file "/var/log/messages" "syslog")
72
73 ;; core dump
74 (when (file-exists? %core-dump)
75 (copy-file %core-dump "core-dump"))
76
77 ;; dmesg
78 (let ((pipe (open-pipe* OPEN_READ "dmesg")))
79 (call-with-output-file "dmesg"
80 (lambda (port)
81 (dump-port pipe port)
82 (close-pipe pipe)))))
83 dump-dir)
84
85(define* (make-dump dump-dir file-choices)
86 "Create a crash dump archive from DUMP-DIR containing FILE-CHOICES.
87Returns the archive path."
88 (define output (string-append (basename dump-dir) ".tar.gz"))
89 (with-directory-excursion (dirname dump-dir)
90 (apply system* "tar" "-zcf" output
91 (map (lambda (f)
92 (string-append (basename dump-dir) "/" f))
93 file-choices)))
94 (canonicalize-path (string-append (dirname dump-dir) "/" output)))
95
96(define* (send-dump-report dump
97 #:key
98 (url "https://dump.guix.gnu.org"))
99 "Turn the DUMP archive into a multipart body and send it to the Guix crash
100dump server at URL."
101 (define (match-boundary kont)
102 (match-lambda
103 (('boundary . (? string? b))
104 (kont b))
105 (x #f)))
106
107 (define (response->string response)
108 (bytevector->string
109 (read-response-body response)
110 "UTF-8"))
111
112 (let-values (((body boundary)
113 (call-with-input-file dump
114 (lambda (port)
115 (format-multipart-body
116 `((,%dump-type . ,port)))))))
117 (false-if-exception
118 (response->string
119 (http-post
120 (string-append url "/upload")
121 #:keep-alive? #t
122 #:streaming? #t
123 #:headers `((content-type
124 . (multipart/form-data
125 (boundary . ,boundary))))
126 #:body body)))))