suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Extending cookie support with expiration

Browse Source 
Providing access to paths on id-cookies

Change PNR to limit checksum updating unless forced
This commit is contained in:
Jay McCarthy 2013-03-07 10:20:11 -07:00
parent 9d3a42f166
commit 6bf03c1244
7 changed files with 71 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/meta/planet2-index/official/main.rkt
View File

@ -55,7 +55,7 @@
(define pkgs-path (build-path root "pkgs"))
(make-directory* pkgs-path)
(define id-cookie-name "id")
(define id-cookie-name "pnrid")
;; XXX Add a caching system
(define (package-list)
@ -172,8 +172,9 @@
=> (λ (user)
`(span ([id "logout"])
,user
" | "
(a ([href ,(main-url page/logout)]) "logout")))]
;;" | "
;;(a ([href ,(main-url page/logout)]) "logout")
))]
[else
""]))
,@xexpr-forest
@ -188,7 +189,7 @@
(redirect-to
(main-url page/main)
#:headers
(list (cookie->header (logout-id-cookie id-cookie-name)))))
(list (cookie->header (logout-id-cookie id-cookie-name #:path "/")))))
(define (package-list/search ts)
(filter
@ -287,7 +288,7 @@
#:headers
(list
(cookie->header
(make-id-cookie id-cookie-name secret-key email)))))
(make-id-cookie id-cookie-name secret-key email #:path "/")))))
(when (regexp-match (regexp-quote "/") email)
(send/back
@ -488,7 +489,7 @@
(unless (or (not pkg) (equal? new-pkg pkg))
(package-remove! pkg))
(update-checksum new-pkg)
(update-checksum #t new-pkg)
(define new-tag
(request-binding/string pkg-req "tag" #f))
@ -680,17 +681,22 @@
(define (page/manage/update req)
(update-checksums
#t
(package-list/mine req))
(redirect-to (main-url page/manage)))
(define (update-checksums pkgs)
(for-each update-checksum pkgs))
(define (update-checksums force? pkgs)
(for-each (curry update-checksum force?) pkgs))
(define (update-checksum pkg-name)
(define (update-checksum force? pkg-name)
(define i (package-info pkg-name))
(define old-checksum
(package-ref i 'checksum))
(define now (current-seconds))
(define last (hash-ref i 'last-checked -inf.0))
(when (or force?
(>= (- now last) (* 24 60 60)))
(printf "\tupdating ~a\n" pkg-name)
(define new-checksum
(package-url->checksum
(package-ref i 'source)
@ -707,7 +713,7 @@
(if (and new-checksum (equal? new-checksum old-checksum))
i
(hash-set i 'last-updated now)))
(package-info-set! pkg-name i)))
(package-info-set! pkg-name i))))
(define basic-start
(planet2-index/basic package-list package-info))
@ -719,7 +725,7 @@
(while true
(printf "updating checksums\n")
(with-handlers ([exn:fail? void])
(update-checksums (package-list)))
(update-checksums #f (package-list)))
;; update once per day based on whenever the server started
(sleep (* 24 60 60)))))
(serve/servlet

2
collects/meta/planet2-index/sync.sh
View File

@ -9,3 +9,5 @@ for i in official planet-compat ; do
done
rsync -a --progress -h --delete --exclude root --exclude compiled --exclude doc ../../planet2/ plt-etc:local/plt/collects/$i/
rsync -a --progress -h --delete --exclude compiled ../../web-server ../../net plt-etc:local/plt/collects/

16
collects/net/cookie.rkt
View File

@ -61,6 +61,7 @@
cookie:add-comment
cookie:add-domain
cookie:add-max-age
cookie:add-expires
cookie:add-path
cookie:secure
cookie:version
@ -73,7 +74,7 @@
(struct-out cookie-error))
(define-serializable-struct cookie
(name value comment domain max-age path secure version) #:mutable)
(name value comment domain max-age path secure version expires) #:mutable)
(define-struct (cookie-error exn:fail) ())
;; error* : string args ... -> raises a cookie-error exception
@ -92,6 +93,7 @@
;; cookie-av = "Comment" "=" value
;; | "Domain" "=" value
;; | "Max-Age" "=" value
;; | "Expires" "=" value
;; | "Path" "=" value
;; | "Secure"
;; | "Version" "=" 1*DIGIT
@ -106,6 +108,7 @@
#f ; current path
#f ; normal (non SSL)
#f ; default version
#f ; doesn't expire
)))
;;!
@ -127,7 +130,8 @@
(format-if "Max-Age=~a" (cookie-max-age cookie))
(format-if "Path=~a" (cookie-path cookie))
(and (cookie-secure cookie) "Secure")
(format "Version=~a" (or (cookie-version cookie) 1))))
(format "Version=~a" (or (cookie-version cookie) 1))
(format-if "expires=~a" (cookie-expires cookie))))
"; "))
(define (cookie:add-comment cookie pre-comment)
@ -145,6 +149,14 @@
(set-cookie-domain! cookie domain)
cookie)
(define (cookie:add-expires cookie expires)
(unless (string? expires)
(error* "invalid expires: ~a" expires))
(unless (cookie? cookie)
(error* "cookie expected, received: ~a" cookie))
(set-cookie-expires! cookie expires)
cookie)
(define (cookie:add-max-age cookie seconds)
(unless (and (integer? seconds) (not (negative? seconds)))
(error* "invalid Max-Age for cookie: ~a" seconds))

6
collects/net/scribblings/cookie.scrbl
View File

@ -64,6 +64,12 @@ that a client should retain the cookie.}
Modifies @racket[cookie] with a path, and also returns
@racket[cookie].}
@defproc[(cookie:add-expires [cookie cookie?] [path string])
cookie?]{
Modifies @racket[cookie] with an expiration, and also returns
@racket[cookie].}
@defproc[(cookie:secure [cookie cookie?] [secure boolean?])
cookie?]{

3
collects/web-server/http/cookie.rkt
View File

@ -11,6 +11,7 @@
#:domain (or/c false/c valid-domain?)
#:max-age (or/c false/c exact-nonnegative-integer?)
#:path (or/c false/c string?)
#:expires (or/c false/c string?)
#:secure? (or/c false/c boolean?))
. ->* . cookie?)]
[cookie->header (cookie? . -> . header?)])
@ -31,10 +32,12 @@
#:domain [domain #f]
#:max-age [max-age #f]
#:path [path #f]
#:expires [expires #f]
#:secure? [secure? #f])
(setter (set-cookie name val)
(cookie:add-comment comment)
(cookie:add-domain domain)
(cookie:add-expires expires)
(cookie:add-max-age max-age)
(cookie:add-path path)
(cookie:secure secure?)))

12
collects/web-server/http/id-cookie.rkt
View File

@ -29,11 +29,12 @@
(and (client-cookie? c)
(string=? (client-cookie-name c) name)))
(define (make-id-cookie name key data)
(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)))
@ -59,8 +60,8 @@
(for/or ([c (in-list cookies)])
(valid-id-cookie? name key timeout c)))
(define (logout-id-cookie name)
(make-cookie name "invalid format"))
(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
@ -68,11 +69,12 @@
(-> path-string?
bytes?)]
[logout-id-cookie
(-> cookie-name? 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?
(->* (cookie-name? bytes? cookie-value?)
(#:path string?)
cookie?)]))

7
collects/web-server/scribblings/http.scrbl
View File

@ -262,6 +262,7 @@ transmission that the server @bold{will not catch}.}
[#:domain domain (or/c false/c valid-domain?) #f]
[#:max-age max-age (or/c false/c exact-nonnegative-integer?) #f]
[#:path path (or/c false/c string?) #f]
[#:expires expires (or/c false/c string?) #f]
[#:secure? secure? (or/c false/c boolean?) #f])
cookie?]{
Constructs a cookie with the appropriate fields.
@ -329,7 +330,8 @@ good entropy, if you care about that sort of thing.
@defproc[(make-id-cookie
[name cookie-name?]
[secret-salt bytes?]
[value cookie-value?])
[value cookie-value?]
[#:path path (or/c false/c string?) #f])
cookie?]{
Generates an authenticated cookie named @racket[name] containing @racket[value], signed with @racket[secret-salt].
}
@ -344,7 +346,8 @@ good entropy, if you care about that sort of thing.
}
@defproc[(logout-id-cookie
[name cookie-name?])
[name cookie-name?]
[#:path path (or/c false/c string?) #f])
cookie?]{
Generates a cookie named @racket[name] that is not validly authenticated.