guix/maintenance
2
0
Fork 0
mirror of git://git.savannah.gnu.org/guix/maintenance.git synced 2023-12-14 03:33:04 +01:00
Code Issues Releases Wiki Activity

Add a crash-dump service.

Browse source
This commit is contained in:
Mathieu Othacehe 2021-12-28 16:16:14 +01:00
parent 8281e0d864
commit cffcedb57e
No known key found for this signature in database
GPG key ID: 8354763531769CA6
4 changed files with 397 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

269
hydra/crash-dump.scm Executable file
View file

@ -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)))))))

3
hydra/modules/sysadmin/dns.scm
View file

@ -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)))))

101
hydra/modules/sysadmin/services.scm
View file

@ -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.")))

26
hydra/nginx/berlin.scm
View file

@ -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"