ktakashi · June 12, 2015 12:46
diff --git a/base64.html b/base64.html
 <html>
  <head>
    <title>Base64 encode/decode</title>
  </head>
  <body>
    <form action="/base64" method="POST" enctype="multipart/form-data">
      Base64<br />
      <textarea name="base64" id="base64"></textarea>
      <br />
      Plain<br />
      <textarea name="plain" id="plain"></textarea>
      <br />
      <input type="submit" value="Encode!">
    </form>
  </body>
 </html>
diff --git a/server.scm b/server.scm
 #!read-macro=sagittarius/bv-string
 #!read-macro=sagittarius/regex
 (import (rnrs)
 	(net server)
 	(rfc mime) 
 	(rfc :5322)
 	(sagittarius regex)
 	(prefix (binary io) binary:) 
 	(sagittarius socket)
 	(srfi :39 parameters)
 	(util port)
 	(text sxml serializer)
 	(text sxml html-parser))

 (define (default-not-found-handler req)
  (values 404 'text/plain "Not Found"))

 (define *not-found-handler* (make-parameter default-not-found-handler))

 (define (http-make-path-entry method path)
  (string-append method ":" path))

 (define-syntax http-server-dispatcher
  (syntax-rules ()
    ((_ "dispatch" table ((method path handler) next ...))
     (begin
       (hashtable-set! table (http-make-path-entry
 			      (symbol->string 'method) path)
 		       handler)
       (http-server-dispatcher "dispatch" table (next ...))))
    ;; done
    ((_ "dispatch" table ()) (begin))
    ;; entry point
    ((_ specs ...)
     (let ((r (make-string-hashtable)))
       (http-server-dispatcher "dispatch" r (specs ...))
       r))))

 (define-record-type (<http-request> make-http-request http-request?)
  (fields (immutable method  http-request-method)
 	  (immutable path    http-request-path)
 	  (immutable headers http-request-headers)
 	  (immutable parameters http-request-parameters)
 	  ;; raw POST?
 	  (immutable source  http-request-source)))

 (define (http-emit-response out status mime content headers)
  (define (get-content mime content)
    (case mime
      ((shtml) 
       ;; TODO UTF-8?
       (let ((bv (string->utf8 (shtml->html content))))
 	 (values "text/html" (bytevector-length bv)
 		 (open-bytevector-input-port bv))))
      ((sxml)
       (let ((bv (string->utf8 (srl:sxml->xml content))))
 	 (values "text/html" (bytevector-length bv)
 		 (open-bytevector-input-port bv))))
      ((file)
       (let ((size (file-size-in-bytes content)))
 	 (values "application/octet-stream" size
 		 (open-file-input-port content (file-options no-fail)))))
      ;; TODO 
      (else
       (cond ((string? content)
 	      (let ((bv (string->utf8 content)))
 		(values mime (bytevector-length bv)
 			(open-bytevector-input-port bv))))
 	     ((bytevector? content)
 	      (values mime (bytevector-length bv)
 		      (open-bytevector-input-port bv)))
 	     ((and (binary-port? content) (input-port? content))
 	      (values mime #f content))
 	     (else
 	      (error 'http-emit-response "unknown type" content))))))
  (define get-header rfc5322-header-ref)
  (let-values (((mime size content) (get-content mime content)))
    (let ((content-type (or (get-header headers "content-type") mime))
 	  (content-length (or (get-header headers "content-length") size))
 	  (headers (remp (lambda (slot)
 			   (or (string=? (car slot) "content-length")
 			       (string=? (car slot) "content-type")))
 			 headers)))
      (put-bytevector out #*"HTTP/1.1 ")
      (put-bytevector out (string->utf8 
 			   (format "~a ~a\r\n" (car status) (cadr status))))
      (put-bytevector out (string->utf8
 			   (format "Content-Type: ~a\r\n" content-type)))
      (when content-length
 	(put-bytevector out (string->utf8
 			     (format "Content-Length: ~a\r\n" content-length))))
      (for-each (lambda (slot)
 		  (put-bytevector 
 		   out 
 		   (string->utf8
 		    (format "~a: ~a\r\n" (car slot) (cadr slot)))))
 		headers)
      (put-bytevector out #*"\r\n")
      (copy-binary-port out content)
      (close-port content))))

 ;; TODO
 (define (http-internal-server-error out e header?)
  (print e)
  (let* ((content (format "Server Error\r\n condition:~a\r\n headers: ~a\r\n"
 			 e header?))
 	 (bv (string->utf8 content)))
    (put-bytevector out #*"HTTP/1.1 500 Internal Server Error\r\n")
    (put-bytevector out #*"Content-Type: text/plain\r\n\r\n")
    (put-bytevector out #*"Content-Length: ")
    (put-bytevector out (string->utf8 (number->string (bytevector-length bv))))
    (put-bytevector out #*"\r\n")
    (put-bytevector out bv)))


 ;; TODO
 (define-constant +http-status-message+
  '((200 "OK")
    (404 "Not Found")
    (500 "Internal Server Error")))

 (define (http-handler dispatcher)
  (lambda (server socket)
    (define in (socket-input-port socket))
    (define out (socket-output-port socket))
    (define (fixup-status status)
      (if (pair? status)
 	  status
 	  (cond ((assv status +http-status-message+))
 		(else (list status "Unknown status")))))
    ;; lazy
    (define (mime-handler packet port)
      (get-bytevector-all port))

    (define (parse-mime headers in)
      (define (get-name params)
 	(let loop ((params params))
 	  (cond ((null? params) #f)
 		((and (pair? (car params)) (string=? "name" (caar params)))
 		 (cdar params))
 		(else (loop (cdr params))))))
      (define (get-names&contents body)
 	(define (get-name&content mime)
 	  (let* ((headers (mime-part-headers mime))
 		 (field (rfc5322-header-ref headers "content-disposition"))
 		 (params (mime-parse-content-disposition field))
 		 (name (get-name params)))
 	    (cons name mime)))
 	(map get-name&content (mime-part-content body)))
      (or (and-let* ((content-type (rfc5322-header-ref headers "content-type"))
 		     (parsed (mime-parse-content-type content-type))
 		     ( (string=? (car parsed) "multipart") )
 		     ;; should we check subpart?
 		     ( (string=? (cadr parsed) "form-data") )
 		     (body (mime-parse-message in headers mime-handler)))
 	    (get-names&contents body))
 	  '()))
 	
    (let ((first (binary:get-line in)))
      (cond ((#/(\w+)\s+([^\s]+)\s+HTTP\/([\d\.]+)/ first) =>
 	     (lambda (m)
 	       (let* ((method (utf8->string (m 1)))
 		      (path   (utf8->string (m 2)))
 		      (prot   (m 3))
 		      (headers (rfc5322-read-headers in))
 		      ;; TODO query string
 		      (handler (hashtable-ref dispatcher 
 					      (string-append method ":" path)
 					      ;; can be dynamically changed
 					      (*not-found-handler*)))
 		      (params (parse-mime headers in)))
 		 ;; TODO POST data
 		 (guard (e (else (http-internal-server-error out e headers)))
 		   (let-values (((status mime content . headers)
 				 ;; TODO proper http request
 				 (handler (make-http-request
 					   method path headers params in))))
 		     (http-emit-response out 
 					 (fixup-status status)
 					 mime content headers))))))
 	    (else
 	     (http-internal-server-error 
 	      out #f
 	      (utf8->string (get-bytevector-all in))))))
    ;; close the socket
    (socket-close socket)))


 (define (http-file-handler file mime)
  (lambda (req)
    (let ((size (file-size-in-bytes file)))
      (values 200 mime (open-file-input-port file (file-options no-fail))
 	      (list "content-length" size)))))

 ;; Encode/decode base64
 (import (rfc base64)
 	(text sxml sxpath)
 	(text sxml tools)
 	(srfi :26 cut))

 (define (form-handler resp-file)
  (define (convert-mime param)
    (let ((name (car param))
 	  (mime (cdr param)))
      (cond ((eof-object? (mime-part-content mime)) (cons #f #f))
 	    ((string=? name "base64")
 	     (cons "plain" (base64-decode (mime-part-content mime))))
 	    ((string=? name "plain") 
 	     (cons "base64" (base64-encode (mime-part-content mime))))
 	    (else (cons #f #f)))))
  (define (replace-it param shtml)
    (and-let* ((name (car param))
 	       (content ((if-car-sxpath (format "//*[@id = '~a']" name))
 			 shtml)))
      (sxml:change-content! content (list (utf8->string (cdr param))))))
      
  (lambda (req)
    (let ((names&contents (map convert-mime (http-request-parameters req)))
 	  (shtml (cadr (call-with-input-file resp-file html->shtml))))

      (for-each (cut replace-it <> shtml) names&contents)
      ;; replace
      (values 200 'shtml shtml))))

 (define dispatcher
  (http-server-dispatcher
   (GET "/base64" (http-file-handler "base64.html" "text/html"))
   (POST "/base64" (form-handler "base64.html"))))


 (define config (make-server-config :max-thread 5
 				   :non-blocking? #t
 				   :exception-handler print))

 (define http-server (make-simple-server "8500" 
 					(http-handler dispatcher)
 					:config config))


 (server-start! http-server)
	<html>
	<head>
	<title>Base64 encode/decode</title>
	</head>
	<body>
	<form action="/base64" method="POST" enctype="multipart/form-data">
	Base64<br />
	<textarea name="base64" id="base64"></textarea>
	<br />
	Plain<br />
	<textarea name="plain" id="plain"></textarea>
	<br />
	<input type="submit" value="Encode!">
	</form>
	</body>
	</html>
	#!read-macro=sagittarius/bv-string
	#!read-macro=sagittarius/regex
	(import (rnrs)
	(net server)
	(rfc mime)
	(rfc :5322)
	(sagittarius regex)
	(prefix (binary io) binary:)
	(sagittarius socket)
	(srfi :39 parameters)
	(util port)
	(text sxml serializer)
	(text sxml html-parser))

	(define (default-not-found-handler req)
	(values 404 'text/plain "Not Found"))

	(define not-found-handler (make-parameter default-not-found-handler))

	(define (http-make-path-entry method path)
	(string-append method ":" path))

	(define-syntax http-server-dispatcher
	(syntax-rules ()
	((_ "dispatch" table ((method path handler) next ...))
	(begin
	(hashtable-set! table (http-make-path-entry
	(symbol->string 'method) path)
	handler)
	(http-server-dispatcher "dispatch" table (next ...))))
	;; done
	((_ "dispatch" table ()) (begin))
	;; entry point
	((_ specs ...)
	(let ((r (make-string-hashtable)))
	(http-server-dispatcher "dispatch" r (specs ...))
	r))))

	(define-record-type (<http-request> make-http-request http-request?)
	(fields (immutable method http-request-method)
	(immutable path http-request-path)
	(immutable headers http-request-headers)
	(immutable parameters http-request-parameters)
	;; raw POST?
	(immutable source http-request-source)))

	(define (http-emit-response out status mime content headers)
	(define (get-content mime content)
	(case mime
	((shtml)
	;; TODO UTF-8?
	(let ((bv (string->utf8 (shtml->html content))))
	(values "text/html" (bytevector-length bv)
	(open-bytevector-input-port bv))))
	((sxml)
	(let ((bv (string->utf8 (srl:sxml->xml content))))
	(values "text/html" (bytevector-length bv)
	(open-bytevector-input-port bv))))
	((file)
	(let ((size (file-size-in-bytes content)))
	(values "application/octet-stream" size
	(open-file-input-port content (file-options no-fail)))))
	;; TODO
	(else
	(cond ((string? content)
	(let ((bv (string->utf8 content)))
	(values mime (bytevector-length bv)
	(open-bytevector-input-port bv))))
	((bytevector? content)
	(values mime (bytevector-length bv)
	(open-bytevector-input-port bv)))
	((and (binary-port? content) (input-port? content))
	(values mime #f content))
	(else
	(error 'http-emit-response "unknown type" content))))))
	(define get-header rfc5322-header-ref)
	(let-values (((mime size content) (get-content mime content)))
	(let ((content-type (or (get-header headers "content-type") mime))
	(content-length (or (get-header headers "content-length") size))
	(headers (remp (lambda (slot)
	(or (string=? (car slot) "content-length")
	(string=? (car slot) "content-type")))
	headers)))
	(put-bytevector out #*"HTTP/1.1 ")
	(put-bytevector out (string->utf8
	(format "~a ~a\r\n" (car status) (cadr status))))
	(put-bytevector out (string->utf8
	(format "Content-Type: ~a\r\n" content-type)))
	(when content-length
	(put-bytevector out (string->utf8
	(format "Content-Length: ~a\r\n" content-length))))
	(for-each (lambda (slot)
	(put-bytevector
	out
	(string->utf8
	(format "~a: ~a\r\n" (car slot) (cadr slot)))))
	headers)
	(put-bytevector out #*"\r\n")
	(copy-binary-port out content)
	(close-port content))))

	;; TODO
	(define (http-internal-server-error out e header?)
	(print e)
	(let* ((content (format "Server Error\r\n condition:~a\r\n headers: ~a\r\n"
	e header?))
	(bv (string->utf8 content)))
	(put-bytevector out #*"HTTP/1.1 500 Internal Server Error\r\n")
	(put-bytevector out #*"Content-Type: text/plain\r\n\r\n")
	(put-bytevector out #*"Content-Length: ")
	(put-bytevector out (string->utf8 (number->string (bytevector-length bv))))
	(put-bytevector out #*"\r\n")
	(put-bytevector out bv)))


	;; TODO
	(define-constant +http-status-message+
	'((200 "OK")
	(404 "Not Found")
	(500 "Internal Server Error")))

	(define (http-handler dispatcher)
	(lambda (server socket)
	(define in (socket-input-port socket))
	(define out (socket-output-port socket))
	(define (fixup-status status)
	(if (pair? status)
	status
	(cond ((assv status +http-status-message+))
	(else (list status "Unknown status")))))
	;; lazy
	(define (mime-handler packet port)
	(get-bytevector-all port))

	(define (parse-mime headers in)
	(define (get-name params)
	(let loop ((params params))
	(cond ((null? params) #f)
	((and (pair? (car params)) (string=? "name" (caar params)))
	(cdar params))
	(else (loop (cdr params))))))
	(define (get-names&contents body)
	(define (get-name&content mime)
	(let* ((headers (mime-part-headers mime))
	(field (rfc5322-header-ref headers "content-disposition"))
	(params (mime-parse-content-disposition field))
	(name (get-name params)))
	(cons name mime)))
	(map get-name&content (mime-part-content body)))
	(or (and-let* ((content-type (rfc5322-header-ref headers "content-type"))
	(parsed (mime-parse-content-type content-type))
	( (string=? (car parsed) "multipart") )
	;; should we check subpart?
	( (string=? (cadr parsed) "form-data") )
	(body (mime-parse-message in headers mime-handler)))
	(get-names&contents body))
	'()))

	(let ((first (binary:get-line in)))
	(cond ((#/(\w+)\s+([^\s]+)\s+HTTP\/([\d\.]+)/ first) =>
	(lambda (m)
	(let* ((method (utf8->string (m 1)))
	(path (utf8->string (m 2)))
	(prot (m 3))
	(headers (rfc5322-read-headers in))
	;; TODO query string
	(handler (hashtable-ref dispatcher
	(string-append method ":" path)
	;; can be dynamically changed
	(not-found-handler)))
	(params (parse-mime headers in)))
	;; TODO POST data
	(guard (e (else (http-internal-server-error out e headers)))
	(let-values (((status mime content . headers)
	;; TODO proper http request
	(handler (make-http-request
	method path headers params in))))
	(http-emit-response out
	(fixup-status status)
	mime content headers))))))
	(else
	(http-internal-server-error
	out #f
	(utf8->string (get-bytevector-all in))))))
	;; close the socket
	(socket-close socket)))


	(define (http-file-handler file mime)
	(lambda (req)
	(let ((size (file-size-in-bytes file)))
	(values 200 mime (open-file-input-port file (file-options no-fail))
	(list "content-length" size)))))

	;; Encode/decode base64
	(import (rfc base64)
	(text sxml sxpath)
	(text sxml tools)
	(srfi :26 cut))

	(define (form-handler resp-file)
	(define (convert-mime param)
	(let ((name (car param))
	(mime (cdr param)))
	(cond ((eof-object? (mime-part-content mime)) (cons #f #f))
	((string=? name "base64")
	(cons "plain" (base64-decode (mime-part-content mime))))
	((string=? name "plain")
	(cons "base64" (base64-encode (mime-part-content mime))))
	(else (cons #f #f)))))
	(define (replace-it param shtml)
	(and-let* ((name (car param))
	(content ((if-car-sxpath (format "//*[@id = '~a']" name))
	shtml)))
	(sxml:change-content! content (list (utf8->string (cdr param))))))

	(lambda (req)
	(let ((names&contents (map convert-mime (http-request-parameters req)))
	(shtml (cadr (call-with-input-file resp-file html->shtml))))

	(for-each (cut replace-it <> shtml) names&contents)
	;; replace
	(values 200 'shtml shtml))))

	(define dispatcher
	(http-server-dispatcher
	(GET "/base64" (http-file-handler "base64.html" "text/html"))
	(POST "/base64" (form-handler "base64.html"))))


	(define config (make-server-config :max-thread 5
	:non-blocking? #t
	:exception-handler print))

	(define http-server (make-simple-server "8500"
	(http-handler dispatcher)
	:config config))


	(server-start! http-server)