;;; SPDX-FileCopyrightText: 2021 Li Ian-Xue (b4283) <b4283@pm.me>

;;; SPDX-FileCopyrightText: 2025 Evgeny Pisemsky <mail@pisemsky.site>

;;;

;;; SPDX-License-Identifier: GPL-3.0-only

(define-module (pastebin http))

(use-modules (web request)

             (web response)

             (web uri)

             (sxml simple)

             (pastebin data)

             (rnrs bytevectors)

             (ice-9 textual-ports)

             (ice-9 binary-ports)

             (ice-9 regex)

             (ice-9 match)

             (srfi srfi-1))

(export make-pastebin-handler)

(define (read-parts reqbody boundary)

  (define b2 (string-append "(\r\n)?--" boundary))

  (let A ((start 0) (parts '()))

    (let ((sm (string-match b2 reqbody start)))

      (if sm

          ;; +2 => CRLF

          (A (+ 2 (match:end sm 0))

             (cons (substring reqbody start (match:start sm 0)) parts))

          (cdr (reverse parts))))))

(define (get-new-pin str pin)

  (let ((crlfi (string-contains str "\r\n" pin)))

    (if crlfi crlfi (string-length str))))

(define (parse-part partstr)

  (let A ((headers '()) (pin 0))

    (let* ((newpin (get-new-pin partstr pin))

           (line (substring partstr pin newpin)))

      (if (string-null? line)

          (cons (reverse headers) (substring partstr (+ 2 newpin)))

          (A (cons line headers) (+ 2 newpin))))))

(define (get-content-dispo-name-from-headers headers)

  (let ((fl (find (lambda (line) (string-prefix-ci? "content-disposition: " line)) headers)))

    (if fl

        (let ((sm (string-match "name=(.*)" fl)))

          (if sm (string-trim-both (match:substring sm 1) #\") ""))

        "")))

(define (read-multipart-form-data reqbody boundary)

  (define parts (read-parts reqbody boundary))

  (map

   (lambda (part)

     (let ((pp (parse-part part)))

       (cons (get-content-dispo-name-from-headers (car pp)) (cdr pp))))

   parts))

(define (not-found)

  (values (build-response #:code 404)

          (lambda (port) 1)))

(define (templatize title body css-url)

  `(html (@ (lang "en"))

         (head

          (title ,title)

          (meta (@ (charset "utf-8")))

          (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))

          ,(if css-url

               `(link (@ (rel "stylesheet") (href ,css-url)))

               '()))

         (body ,@body)))

(define (list-handler pb-data-path css-url)

  (values (build-response

           #:code 200

           #:headers '((content-type . (text/html))))

          (lambda (port)

            (let* ((top5 (call-with-dir-as-pb-data

                          pb-data-path

                          (lambda (pb-data)

                            (pb-data-get-top pb-data 5))))

                   (sxml (templatize

                          "Pastebin"

                          `((header (h1 "Pastebin"))

                            (main (section (h2 "Recent")

                                           ,(map (lambda (entry)

                                                   `(article (h3 (a (@ (href ,(format #f "/raw/~a" (pb-entry-id entry)))

                                                                       (target "_blank"))

                                                                    ,(pb-entry-id entry)))

                                                             (pre ,(pb-entry-text entry))))

                                                 top5))

                                  (section (h2 "New")

                                           (form (@ (method "post")

                                                    (enctype "multipart/form-data")

                                                    (action "/post"))

                                                 (fieldset (div (label (@ (for "form-text"))

                                                                       "Paste content"))

                                                           (div (textarea (@ (id "form-text")

                                                                             (name "text")) ""))

                                                           (div (label (@ (for "form-showurl"))

                                                                       (input (@ (type "checkbox")

                                                                                 (id "form-showurl")

                                                                                 (name "showUrl")

                                                                                 (value "1")))

                                                                       "Show raw URL after paste"))

                                                           (div (input (@ (type "submit")

                                                                          (value "Submit"))))))))

                            (footer (p (a (@ (href "https://repo.pisemsky.site/guile-pastebin")

                                             (target "_blank"))

                                          "Source"))))

                          css-url)))

              (display "<!DOCTYPE html>\n" port)

              (sxml->xml sxml port)))))

(define (post-handler request request-body pb-data-path)

  (if (eq? (request-method request) 'POST)

      (let* ((headers (request-headers request))

             (content-type-all (assq-ref headers 'content-type))

             (content-type (if content-type-all

                               (car content-type-all)

                               #f))

             (boundary (if (eq? content-type 'multipart/form-data)

                           (assq-ref (cdr content-type-all) 'boundary)

                           #f))

             (reqbody-string (utf8->string request-body))

             (form-data (if boundary

                            (read-multipart-form-data reqbody-string boundary)

                            #f))

             (new-pb-data (if form-data

                              (call-with-dir-as-pb-data

                               pb-data-path

                               (lambda (pb-data)

                                 (pb-data-new-entry pb-data

                                                    (assoc-ref form-data "text"))))

                              #f)))

        ;; determine what to respond

        (if (and new-pb-data

                 (assoc-ref form-data "showUrl"))

            ;; show url after paste

            (values (build-response

                     #:code 200

                     #:headers '((content-type . (text/plain))))

                    (lambda (port)

                      (let* ((hostp (assq-ref headers 'host))

                             (proto (assq-ref headers 'x-forwarded-proto)))

                        (put-string

                         port

                         (uri->string

                          (build-uri (if (equal? proto "https") 'https 'http)

                                     #:host (car hostp)

                                     #:port (cdr hostp)

                                     #:path (format #f "/raw/~a\r\n"

                                                    (pb-entry-id new-pb-data))))))))

            ;; respond with 303 See Other

            (values (build-response

                     #:code 303

                     #:headers `((location . ,(build-uri-reference #:path "/"))))

                    (lambda (port) 1))))

      ;; INVALID request: access /post without HTTP POST

      (values (build-response #:code 400)

              (lambda (port) 1))))

(define (raw-handler pb-data-path pb-id)

  (if (pb-entry-id-valid? pb-id)

      (values (build-response

               #:code 200

               #:headers '((content-type . (text/plain))))

              (lambda (port)

                (call-with-input-file

                    ;; the file name

                    (call-with-dir-as-pb-data

                     pb-data-path

                     (lambda (p) (pb-get-file-path p pb-id)))

                  ;; the input port

                  (lambda (inport)

                    (let A ((inport' inport))

                      (let ((bv (get-bytevector-n inport' 4096)))

                        (if (not (eof-object? bv))

                            (begin

                              (put-bytevector port bv)

                              (A inport')))))))))

      (not-found)))

(define* (make-pastebin-handler data-path #:key css-url)

  (lambda (request request-body)

    (match (split-and-decode-uri-path (uri-path (request-uri request)))

      (()

       (list-handler data-path css-url))

      (("post")

       (post-handler request request-body data-path))

      (("raw" pb-id)

       (raw-handler data-path pb-id))

      (_

       (not-found)))))