maintenance/hydra/crash-dump.scm

#!/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)))))))