branch master updated: Add a crash-dump service.

[Mathieu Othacehe]

This is an automated email from the git hooks/post-receive script.

mothacehe pushed a commit to branch master
in repository maintenance.

The following commit(s) were added to refs/heads/master by this push:
     new cffcedb  Add a crash-dump service.
cffcedb is described below

commit cffcedb57e113c326cc585cedcb0a29d20ee9852
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Tue Dec 28 16:16:14 2021 +0100

    Add a crash-dump service.
---
 hydra/crash-dump.scm                | 269 ++++++++++++++++++++++++++++++++++++
 hydra/modules/sysadmin/dns.scm      |   3 +-
 hydra/modules/sysadmin/services.scm | 101 +++++++++++++-
 hydra/nginx/berlin.scm              |  26 ++++
 4 files changed, 397 insertions(+), 2 deletions(-)

diff --git a/hydra/crash-dump.scm b/hydra/crash-dump.scm
new file mode 100755
index 0000000..6f5148b
--- /dev/null
+++ b/hydra/crash-dump.scm
@@ -0,0 +1,269 @@
+#!/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)
+             (json)
+             (gcrypt base16)
+             (gcrypt hash)
+             (srfi srfi-1)
+             (srfi srfi-11)
+             (srfi srfi-26)
+             (rnrs bytevectors)
+             (rnrs io ports)
+             (ice-9 binary-ports)
+             (ice-9 ftw)
+             (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 (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 (dumps)
+  (let ((files
+         (scandir (%output)
+                  (negate (cut member <> '("." ".."))))))
+    (list->vector
+     (map (lambda (file)
+            (let* ((file (string-append (%output) "/" file))
+                   (file-stat (stat file)))
+              `((name . ,(basename file))
+                (size . ,(stat:size file-stat))
+                (m_time . ,(stat:mtime file-stat)))))
+          files))))
+
+(define (make-handler)
+  (define (handle request body)
+    (format #t "~a ~a~%"
+            (request-method request)
+            (uri-path (request-uri request)))
+    (match (cons (request-method request)
+                 (request-path-components request))
+      (('GET)
+       (values (build-response
+                #:code 200
+                #:headers '((content-type . (application/json))))
+               (scm->json-string (dumps))))
+      (('GET "download" name)
+       (let ((file
+              (string-append (%output) "/" name)))
+         (if (file-exists? file)
+             (values
+              (build-response
+               #:code 200
+               #:headers `((content-type . (application/octet-stream))
+                           (content-disposition
+                            . (form-data (filename . ,(basename name))))))
+              (call-with-input-file file get-bytevector-all))
+             (not-found request))))
+      (('POST "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))))
+
+  (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 5b7e20e..52570a8 100644
--- a/hydra/modules/sysadmin/dns.scm
+++ b/hydra/modules/sysadmin/dns.scm
@@ -108,6 +108,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)
@@ -132,4 +133,4 @@
             (origin "guix.gnu.org")
             (ns primary-ns)
             (entries guix.gnu.org.zone)
-            (serial 2022021910)))))
+            (serial 2022022010)))))
diff --git a/hydra/modules/sysadmin/services.scm 
b/hydra/modules/sysadmin/services.scm
index ab0ac5f..d8ab02f 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,100 @@ to a selected directory.")
                                         goggles-shepherd-services)))
    (default-value goggles)
    (description "Run Goggles, the IRC log web interface.")))
+
+
+;;;
+;;; Crash-dump.
+;;;
+
+(define %crash-dump-cache-directory
+  ;; Directory where Crash-dump stores the reports.
+  "/var/cache/crash-dump")
+
+(define %crash-dump-activation
+  (with-imported-modules '((guix build utils))
+    #~(begin
+        (use-modules (guix build utils))
+        (let ((user (getpwnam "crash-dump")))
+          (mkdir-p #$%crash-dump-cache-directory)
+          (chown #$%crash-dump-cache-directory
+                 (passwd:uid user) (passwd:gid user))))))
+
+(define crash-dump
+  (program-file "crash-dump"
+                (with-extensions (list guile-gcrypt guile-webutils
+                                       guile-json-4)
+                  #~(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"
+                                    "-o" #$%crash-dump-cache-directory))))))
+
+(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"
+                     #:mappings (list (file-system-mapping
+                                       (source #$%crash-dump-cache-directory)
+                                       (target source)
+                                       (writable? #t)))
+                     ;; 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 activation-service-type
+                                        (const %crash-dump-activation))
+                     (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 8abd15e..b99d649 100644
--- a/hydra/nginx/berlin.scm
+++ b/hydra/nginx/berlin.scm
@@ -311,6 +311,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"