1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
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
|
#lang racket/base
(require net/base64
net/cookie
racket/match
racket/file
racket/contract
web-server/http
web-server/stuffers/hmac-sha1
web-server/private/util)
(define (substring* s st en)
(substring s st (+ (string-length s) en)))
(define (mac key v)
(substring*
(bytes->string/utf-8
(base64-encode (HMAC-SHA1 key (write/bytes v)) #""))
0 -3))
(define (make-secret-salt/file secret-salt-path)
(unless (file-exists? secret-salt-path)
(with-output-to-file secret-salt-path
(λ ()
(for ([i (in-range 128)])
(write-byte (random 256))))))
(file->bytes secret-salt-path))
(define (id-cookie? name c)
(and (client-cookie? c)
(string=? (client-cookie-name c) name)))
(define (make-id-cookie name key data #:path [path #f])
(define authored (current-seconds))
(define digest
(mac key (list authored data)))
(make-cookie name
#:path path
(format "~a&~a&~a"
digest authored data)))
(define (valid-id-cookie? name key timeout c)
(and (id-cookie? name c)
(with-handlers ([exn:fail? (lambda (x) #f)])
(match (client-cookie-value c)
[(regexp #rx"^(.+)&(.+)&(.*)$" (list _ digest authored-s data))
(define authored (string->number authored-s))
(define re-digest (mac key (list authored data)))
(and (string=? digest re-digest)
(<= authored timeout)
data)]
[cv
#f]))))
(define (request-id-cookie
name
key
#:timeout [timeout +inf.0]
req)
(define cookies (request-cookies req))
(for/or ([c (in-list cookies)])
(valid-id-cookie? name key timeout c)))
(define (logout-id-cookie name #:path [path #f])
(make-cookie name "invalid format" #:path path #:expires "Thu, 01 Jan 1970 00:00:00 GMT"))
(provide
(contract-out
[make-secret-salt/file
(-> path-string?
bytes?)]
[logout-id-cookie
(->* (cookie-name?) (#:path string?) cookie?)]
[request-id-cookie
(->* (cookie-name? bytes? request?)
(#:timeout number?)
(or/c false/c cookie-value?))]
[make-id-cookie
(->* (cookie-name? bytes? cookie-value?)
(#:path string?)
cookie?)]))
|
