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
Side-by-Side 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

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

(define (wrap-suspension sk)
  (let ((evp (create-envelope FORMAT-CRYPTLIB)))
    (current-user-id) (current-group-id) (current-directory))
   (lambda (v)
     (cond
      ((blob? v)
    (dynamic-wind
	void
	(lambda ()
       v)
      (else
	  (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))
       (let loop ([v (->string v)] [n 1000])
	 (if (positive? n)
	  (base64-encode (read-string #f (open-input-object evp #f #t)) #t))
	(lambda ()
	  (destroy-object evp)))))
	     (loop (hash v) (fx- n 1))
	     (string->blob (substring/shared v 0 symmetric-box-keybytes)))))))))

(define crypt-condition?
  (condition-predicate 'crypt))
(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 crypt-condition-code
  (condition-property-accessor 'crypt 'code #f))
(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)
  (condition-case
   (let ((evp (create-envelope FORMAT-AUTO)))
     (dynamic-wind
  (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))
	 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))
	     (c (substring/shared sk symmetric-box-noncebytes)))
    ((symmetric-unbox (current-suspension-key)) c (blob->u8vector/shared (string->blob n)))))
		    (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
︙
Changes to webgate.meta. 
1
2
3
4
5
6

7
8
9
10
11
12
13

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

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

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
   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.008s by Fossil 2.26 [1205ec86cb] 2025-04-30 16:57:32