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