WebGate

;;; Support for suspended computations

(define current-suspension-key
  (make-parameter
   (sprintf
    "~a:~a:~a"
    (current-user-id) (current-group-id) (current-directory))))

(define (wrap-suspension sk)
  (let ((evp (create-envelope FORMAT-CRYPTLIB)))
    (dynamic-wind
	void
	(lambda ()
	  (attribute-set! evp OPTION-ENCR-ALGO ALGO-AES)
	  (attribute-set! evp OPTION-ENCR-HASH ALGO-SHA2)
	  (attribute-set! evp OPTION-ENCR-MAC ALGO-HMAC-SHA2)
	  (attribute-set! evp ENVINFO-INTEGRITY INTEGRITY-FULL)
	  (attribute-set!/string evp ENVINFO-PASSWORD (current-suspension-key))
	  (attribute-set! evp ENVINFO-DATASIZE (string-length sk))
	  (let ((port (open-output-object evp)))
	    (write-string sk #f port)
	    (close-output-port port))
	  (base64-encode (read-string #f (open-input-object evp #f #t)) #t))
	(lambda ()
	  (destroy-object evp)))))

(define crypt-condition?
  (condition-predicate 'crypt))

(define crypt-condition-code
  (condition-property-accessor 'crypt 'code #f))

(define (unwrap-suspension sk)
  (condition-case
   (let ((evp (create-envelope FORMAT-AUTO)))
     (dynamic-wind
	 void
	 (lambda ()
	   (with-exception-handler
	    (let ((abort (current-exception-handler)))
	      (lambda (exn)
		(if (and (crypt-condition? exn)
			 (eqv? (crypt-condition-code exn) ENVELOPE-RESOURCE))
		    (attribute-set!/string
		     evp ENVINFO-PASSWORD (current-suspension-key))
		    (abort exn))))
	    (lambda ()
	      (let ((port (open-output-object evp)))
		(write-string (base64-decode sk) #f port)
		(close-output-port port))
	      (and (eqv? (attribute evp ENVINFO-INTEGRITY) INTEGRITY-FULL)
		   (read-string #f (open-input-object evp #f #t))))))
	 (lambda ()
	   (destroy-object evp))))
    ((exn crypt) #f)
    ((exn syntax) #f)))

(define-resource (suspended "suspended" sk parameters)
  (cond
   ((unwrap-suspension sk)
    => (cut continuation-resume <> parameters))
   (else
    (make-error-response
     404 "The requested suspended resource was not found on the server."))))

(define (send/suspend proc)
  (continuation-suspend
   (lambda (sk)
     (proc (resource-uri suspended (wrap-suspension sk))))))

;;; Support for suspended computations

(define current-suspension-key
  (make-parameter
   (sprintf
    "~a:~a:~a"
    (current-user-id) (current-group-id) (current-directory))
   (lambda (v)
     (cond
      ((blob? v)
       v)
      (else
       (let loop ([v (->string v)] [n 1000])
	 (if (positive? n)
	     (loop (hash v) (fx- n 1))
	     (string->blob (substring/shared v 0 symmetric-box-keybytes)))))))))

(define (suspension-nonce)
  (substring/shared
   (hash
    (let ((getenv (resource-context-getenv (current-resource-context))))
      (sprintf
       "~a:~a/~a:~a"
       (getenv "REMOTE_ADDR") (getenv "REMOTE_PORT")
       (current-seconds) (current-milliseconds))))
   0 symmetric-box-noncebytes))

(define (wrap-suspension sk)
  (let* ((n (suspension-nonce))
	 (c ((symmetric-box (current-suspension-key)) sk (blob->u8vector/shared (string->blob n)))))
    (base64-encode (string-append n c) #t)))

(define (unwrap-suspension sk)
  (and-let* ((sk (condition-case (base64-decode sk) ((exn syntax) #f)))
	     ((> (string-length sk) symmetric-box-noncebytes))
	     (n (substring/shared sk 0 symmetric-box-noncebytes))
	     (c (substring/shared sk symmetric-box-noncebytes)))
    ((symmetric-unbox (current-suspension-key)) c (blob->u8vector/shared (string->blob n)))))



















(define-resource (suspended "suspended" sk parameters)
  (cond
   ((unwrap-suspension sk)
    => (cut continuation-resume <> parameters))
   (else
    (make-error-response
     404 "The requested suspended resource was not found on the server."))))

(define (send/suspend proc)
  (continuation-suspend
   (lambda (sk)
     (proc (resource-uri suspended (wrap-suspension sk))))))

;; -*- mode: Scheme; -*-
((category net)
 (license "BSD")
 (author "Thomas Chust")
 (synopsis "(S)CGI web application framework")
 (needs srfi-99 protobuf cryptlib)
 (files "webgate.scm"
	"at-expr.scm"
	"suspension.scm"
	"webgate-utils.scm"
	"webgate-core.scm"
	"webgate-suspend.scm"
	"webgate-cgi.scm"
	"webgate-scgi.scm"))

;; -*- mode: Scheme; -*-
((category net)
 (license "BSD")
 (author "Thomas Chust")
 (synopsis "(S)CGI web application framework")
 (needs srfi-99 protobuf tweetnacl)
 (files "webgate.scm"
	"at-expr.scm"
	"suspension.scm"
	"webgate-utils.scm"
	"webgate-core.scm"
	"webgate-suspend.scm"
	"webgate-cgi.scm"
	"webgate-scgi.scm"))

;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(require-library
 srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69 srfi-99
 data-structures ports extras lolevel irregex tcp posix
 suspension cryptlib)

(module webgate-utils
  (write-netstring read-netstring
   make-at-reader make-at-read-table use-at-read-table
   uri-encode uri-decode
   base64-encode base64-decode
   write-html)
................................................................................

(module webgate-suspend
  (current-suspension-key
   suspended
   send/suspend)
  (import
   scheme chicken
   srfi-1 srfi-18 srfi-69
   extras suspension cryptlib webgate-utils webgate-core
   (only posix current-user-id current-group-id current-directory))
  (include
   "webgate-suspend.scm"))

(module webgate-cgi
  (cgi-main-loop)
  (import

;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(require-library
 srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69 srfi-99
 data-structures ports extras lolevel irregex tcp posix
 suspension tweetnacl)

(module webgate-utils
  (write-netstring read-netstring
   make-at-reader make-at-read-table use-at-read-table
   uri-encode uri-decode
   base64-encode base64-decode
   write-html)
................................................................................

(module webgate-suspend
  (current-suspension-key
   suspended
   send/suspend)
  (import
   scheme chicken
   srfi-1 srfi-4 srfi-13 srfi-18 srfi-69
   data-structures extras suspension tweetnacl webgate-utils webgate-core
   (only posix current-user-id current-group-id current-directory))
  (include
   "webgate-suspend.scm"))

(module webgate-cgi
  (cgi-main-loop)
  (import