From 9e98df09813711b78249c1839b7cbe079dc46fa9 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe 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 +;;; +;;; 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 . + +(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 +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."))) + + +;;; +;;; 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