WebGate

Check-in [1c90f0c41c]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Use TweetNaCl instead of Cryptlib for suspension encapsulation
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 1c90f0c41c6623fe2801304079009524cdb3a422
User & Date: murphy 2015-05-04 09:22:50
Context
2015-05-04
10:39
Allow WebGate to work with the standard suspension egg check-in: d11a75d327 user: murphy tags: trunk
09:22
Use TweetNaCl instead of Cryptlib for suspension encapsulation check-in: 1c90f0c41c user: murphy tags: trunk
09:15
Moved suspension module into separate compilation unit, isolating disabled interrupts check-in: 72a7ba057e user: murphy tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to webgate-suspend.scm.

    25     25   
    26     26   ;;; Support for suspended computations
    27     27   
    28     28   (define current-suspension-key
    29     29     (make-parameter
    30     30      (sprintf
    31     31       "~a:~a:~a"
    32         -    (current-user-id) (current-group-id) (current-directory))))
           32  +    (current-user-id) (current-group-id) (current-directory))
           33  +   (lambda (v)
           34  +     (cond
           35  +      ((blob? v)
           36  +       v)
           37  +      (else
           38  +       (let loop ([v (->string v)] [n 1000])
           39  +	 (if (positive? n)
           40  +	     (loop (hash v) (fx- n 1))
           41  +	     (string->blob (substring/shared v 0 symmetric-box-keybytes)))))))))
           42  +
           43  +(define (suspension-nonce)
           44  +  (substring/shared
           45  +   (hash
           46  +    (let ((getenv (resource-context-getenv (current-resource-context))))
           47  +      (sprintf
           48  +       "~a:~a/~a:~a"
           49  +       (getenv "REMOTE_ADDR") (getenv "REMOTE_PORT")
           50  +       (current-seconds) (current-milliseconds))))
           51  +   0 symmetric-box-noncebytes))
    33     52   
    34     53   (define (wrap-suspension sk)
    35         -  (let ((evp (create-envelope FORMAT-CRYPTLIB)))
    36         -    (dynamic-wind
    37         -	void
    38         -	(lambda ()
    39         -	  (attribute-set! evp OPTION-ENCR-ALGO ALGO-AES)
    40         -	  (attribute-set! evp OPTION-ENCR-HASH ALGO-SHA2)
    41         -	  (attribute-set! evp OPTION-ENCR-MAC ALGO-HMAC-SHA2)
    42         -	  (attribute-set! evp ENVINFO-INTEGRITY INTEGRITY-FULL)
    43         -	  (attribute-set!/string evp ENVINFO-PASSWORD (current-suspension-key))
    44         -	  (attribute-set! evp ENVINFO-DATASIZE (string-length sk))
    45         -	  (let ((port (open-output-object evp)))
    46         -	    (write-string sk #f port)
    47         -	    (close-output-port port))
    48         -	  (base64-encode (read-string #f (open-input-object evp #f #t)) #t))
    49         -	(lambda ()
    50         -	  (destroy-object evp)))))
    51         -
    52         -(define crypt-condition?
    53         -  (condition-predicate 'crypt))
    54         -
    55         -(define crypt-condition-code
    56         -  (condition-property-accessor 'crypt 'code #f))
           54  +  (let* ((n (suspension-nonce))
           55  +	 (c ((symmetric-box (current-suspension-key)) sk (blob->u8vector/shared (string->blob n)))))
           56  +    (base64-encode (string-append n c) #t)))
    57     57   
    58     58   (define (unwrap-suspension sk)
    59         -  (condition-case
    60         -   (let ((evp (create-envelope FORMAT-AUTO)))
    61         -     (dynamic-wind
    62         -	 void
    63         -	 (lambda ()
    64         -	   (with-exception-handler
    65         -	    (let ((abort (current-exception-handler)))
    66         -	      (lambda (exn)
    67         -		(if (and (crypt-condition? exn)
    68         -			 (eqv? (crypt-condition-code exn) ENVELOPE-RESOURCE))
    69         -		    (attribute-set!/string
    70         -		     evp ENVINFO-PASSWORD (current-suspension-key))
    71         -		    (abort exn))))
    72         -	    (lambda ()
    73         -	      (let ((port (open-output-object evp)))
    74         -		(write-string (base64-decode sk) #f port)
    75         -		(close-output-port port))
    76         -	      (and (eqv? (attribute evp ENVINFO-INTEGRITY) INTEGRITY-FULL)
    77         -		   (read-string #f (open-input-object evp #f #t))))))
    78         -	 (lambda ()
    79         -	   (destroy-object evp))))
    80         -    ((exn crypt) #f)
    81         -    ((exn syntax) #f)))
           59  +  (and-let* ((sk (condition-case (base64-decode sk) ((exn syntax) #f)))
           60  +	     ((> (string-length sk) symmetric-box-noncebytes))
           61  +	     (n (substring/shared sk 0 symmetric-box-noncebytes))
           62  +	     (c (substring/shared sk symmetric-box-noncebytes)))
           63  +    ((symmetric-unbox (current-suspension-key)) c (blob->u8vector/shared (string->blob n)))))
    82     64   
    83     65   (define-resource (suspended "suspended" sk parameters)
    84     66     (cond
    85     67      ((unwrap-suspension sk)
    86     68       => (cut continuation-resume <> parameters))
    87     69      (else
    88     70       (make-error-response
    89     71        404 "The requested suspended resource was not found on the server."))))
    90     72   
    91     73   (define (send/suspend proc)
    92     74     (continuation-suspend
    93     75      (lambda (sk)
    94     76        (proc (resource-uri suspended (wrap-suspension sk))))))

Changes to webgate.meta.

     1      1   ;; -*- mode: Scheme; -*-
     2      2   ((category net)
     3      3    (license "BSD")
     4      4    (author "Thomas Chust")
     5      5    (synopsis "(S)CGI web application framework")
     6         - (needs srfi-99 protobuf cryptlib)
            6  + (needs srfi-99 protobuf tweetnacl)
     7      7    (files "webgate.scm"
     8      8   	"at-expr.scm"
     9      9   	"suspension.scm"
    10     10   	"webgate-utils.scm"
    11     11   	"webgate-core.scm"
    12     12   	"webgate-suspend.scm"
    13     13   	"webgate-cgi.scm"
    14     14   	"webgate-scgi.scm"))

Changes to webgate.scm.

    22     22   ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
    23     23   ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
    24     24   ;; SOFTWARE.
    25     25   
    26     26   (require-library
    27     27    srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69 srfi-99
    28     28    data-structures ports extras lolevel irregex tcp posix
    29         - suspension cryptlib)
           29  + suspension tweetnacl)
    30     30   
    31     31   (module webgate-utils
    32     32     (write-netstring read-netstring
    33     33      make-at-reader make-at-read-table use-at-read-table
    34     34      uri-encode uri-decode
    35     35      base64-encode base64-decode
    36     36      write-html)
................................................................................
    71     71   
    72     72   (module webgate-suspend
    73     73     (current-suspension-key
    74     74      suspended
    75     75      send/suspend)
    76     76     (import
    77     77      scheme chicken
    78         -   srfi-1 srfi-18 srfi-69
    79         -   extras suspension cryptlib webgate-utils webgate-core
           78  +   srfi-1 srfi-4 srfi-13 srfi-18 srfi-69
           79  +   data-structures extras suspension tweetnacl webgate-utils webgate-core
    80     80      (only posix current-user-id current-group-id current-directory))
    81     81     (include
    82     82      "webgate-suspend.scm"))
    83     83   
    84     84   (module webgate-cgi
    85     85     (cgi-main-loop)
    86     86     (import