dynamic server in place

This commit is contained in:
Jay McCarthy 2013-10-11 13:06:03 -06:00
parent 1fdc8e6c76
commit 975d06db7f
6 changed files with 371 additions and 108 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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