WebGate

Check-in [1c90f0c41c]
Login
Home Timeline Branches Tags Tickets Wiki

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

Overview
Comment:Use TweetNaCl instead of Cryptlib for suspension encapsulation
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 1c90f0c41c6623fe2801304079009524cdb3a422
User & Date: murphy 2015-05-04 09:22:50.807
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
Unified Diff Ignore Whitespace Patch
Changes to webgate-suspend.scm.
︙︙
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53







54
55


56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88


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








|
|
|
|
<
|
|
<
<
<
<
<
<
<
|
|
<
|
|

|
|
>
>
>
>
>
>
>

|
>
>
|


|
|
|
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<








25
26
27
28
29
30
31
32
33
34
35

36
37







38
39

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61







62
63











64
65
66
67
68
69
70


;;; 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
︙︙
Changes to webgate.meta. 
1
2
3
4
5
6
7
8
9
10
11
12
13

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






|








1
2
3
4
5
6
7
8
9
10
11
12
13

;; -*- 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"
︙︙
Changes to webgate.scm.
︙︙
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

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








|








22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

;; 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)
︙︙
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86


(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








|
|








71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86


(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
︙︙
This page was generated in about 0.009s by Fossil 2.26 [1205ec86cb] 2025-04-30 16:57:32