;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;;
;;; This program 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.
;;;
;;; This program 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 this program. If not, see
;;; <http://www.gnu.org/licenses/>.

(use-modules (ice-9 match)
             (jakob dynamic blacklist)
             (jakob dynamic captcha)
             (jakob dynamic config)
             (jakob dynamic capabilities comment-form)
             (jakob dynamic capabilities comments)
             (jakob dynamic capabilities gallery)
             (jakob dynamic capabilities rsvp)
             (jakob dynamic errors)
             (jakob dynamic logging)
             (jakob dynamic rate-limiter)
             (jakob dynamic util)
             (json)
             (rnrs conditions)
             (rnrs exceptions)
             (srfi srfi-1)
             (srfi srfi-19)
             (web request)
             (web response)
             (web server)
             (web uri))

(define (not-found request)
  "Build a (somewhat) descriptive response for a non-existent resource."
  (values (build-response #:code 404)
          (string-append "Resource not found: "
                         (uri->string (request-uri request)))))

(define (format-error-response condition)
  "Format CONDITION, a &reportable-condition, as an HTTP response"
  (values (build-response #:code (reportable-condition-code condition))
          (scm->json-string
           `((success . #f)
             (error . ,(reportable-condition-message condition))))))

(define-syntax values->list
  (syntax-rules ()
    ((values-list exp)
     (call-with-values (lambda () exp) list))))

(define (clearnet-only handler)
  (lambda (request body)
    (if (and (not (%debug-enabled)) (from-darknet? request))
        (panic "This API is only available on the clearnet." #:code 403)
        (handler request body))))

(define (dump-error request body endpoint)
  (define file-name (date->string (current-date) "jakob-api-crash-report-~4.txt"))
  (log-append! 'error (format #f "Unhandled error! Crash report written to ~a" file-name))
  (call-with-output-file file-name
    (lambda (port)
      (format port "Error caused by endpoint `~a'~%~%" endpoint)
      (format port "Full dump of `request':")
      (write request port)
      (format port "~%~%")
      (format port "Full dump of `body':")
      (write body port)
      (format port "~%~%")
      (display-backtrace (make-stack #t) port))))

(define (handle-api-request request body endpoint)
  "Route handler for the API server."
  (let ((method (request-method request))
        (originating-ip (if (%debug-enabled)
                            "127.0.0.1"
                            (assoc-ref (request-headers request) 'x-forwarded-for)))
        (args (uri-query (request-uri request))))
    (log-append! 'info (if args
                           (format #f "~a ~a (~a) (~a)" method endpoint args originating-ip)
                           (format #f "~a ~a (~a)" method endpoint originating-ip)))
    ;; Somewhat painful wrap/unwrap of values because there isn't support for
    ;; returning multiple values from a `guard' clause.
    (apply values
      (guard (ex ((reportable-condition? ex)
                  (values->list (format-error-response ex)))
                 ((equal? "application/json" (assoc-ref (request-headers request) 'accept))
                  (dump-error request body endpoint)
                  (list (build-response #:code 500)
                        (scm->json-string
                         '((success . #f) (error . "Internal error.")))))
                 (#t
                  (dump-error request body endpoint)
                  (list (build-response #:code 500) "Internal server error.")))
        (fail-when-ip-blacklisted originating-ip)
        (values->list
         (((if (%debug-enabled) identity rate-limit-wrap)
           (match (cons (request-method request) endpoint)
             (('GET  "apps" "comment-form" _)            get-comment-form)
             ('(GET  "api"  "challenge" "proof-of-work") make-pow-challenge!)
             ('(GET  "api"  "challenge" "captcha")       make-captcha-challenge!)
             ('(GET  "api"  "comments")                  get-comments)
             (('POST "api"  "comment")                   put-comment)
             (('POST "api"  "comment" "react")           put-reaction)

             (('GET  "apps" "gallery")                   (clearnet-only get-gallery))
             (('GET  "apps" "rsvp" "event-info")         (clearnet-only get-event-info))
             (('POST "apps" "rsvp")                      (clearnet-only post-event-rsvp))
             (_ (lambda (. args) (not-found request)))))
          request body))))))

(define (main-request-handler request body)
  "Server entry-point; parse `request' and defer to routing system."
  (define (wrap-response response)
    ;; This is either a response, or an alist of headers. The latter case is
    ;; simple to handle, but the former requires us to do a (rather unweildy)
    ;; copy of the response to inject our headers.
    (if (response? response)
        (build-response
         #:version           (response-version       response)
         #:code              (response-code          response)
         #:reason-phrase     (response-reason-phrase response)
         #:headers           (cons '(Access-Control-Allow-Origin . "*")
                                    (response-headers response))
         #:port              (response-port          response)
         #:validate-headers? #t)
        (cons '(Access-Control-Allow-Origin . "*") response)))
  (let* ((path-encoded (uri-path (request-uri request)))
         (path (split-and-decode-uri-path path-encoded)))
    (define-values (response resp-body)
      (handle-api-request request body path))
    (values (wrap-response response) resp-body)))

(format #t "Server started.~%")
(run-server main-request-handler 'http `(#:addr ,INADDR_ANY #:port ,(%api-server-port)))