Extending cookie support with expiration

Providing access to paths on id-cookies

Change PNR to limit checksum updating unless forced

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)
+(define (update-checksums force? pkgs)
-  (for-each update-checksum 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
+  (define last (hash-ref i 'last-checked -inf.0))
-    (package-url->checksum
+  (when (or force? 
-     (package-ref i 'source)
+            (>= (- now last) (* 24 60 60)))
-     (list (cons 'client_id (client_id))
+    (printf "\tupdating ~a\n" pkg-name)
-           (cons 'client_secret (client_secret)))))
+    (define new-checksum
-  (package-begin
+      (package-url->checksum
-   (define* i
+       (package-ref i 'source)
-     (hash-set i 'checksum
+       (list (cons 'client_id (client_id))
-               (or new-checksum
+             (cons 'client_secret (client_secret)))))
-                   old-checksum)))
+    (package-begin
-   (define* i
+     (define* i
-     (hash-set i 'last-checked now))
+       (hash-set i 'checksum
-   (define* i
+                 (or new-checksum
-     (if (and new-checksum (equal? new-checksum old-checksum))
+                     old-checksum)))
-       i
+     (define* i
-       (hash-set i 'last-updated now)))
+       (hash-set i 'last-checked now))
-   (package-info-set! pkg-name i)))
+     (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

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/

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

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?]{
 

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

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)
+(define (logout-id-cookie name #:path [path #f])
-  (make-cookie name "invalid format"))
+  (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?)
-       cookie?)]))
+        (#:path string?)
+        cookie?)]))

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.