WebGate: Artifact Content

Artifact 71471e1a09ff9540be922f6aafe265d67f3409c4:

File webgate-suspend.scm — part of check-in [1b29946a75] at 2013-05-31 12:21:09 on branch trunk — Support for uri-safe or standard base64-encode (user: murphy size: 3361)
;; -*- mode: Scheme; -*-
;;
;; This file is part of WebGate for CHICKEN.
;; Copyright (c) 2011-2013 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;; 
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; 
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; 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.

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