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