diff --git a/collects/meta/planet2-index/official/main.rkt b/collects/meta/planet2-index/official/main.rkt index 8e712edcba..1615ccf64d 100644 --- a/collects/meta/planet2-index/official/main.rkt +++ b/collects/meta/planet2-index/official/main.rkt @@ -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,34 +681,39 @@ (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 new-checksum - (package-url->checksum - (package-ref i 'source) - (list (cons 'client_id (client_id)) - (cons 'client_secret (client_secret))))) - (package-begin - (define* i - (hash-set i 'checksum - (or new-checksum - old-checksum))) - (define* i - (hash-set i 'last-checked now)) - (define* i - (if (and new-checksum (equal? new-checksum old-checksum)) - i - (hash-set i 'last-updated now))) - (package-info-set! pkg-name i))) + (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) + (list (cons 'client_id (client_id)) + (cons 'client_secret (client_secret))))) + (package-begin + (define* i + (hash-set i 'checksum + (or new-checksum + old-checksum))) + (define* i + (hash-set i 'last-checked now)) + (define* i + (if (and new-checksum (equal? new-checksum old-checksum)) + i + (hash-set i 'last-updated now))) + (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 diff --git a/collects/meta/planet2-index/sync.sh b/collects/meta/planet2-index/sync.sh index 22dfd95712..cbb504e587 100755 --- a/collects/meta/planet2-index/sync.sh +++ b/collects/meta/planet2-index/sync.sh @@ -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/ diff --git a/collects/net/cookie.rkt b/collects/net/cookie.rkt index 3600bd844c..c2a8d9a1bc 100644 --- a/collects/net/cookie.rkt +++ b/collects/net/cookie.rkt @@ -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)) diff --git a/collects/net/scribblings/cookie.scrbl b/collects/net/scribblings/cookie.scrbl index 59ee053eee..5cda30cb48 100644 --- a/collects/net/scribblings/cookie.scrbl +++ b/collects/net/scribblings/cookie.scrbl @@ -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?]{ diff --git a/collects/web-server/http/cookie.rkt b/collects/web-server/http/cookie.rkt index ac5d26a823..fa1188547a 100644 --- a/collects/web-server/http/cookie.rkt +++ b/collects/web-server/http/cookie.rkt @@ -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?))) diff --git a/collects/web-server/http/id-cookie.rkt b/collects/web-server/http/id-cookie.rkt index 53a8c35179..91bee00aba 100644 --- a/collects/web-server/http/id-cookie.rkt +++ b/collects/web-server/http/id-cookie.rkt @@ -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?)])) + (->* (cookie-name? bytes? cookie-value?) + (#:path string?) + cookie?)])) diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl index 6bd464fd10..64879cd165 100644 --- a/collects/web-server/scribblings/http.scrbl +++ b/collects/web-server/scribblings/http.scrbl @@ -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.