gnu/installer/dump.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
   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 (make-dump
  32             send-dump-report))
  33
  34 ;; The installer crash dump type.
  35 (define %dump-type "installer-dump")
  36
  37 (define (result->list result)
  38   "Return the alist for the given RESULT."
  39   (hash-map->list (lambda (k v)
  40                     (cons k v))
  41                   result))
  42
  43 (define* (make-dump output
  44                     #:key
  45                     result
  46                     backtrace)
  47   "Create a crash dump archive in OUTPUT.  RESULT is the installer result hash
  48 table.  BACKTRACE is the installer Guile backtrace."
  49   (let ((dump-dir "/tmp/dump"))
  50     (mkdir-p dump-dir)
  51     (with-directory-excursion dump-dir
  52       ;; backtrace
  53       (copy-file backtrace "installer-backtrace")
  54
  55       ;; installer result
  56       (call-with-output-file "installer-result"
  57         (lambda (port)
  58           (write (result->list result) port)))
  59
  60       ;; syslog
  61       (copy-file "/var/log/messages" "syslog")
  62
  63       ;; dmesg
  64       (let ((pipe (open-pipe* OPEN_READ "dmesg")))
  65         (call-with-output-file "dmesg"
  66           (lambda (port)
  67             (dump-port pipe port)
  68             (close-pipe pipe)))))
  69
  70     (with-directory-excursion (dirname dump-dir)
  71       (system* "tar" "-zcf" output (basename dump-dir)))))
  72
  73 (define* (send-dump-report dump
  74                            #:key
  75                            (url "https://dump.guix.gnu.org"))
  76   "Turn the DUMP archive into a multipart body and send it to the Guix crash
  77 dump server at URL."
  78   (define (match-boundary kont)
  79     (match-lambda
  80       (('boundary . (? string? b))
  81        (kont b))
  82       (x #f)))
  83
  84   (define (response->string response)
  85     (bytevector->string
  86      (read-response-body response)
  87      "UTF-8"))
  88
  89   (let-values (((body boundary)
  90                 (call-with-input-file dump
  91                   (lambda (port)
  92                     (format-multipart-body
  93                      `((,%dump-type . ,port)))))))
  94     (false-if-exception
  95      (response->string
  96       (http-post
  97        (string-append url "/upload")
  98        #:keep-alive? #t
  99        #:streaming? #t
 100        #:headers `((content-type
 101                     . (multipart/form-data
 102                        (boundary . ,boundary))))
 103        #:body body)))))