b4284/README.md

## README.md

      
    Raw
  

              README.md
            
          
    I'm using guile scheme to build some CGI program, and needed to process POST requests for uploaded files -- multipart/form-data to be exact. But what guile provides seems to be lacking this facility, so I wrote a crude one. This should be enough for small enough files. I/O is about 5K-7K KB/s for uploading files.
The main function in the script contains a simple example of how to get the parameters with this skeleton. Its usage is paired with convert.html, which trans-writes whatever you upload to the filesystem.

  
## convert.html
<!doctype html>
<html>
  <head>
    <meta charset="UTF-8">
  </head>
  <body>
    <div>
      <form action="cgi-bin/convert.cgi" enctype="multipart/form-data" method="post">
	    <div>Write <input type="file" name="file1"> to <input type="text" name="out_file_1"></div>
	    <div>Write <input type="file" name="file2"> to <input type="text" name="out_file_2"></div>
	    <input type="hidden" name="hidden1" value="h1value">
	    <input type="hidden" name="hidden2" value="h2value">
	    <input type="submit" value="Submit">
      </form>
    </div>
  </body>
</html>

## convert.scm
#!/usr/bin/guile \
-e main -s
!#

(use-modules (ice-9 binary-ports)
             (ice-9 textual-ports)
             (web uri)
             (ice-9 match)
             (ice-9 format)
             (rnrs bytevectors)
             (srfi srfi-1)
             (srfi srfi-11)
             (ice-9 rdelim))

(set-port-encoding! (current-input-port) "UTF-8")
(set-port-encoding! (current-output-port) "UTF-8")
(set-port-encoding! (current-error-port) "UTF-8")

(define (decode-query-string qs)
  (map
   (lambda (pair-str)
     (match (string-split pair-str #\=)
       ((k v)
        (cons (uri-decode k)
              (uri-decode v)))
       (_ `(invalid ,pair-str))))
   (string-split qs #\&)))

(define (read-to-0d0a port)
  (let A ((unread '())
          (u8-list '())
          (0d #f))
    (if (null? unread)
        (let ((bv (get-bytevector-n port 4096)))
          (if (eof-object? bv)
              (if (null? u8-list)
                  (eof-object)
                  (reverse u8-list))
              (A (bytevector->u8-list bv) u8-list 0d)))
        (let ((u8 (car unread)))
          (if 0d
              (if (= u8 #x0A)
                  (begin
                    (unget-bytevector port (u8-list->bytevector (cdr unread)))
                    (reverse (cdr u8-list)))
                  (A (cdr unread) (cons u8 u8-list) (= u8 #x0D)))
              (A (cdr unread) (cons u8 u8-list) (= u8 #x0D)))))))

(define (get-http-header header-string)
  (define column-idx (string-index header-string #\:))
  (define header-key (string-trim-both
                      (substring header-string 0 column-idx)))
  (define header-value (string-trim-both
                        (substring header-string (+ 1 column-idx))))
  (define header-values (map string-trim-both
                             (string-split header-value #\;)))
  (define header-values2
    (map
     (lambda (s)
       (let ((eq-idx (string-index s #\=)))
         (if eq-idx
             (let ((before-eq (substring s 0 eq-idx))
                   (after-eq (string-trim-both (substring s (+ 1 eq-idx))
                                               #\")))
               (cons before-eq after-eq))
             s)))
     header-values))
  (cons header-key header-values2))

(define u8-list->string
  (compose utf8->string u8-list->bytevector))

(define string->u8-list
  (compose bytevector->u8-list string->utf8))

(define (get-multipart-form-data port)
  (define boundary-string
    (let* ((content-type (getenv "CONTENT_TYPE"))
           (boundary-index (string-contains content-type "boundary=")))
      (if boundary-index
          (string-append "--"
                         (substring content-type (+ boundary-index 9)))
          ;; no boundary found, meaning no way to decode post content.
          (throw 'post-decode-error))))
  (define boundary (string->u8-list boundary-string))
  (define boundary-length (length boundary))
  (define ending-boundary (append boundary (string->u8-list "--")))
  (if (equal? (read-to-0d0a port) boundary)
      (let A ((sections '())
              (headers '())
              (look-for 'headers))
        (let ((0d0a (read-to-0d0a port)))
          (case look-for
            ((headers)
             ;; header parser
             (let ((header-string (u8-list->string 0d0a)))
               (if (string-null? header-string)
                   (A sections headers 'content-boundary)
                   (A sections (cons (get-http-header header-string) headers)
                      'headers))))
            ((content-boundary)
             ;; content-boundary parser
             (let B ((current-data (list 0d0a)))
               (let ((next-0d0a (read-to-0d0a port)))
                 (if (eof-object? next-0d0a)
                     ;; unable to get good boundary after content.
                     (throw 'end-of-file-reached)
                     (let ((is-boundary (equal? next-0d0a boundary))
                           (is-ending-boundary
                            (equal? next-0d0a ending-boundary)))
                       (if (or is-boundary is-ending-boundary)
                           ;; is boundary
                           (A (cons
                               (list (cons 'headers headers)
                                     (cons 'content
                                           (u8-list->bytevector
                                            ;; optimize: append is expensive!
                                            (apply append
                                                   (reverse current-data)))))
                               sections)
                              '()
                              ;; goto end if it is ending boundary
                              (if is-ending-boundary 'end 'headers))
                           ;; next-0d0a is NOT boundary. keep reading!
                           (B (cons* next-0d0a '(#x0D #x0A)
                                     current-data))))))))

            ((end) sections))))
      (throw 'incorrect-first-boundary)))

(define (multipart-param->post-param param-alist)
  (let* ((headers-alist (assq-ref param-alist 'headers))
         (content (assq-ref param-alist 'content))
         (content-disposition
          (assoc-ref headers-alist "Content-Disposition"))
         (name (assoc-ref content-disposition "name"))
         (filename (assoc-ref content-disposition "filename")))
    (if filename
        (cons name (list filename content))
        (cons name (utf8->string content)))))

(define (get-post-params port)
  (let A ((post-params '())
          (multipart-params (get-multipart-form-data port)))
    (if (null? multipart-params)
        post-params
        (A (cons (multipart-param->post-param (car multipart-params))
                 post-params)
           (cdr multipart-params)))))

(define (get-params port)
  (match (getenv "REQUEST_METHOD")
    ("GET" (decode-query-string (getenv "QUERY_STRING")))
    ("POST" (get-post-params port))))

(define (bytevector-hexdump bv)
  (define bvlen (bytevector-length bv))
  (define dump-string
    (let A ((out-strings '()) (i 0))
      (if (< i bvlen)
          (if (>= (- bvlen i) 16)
              (A (cons (format #f
                               "~8,'0x:\
 ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~)\
 ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~) \
 ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~)\
 ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~)"

                               i
                               (bytevector-u8-ref bv (+ i 0))
                               (bytevector-u8-ref bv (+ i 1))
                               (bytevector-u8-ref bv (+ i 2))
                               (bytevector-u8-ref bv (+ i 3))
                               (bytevector-u8-ref bv (+ i 4))
                               (bytevector-u8-ref bv (+ i 5))
                               (bytevector-u8-ref bv (+ i 6))
                               (bytevector-u8-ref bv (+ i 7))
                               (bytevector-u8-ref bv (+ i 8))
                               (bytevector-u8-ref bv (+ i 9))
                               (bytevector-u8-ref bv (+ i 10))
                               (bytevector-u8-ref bv (+ i 11))
                               (bytevector-u8-ref bv (+ i 12))
                               (bytevector-u8-ref bv (+ i 13))
                               (bytevector-u8-ref bv (+ i 14))
                               (bytevector-u8-ref bv (+ i 15)))
                       out-strings)
                 (+ 16 i))
              (let ((out-string
                     (with-output-to-string
                       (lambda ()
                         (define buffer (make-bytevector (- bvlen i)))
                         (bytevector-copy! bv i buffer 0 (- bvlen i))
                         (format #t "~8,'0x:" i)
                         (format #t "~{ ~:@(~2,'0x~)~}"
                                 (bytevector->u8-list buffer))))))
                (A (cons out-string out-strings) bvlen)))
          (string-join (reverse (cons "" out-strings)) "\n"))))
  (if (string-null? dump-string)
      ""
      (substring dump-string 1)))

(define (main args)
  ;; get parameters
  (define params (get-params (current-input-port)))
  ;; build output string
  (define outstr
    (with-output-to-string
      (lambda ()
        (format #t "Content-Type: text/plain; charset=utf-8\r\n\r\n")
        (for-each
         (lambda (p)
           (cond
            ;; file object
            ((and (pair? (cdr p))
                  (string? (cadr p))
                  (bytevector? (caddr p)))
             (format #t "~a: file (filename: ~a, length: ~a)~%"
                     (car p) (cadr p) (bytevector-length (caddr p)))
             ;; OPTIMIZE: hexdump is still very slow!
             ;; (display (bytevector-hexdump (caddr p)))
             )
            (else
             (format #t "~a: ~a~%" (car p) (cdr p)))))
         params))))

  ;; stock example: trans-writing files.
  (call-with-output-file (assoc-ref params "out_file_1")
    (lambda (port)
      (put-bytevector port (cadr (assoc-ref params "file1")))))
  (call-with-output-file (assoc-ref params "out_file_2")
    (lambda (port)
      (put-bytevector port (cadr (assoc-ref params "file2")))))

  ;; send output string to stderr to log to your apache httpd.
  (display outstr (current-error-port))

  ;; actual output.
  (display outstr))
	<!doctype html>
	<html>
	<head>
	<meta charset="UTF-8">
	</head>
	<body>
	<div>
	<form action="cgi-bin/convert.cgi" enctype="multipart/form-data" method="post">
	<div>Write <input type="file" name="file1"> to <input type="text" name="out_file_1"></div>
	<div>Write <input type="file" name="file2"> to <input type="text" name="out_file_2"></div>
	<input type="hidden" name="hidden1" value="h1value">
	<input type="hidden" name="hidden2" value="h2value">
	<input type="submit" value="Submit">
	</form>
	</div>
	</body>
	</html>
	#!/usr/bin/guile \
	-e main -s
	!#

	(use-modules (ice-9 binary-ports)
	(ice-9 textual-ports)
	(web uri)
	(ice-9 match)
	(ice-9 format)
	(rnrs bytevectors)
	(srfi srfi-1)
	(srfi srfi-11)
	(ice-9 rdelim))

	(set-port-encoding! (current-input-port) "UTF-8")
	(set-port-encoding! (current-output-port) "UTF-8")
	(set-port-encoding! (current-error-port) "UTF-8")

	(define (decode-query-string qs)
	(map
	(lambda (pair-str)
	(match (string-split pair-str #\=)
	((k v)
	(cons (uri-decode k)
	(uri-decode v)))
	(_ `(invalid ,pair-str))))
	(string-split qs #\&)))

	(define (read-to-0d0a port)
	(let A ((unread '())
	(u8-list '())
	(0d #f))
	(if (null? unread)
	(let ((bv (get-bytevector-n port 4096)))
	(if (eof-object? bv)
	(if (null? u8-list)
	(eof-object)
	(reverse u8-list))
	(A (bytevector->u8-list bv) u8-list 0d)))
	(let ((u8 (car unread)))
	(if 0d
	(if (= u8 #x0A)
	(begin
	(unget-bytevector port (u8-list->bytevector (cdr unread)))
	(reverse (cdr u8-list)))
	(A (cdr unread) (cons u8 u8-list) (= u8 #x0D)))
	(A (cdr unread) (cons u8 u8-list) (= u8 #x0D)))))))

	(define (get-http-header header-string)
	(define column-idx (string-index header-string #\:))
	(define header-key (string-trim-both
	(substring header-string 0 column-idx)))
	(define header-value (string-trim-both
	(substring header-string (+ 1 column-idx))))
	(define header-values (map string-trim-both
	(string-split header-value #\;)))
	(define header-values2
	(map
	(lambda (s)
	(let ((eq-idx (string-index s #\=)))
	(if eq-idx
	(let ((before-eq (substring s 0 eq-idx))
	(after-eq (string-trim-both (substring s (+ 1 eq-idx))
	#\")))
	(cons before-eq after-eq))
	s)))
	header-values))
	(cons header-key header-values2))

	(define u8-list->string
	(compose utf8->string u8-list->bytevector))

	(define string->u8-list
	(compose bytevector->u8-list string->utf8))

	(define (get-multipart-form-data port)
	(define boundary-string
	(let* ((content-type (getenv "CONTENT_TYPE"))
	(boundary-index (string-contains content-type "boundary=")))
	(if boundary-index
	(string-append "--"
	(substring content-type (+ boundary-index 9)))
	;; no boundary found, meaning no way to decode post content.
	(throw 'post-decode-error))))
	(define boundary (string->u8-list boundary-string))
	(define boundary-length (length boundary))
	(define ending-boundary (append boundary (string->u8-list "--")))
	(if (equal? (read-to-0d0a port) boundary)
	(let A ((sections '())
	(headers '())
	(look-for 'headers))
	(let ((0d0a (read-to-0d0a port)))
	(case look-for
	((headers)
	;; header parser
	(let ((header-string (u8-list->string 0d0a)))
	(if (string-null? header-string)
	(A sections headers 'content-boundary)
	(A sections (cons (get-http-header header-string) headers)
	'headers))))
	((content-boundary)
	;; content-boundary parser
	(let B ((current-data (list 0d0a)))
	(let ((next-0d0a (read-to-0d0a port)))
	(if (eof-object? next-0d0a)
	;; unable to get good boundary after content.
	(throw 'end-of-file-reached)
	(let ((is-boundary (equal? next-0d0a boundary))
	(is-ending-boundary
	(equal? next-0d0a ending-boundary)))
	(if (or is-boundary is-ending-boundary)
	;; is boundary
	(A (cons
	(list (cons 'headers headers)
	(cons 'content
	(u8-list->bytevector
	;; optimize: append is expensive!
	(apply append
	(reverse current-data)))))
	sections)
	'()
	;; goto end if it is ending boundary
	(if is-ending-boundary 'end 'headers))
	;; next-0d0a is NOT boundary. keep reading!
	(B (cons* next-0d0a '(#x0D #x0A)
	current-data))))))))

	((end) sections))))
	(throw 'incorrect-first-boundary)))

	(define (multipart-param->post-param param-alist)
	(let* ((headers-alist (assq-ref param-alist 'headers))
	(content (assq-ref param-alist 'content))
	(content-disposition
	(assoc-ref headers-alist "Content-Disposition"))
	(name (assoc-ref content-disposition "name"))
	(filename (assoc-ref content-disposition "filename")))
	(if filename
	(cons name (list filename content))
	(cons name (utf8->string content)))))

	(define (get-post-params port)
	(let A ((post-params '())
	(multipart-params (get-multipart-form-data port)))
	(if (null? multipart-params)
	post-params
	(A (cons (multipart-param->post-param (car multipart-params))
	post-params)
	(cdr multipart-params)))))

	(define (get-params port)
	(match (getenv "REQUEST_METHOD")
	("GET" (decode-query-string (getenv "QUERY_STRING")))
	("POST" (get-post-params port))))

	(define (bytevector-hexdump bv)
	(define bvlen (bytevector-length bv))
	(define dump-string
	(let A ((out-strings '()) (i 0))
	(if (< i bvlen)
	(if (>= (- bvlen i) 16)
	(A (cons (format #f
	"~8,'0x:\
	~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~)\
	~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~) \
	~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~)\
	~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~) ~:@(~2,'0x~)"

	i
	(bytevector-u8-ref bv (+ i 0))
	(bytevector-u8-ref bv (+ i 1))
	(bytevector-u8-ref bv (+ i 2))
	(bytevector-u8-ref bv (+ i 3))
	(bytevector-u8-ref bv (+ i 4))
	(bytevector-u8-ref bv (+ i 5))
	(bytevector-u8-ref bv (+ i 6))
	(bytevector-u8-ref bv (+ i 7))
	(bytevector-u8-ref bv (+ i 8))
	(bytevector-u8-ref bv (+ i 9))
	(bytevector-u8-ref bv (+ i 10))
	(bytevector-u8-ref bv (+ i 11))
	(bytevector-u8-ref bv (+ i 12))
	(bytevector-u8-ref bv (+ i 13))
	(bytevector-u8-ref bv (+ i 14))
	(bytevector-u8-ref bv (+ i 15)))
	out-strings)
	(+ 16 i))
	(let ((out-string
	(with-output-to-string
	(lambda ()
	(define buffer (make-bytevector (- bvlen i)))
	(bytevector-copy! bv i buffer 0 (- bvlen i))
	(format #t "~8,'0x:" i)
	(format #t "~{ ~:@(~2,'0x~)~}"
	(bytevector->u8-list buffer))))))
	(A (cons out-string out-strings) bvlen)))
	(string-join (reverse (cons "" out-strings)) "\n"))))
	(if (string-null? dump-string)
	""
	(substring dump-string 1)))

	(define (main args)
	;; get parameters
	(define params (get-params (current-input-port)))
	;; build output string
	(define outstr
	(with-output-to-string
	(lambda ()
	(format #t "Content-Type: text/plain; charset=utf-8\r\n\r\n")
	(for-each
	(lambda (p)
	(cond
	;; file object
	((and (pair? (cdr p))
	(string? (cadr p))
	(bytevector? (caddr p)))
	(format #t "~a: file (filename: ~a, length: ~a)~%"
	(car p) (cadr p) (bytevector-length (caddr p)))
	;; OPTIMIZE: hexdump is still very slow!
	;; (display (bytevector-hexdump (caddr p)))
	)
	(else
	(format #t "~a: ~a~%" (car p) (cdr p)))))
	params))))

	;; stock example: trans-writing files.
	(call-with-output-file (assoc-ref params "out_file_1")
	(lambda (port)
	(put-bytevector port (cadr (assoc-ref params "file1")))))
	(call-with-output-file (assoc-ref params "out_file_2")
	(lambda (port)
	(put-bytevector port (cadr (assoc-ref params "file2")))))

	;; send output string to stderr to log to your apache httpd.
	(display outstr (current-error-port))

	;; actual output.
	(display outstr))