<!--

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

-->

# guile-pastebin

A very simple pastebin written in Guile Scheme.

## How to run

Execute one of the following commands in the root of repository:

guile -L modules scripts/pastebin [OPTIONS] <DATA_DIR>

GUILE_LOAD_PATH=modules scripts/pastebin [OPTIONS] <DATA_DIR>

Then navigate your web browser at `http://localhost:8080`. By default,

pastebin listens on all IPv4 addresses (`0.0.0.0`) and runs on port

`8080`. These can be changed by passing the command line options

`--addr` and `--port`, respectively.

`<DATA_DIR>` is a writable filesystem location you want to use to

store pastes. If it doesn't exist, it will be created.

It was tested on Guile 3.0.9. Many thanks to the Guile development

team for such great software.

;;; 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 httpserver))

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

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

         (head

          (title ,title)

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

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

          (link (@ (rel "stylesheet") (href "https://unpkg.com/simpledotcss/simple.min.css"))))

         (body ,@body)))

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

  (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://github.com/pisemsky/guile-pastebin")

                                             (target "_blank"))

                                          "Source")))))))

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

  (lambda (request request-body)

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

      ;; URI: / -- show the top 5 paste list

      (()

       (list-handler data-path))

      ;; URI: /post -- create paste

      (("post")

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

      ;; URI: /raw/<id> -- return raw content of the paste

      (("raw" pb-id)

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

      ;; URI: * -- everything else -- show 404 error

      (_

       (not-found)))))

(use-modules (pastebin httpserver)

         (addr-str (option-ref options 'addr "0.0.0.0"))

             (pastebin httpserver))