data

(use-modules (pastebin httpserver)

             (web server))

(define (run-pastebin args)

  (let ((data-dir (cadr args)))

    (if (not (file-exists? data-dir))

        (mkdir data-dir))

    (run-server (make-pastebin-handler data-dir) 'http '(#:addr 0))))

(define-module (pastebin data))

(use-modules (srfi srfi-9)

             (srfi srfi-1)

             (ice-9 ftw)

             (ice-9 textual-ports))

(export <pb-data>

        <pb-entry>

        pb-entry-id

        pb-entry-text

        pb-data-open

        pb-data-close

        call-with-dir-as-pb-data

        pb-data-get-top

        pb-data-new-entry)

(define-record-type <pb-data>

  (make-pb-data dir)

  pb-data?

  (dir pb-data-dir set-pb-data-dir!))

(define-record-type <pb-entry>

  (make-pb-entry id text)

  pb-entry?

  (id pb-entry-id set-pb-entry-id!)

  (text pb-entry-text set-pb-entry-text!))

;; input: dir: string

;; output: <pb-data>

(define (pb-data-open dir)

  (make-pb-data dir))

(define (pb-data-close pb-data) #t)

(define (call-with-dir-as-pb-data dir p)

  (let ((pb-data (pb-data-open dir)))

    (let ((R (p pb-data)))

      (pb-data-close pb-data)

      R)))

(define (get-file-path pb-data filename)

  (string-append (pb-data-dir pb-data) "/" filename))

;; input: <pb-data>, integer

;; output: list of <pb-entry>

(define (pb-data-get-top pb-data n)

  (map

   (lambda (filename)

     (make-pb-entry

      filename

      (call-with-input-file (get-file-path pb-data filename)

        (lambda (port)

          (get-string-all port)))))

   (let ((file-ls (list-files pb-data)))

     (reverse (take-right file-ls (min n (length file-ls)))))))

;; input: <pb-data>, text

;; output: <pb-entry>

(define (pb-data-new-entry pb-data text)

  (let ((next-filename (get-next-filename pb-data)))

    (call-with-output-file (get-file-path pb-data next-filename)

      (lambda (port)

        (put-string port text)))

    (make-pb-entry next-filename text)))

(define (list-files pb-data)

  (scandir (pb-data-dir pb-data) (lambda (filename) (= (string-length filename) 5))))

(define (get-next-filename pb-data)

  (let ((entries (list-files pb-data)))

    (if (null? entries)

        "00000"

        (get-next-5digit (last entries)))))

(define (get-next-5digit str)

  (let A ((add #t)

          (char-int-ls (reverse (map char->integer (string->list str))))

          (result '()))

    (if (null? char-int-ls)

        (list->string (map integer->char result))

        (if add

            (let* ((hd (car char-int-ls)) (tl (cdr char-int-ls)))

              (if (= hd #x7A)

                  (A #t tl (cons #x30 result))

                  (A #f tl (cons (case hd

                                   ((#x39) #x41)

                                   ((#x5A) #x61)

                                   (else (1+ hd))) result))))

            (A #f '() (append (reverse char-int-ls) result))))))

(define-module (pastebin httpserver))

(use-modules (web request)

             (web response)

             (sxml simple)

             (pastebin data)

             (rnrs bytevectors)

             (ice-9 textual-ports)

             (ice-9 regex)

             (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 (templatize title body)

  `(html (head

          (title ,title)

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

         (body ,@body)))

(define (make-pastebin-handler data-path)

  (lambda (request request-body)

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

          (if boundary

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

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

                 data-path

                 (lambda (pb-data)

                   (pb-data-new-entry pb-data

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

    (values (build-response

             #:code 200

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

            (lambda (port)

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

                            data-path

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

                     (sxml (templatize

                            "pastebin"

                            `((form (@ (method "post") (enctype "multipart/form-data"))

                                    (textarea (@ (name "text")) "") (input (@ (type "submit"))))

                              (table (@ (border 1)) (tr (th "id") (th "text"))

                                     ,(map (lambda (entry) `(tr (td ,(pb-entry-id entry))

                                                                (td ,(pb-entry-text entry))))

                                           top5))))))

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

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