WebGate

Check-in [1b29946a75]
Login

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

Overview
Comment:Support for uri-safe or standard base64-encode
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 1b29946a75a939d669c10b59359a417195aeaf03
User & Date: murphy 2013-05-31 12:21:09
Context
2013-05-31
12:24
make-redirect-response utility procedure check-in: e1670c701e user: murphy tags: trunk
12:21
Support for uri-safe or standard base64-encode check-in: 1b29946a75 user: murphy tags: trunk
2013-05-30
18:10
Base the default suspension key on user identity and working directory check-in: 7ddd794862 user: murphy tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to webgate-suspend.scm.

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
	  (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))))
	(lambda ()
	  (destroy-object evp)))))

(define crypt-condition?
  (condition-predicate 'crypt))

(define crypt-condition-code







|







41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
	  (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

Changes to webgate-utils.scm.

222
223
224
225
226
227
228


229
230
231

232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263

264
265


266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
	    (string
	     (integer->char
	      (string->number (irregex-match-substring m 1) 16))))))))))

;;; Base64URI encoding

(define base64-alphabet


  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")

(define (base64-encode s)

  (let* ((n (string-length s))
	 (e (make-string (inexact->exact (ceiling (* 4/3 n))))))
    (do ((is 0 (fx+ is 3)) (ie 0 (fx+ ie 4))) ((fx>= is n) e)
      (let ((i (fxior
		(fxshl (char->integer (string-ref s is)) 16)
		(if (fx< (fx+ is 1) n)
		    (fxior
		     (fxshl (char->integer (string-ref s (fx+ is 1))) 8)
		     (if (fx< (fx+ is 2) n)
			 (char->integer (string-ref s (fx+ is 2)))
			 0))
		    0))))
	(string-set!
	 e ie
	 (string-ref base64-alphabet (fxand (fxshr i 18) #b111111)))
	(string-set!
	 e (fx+ ie 1)
	 (string-ref base64-alphabet (fxand (fxshr i 12) #b111111)))
	(when (fx< (fx+ is 1) n)
	  (string-set!
	   e (fx+ ie 2)
	   (string-ref base64-alphabet (fxand (fxshr i 6) #b111111)))
	  (when (fx< (fx+ is 2) n)
	    (string-set!
	     e (fx+ ie 3)
	     (string-ref base64-alphabet (fxand i #b111111)))))))))

(define base64-decode
  (let ((char->partial
	 (let ((tab
		(make-hash-table
		 eqv? eqv?-hash (string-length base64-alphabet))))

	   (do ((i 0 (fx+ i 1))) ((fx>= i (string-length base64-alphabet)))
	     (hash-table-set! tab (string-ref base64-alphabet i) i))


	   (lambda (chr)
	     (hash-table-ref
	      tab chr
	      (cut syntax-error 'base64-decode "illegal character" chr))))))
    (lambda (e)
      (let* ((n (string-length e))
	     (s (make-string (inexact->exact (floor (* 3/4 n))))))
	(do ((ie 0 (fx+ ie 4)) (is 0 (fx+ is 3))) ((fx>= ie n) s)
	  (let ((i (fxior
		    (fxshl
		     (char->partial (string-ref e ie)) 18)
		    (if (fx< (fx+ ie 1) n)
			(fxior
			 (fxshl
			  (char->partial (string-ref e (fx+ ie 1))) 12)
			 (if (fx< (fx+ ie 2) n)
			     (fxior
			      (fxshl
			       (char->partial (string-ref e (fx+ ie 2))) 6)
			      (if (fx< (fx+ ie 3) n)
				  (char->partial (string-ref e (fx+ ie 3)))
				  0))
			     0))
			0))))
	    (string-set!
	     s is (integer->char (fxand (fxshr i 16) #xff)))
	    (when (fx< (fx+ ie 2) n)
	      (string-set!







>
>


|
>
|













|


|



|



|


<
|
<
|
>
|
|
>
>


|







|



|



|

|







222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262

263

264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
	    (string
	     (integer->char
	      (string->number (irregex-match-substring m 1) 16))))))))))

;;; Base64URI encoding

(define base64-alphabet
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
(define base64-alphabet/uri
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")

(define (base64-encode s #!optional uri-safe?)
  (let* ((alphabet (if uri-safe? base64-alphabet/uri base64-alphabet))
	 (n (string-length s))
	 (e (make-string (inexact->exact (ceiling (* 4/3 n))))))
    (do ((is 0 (fx+ is 3)) (ie 0 (fx+ ie 4))) ((fx>= is n) e)
      (let ((i (fxior
		(fxshl (char->integer (string-ref s is)) 16)
		(if (fx< (fx+ is 1) n)
		    (fxior
		     (fxshl (char->integer (string-ref s (fx+ is 1))) 8)
		     (if (fx< (fx+ is 2) n)
			 (char->integer (string-ref s (fx+ is 2)))
			 0))
		    0))))
	(string-set!
	 e ie
	 (string-ref alphabet (fxand (fxshr i 18) #b111111)))
	(string-set!
	 e (fx+ ie 1)
	 (string-ref alphabet (fxand (fxshr i 12) #b111111)))
	(when (fx< (fx+ is 1) n)
	  (string-set!
	   e (fx+ ie 2)
	   (string-ref alphabet (fxand (fxshr i 6) #b111111)))
	  (when (fx< (fx+ is 2) n)
	    (string-set!
	     e (fx+ ie 3)
	     (string-ref alphabet (fxand i #b111111)))))))))

(define base64-decode

  (let ((alphabet-ref

	 (let* ((n (string-length base64-alphabet))
		(alphabet (make-hash-table eqv? eqv?-hash (fx+ n 2))))
	   (do ((i 0 (fx+ i 1))) ((fx>= i n))
	     (hash-table-set! alphabet (string-ref base64-alphabet i) i))
	   (do ((i (fx- n 2) (fx+ i 1))) ((fx>= i n))
	     (hash-table-set! alphabet (string-ref base64-alphabet/uri i) i))
	   (lambda (chr)
	     (hash-table-ref
	      alphabet chr
	      (cut syntax-error 'base64-decode "illegal character" chr))))))
    (lambda (e)
      (let* ((n (string-length e))
	     (s (make-string (inexact->exact (floor (* 3/4 n))))))
	(do ((ie 0 (fx+ ie 4)) (is 0 (fx+ is 3))) ((fx>= ie n) s)
	  (let ((i (fxior
		    (fxshl
		     (alphabet-ref (string-ref e ie)) 18)
		    (if (fx< (fx+ ie 1) n)
			(fxior
			 (fxshl
			  (alphabet-ref (string-ref e (fx+ ie 1))) 12)
			 (if (fx< (fx+ ie 2) n)
			     (fxior
			      (fxshl
			       (alphabet-ref (string-ref e (fx+ ie 2))) 6)
			      (if (fx< (fx+ ie 3) n)
				  (alphabet-ref (string-ref e (fx+ ie 3)))
				  0))
			     0))
			0))))
	    (string-set!
	     s is (integer->char (fxand (fxshr i 16) #xff)))
	    (when (fx< (fx+ ie 2) n)
	      (string-set!