dynamic server in place

2013-10-11 13:06:03 -06:00 · 2013-10-11 13:06:03 -06:00 · 975d06db7f
commit 975d06db7f
parent 1fdc8e6c76
6 changed files with 371 additions and 108 deletions
--- a/pkgs/plt-services/meta/pkg-index/official/common.rkt
+++ b/pkgs/plt-services/meta/pkg-index/official/common.rkt
@ -2,6 +2,10 @@
 (require racket/file
         racket/runtime-path
         pkg/util
+         racket/match
+         racket/list
+         racket/date
+         racket/system
         racket/string
         web-server/http/id-cookie)

@ -25,7 +29,89 @@

 (define static-path (build-path src "static"))

+(define (package-list)
+  (sort (map path->string (directory-list pkgs-path))
+        string-ci<=?))
+(define (package-info pkg-name #:version [version #f])
+  (define no-version (hash-set (file->value (build-path pkgs-path pkg-name)) 'name pkg-name))
+  (cond
+    [(and version
+          (hash-ref no-version 'versions #f)
+          (hash-ref (hash-ref no-version 'versions) version #f))
+     =>
+     (λ (version-ht)
+       (hash-merge version-ht no-version))]
+    [else
+     no-version]))
+
+(define (package-ref pkg-info key)
+  (hash-ref pkg-info key
+            (λ ()
+              (match key
+                [(or 'author 'checksum 'source)
+                 (error 'pkg "Package ~e is missing a required field: ~e"
+                        (hash-ref pkg-info 'name) key)]
+                ['ring
+                 2]
+                ['checksum-error
+                 #f]
+                ['tags
+                 empty]
+                ['versions
+                 (hash)]
+                [(or 'last-checked 'last-edit 'last-updated)
+                 -inf.0]))))
+
+(define (package-info-set! pkg-name i)
+  (write-to-file i (build-path pkgs-path pkg-name)
+                 #:exists 'replace))
+
+(define (hash-merge from to)
+  (for/fold ([to to])
+      ([(k v) (in-hash from)])
+    (hash-set to k v)))
+
 (define (author->list as)
  (string-split as))

+(define (valid-name? t)
+  (not (regexp-match #rx"[^a-zA-Z0-9_\\-]" t)))
+
+(define (valid-author? a)
+  (not (regexp-match #rx"[ :]" a)))
+
+(define valid-tag?
+  valid-name?)
+
+(define-runtime-path update.rkt "update.rkt")
+(define-runtime-path static.rkt "static.rkt")
+(define-runtime-path s3.rkt "s3.rkt")
+
+(define run-sema (make-semaphore 1))
+(define (run! file args)
+  (call-with-semaphore
+   run-sema
+   (λ ()
+     (parameterize ([date-display-format 'iso-8601])
+       (printf "~a: ~a ~v\n" (date->string (current-date) #t) file args))
+     (apply system* (find-executable-path (find-system-path 'exec-file))
+            "-t" file
+            "--"
+            args)
+     (printf "~a: done\n" (date->string (current-date) #t)))))
+
+(define (run-update! pkgs)
+  (run! update.rkt pkgs))
+(define (run-static! pkgs)
+  (run! static.rkt pkgs))
+(define (run-s3! pkgs)
+  (run! s3.rkt pkgs))
+
+(define (signal-update! pkgs)
+  (thread (λ () (run-update! pkgs))))
+(define (signal-static! pkgs)
+  (thread (λ () (run-static! pkgs))))
+(define (signal-s3! pkgs)
+  (thread (λ () (run-s3! pkgs))))
+
 (provide (all-defined-out))
--- a/pkgs/plt-services/meta/pkg-index/official/dynamic.rkt
+++ b/pkgs/plt-services/meta/pkg-index/official/dynamic.rkt
@ -4,52 +4,23 @@
         "jsonp.rkt"
         web-server/servlet-env
         racket/file
-         xml
-         racket/function
-         racket/runtime-path
         web-server/dispatch
-         pkg/util
-         (prefix-in pkg: pkg/lib)
         racket/match
-         racket/package
-         racket/system
-         racket/date
         racket/string
-         web-server/servlet
-         web-server/formlets
-         racket/bool
+         net/url
         racket/list
         net/sendmail
         meta/pkg-index/basic/main
-         web-server/http/id-cookie
         file/sha1
         (prefix-in bcrypt- bcrypt)
         version/utils)

-(define (package-info pkg-name #:version [version #f])
-  (define no-version (hash-set (file->value (build-path pkgs-path pkg-name)) 'name pkg-name))
-  (cond
-    [(and version
-          (hash-ref no-version 'versions #f)
-          (hash-ref (hash-ref no-version 'versions) version #f))
-     =>
-     (λ (version-ht)
-       (hash-merge version-ht no-version))]
-    [else
-     no-version]))
-
-(define (package-info-set! pkg-name i)
-  (write-to-file i (build-path pkgs-path pkg-name)
-                 #:exists 'replace))
+(define (package-remove! pkg-name)
+  (delete-file (build-path pkgs-path pkg-name)))

 (define (package-exists? pkg-name)
  (file-exists? (build-path pkgs-path pkg-name)))

-(define (hash-merge from to)
-  (for/fold ([to to])
-      ([(k v) (in-hash from)])
-    (hash-set to k v)))
-
 (define (hash-deep-merge ht more-ht)
  (for/fold ([ht ht])
      ([(k new-v) (in-hash more-ht)])
@ -86,13 +57,9 @@
                            (for/fold ([pi new-pi]) ([k (in-list '(last-edit last-checked last-updated))])
                              (hash-set pi k now))))
       (package-info-set! p updated-pi)
-       (signal-update! #t p))
+       (signal-update! (list p)))
     (response/sexpr #t)]))

-(define (signal-update! force? pkg)
-  ;; XXX
-  (void))
-
 (define (redirect-to-static req)
  (redirect-to
   (url->string
@ -190,69 +157,206 @@
    [#t
     (hasheq 'curation (curation-administrator? email))]))

-;; XXX
 (define-jsonp/auth
  (jsonp/package/modify
   ['pkg pkg]
   ['name mn-name]
   ['description mn-desc]
   ['source mn-source])
-  #f)
+  (cond
+    [(equal? pkg "")
+     (cond
+       [(package-exists? mn-name)
+        #f]
+       [else
+        (package-info-set! mn-name
+                           (hasheq 'name mn-name
+                                   'source mn-source
+                                   'author (current-user)
+                                   'description mn-desc
+                                   'last-edit (current-seconds)))
+        (signal-update! (list mn-name))
+        #t])]
+    [else
+     (ensure-package-author
+      pkg
+      (λ ()
+        (cond
+          [(equal? mn-name pkg)
+           (package-info-set! pkg
+                              (hash-set* (package-info pkg)
+                                         'source mn-source
+                                         'description mn-desc
+                                         'last-edit (current-seconds)))
+           (signal-update! (list pkg))
+           #t]
+          [(and (valid-name? mn-name)
+                (not (package-exists? mn-name)))
+           (package-info-set! mn-name
+                              (hash-set* (package-info pkg)
+                                         'name mn-name
+                                         'source mn-source
+                                         'description mn-desc
+                                         'last-edit (current-seconds)))
+           (package-remove! pkg)
+           (signal-update! (list mn-name))
+           #t]
+          [else
+           #f])))]))

-;; XXX
 (define-jsonp/auth
  (jsonp/package/version/add
   ['pkg pkg]
   ['version version]
   ['source source])
-  #f)
+  (ensure-package-author
+   pkg
+   (λ ()
+     (cond
+       [(valid-version? version)
+        (package-info-set!
+         pkg
+         (hash-update (package-info pkg) 'versions
+                      (λ (v-ht)
+                        (hash-set v-ht version
+                                  (hasheq 'source source
+                                          'checksum "")))
+                      hash))
+        (signal-update! (list pkg))
+        #t]
+       [else
+        #f]))))

-;; XXX
 (define-jsonp/auth
  (jsonp/package/version/del
   ['pkg pkg]
   ['version version])
-  #f)
+  (ensure-package-author
+   pkg
+   (λ ()
+     (cond
+       [(valid-version? version)
+        (package-info-set!
+         pkg
+         (hash-update (package-info pkg) 'versions
+                      (λ (v-ht)
+                        (hash-remove v-ht version))
+                      hash))
+        (signal-update! (list pkg))
+        #t]
+       [else
+        #f]))))
+
+(define (tags-normalize ts)
+  (remove-duplicates (sort ts string-ci<?)))

-;; XXX
 (define-jsonp/auth
  (jsonp/package/tag/add
   ['pkg pkg]
   ['tag tag])
-  #f)
+  (ensure-package-author
+   pkg
+   (λ ()
+     (cond
+       [(valid-tag? tag)
+        (define i (package-info pkg))
+        (package-info-set!
+         pkg
+         (hash-set i 'tags (tags-normalize (cons tag (package-ref i 'tags)))))
+        (signal-static! (list pkg))
+        #t]
+       [else
+        #f]))))

-;; XXX
 (define-jsonp/auth
  (jsonp/package/tag/del
   ['pkg pkg]
   ['tag tag])
-  #f)
+  (ensure-package-author
+   pkg
+   (λ ()
+     (define i (package-info pkg))
+     (package-info-set!
+      pkg
+      (hash-set i 'tags
+                (remove tag
+                        (package-ref i 'tags))))
+     (signal-static! (list pkg))
+     #t)))

-;; XXX
 (define-jsonp/auth
  (jsonp/package/author/add
   ['pkg pkg]
   ['author author])
-  #f)
+  (ensure-package-author
+   pkg
+   (λ ()
+     (cond
+       [(valid-author? author)
+        (define i (package-info pkg))
+        (package-info-set!
+         pkg
+         (hash-set i 'author (format "~a ~a" (package-ref i 'author) author)))
+        (signal-static! (list pkg))
+        #t]
+       [else
+        #f]))))
+
+(define (ensure-package-author pkg f)
+  (cond
+    [(package-author? pkg (current-user))
+     (f)]
+    [else
+     #f]))

-;; XXX
 (define-jsonp/auth
  (jsonp/package/author/del
   ['pkg pkg]
   ['author author])
-  #f)
+  (ensure-package-author
+   pkg
+   (λ ()
+     (cond
+       [(not (equal? (current-user) author))
+        (define i (package-info pkg))
+        (package-info-set!
+         pkg
+         (hash-set i 'author
+                   (string-join
+                    (remove author
+                            (author->list (package-ref i 'author))))))
+        (signal-static! (list pkg))
+        #t]
+       [else
+        #f]))))

-;; XXX
 (define-jsonp/auth
  (jsonp/package/curate
   ['pkg pkg]
   ['ring ring-s])
-  #f)
+  (cond
+    [(curation-administrator? (current-user))
+     (define i (package-info pkg))
+     (define ring-n (string->number ring-s))
+     (package-info-set!
+      pkg
+      (hash-set i 'ring (min 2 (max 0 ring-n))))
+     (signal-static! (list pkg))
+     #t]
+    [else
+     #f]))
+
+(define (package-author? p u)
+  (define i (package-info p))
+  (member u (author->list (package-ref i 'author))))
+
+(define (packages-of u)
+  (filter (λ (p) (package-author? p u)) (package-list)))

-;; XXX
 (define-jsonp/auth
  (jsonp/update)
-  #f)
+  (signal-update! (packages-of (current-user)))
+  #t)

 (define-values (main-dispatch main-url)
  (dispatch-rules
@ -273,7 +377,7 @@
  (printf "launching on port ~a\n" port)
  (serve/servlet
   (λ (req)
-     (displayln (url->string (request-uri req)))
+     ;; (displayln (url->string (request-uri req)))
     (main-dispatch req))
   #:command-line? #t
   #:listen-ip #f
--- a/pkgs/plt-services/meta/pkg-index/official/main.rkt
+++ b/pkgs/plt-services/meta/pkg-index/official/main.rkt
@ -42,50 +42,10 @@
 (define id-cookie-name "pnrid")

 ;; XXX Add a caching system
-(define (package-list)
-  (sort (map path->string (directory-list pkgs-path))
-        string-ci<=?))
 (define (package-exists? pkg-name)
  (file-exists? (build-path pkgs-path pkg-name)))
 (define (package-remove! pkg-name)
  (delete-file (build-path pkgs-path pkg-name)))
-(define (package-info pkg-name #:version [version #f])
-  (define no-version (hash-set (file->value (build-path pkgs-path pkg-name)) 'name pkg-name))
-  (cond
-    [(and version
-          (hash-ref no-version 'versions #f)
-          (hash-ref (hash-ref no-version 'versions) version #f))
-     =>
-     (λ (version-ht)
-       (hash-merge version-ht no-version))]
-    [else
-     no-version]))
-(define (package-info-set! pkg-name i)
-  (write-to-file i (build-path pkgs-path pkg-name)
-                 #:exists 'replace))
-
-(define (hash-merge from to)
-  (for/fold ([to to])
-      ([(k v) (in-hash from)])
-    (hash-set to k v)))
-
-(define (package-ref pkg-info key)
-  (hash-ref pkg-info key
-            (λ ()
-              (match key
-                [(or 'author 'checksum 'source)
-                 (error 'pkg "Package ~e is missing a required field: ~e"
-                        (hash-ref pkg-info 'name) key)]
-                ['ring
-                 *default-ring*]
-                ['checksum-error
-                 #f]
-                ['tags
-                 empty]
-                ['versions
-                 (hash)]
-                [(or 'last-checked 'last-edit 'last-updated)
-                 -inf.0]))))

 (define-values (main-dispatch main-url)
  (dispatch-rules
@ -664,9 +624,6 @@
  (add-tag! pkg-name new-tag)
  (redirect-to (main-url page/info pkg-name)))

-(define (valid-name? t)
-  (not (regexp-match #rx"[^a-zA-Z0-9_\\-]" t)))
-
 (module+ test
  (check-equal? (valid-name? "net") #t)
  (check-equal? (valid-name? "120") #t)
--- a/pkgs/plt-services/meta/pkg-index/official/s3.rkt
+++ b/pkgs/plt-services/meta/pkg-index/official/s3.rkt
@ -0,0 +1,20 @@
+#lang racket/base
+(require racket/list
+         "common.rkt")
+
+(define (upload-all)
+  (error 'upload-all "XXX"))
+(define (upload-pkgs pkgs)
+  ;; FUTURE make this more efficient
+  (upload-all))
+
+(module+ main
+  (require racket/cmdline)
+  (command-line
+   #:program "s3"
+   #:args pkgs
+   (cond
+     [(empty? pkgs)
+      (upload-all)]
+     [else
+      (upload-pkgs pkgs)])))
--- a/pkgs/plt-services/meta/pkg-index/official/static.rkt
+++ b/pkgs/plt-services/meta/pkg-index/official/static.rkt
@ -10,7 +10,8 @@
         racket/list
         racket/path
         racket/promise
-         meta/pkg-index/basic/main)
+         meta/pkg-index/basic/main
+         "common.rkt")

 (define convert-to-json
  (match-lambda
@ -41,13 +42,9 @@
   [x
    (error 'convert-to-json-key "~e" x)]))

-(module+ main
-  (require "common.rkt")
-
-  (define pkg-list
-    (map path->string (directory-list pkgs-path)))
-  (define pkg-ht
-    (make-hash))
+(define (generate-static)
+  (define pkg-list (package-list))
+  (define pkg-ht (make-hash))

  (for ([pkg-name (in-list pkg-list)])
    (define ht (file->value (build-path pkgs-path pkg-name)))
@ -141,7 +138,7 @@
           (struct-copy
            url pkg-url
            [scheme "http"]
-            [path (list user repo (path/param "tree" empty) 
+            [path (list user repo (path/param "tree" empty)
                        (path/param "master" empty))]))]
         [_
          pkg-url-str])]
@ -255,3 +252,13 @@
  (cache "/pkgs-all" "pkgs-all")
  (for ([p (in-list pkg-list)])
    (cache (format "/pkg/~a" p) (format "pkg/~a" p))))
+
+(module+ main
+  (require racket/cmdline)
+
+  (command-line
+   #:program "static"
+   #:args pkgs
+   ;; FUTURE make this more efficient
+   (generate-static)
+   (run-s3! pkgs)))
--- a/pkgs/plt-services/meta/pkg-index/official/update.rkt
+++ b/pkgs/plt-services/meta/pkg-index/official/update.rkt
@ -0,0 +1,89 @@
+#lang racket/base
+(require racket/list
+         racket/function
+         pkg/util
+         racket/package
+         (prefix-in pkg: pkg/lib)
+         "common.rkt")
+
+(define (update-all)
+  (update-checksums #f (package-list)))
+(define (update-pkgs pkgs)
+  (update-checksums #t pkgs))
+
+(define (update-checksums force? pkgs)
+  (for-each (curry update-checksum force?) pkgs))
+
+(define (update-checksum force? pkg-name)
+  (with-handlers
+      ([exn:fail?
+        (λ (x)
+          (define i (package-info pkg-name))
+          (package-info-set! 
+           pkg-name 
+           (hash-set i 'checksum-error (exn-message x))))])
+    (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)))
+      (package-begin
+       (define* i
+         (hash-set i 'checksum
+                   (or new-checksum
+                       old-checksum)))
+       (define* i
+         (hash-set i 'last-checked now))
+       (define* i
+         (hash-update i 'versions
+                      (λ (v-ht)
+                        (for/hash ([(v vi) (in-hash v-ht)])
+                          (define old-checksum (hash-ref vi 'checksum ""))
+                          (define new-checksum
+                            (package-url->checksum
+                             (hash-ref vi 'source)))
+                          (values v
+                                  (hash-set vi 'checksum
+                                            (or new-checksum
+                                                old-checksum)))))
+                      hash))
+       (define* i
+         (if (and new-checksum (equal? new-checksum old-checksum)
+                  ;; update if 'modules was not present:
+                  (hash-ref i 'modules #f))
+           i
+           (hash-set (update-from-content i) 'last-updated now)))
+       (define* i
+         (hash-set i 'checksum-error #f))
+       (package-info-set! pkg-name i)))))
+
+(define (update-from-content i)
+  (define-values (checksum module-paths dependencies)
+    (pkg:get-pkg-content (pkg:pkg-desc (hash-ref i 'source)
+                                       #f
+                                       #f
+                                       (hash-ref i 'checksum)
+                                       #f)))
+  (package-begin
+   (define* i (hash-set i 'modules module-paths))
+   (define* i (hash-set i 'dependencies dependencies))
+   i))
+
+(module+ main
+  (require racket/cmdline)
+  (command-line
+   #:program "update"
+   #:args pkgs
+   (cond
+     [(empty? pkgs)
+      (update-all)
+      (run-static! empty)]
+     [else
+      (update-pkgs pkgs)
+      (run-static! pkgs)])))