[bug#52866] maintenance: Add a crash dump service.

[Mathieu Othacehe <othacehe@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 557 bytes --]


Hello,

Here's a patch that adds a crash dump service. The concept is simple, a
Guile HTTP server is listening on "dump.guix.gnu.org". Crash reports can
be uploaded using multipart forms in POST requests. They are then stored
on Berlin.

I have implemented the installer dump service. On a crash, it optionally
submits an archive report containing the backtrace, the installer state,
the syslog and dmesg logs.

We could also upload other backtraces that are generated by the "guix"
command itself, when running "guix pull" for instance.

Thanks,

Mathieu

[-- Attachment #2: 0001-Add-a-crash-dump-service.patch --]
[-- Type: text/x-patch, Size: 16380 bytes --]

From 9e98df09813711b78249c1839b7cbe079dc46fa9 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Tue, 28 Dec 2021 16:16:14 +0100
Subject: [PATCH 1/1] Add a crash-dump service.

---
 hydra/crash-dump.scm                | 243 ++++++++++++++++++++++++++++
 hydra/modules/sysadmin/dns.scm      |   3 +-
 hydra/modules/sysadmin/services.scm |  79 ++++++++-
 hydra/nginx/berlin.scm              |  26 +++
 4 files changed, 349 insertions(+), 2 deletions(-)
 create mode 100755 hydra/crash-dump.scm

diff --git a/hydra/crash-dump.scm b/hydra/crash-dump.scm
new file mode 100755
index 0000000..6d94bfb
--- /dev/null
+++ b/hydra/crash-dump.scm
@@ -0,0 +1,243 @@
+#!/run/current-system/profile/bin/guile \
+--no-auto-compile -e crash-dump -s
+!#
+;;;; crash-dump -- crash dump HTTP web server.
+;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of Crash-dump.
+;;;
+;;; Crash-dump is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Crash-dump is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Crash-dump.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (web server)
+             (web request)
+             (web response)
+             (web uri)
+             (webutils multipart)
+             (gcrypt base16)
+             (gcrypt hash)
+             (srfi srfi-1)
+             (srfi srfi-11)
+             (srfi srfi-26)
+             (rnrs bytevectors)
+             (rnrs io ports)
+             (ice-9 binary-ports)
+             (ice-9 getopt-long)
+             (ice-9 match))
+
+(define %program-name
+  (make-parameter "crash-dump"))
+
+(define %program-version
+  (make-parameter "0.1"))
+
+;; The dumps output directory.
+(define %output
+  (make-parameter #f))
+
+;; The supported dump types.
+(define %whitelist-dumps
+  '(installer-dump))
+
+(define (show-help)
+  (format #t "Usage: ~a [OPTIONS]~%" (%program-name))
+  (display "Run the crash-dump web server.
+  -o  --output=DIR          Crash dumps directory.
+  -p  --port=NUM            Port of the HTTP server.
+      --listen=HOST         Listen on the network interface for HOST
+  -V, --version             Display version
+  -h, --help                Display this help message")
+  (newline))
+
+(define (show-version)
+  "Display version information for COMMAND."
+  (simple-format #t "~a ~a~%"
+                 (%program-name) (%program-version))
+  (display "Copyright (C) 2021 the Guix authors
+License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.")
+  (newline)
+  (exit 0))
+
+(define %options
+  '((output         (single-char #\o) (value #t))
+    (port           (single-char #\p) (value #t))
+    (listen                           (value #t))
+    (version        (single-char #\V) (value #f))
+    (help           (single-char #\h) (value #f))))
+
+(define (getaddrinfo* host)
+  "Like 'getaddrinfo', but properly report errors."
+  (catch 'getaddrinfo-error
+    (lambda ()
+      (getaddrinfo host))
+    (lambda (key error)
+      (exit "lookup of host '~a' failed: ~a~%"
+             host (gai-strerror error)))))
+
+;;; A common buffer size value used for the TCP socket SO_SNDBUF option.
+(define %default-buffer-size
+  (* 208 1024))
+
+(define %default-socket-options
+  ;; List of options passed to 'setsockopt' when transmitting files.
+  (list (list SO_SNDBUF %default-buffer-size)))
+
+(define* (configure-socket socket #:key (level SOL_SOCKET)
+                           (options %default-socket-options))
+  "Apply multiple option tuples in OPTIONS to SOCKET, using LEVEL."
+  (for-each (cut apply setsockopt socket level <>)
+            options))
+
+(define (open-server-socket address)
+  "Return a TCP socket bound to ADDRESS, a socket address."
+  (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
+    (configure-socket sock #:options (cons (list SO_REUSEADDR 1)
+                                           %default-socket-options))
+    (bind sock address)
+    sock))
+
+(define (post-request? request)
+  "Return #t if REQUEST uses the POST method."
+  (eq? (request-method request) 'POST))
+
+(define (request-path-components request)
+  "Split the URI path of REQUEST into a list of component strings.  For
+example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
+  (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(define (preserve-connection-headers request response)
+  "Add REQUEST's 'connection' header, if any, to HEADERS, a list of response
+headers."
+  (if (pair? response)
+      (let ((connection
+             (assq 'connection (request-headers request))))
+        (append response
+                (if connection
+                    (list connection)
+                    '())))
+      response))
+
+(define* (not-found request
+                    #:key (phrase "Resource not found")
+                    ttl)
+  "Render 404 response for REQUEST."
+  (values (build-response #:code 404
+                          #:headers (if ttl
+                                        `((cache-control (max-age . ,ttl)))
+                                        '()))
+          (string-append phrase ": "
+                         (uri-path (request-uri request)))))
+
+(define* (dump-port in out
+                    #:optional len
+                    #:key (buffer-size 16384)
+                    (progress (lambda (t k) (k))))
+  "Read LEN bytes from IN or as much data as possible if LEN is #f, and write
+it to OUT, using chunks of BUFFER-SIZE bytes.  Call PROGRESS at the beginning
+and after each successful transfer of BUFFER-SIZE bytes or less, passing it
+the total number of bytes transferred and the continuation of the transfer as
+a thunk."
+  (define buffer
+    (make-bytevector buffer-size))
+
+  (define (loop total bytes)
+    (or (eof-object? bytes)
+        (and len (= total len))
+        (let ((total (+ total bytes)))
+          (put-bytevector out buffer 0 bytes)
+          (progress
+           total
+           (lambda ()
+             (loop total
+                   (get-bytevector-n! in buffer 0
+                                      (if len
+                                          (min (- len total) buffer-size)
+                                          buffer-size))))))))
+
+  ;; Make sure PROGRESS is called when we start so that it can measure
+  ;; throughput.
+  (progress
+   0
+   (lambda ()
+     (loop 0 (get-bytevector-n! in buffer 0
+                                (if len
+                                    (min len buffer-size)
+                                    buffer-size))))))
+
+(define (output-file file port)
+  (let ((checksum
+         (string-take
+          (bytevector->base16-string (port-sha256 port)) 8)))
+    (seek port 0 SEEK_SET)
+    (format #f "~a/~a-~a" (%output) file checksum)))
+
+(define (make-handler)
+  (define (handle request body)
+    (format #t "~a ~a~%"
+            (request-method request)
+            (uri-path (request-uri request)))
+    (if (post-request? request)                    ;reject GET, PUT, etc.
+        (match (request-path-components request)
+          ;; /upload
+          (("upload")
+           (match (parse-request-body request body)
+             (((? part? p))
+              (let* ((name (string->symbol (part-name p)))
+                     (file (part-body p))
+                     (filename (output-file name file)))
+                (if (memq name %whitelist-dumps)
+                    (begin
+                      (call-with-output-file filename
+                        (lambda (port)
+                          (dump-port file port)))
+                      (values (build-response #:code 200)
+                              (basename filename)))
+                    (values (build-response #:code 400)
+                            (format #f "The part name '~a' is not supported."
+                                    name)))))
+             (x (format #t "invalid content"))))
+          (x (not-found request)))
+        (not-found request)))
+
+  (lambda (request body)
+    (let-values (((response response-body)
+                  (handle request body)))
+      (values (preserve-connection-headers request response)
+              response-body))))
+
+(define* (crash-dump #:optional (args (command-line)))
+  (let ((opts (getopt-long args %options)))
+    (cond
+     ((option-ref opts 'help #f)
+      (show-help)
+      (exit 0))
+     ((option-ref opts 'version #f)
+      (show-version)
+      (exit 0))
+     (else
+      (let* ((output (%output
+                      (option-ref opts 'output "/tmp")))
+             (port (string->number (option-ref opts 'port "8080")))
+             (addr (match (getaddrinfo*
+                           (option-ref opts 'listen "localhost"))
+                     ((info _ ...)
+                      (addrinfo:addr info))
+                     (()
+                      (exit "lookup of host returned nothing"))))
+             (socket (open-server-socket
+                      (make-socket-address (sockaddr:fam addr)
+                                           (sockaddr:addr addr)
+                                           port))))
+        (run-server (make-handler) 'http `(#:socket ,socket)))))))
diff --git a/hydra/modules/sysadmin/dns.scm b/hydra/modules/sysadmin/dns.scm
index 53ae57a..c254e6d 100644
--- a/hydra/modules/sysadmin/dns.scm
+++ b/hydra/modules/sysadmin/dns.scm
@@ -104,6 +104,7 @@
   ;; Services.
   ("issues"   ""  "IN"  "A"      berlin-ip4)
   ("monitor"  ""  "IN"  "A"      berlin-ip4)
+  ("dump"     ""  "IN"  "A"      berlin-ip4)
   ("logs"     ""  "IN"  "A"      bayfront-ip4)
   ("ci"       ""  "IN"  "A"      berlin-ip4)
   ("disarchive" ""  "IN"  "A"    berlin-ip4)
@@ -128,4 +129,4 @@
             (origin "guix.gnu.org")
             (ns primary-ns)
             (entries guix.gnu.org.zone)
-            (serial 2021122114)))))
+            (serial 202212281643)))))
diff --git a/hydra/modules/sysadmin/services.scm b/hydra/modules/sysadmin/services.scm
index ab0ac5f..6c1edae 100644
--- a/hydra/modules/sysadmin/services.scm
+++ b/hydra/modules/sysadmin/services.scm
@@ -56,7 +56,8 @@
             KiB MiB GiB TiB
             disarchive-configuration
             disarchive-service-type
-            goggles-service-type))
+            goggles-service-type
+            crash-dump-service-type))
 
 (define not-config?
   ;; Select (guix …) and (gnu …) modules, except (guix config).
@@ -589,6 +590,7 @@ to a selected directory.")
          %nginx-mime-types
          %nginx-cache-activation
 
+         (service crash-dump-service-type)
          (cuirass-service #:branches branches
                           #:systems systems
                           #:nar-ttl nar-ttl)
@@ -732,3 +734,78 @@ to a selected directory.")
                                         goggles-shepherd-services)))
    (default-value goggles)
    (description "Run Goggles, the IRC log web interface.")))
+
+\f
+;;;
+;;; Crash-dump.
+;;;
+
+(define crash-dump
+  (program-file "crash-dump"
+                (with-extensions (list guile-gcrypt guile-webutils)
+                  #~(begin
+                      (setvbuf (current-output-port) 'line)
+                      (setvbuf (current-error-port) 'line)
+                      (format (current-error-port) "Starting crash-dump...~%")
+
+                      (load-compiled
+                       #$(computed-file
+                          "crash-dump.go"
+                          #~(begin
+                              (use-modules (system base compile))
+
+                              (compile-file
+                               #$(local-file "../../crash-dump.scm")
+                               #:output-file #$output))))
+                      (crash-dump '("_" "-p" "2121"))))))
+
+(define (crash-dump-shepherd-services crash-dump)
+  (with-imported-modules (source-module-closure
+                          '((gnu build shepherd)
+                            (gnu system file-systems)))
+    (list (shepherd-service
+           (provision '(crash-dump))
+           (requirement '(user-processes loopback))
+           (documentation "Run Crash-dump.")
+           (modules '((gnu build shepherd)
+                      (gnu system file-systems)))
+           (start #~(make-forkexec-constructor/container
+                     (list #$crash-dump)
+                     #:user "crash-dump" #:group "crash-dump"
+                     #:log-file "/var/log/crash-dump.log"
+                     ;; Run in a UTF-8 locale for proper rendering of the
+                     ;; logs.
+                     #:environment-variables
+                     (list (string-append "GUIX_LOCPATH=" #$glibc-utf8-locales
+                                          "/lib/locale")
+                           "LC_ALL=en_US.utf8")))
+           (stop #~(make-kill-destructor))))))
+
+(define %crash-dump-accounts
+  (list (user-account
+         (name "crash-dump")
+         (group "crash-dump")
+         (home-directory "/var/empty")
+         (create-home-directory? #f)
+         (shell (file-append shadow "/sbin/nologin"))
+         (comment "The Crash-dump web server")
+         (system? #t))
+        (user-group
+         (name "crash-dump")
+         (system? #t))))
+
+(define %crash-dump-log-rotations
+  (list (log-rotation
+         (files (list "/var/log/crash-dump.log")))))
+
+(define crash-dump-service-type
+  (service-type
+   (name 'crash-dump)
+   (extensions (list (service-extension account-service-type
+                                        (const %crash-dump-accounts))
+                     (service-extension rottlog-service-type
+                                        (const %crash-dump-log-rotations))
+                     (service-extension shepherd-root-service-type
+                                        crash-dump-shepherd-services)))
+   (default-value crash-dump)
+   (description "Run a crash dump HTTP web server.")))
diff --git a/hydra/nginx/berlin.scm b/hydra/nginx/berlin.scm
index ecdbb13..aea7db0 100644
--- a/hydra/nginx/berlin.scm
+++ b/hydra/nginx/berlin.scm
@@ -318,6 +318,32 @@ PUBLISH-URL."
        "send_timeout                600;"
        "access_log /var/log/nginx/issues-guix-gnu-org.https.access.log;"))))
 
+   (nginx-server-configuration
+    (listen '("443 ssl"))
+    (server-name '("dump.guix.gnu.org"))
+    (ssl-certificate (le "dump.guix.gnu.org"))
+    (ssl-certificate-key (le "dump.guix.gnu.org" 'key))
+    (locations
+     (list
+      (nginx-location-configuration ;certbot
+       (uri "/.well-known")
+       (body (list "root /var/www;")))
+      (nginx-location-configuration
+       (uri "/")
+       (body '("proxy_pass http://localhost:2121;")))))
+    (raw-content
+     (append
+         %tls-settings
+         (list
+          "proxy_set_header X-Forwarded-Host $host;"
+          "proxy_set_header X-Forwarded-Port $server_port;"
+          "proxy_set_header X-Forwarded-For  $proxy_add_x_forwarded_for;"
+          "proxy_connect_timeout       600;"
+          "proxy_send_timeout          600;"
+          "proxy_read_timeout          600;"
+          "send_timeout                600;"
+          "access_log /var/log/nginx/dump-guix-gnu-org.https.access.log;"))))
+
    (nginx-server-configuration
     (listen '("443 ssl"))
     (server-name '("guixwl.org"
-- 
2.34.0