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 (prepare-dump
  32             make-dump
  33             send-dump-report))
  34
  35 ;; The installer crash dump type.
  36 (define %dump-type "installer-dump")
  37
  38 (define (result->list result)
  39   "Return the alist for the given RESULT."
  40   (hash-map->list (lambda (k v)
  41                     (cons k v))
  42                   result))
  43
  44 (define* (prepare-dump key args #:key result)
  45   "Create a crash dump directory.  KEY and ARGS represent the thrown error.
  46 RESULT is the installer result hash table.  Returns the created directory path."
  47   (define now (localtime (current-time)))
  48   (define dump-dir
  49     (format #f "/tmp/dump.~a"
  50             (strftime "%F.%H.%M.%S" now)))
  51   (mkdir-p dump-dir)
  52   (with-directory-excursion dump-dir
  53     ;; backtrace
  54     (call-with-output-file "installer-backtrace"
  55       (lambda (port)
  56         (display-backtrace (make-stack #t) port)
  57         (print-exception port
  58                          (stack-ref (make-stack #t) 1)
  59                          key args)))
  60
  61     ;; installer result
  62     (call-with-output-file "installer-result"
  63       (lambda (port)
  64         (write (result->list result) port)))
  65
  66     ;; syslog
  67     (copy-file "/var/log/messages" "syslog")
  68
  69     ;; dmesg
  70     (let ((pipe (open-pipe* OPEN_READ "dmesg")))
  71       (call-with-output-file "dmesg"
  72         (lambda (port)
  73           (dump-port pipe port)
  74           (close-pipe pipe)))))
  75   dump-dir)
  76
  77 (define* (make-dump dump-dir file-choices)
  78   "Create a crash dump archive from DUMP-DIR containing FILE-CHOICES.
  79 Returns the archive path."
  80   (define output (string-append (basename dump-dir) ".tar.gz"))
  81   (with-directory-excursion (dirname dump-dir)
  82     (apply system* "tar" "-zcf" output
  83            (map (lambda (f)
  84                   (string-append (basename dump-dir) "/" f))
  85                 file-choices)))
  86   (canonicalize-path (string-append (dirname dump-dir) "/" output)))
  87
  88 (define* (send-dump-report dump
  89                            #:key
  90                            (url "https://dump.guix.gnu.org"))
  91   "Turn the DUMP archive into a multipart body and send it to the Guix crash
  92 dump server at URL."
  93   (define (match-boundary kont)
  94     (match-lambda
  95       (('boundary . (? string? b))
  96        (kont b))
  97       (x #f)))
  98
  99   (define (response->string response)
 100     (bytevector->string
 101      (read-response-body response)
 102      "UTF-8"))
 103
 104   (let-values (((body boundary)
 105                 (call-with-input-file dump
 106                   (lambda (port)
 107                     (format-multipart-body
 108                      `((,%dump-type . ,port)))))))
 109     (false-if-exception
 110      (response->string
 111       (http-post
 112        (string-append url "/upload")
 113        #:keep-alive? #t
 114        #:streaming? #t
 115        #:headers `((content-type
 116                     . (multipart/form-data
 117                        (boundary . ,boundary))))
 118        #:body body)))))