guile-webutils/webutils/multipart.scm

;;; guile-webutils -- Web application utilities for Guile
;;; Copyright © 2016  Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017  Christopher Allan Webber <cwebber@dustycloud.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/>.

(define-module (webutils multipart)
  #:use-module (webutils bytevectors)
  #:use-module (ice-9 match)
  #:use-module ((ice-9 binary-ports)
                #:select (unget-bytevector
                          open-bytevector-input-port))
  #:use-module ((ice-9 iconv)
                #:select (bytevector->string
                          string->bytevector))
  #:use-module ((rnrs io ports)
                #:select (get-string-all
                          latin-1-codec
                          get-bytevector-some
                          put-bytevector
                          open-bytevector-output-port))
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module ((web http) #:select (read-headers
                                     write-headers))
  #:use-module (web request)
  #:use-module (gcrypt random)
  #:export (parse-request-body

            make-part
            part?
            part-headers
            part-body

            part-content-disposition-params
            part-name parts-ref parts-ref-string
            part-content-type

            write-multipart-to-port
            format-multipart-body))


;;; Parsing
;;;

(define-record-type <part>
  (make-part headers body)
  part?
  (headers part-headers)
  (body part-body))

(define (parse-form-part part)
  "Break the PART string at the first empty line and return a part
record object."
  (match-let
      (((prefix match suffix)
         (bytevector-partition
          (u8-list->bytevector '(13 10 13 10)) part)))
    (make-part
     (call-with-input-string
         ;; TODO: bytestring-append?
         (string-append (bytevector->string
                         (bytevector-drop prefix 2) "ISO-8859-1")
                        "\r\n\r\n")
       read-headers)
     ;; Drop last two bytes because every part body ends with "\r\n".
     (open-bytevector-input-port
      (bytevector-drop-right suffix 2)))))

(define (%get-string-from-port port)
  "Get a string from the port and then reset it back to the beginning"
  (seek port 0 SEEK_SET)
  (let ((str (get-string-all port)))
    (seek port 0 SEEK_SET)
    str))

(define (set-parts-default-encodings! parts)
  "Set the default encoding on each part-body port in PARTS."
  (let ((default-encoding
          (or (and=> (parts-ref parts "_charset_")
                     (lambda (charset-part)
                       (%get-string-from-port (part-body charset-part))))
              "UTF-8")))
    (for-each
     (lambda (part)
       (let ((charset
              (or (assoc-ref (cdr (part-content-type part))
                             'charset)
                  default-encoding)))
         (set-port-encoding! (part-body part)
                             charset)))
     parts))
  parts)

(define (parse-request-body request body)
  "Parse the multipart/form-data request BODY and return an alist."
  (match-let
      ((('multipart/form-data ('boundary . boundary))
        (assoc-ref (request-headers request) 'content-type)))
    (set-parts-default-encodings!
     (map parse-form-part
          (split-parts (string-append "--" boundary) body)))))

(define (split-parts boundary payload)
  "Split the bytevector PAYLOAD containing the request body at the
given BOUNDARY string.  Return a list of bytevectors."

  (define boundbv  (string->bytevector boundary (latin-1-codec)))
  (define boundlen (bytevector-length boundbv))

  (let loop ((rest payload)
             (parts '()))
    (match-let
        (((prefix match suffix)
          (bytevector-partition boundbv rest)))
      (if suffix
          (loop suffix
                (cons prefix parts))
          ;; The last part is always empty
          (cdr (reverse parts))))))

(define (part-content-disposition-params part)
  "Return the parameters from the Content-Disposition part of PART"
  (and=> (assoc-ref (part-headers part) 'content-disposition)
         (match-lambda
           (('form-data alist ...)
            alist)
           (_ '()))))

(define (part-name part)
  "Retrieve the name of PART from the Content-Disposition."
  (assoc-ref (part-content-disposition-params part) 'name))

(define (parts-ref parts name)
  "Return the part from PARTS matching NAME."
  (find (lambda (part)
          (equal? (part-name part) name))
        parts))

(define (parts-ref-string parts name)
  "Return the part from PARTS matching NAME, as a string."
  (%get-string-from-port (part-body (parts-ref parts name))))

(define (part-content-type part)
  "Retrieve the Content-Type of PART, or the default of '(text-plain)."
  (or (assoc-ref (part-headers part) 'content-type)
      '(text-plain)))


;;; Composing/posting
;;;

(define (write-multipart-to-port parts boundary port)
  "Write multipart message containing PARTS separated by BOUNDARY to PORT."
  (define (write-crlf)
    (display "\r\n" port))
  (define (write-ddash)
    (display "--" port))
  (define (write-boundary)
    (write-ddash)
    (display boundary port))
  (define (write-part part)
    (define (write-body body)
      ;; TODO: Also support ports...
      (match body
        ((? string? _)
         (display body port))
        ((? bytevector? _)
         (put-bytevector port body))
        ((? port? body-port)
         (let lp ()
           (match (get-bytevector-some body-port)
             ((? eof-object? _)
              'done)
             (body-bv
              (put-bytevector port body-bv)
              (lp)))))))
    (define (write-headers-and-body headers body)
      (write-headers headers port)
      (write-crlf)
      (write-body body))

    (match part
      (((? string? name) . body)
       (write-headers-and-body `((content-disposition form-data
                                                      (name . ,name)))
                               body))
      ((? part? _)
       (write-headers-and-body (part-headers part)
                               (part-body part)))))
  (for-each (lambda (part)
              (write-boundary)
              (write-crlf)
              (write-part part)
              (write-crlf))
            parts)

  (write-boundary)(write-ddash)
  (write-crlf))

(define* (format-multipart-body parts #:key (boundary (random-token)))
  "Take PARTS and use to construct submittable multirequest body.

Returns two values to its continuation, the formatted body and the
boundary used to write it."
  (call-with-values (lambda ()
                      (open-bytevector-output-port))
    (lambda (bv-port get-bv)
      (write-multipart-to-port parts boundary bv-port)
      (values (get-bv) boundary))))