dynamic server in place
This commit is contained in:
parent
1fdc8e6c76
commit
975d06db7f
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
20
pkgs/plt-services/meta/pkg-index/official/s3.rkt
Normal file
20
pkgs/plt-services/meta/pkg-index/official/s3.rkt
Normal 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)])))
|
|
@ -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)))
|
||||
|
|
89
pkgs/plt-services/meta/pkg-index/official/update.rkt
Normal file
89
pkgs/plt-services/meta/pkg-index/official/update.rkt
Normal 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)])))
|
Loading…
Reference in New Issue
Block a user