Release Planet 2 (beta)
This was developed in a different repository, so the history will be archived there: https://github.com/jeapostrophe/galaxy
This commit is contained in:
Jay McCarthy
parent
5589bcb278
commit
fae660b0e4
44
collects/meta/planet2-index/basic/main.rkt
Normal file
44
collects/meta/planet2-index/basic/main.rkt
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
#lang racket/base
|
||||
(require racket/list
|
||||
racket/contract
|
||||
web-server/http
|
||||
web-server/dispatch)
|
||||
|
||||
(define (response/sexpr v)
|
||||
(response 200 #"Okay" (current-seconds)
|
||||
#"text/s-expr" empty
|
||||
(λ (op) (write v op))))
|
||||
|
||||
(define (planet2-index/basic get-pkgs pkg-name->info)
|
||||
(define (write-info req pkg-name)
|
||||
(response/sexpr (pkg-name->info pkg-name)))
|
||||
(define (display-info req pkg-name)
|
||||
(define info (pkg-name->info pkg-name))
|
||||
(response/xexpr
|
||||
`(html
|
||||
(body
|
||||
(h1 ,pkg-name)
|
||||
(p (a ([href ,(hash-ref info 'source)]) ,(hash-ref info 'source)))
|
||||
(p ,(hash-ref info 'checksum))))))
|
||||
(define (list-pkgs req)
|
||||
(response/xexpr
|
||||
`(html
|
||||
(body
|
||||
(table
|
||||
(tr (th "Package"))
|
||||
,@(for/list ([n (in-list (sort (get-pkgs) string<=?))])
|
||||
`(tr
|
||||
(td (a ([href ,(get-url display-info n)]) ,n)))))))))
|
||||
(define-values (dispatch get-url)
|
||||
(dispatch-rules
|
||||
[() list-pkgs]
|
||||
[("") list-pkgs]
|
||||
[("pkg" (string-arg) "display") display-info]
|
||||
[("pkg" (string-arg)) write-info]))
|
||||
dispatch)
|
||||
|
||||
(provide/contract
|
||||
[planet2-index/basic
|
||||
(-> (-> (listof string?))
|
||||
(-> string? (hash/c symbol? any/c))
|
||||
(-> request? response?))])
|
||||
1
collects/meta/planet2-index/official/.gitignore
vendored
Normal file
1
collects/meta/planet2-index/official/.gitignore
vendored
Normal file
|
|
@ -0,0 +1 @@
|
|||
/root
|
||||
52
collects/meta/planet2-index/official/gravatar.rkt
Normal file
52
collects/meta/planet2-index/official/gravatar.rkt
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
#lang racket/base
|
||||
(require racket/string
|
||||
racket/contract
|
||||
xml
|
||||
xml/path
|
||||
racket/port
|
||||
net/url
|
||||
file/md5
|
||||
planet2/util)
|
||||
|
||||
(define (gravatar-hash email)
|
||||
(bytes->string/utf-8
|
||||
(md5
|
||||
(string-downcase
|
||||
(string-trim email)))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (gravatar-hash "MyEmailAddress@example.com ")
|
||||
"0bc83cb571cd1c50ba6f3e8a78ef1346")
|
||||
(check-equal? (gravatar-hash "MyEmailAddress@example.com ")
|
||||
(gravatar-hash " MyEmailAddress@example.com ")))
|
||||
|
||||
(define (gravatar-image-url email)
|
||||
(format "https://secure.gravatar.com/avatar/~a.jpg?d=retro"
|
||||
(gravatar-hash email)))
|
||||
|
||||
(define (gravatar-profile email)
|
||||
(parameterize ([collapse-whitespace #t]
|
||||
[xexpr-drop-empty-attributes #t])
|
||||
(call/input-url+200
|
||||
(string->url
|
||||
(format "http://www.gravatar.com/~a.xml"
|
||||
(gravatar-hash email)))
|
||||
(compose string->xexpr port->string))))
|
||||
|
||||
(define (gravatar-display-name email)
|
||||
(define profile (gravatar-profile email))
|
||||
(and profile
|
||||
(se-path* '(response entry displayName)
|
||||
profile)))
|
||||
|
||||
(module+ test
|
||||
(check-equal? (gravatar-display-name "jay.mccarthy@gmail.com")
|
||||
"Jay McCarthy")
|
||||
(check-equal? (gravatar-display-name "jay@racket-lang.org")
|
||||
#f))
|
||||
|
||||
(provide/contract
|
||||
[gravatar-display-name (-> string? (or/c string? false/c))]
|
||||
[gravatar-profile (-> string? xexpr?)]
|
||||
[gravatar-image-url (-> string? string?)])
|
||||
652
collects/meta/planet2-index/official/main.rkt
Normal file
652
collects/meta/planet2-index/official/main.rkt
Normal file
|
|
@ -0,0 +1,652 @@
|
|||
#lang racket/base
|
||||
(require web-server/http
|
||||
web-server/servlet-env
|
||||
racket/file
|
||||
racket/function
|
||||
racket/runtime-path
|
||||
web-server/dispatch
|
||||
planet2/util
|
||||
racket/match
|
||||
racket/package
|
||||
racket/system
|
||||
racket/date
|
||||
racket/string
|
||||
web-server/servlet
|
||||
web-server/formlets
|
||||
racket/bool
|
||||
racket/list
|
||||
net/sendmail
|
||||
meta/planet2-index/basic/main
|
||||
web-server/http/id-cookie
|
||||
file/sha1)
|
||||
|
||||
(define-syntax-rule (while cond e ...)
|
||||
(let loop ()
|
||||
(when cond
|
||||
e ...
|
||||
(loop))))
|
||||
|
||||
(define (snoc l x)
|
||||
(append l (list x)))
|
||||
|
||||
(define (salty str)
|
||||
(sha1 (open-input-string str)))
|
||||
|
||||
(define-runtime-path src ".")
|
||||
|
||||
(define-runtime-path root "root")
|
||||
(make-directory* root)
|
||||
(define secret-key
|
||||
(make-secret-salt/file
|
||||
(build-path root "secret.key")))
|
||||
(define users-path (build-path root "users"))
|
||||
(make-directory* users-path)
|
||||
|
||||
(module+ main
|
||||
(define users-old-path (build-path root "users.old"))
|
||||
(when (directory-exists? users-old-path)
|
||||
(for ([u (in-list (directory-list users-old-path))])
|
||||
(define uop (build-path users-old-path u))
|
||||
(display-to-file (salty (file->string uop))
|
||||
(build-path users-path u))
|
||||
(delete-file uop))
|
||||
(delete-directory users-old-path)))
|
||||
|
||||
(define pkgs-path (build-path root "pkgs"))
|
||||
(make-directory* pkgs-path)
|
||||
|
||||
(define id-cookie-name "id")
|
||||
|
||||
;; 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)
|
||||
(file->value (build-path pkgs-path pkg-name)))
|
||||
(define (package-info-set! pkg-name i)
|
||||
(write-to-file i (build-path pkgs-path pkg-name)
|
||||
#:exists 'replace))
|
||||
|
||||
(define (package-ref pkg-info key)
|
||||
(hash-ref pkg-info key
|
||||
(λ ()
|
||||
(match key
|
||||
[(or 'author 'checksum 'source)
|
||||
(error 'planet2 "Package ~e is missing a required field: ~e"
|
||||
(hash-ref pkg-info 'name) key)]
|
||||
['tags
|
||||
empty]
|
||||
[(or 'last-checked 'last-edit 'last-updated)
|
||||
-inf.0]))))
|
||||
|
||||
(define-values (main-dispatch main-url)
|
||||
(dispatch-rules
|
||||
[() page/main]
|
||||
[("") page/main]
|
||||
[("info" (string-arg)) page/info]
|
||||
[("search" (string-arg) ...) page/search]
|
||||
[("query" "search" (string-arg) ...) page/search/query]
|
||||
[("account" "login") page/login]
|
||||
[("account" "logout") page/logout]
|
||||
[("manage") page/manage]
|
||||
[("manage" "update") page/manage/update]
|
||||
[("manage" "edit" (string-arg)) page/manage/edit]
|
||||
[("manage" "upload") page/manage/upload]
|
||||
[else basic-start]))
|
||||
|
||||
(define (page/main req)
|
||||
(redirect-to (main-url page/search empty)))
|
||||
|
||||
(define (format-time s)
|
||||
(if s
|
||||
(parameterize ([date-display-format 'rfc2822])
|
||||
(date->string (seconds->date s #f) #t))
|
||||
""))
|
||||
|
||||
(define (package-url->useful-url pkg-url-str)
|
||||
(define pkg-url
|
||||
(string->url pkg-url-str))
|
||||
(match (url-scheme pkg-url)
|
||||
["github"
|
||||
(match-define (list* user repo branch path)
|
||||
(url-path pkg-url))
|
||||
(url->string
|
||||
(struct-copy url pkg-url
|
||||
[scheme "http"]
|
||||
[path (list* user repo (path/param "tree" empty) branch path)]))]
|
||||
[_
|
||||
pkg-url-str]))
|
||||
|
||||
(define (page/info req pkg-name)
|
||||
(page/info-like
|
||||
(list (cons "Packages" (main-url page/main))
|
||||
pkg-name)
|
||||
#f
|
||||
(λ (embed/url t)
|
||||
(main-url page/search (list t)))
|
||||
req pkg-name))
|
||||
|
||||
(define (search-term-eval pkg-name info term)
|
||||
(match term
|
||||
[(regexp #rx"^author:(.*?)$" (list _ author))
|
||||
(equal? author (package-ref info 'author))]
|
||||
[_
|
||||
(define term-rx (regexp-quote term))
|
||||
(for/or ([tag (list* pkg-name (package-ref info 'tags))])
|
||||
(regexp-match? term-rx tag))]))
|
||||
|
||||
(define breadcrumb->string
|
||||
(match-lambda
|
||||
[(? string? label)
|
||||
label]
|
||||
[(cons (? string? label)
|
||||
(? string? url))
|
||||
label]))
|
||||
(define breadcrumb->xexpr
|
||||
(match-lambda
|
||||
[(? string? label)
|
||||
`(span ,label)]
|
||||
[(cons (? string? label)
|
||||
(? string? url))
|
||||
`(span (a ([href ,url]) ,label))]))
|
||||
|
||||
(define (template req #:breadcrumb bc . xexpr-forest)
|
||||
(send/back
|
||||
(response/xexpr
|
||||
`(html
|
||||
(head
|
||||
(script ([src "/sorttable.js"]) " ")
|
||||
(link ([rel "stylesheet"]
|
||||
[type "text/css"]
|
||||
[href "/style.css"]))
|
||||
(title ,@(add-between (map breadcrumb->string bc) " > ")))
|
||||
(body
|
||||
(div ([class "breadcrumb"])
|
||||
,@(add-between (map breadcrumb->xexpr bc) " > ")
|
||||
,(cond
|
||||
[(current-user req #f)
|
||||
=> (λ (user)
|
||||
`(span ([id "logout"])
|
||||
,user
|
||||
" | "
|
||||
(a ([href ,(main-url page/logout)]) "logout")))]
|
||||
[else
|
||||
""]))
|
||||
,@xexpr-forest
|
||||
(div ([id "footer"])
|
||||
"Powered by "
|
||||
(a ([href "http://racket-lang.org/"]) "Racket") ". "
|
||||
"Written by "
|
||||
(a ([href "http://faculty.cs.byu.edu/~jay"]) "Jay McCarthy")
|
||||
"."))))))
|
||||
|
||||
(define (page/logout req)
|
||||
(redirect-to
|
||||
(main-url page/main)
|
||||
#:headers
|
||||
(list (cookie->header (logout-id-cookie id-cookie-name)))))
|
||||
|
||||
(define (package-list/search ts)
|
||||
(filter
|
||||
(λ (p)
|
||||
(define i (package-info p))
|
||||
(for/and ([t (in-list ts)])
|
||||
(search-term-eval p i t)))
|
||||
(package-list)))
|
||||
|
||||
(define search-formlet
|
||||
(formlet
|
||||
,{(to-string (required (text-input)))
|
||||
. => . new-terms}
|
||||
(string-split new-terms)))
|
||||
|
||||
(define (page/search/query req old-terms)
|
||||
(define terms (formlet-process search-formlet req))
|
||||
(redirect-to (main-url page/search (append old-terms terms))))
|
||||
|
||||
(define (page/search req terms)
|
||||
(define pkgs (package-list/search terms))
|
||||
(template
|
||||
req
|
||||
#:breadcrumb
|
||||
(list* (cons "Packages" (main-url page/main))
|
||||
"Search"
|
||||
(for/list ([t (in-list terms)])
|
||||
(cons t (main-url page/search (remove* (list t) terms)))))
|
||||
`(div ([id "menu"])
|
||||
(form ([action ,(main-url page/search/query terms)])
|
||||
(span ([class "menu_option"])
|
||||
,@(formlet-display search-formlet)
|
||||
(input ([type "submit"] [value "Search"])))
|
||||
(span ([class "menu_option"])
|
||||
(a ([href ,(main-url page/manage)])
|
||||
,(if (current-user req #f)
|
||||
"Manage Your Packages"
|
||||
"Contribute a Package")))))
|
||||
(package-table page/info pkgs #:terms terms)))
|
||||
|
||||
(define (page/login req)
|
||||
(login req)
|
||||
(redirect-to (main-url page/main)))
|
||||
|
||||
(define (login req [last-error #f])
|
||||
(define login-formlet
|
||||
(formlet
|
||||
(table
|
||||
(tr (td "Email Address:")
|
||||
(td ,{(to-string (required (text-input))) . => . email}))
|
||||
(tr (td "Password:")
|
||||
(td ,{(to-string (required (password-input))) . => . passwd})))
|
||||
(values email passwd)))
|
||||
(define log-req
|
||||
(send/suspend
|
||||
(λ (k-url)
|
||||
(template
|
||||
req
|
||||
#:breadcrumb
|
||||
(list "Login")
|
||||
`(div ([id "login"])
|
||||
(form ([action ,k-url] [method "post"])
|
||||
,@(formlet-display login-formlet)
|
||||
(input ([type "submit"] [value "Log in"])))
|
||||
(p "If you enter an unclaimed email address, then an account will be created.")
|
||||
(p "Passwords are stored in the delicious SHA1 format, but transfered as plain-text over the HTTPS connection.")
|
||||
,@(if last-error
|
||||
`((h1 ([class "error"]) ,last-error))
|
||||
'()))))))
|
||||
(define-values
|
||||
(email passwd)
|
||||
(formlet-process login-formlet log-req))
|
||||
|
||||
(define (authenticated!)
|
||||
(redirect/get
|
||||
#:headers
|
||||
(list
|
||||
(cookie->header
|
||||
(make-id-cookie id-cookie-name secret-key email)))))
|
||||
|
||||
(when (regexp-match (regexp-quote "/") email)
|
||||
(send/back
|
||||
(template
|
||||
log-req
|
||||
#:breadcrumb
|
||||
(list "Login" "Account Registration Error")
|
||||
`(p "Email addresses may not contain / on Planet2:"
|
||||
(tt ,email)))))
|
||||
|
||||
(define password-path (build-path users-path email))
|
||||
|
||||
(cond
|
||||
[(not (file-exists? password-path))
|
||||
(send/suspend
|
||||
(λ (k-url)
|
||||
(send-mail-message
|
||||
"planet2@racket-lang.org"
|
||||
"Account confirmation for Planet2"
|
||||
(list email)
|
||||
empty empty
|
||||
(list "Someone tried to register your email address for an account on Planet2. If you want to authorize this registration and log in, please click the following link:"
|
||||
""
|
||||
(format "https://plt-etc.byu.edu:9004~a" k-url)
|
||||
""
|
||||
"This link will expire, so if it is not available, you'll have to try to register again."))
|
||||
(template
|
||||
log-req
|
||||
#:breadcrumb
|
||||
(list "Login" "Account Registration")
|
||||
`(p "An email has been sent to "
|
||||
(tt ,email)
|
||||
", please click the link it contains to register and log in."))))
|
||||
(display-to-file (salty passwd) password-path)
|
||||
(authenticated!)]
|
||||
[(not (bytes=? (string->bytes/utf-8 (salty passwd))
|
||||
(file->bytes password-path)))
|
||||
(login req (format "The given password is incorrect for email address ~e"
|
||||
email))]
|
||||
[else
|
||||
(authenticated!)]))
|
||||
|
||||
(define (current-user req required?)
|
||||
(define id
|
||||
(request-id-cookie id-cookie-name secret-key req))
|
||||
(cond
|
||||
[id
|
||||
id]
|
||||
[required?
|
||||
(current-user (login req) required?)]
|
||||
[else
|
||||
#f]))
|
||||
|
||||
(define (package-list/mine req)
|
||||
(define u (current-user req #t))
|
||||
(package-list/search (list (format "author:~a" u))))
|
||||
|
||||
(define (package-table page/package pkgs
|
||||
#:terms [terms empty])
|
||||
`(table
|
||||
([class "packages sortable"])
|
||||
(thead
|
||||
(tr (th "Package") (th "Author") (th "Description") (th "Tags")))
|
||||
(tbody
|
||||
,@(for/list ([p (in-list pkgs)])
|
||||
(define i (package-info p))
|
||||
(define author (package-ref i 'author))
|
||||
`(tr
|
||||
([class ,(if (< (- (current-seconds) (* 2 24 60 60))
|
||||
(package-ref i 'last-updated))
|
||||
"recent"
|
||||
"")])
|
||||
(td (a ([href ,(main-url page/package p)])
|
||||
,p))
|
||||
(td (a ([href ,(main-url page/search
|
||||
(snoc terms
|
||||
(format "author:~a" author)))])
|
||||
,author))
|
||||
(td ,(package-ref i 'description))
|
||||
(td ,@(for/list ([t (in-list (package-ref i 'tags))])
|
||||
`(span (a ([href ,(main-url page/search (snoc terms t))])
|
||||
,t)
|
||||
" "))))))))
|
||||
|
||||
(define (page/manage req)
|
||||
(define pkgs (package-list/mine req))
|
||||
(template
|
||||
req
|
||||
#:breadcrumb
|
||||
(list (cons "Packages" (main-url page/main))
|
||||
(current-user req #t)
|
||||
"Manage")
|
||||
`(div ([id "menu"])
|
||||
(span ([class "menu_option"])
|
||||
(a ([href ,(main-url page/manage/upload)])
|
||||
"Upload a new package"))
|
||||
(span ([class "menu_option"])
|
||||
(a ([href ,(main-url page/manage/update)])
|
||||
"Update checksums")))
|
||||
(package-table page/manage/edit pkgs)))
|
||||
|
||||
(define (page/manage/upload req)
|
||||
(page/manage/edit req #f))
|
||||
|
||||
(define (request-binding/string req id [fail? #t])
|
||||
(define res
|
||||
(bindings-assq (string->bytes/utf-8 id)
|
||||
(request-bindings/raw req)))
|
||||
(cond
|
||||
[res
|
||||
(bytes->string/utf-8
|
||||
(binding:form-value
|
||||
res))]
|
||||
[fail?
|
||||
(error 'planet2 "Missing field ~e" id)]
|
||||
[else
|
||||
#f]))
|
||||
|
||||
(define (page/manage/edit req pkg)
|
||||
(define (edit-details pkg-req)
|
||||
(define new-pkg (request-binding/string pkg-req "name"))
|
||||
(when (string=? new-pkg "")
|
||||
(error 'planet2 "Name must not be empty: ~e" new-pkg))
|
||||
(define new-source (request-binding/string pkg-req "source"))
|
||||
(when (string=? new-source "")
|
||||
(error 'planet2 "Source must not be empty: ~e" new-source))
|
||||
(define new-desc (request-binding/string pkg-req "description"))
|
||||
|
||||
(when (regexp-match #rx"[^a-zA-Z0-9_\\-]" new-pkg)
|
||||
(error 'planet2
|
||||
"Illegal character in name; only alphanumerics, plus '-' and '_' allowed: ~e"
|
||||
new-pkg))
|
||||
|
||||
(when (and (not (equal? pkg new-pkg))
|
||||
(or (regexp-match #rx"^[Pp][Ll][Tt]" new-pkg)
|
||||
(regexp-match #rx"^[Pp][Ll][Aa][Nn][Ee][Tt]" new-pkg)
|
||||
(regexp-match #rx"^[Rr][Aa][Cc][Kk][Ee][Tt]" new-pkg)))
|
||||
(error 'planet2
|
||||
"Packages that start with plt, planet, and racket are not allowed without special permission. Please create your package with a different name, then email curation to request a rename: ~e"
|
||||
new-pkg))
|
||||
|
||||
(when (and (package-exists? new-pkg)
|
||||
(not (equal? (package-ref (package-info new-pkg) 'author)
|
||||
(current-user pkg-req #t))))
|
||||
(error 'planet2
|
||||
"Packages may only be modified by their authors: ~e"
|
||||
new-pkg))
|
||||
|
||||
(package-begin
|
||||
(define* i
|
||||
(if pkg
|
||||
(package-info pkg)
|
||||
(hasheq)))
|
||||
|
||||
(define* i
|
||||
(hash-set i 'name new-pkg))
|
||||
(define* i
|
||||
(hash-set i 'source new-source))
|
||||
(define* i
|
||||
(hash-set i 'author (current-user pkg-req #t)))
|
||||
(define* i
|
||||
(hash-set i 'description new-desc))
|
||||
(define* i
|
||||
(hash-set i 'last-edit (current-seconds)))
|
||||
(define* i
|
||||
(if pkg
|
||||
i
|
||||
(hash-set i 'checksum "")))
|
||||
|
||||
(package-info-set! new-pkg i))
|
||||
|
||||
(unless (or (not pkg) (equal? new-pkg pkg))
|
||||
(package-remove! pkg))
|
||||
|
||||
(update-checksum new-pkg)
|
||||
|
||||
(define new-tag
|
||||
(request-binding/string pkg-req "tag" #f))
|
||||
(add-tag! new-pkg new-tag)
|
||||
|
||||
(redirect-to
|
||||
(main-url page/manage/edit new-pkg)))
|
||||
|
||||
(page/info-like
|
||||
(list* (cons "Packages" (main-url page/main))
|
||||
(current-user req #t)
|
||||
(cons "Manage" (main-url page/manage))
|
||||
(if pkg
|
||||
(list pkg
|
||||
"Edit")
|
||||
(list "Upload")))
|
||||
edit-details
|
||||
(λ (embed/url t)
|
||||
(embed/url (remove-tag-handler pkg t)))
|
||||
req pkg))
|
||||
|
||||
|
||||
(define (tags-normalize ts)
|
||||
(remove-duplicates (sort ts string-ci<?)))
|
||||
|
||||
(define ((remove-tag-handler pkg t) req)
|
||||
(define i (package-info pkg))
|
||||
(package-info-set!
|
||||
pkg
|
||||
(hash-update i 'tags
|
||||
(λ (old)
|
||||
(tags-normalize
|
||||
(remove t
|
||||
old)))
|
||||
empty))
|
||||
(redirect-to
|
||||
(main-url page/manage/edit pkg)))
|
||||
|
||||
(define ((add-tag-handler pkg-name) req)
|
||||
(define new-tag
|
||||
(request-binding/string req "tag" #f))
|
||||
(add-tag! pkg-name new-tag)
|
||||
(redirect-to (main-url page/info pkg-name)))
|
||||
|
||||
(define (add-tag! pkg-name new-tag)
|
||||
(when (and new-tag
|
||||
(not (string=? new-tag "")))
|
||||
(define i (package-info pkg-name))
|
||||
(when (regexp-match #rx"[^a-zA-Z0-9]" new-tag)
|
||||
(error 'planet2
|
||||
"Illegal character in tag; only alphanumerics allowed: ~e"
|
||||
new-tag))
|
||||
(package-info-set!
|
||||
pkg-name
|
||||
(hash-update i 'tags
|
||||
(λ (old)
|
||||
(tags-normalize
|
||||
(cons new-tag
|
||||
old)))
|
||||
empty))))
|
||||
|
||||
(define (page/info-like bc edit-details tag-url req pkg-name)
|
||||
(define form-handler
|
||||
(or edit-details
|
||||
(add-tag-handler pkg-name)))
|
||||
|
||||
(send/suspend/dispatch
|
||||
(λ (embed/url)
|
||||
(define i (and pkg-name (package-info pkg-name)))
|
||||
(define (package-ref* i id def)
|
||||
(if i
|
||||
(package-ref i id)
|
||||
def))
|
||||
(define author (package-ref* i 'author ""))
|
||||
(define the-table
|
||||
`(table
|
||||
(tr
|
||||
(td "Name")
|
||||
(td ,(if edit-details
|
||||
`(input ([name "name"]
|
||||
[type "text"]
|
||||
[value ,(or pkg-name "")]))
|
||||
`(span ,pkg-name
|
||||
(br)
|
||||
(span ([class "tooltip"])
|
||||
(a ([href "javascript:0;"])
|
||||
"(install instructions)")
|
||||
(span
|
||||
"Install this package with:" (br) (br)
|
||||
(tt "raco pkg install " ,pkg-name) (br) (br)
|
||||
"or, by evaluating:" (br)
|
||||
(pre
|
||||
,(format "~a\n~a\n~a\n"
|
||||
"#lang racket"
|
||||
"(require planet2)"
|
||||
(format "(install \"~a\")"
|
||||
pkg-name)))))))))
|
||||
(tr
|
||||
(td "Author")
|
||||
(td (a ([href ,(main-url page/search
|
||||
(list (format "author:~a" author)))])
|
||||
,author)))
|
||||
(tr
|
||||
(td "Source")
|
||||
(td
|
||||
,(if edit-details
|
||||
`(span (input ([name "source"]
|
||||
[type "text"]
|
||||
[value ,(package-ref* i 'source "")]))
|
||||
" (" (a ([href "XXX"]) "details") ")")
|
||||
`(a ([href
|
||||
,(package-url->useful-url (package-ref i 'source))])
|
||||
,(package-ref i 'source)))))
|
||||
(tr
|
||||
(td "Checksum")
|
||||
(td ,(package-ref* i 'checksum "")))
|
||||
(tr
|
||||
(td "Last Update")
|
||||
(td ,(format-time (package-ref* i 'last-updated #f))))
|
||||
(tr
|
||||
(td "Last Checked")
|
||||
(td ,(format-time (package-ref* i 'last-checked #f))))
|
||||
(tr
|
||||
(td "Description")
|
||||
(td ,(if edit-details
|
||||
`(textarea ([name "description"])
|
||||
,(package-ref* i 'description ""))
|
||||
(package-ref i 'description))))
|
||||
(tr
|
||||
(td "Last Edit")
|
||||
(td ,(format-time (package-ref* i 'last-edit #f))))
|
||||
(tr
|
||||
(td "Tags")
|
||||
(td
|
||||
(ul
|
||||
,@(for/list ([t (in-list (package-ref* i 'tags empty))])
|
||||
`(li (a ([href ,(tag-url embed/url t)])
|
||||
,t)))
|
||||
,(if pkg-name
|
||||
`(li (input ([name "tag"] [type "text"])))
|
||||
""))))
|
||||
`(tr (td ([class "submit"] [colspan "2"])
|
||||
(input ([type "submit"] [value "Submit"]))))))
|
||||
(template
|
||||
req
|
||||
#:breadcrumb
|
||||
bc
|
||||
`(div
|
||||
([class "package"])
|
||||
(form ([action ,(embed/url form-handler)] [method "post"])
|
||||
,the-table))))))
|
||||
|
||||
(define (page/manage/update req)
|
||||
(update-checksums
|
||||
(package-list/mine req))
|
||||
(redirect-to (main-url page/manage)))
|
||||
|
||||
(define (update-checksums pkgs)
|
||||
(for-each update-checksum pkgs))
|
||||
|
||||
(define (update-checksum 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)))
|
||||
(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))
|
||||
|
||||
(define (go port)
|
||||
(printf "launching on port ~a\n" port)
|
||||
(thread
|
||||
(λ ()
|
||||
(while true
|
||||
(printf "updating checksums\n")
|
||||
(update-checksums (package-list))
|
||||
;; update once per day based on whenever the server started
|
||||
(sleep (* 24 60 60)))))
|
||||
(serve/servlet
|
||||
main-dispatch
|
||||
#:command-line? #t
|
||||
#:listen-ip #f
|
||||
#:ssl? #t
|
||||
#:ssl-cert (build-path root "server-cert.pem")
|
||||
#:ssl-key (build-path root "private-key.pem")
|
||||
#:extra-files-paths
|
||||
(list (build-path src "static")
|
||||
(build-path root "static"))
|
||||
#:servlet-regexp #rx""
|
||||
#:port port))
|
||||
|
||||
(module+ main
|
||||
(go 9004))
|
||||
515
collects/meta/planet2-index/official/static/sorttable.js
Normal file
515
collects/meta/planet2-index/official/static/sorttable.js
Normal file
|
|
@ -0,0 +1,515 @@
|
|||
function TocviewToggle(glyphid, id) {
|
||||
var glyph = document.getElementById(glyphid);
|
||||
var s = document.getElementById(id).style;
|
||||
var expand = s.display == "none";
|
||||
s.display = expand ? "block" : "none";
|
||||
glyph.innerHTML = expand ? "▼" : "►";
|
||||
}
|
||||
|
||||
function ToggleOn(id) {
|
||||
var s = document.getElementById(id).style;
|
||||
var li = document.getElementById("li" + id);
|
||||
s.display = "block";
|
||||
li.setAttribute("class", "tab-selected");
|
||||
}
|
||||
function ToggleOff(id) {
|
||||
var s = document.getElementById(id).style;
|
||||
var li = document.getElementById("li" + id);
|
||||
s.display = "none";
|
||||
li.setAttribute("class", "");
|
||||
}
|
||||
|
||||
/*
|
||||
SortTable
|
||||
version 2
|
||||
7th April 2007
|
||||
Stuart Langridge, http://www.kryogenix.org/code/browser/sorttable/
|
||||
|
||||
Instructions:
|
||||
Download this file
|
||||
Add <script src="sorttable.js"></script> to your HTML
|
||||
Add class="sortable" to any table you'd like to make sortable
|
||||
Click on the headers to sort
|
||||
|
||||
Thanks to many, many people for contributions and suggestions.
|
||||
Licenced as X11: http://www.kryogenix.org/code/browser/licence.html
|
||||
This basically means: do what you want with it.
|
||||
*/
|
||||
|
||||
|
||||
var stIsIE = /*@cc_on!@*/false;
|
||||
|
||||
sorttable = {
|
||||
init: function() {
|
||||
// quit if this function has already been called
|
||||
if (arguments.callee.done) return;
|
||||
// flag this function so we don't do the same thing twice
|
||||
arguments.callee.done = true;
|
||||
// kill the timer
|
||||
if (_timer) clearInterval(_timer);
|
||||
|
||||
if (!document.createElement || !document.getElementsByTagName) return;
|
||||
|
||||
sorttable.DATE_RE = /^(\d\d?)[\/\.-](\d\d?)[\/\.-]((\d\d)?\d\d)$/;
|
||||
|
||||
forEach(document.getElementsByTagName('table'), function(table) {
|
||||
if (table.className.search(/\bsortable\b/) != -1) {
|
||||
sorttable.makeSortable(table);
|
||||
}
|
||||
});
|
||||
|
||||
},
|
||||
|
||||
makeSortable: function(table) {
|
||||
if (table.getElementsByTagName('thead').length == 0) {
|
||||
// table doesn't have a tHead. Since it should have, create one and
|
||||
// put the first table row in it.
|
||||
the = document.createElement('thead');
|
||||
the.appendChild(table.rows[0]);
|
||||
table.insertBefore(the,table.firstChild);
|
||||
}
|
||||
// Safari doesn't support table.tHead, sigh
|
||||
if (table.tHead == null) table.tHead = table.getElementsByTagName('thead')[0];
|
||||
|
||||
if (table.tHead.rows.length != 1) return; // can't cope with two header rows
|
||||
|
||||
// Sorttable v1 put rows with a class of "sortbottom" at the bottom (as
|
||||
// "total" rows, for example). This is B&R, since what you're supposed
|
||||
// to do is put them in a tfoot. So, if there are sortbottom rows,
|
||||
// for backwards compatibility, move them to tfoot (creating it if needed).
|
||||
sortbottomrows = [];
|
||||
for (var i=0; i<table.rows.length; i++) {
|
||||
if (table.rows[i].className.search(/\bsortbottom\b/) != -1) {
|
||||
sortbottomrows[sortbottomrows.length] = table.rows[i];
|
||||
}
|
||||
}
|
||||
if (sortbottomrows) {
|
||||
if (table.tFoot == null) {
|
||||
// table doesn't have a tfoot. Create one.
|
||||
tfo = document.createElement('tfoot');
|
||||
table.appendChild(tfo);
|
||||
}
|
||||
for (var i=0; i<sortbottomrows.length; i++) {
|
||||
tfo.appendChild(sortbottomrows[i]);
|
||||
}
|
||||
delete sortbottomrows;
|
||||
}
|
||||
|
||||
// work through each column and calculate its type
|
||||
headrow = table.tHead.rows[0].cells;
|
||||
for (var i=0; i<headrow.length; i++) {
|
||||
// manually override the type with a sorttable_type attribute
|
||||
if (!headrow[i].className.match(/\bsorttable_nosort\b/)) { // skip this col
|
||||
mtch = headrow[i].className.match(/\bsorttable_([a-z0-9]+)\b/);
|
||||
if (mtch) { override = mtch[1]; }
|
||||
if (mtch && typeof sorttable["sort_"+override] == 'function') {
|
||||
headrow[i].sorttable_sortfunction = sorttable["sort_"+override];
|
||||
} else {
|
||||
headrow[i].sorttable_sortfunction = sorttable.guessType(table,i);
|
||||
}
|
||||
// make it clickable to sort
|
||||
headrow[i].sorttable_columnindex = i;
|
||||
headrow[i].sorttable_tbody = table.tBodies[0];
|
||||
dean_addEvent(headrow[i],"click", function(e) {
|
||||
|
||||
if (this.className.search(/\bsorttable_sorted\b/) != -1) {
|
||||
// if we're already sorted by this column, just
|
||||
// reverse the table, which is quicker
|
||||
sorttable.reverse(this.sorttable_tbody);
|
||||
this.className = this.className.replace('sorttable_sorted',
|
||||
'sorttable_sorted_reverse');
|
||||
this.removeChild(document.getElementById('sorttable_sortfwdind'));
|
||||
sortrevind = document.createElement('span');
|
||||
sortrevind.id = "sorttable_sortrevind";
|
||||
sortrevind.innerHTML = stIsIE ? ' <font face="webdings">5</font>' : ' ▴';
|
||||
this.appendChild(sortrevind);
|
||||
return;
|
||||
}
|
||||
if (this.className.search(/\bsorttable_sorted_reverse\b/) != -1) {
|
||||
// if we're already sorted by this column in reverse, just
|
||||
// re-reverse the table, which is quicker
|
||||
sorttable.reverse(this.sorttable_tbody);
|
||||
this.className = this.className.replace('sorttable_sorted_reverse',
|
||||
'sorttable_sorted');
|
||||
this.removeChild(document.getElementById('sorttable_sortrevind'));
|
||||
sortfwdind = document.createElement('span');
|
||||
sortfwdind.id = "sorttable_sortfwdind";
|
||||
sortfwdind.innerHTML = stIsIE ? ' <font face="webdings">6</font>' : ' ▾';
|
||||
this.appendChild(sortfwdind);
|
||||
return;
|
||||
}
|
||||
|
||||
// remove sorttable_sorted classes
|
||||
theadrow = this.parentNode;
|
||||
forEach(theadrow.childNodes, function(cell) {
|
||||
if (cell.nodeType == 1) { // an element
|
||||
cell.className = cell.className.replace('sorttable_sorted_reverse','');
|
||||
cell.className = cell.className.replace('sorttable_sorted','');
|
||||
}
|
||||
});
|
||||
sortfwdind = document.getElementById('sorttable_sortfwdind');
|
||||
if (sortfwdind) { sortfwdind.parentNode.removeChild(sortfwdind); }
|
||||
sortrevind = document.getElementById('sorttable_sortrevind');
|
||||
if (sortrevind) { sortrevind.parentNode.removeChild(sortrevind); }
|
||||
|
||||
this.className += ' sorttable_sorted';
|
||||
sortfwdind = document.createElement('span');
|
||||
sortfwdind.id = "sorttable_sortfwdind";
|
||||
sortfwdind.innerHTML = stIsIE ? ' <font face="webdings">6</font>' : ' ▾';
|
||||
this.appendChild(sortfwdind);
|
||||
|
||||
// build an array to sort. This is a Schwartzian transform thing,
|
||||
// i.e., we "decorate" each row with the actual sort key,
|
||||
// sort based on the sort keys, and then put the rows back in order
|
||||
// which is a lot faster because you only do getInnerText once per row
|
||||
row_array = [];
|
||||
col = this.sorttable_columnindex;
|
||||
rows = this.sorttable_tbody.rows;
|
||||
for (var j=0; j<rows.length; j++) {
|
||||
row_array[row_array.length] = [sorttable.getInnerText(rows[j].cells[col]), rows[j]];
|
||||
}
|
||||
/* If you want a stable sort, uncomment the following line */
|
||||
//sorttable.shaker_sort(row_array, this.sorttable_sortfunction);
|
||||
/* and comment out this one */
|
||||
row_array.sort(this.sorttable_sortfunction);
|
||||
row_array.reverse();
|
||||
|
||||
tb = this.sorttable_tbody;
|
||||
for (var j=0; j<row_array.length; j++) {
|
||||
tb.appendChild(row_array[j][1]);
|
||||
}
|
||||
|
||||
delete row_array;
|
||||
});
|
||||
}
|
||||
}
|
||||
},
|
||||
|
||||
guessType: function(table, column) {
|
||||
// guess the type of a column based on its first non-blank row
|
||||
sortfn = sorttable.sort_alpha;
|
||||
for (var i=0; i<table.tBodies[0].rows.length; i++) {
|
||||
text = sorttable.getInnerText(table.tBodies[0].rows[i].cells[column]);
|
||||
if (text != '') {
|
||||
if (text.match(/^-?[£$¤]?[\d,.]+%?$/)) {
|
||||
return sorttable.sort_numeric;
|
||||
}
|
||||
// check for a date: dd/mm/yyyy or dd/mm/yy
|
||||
// can have / or . or - as separator
|
||||
// can be mm/dd as well
|
||||
possdate = text.match(sorttable.DATE_RE)
|
||||
if (possdate) {
|
||||
// looks like a date
|
||||
first = parseInt(possdate[1]);
|
||||
second = parseInt(possdate[2]);
|
||||
if (first > 12) {
|
||||
// definitely dd/mm
|
||||
return sorttable.sort_ddmm;
|
||||
} else if (second > 12) {
|
||||
return sorttable.sort_mmdd;
|
||||
} else {
|
||||
// looks like a date, but we can't tell which, so assume
|
||||
// that it's dd/mm (English imperialism!) and keep looking
|
||||
sortfn = sorttable.sort_ddmm;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return sortfn;
|
||||
},
|
||||
|
||||
getInnerText: function(node) {
|
||||
// gets the text we want to use for sorting for a cell.
|
||||
// strips leading and trailing whitespace.
|
||||
// this is *not* a generic getInnerText function; it's special to sorttable.
|
||||
// for example, you can override the cell text with a customkey attribute.
|
||||
// it also gets .value for <input> fields.
|
||||
|
||||
hasInputs = (typeof node.getElementsByTagName == 'function') &&
|
||||
node.getElementsByTagName('input').length;
|
||||
|
||||
if (node.getAttribute("sorttable_customkey") != null) {
|
||||
return node.getAttribute("sorttable_customkey");
|
||||
}
|
||||
else if (typeof node.textContent != 'undefined' && !hasInputs) {
|
||||
return node.textContent.replace(/^\s+|\s+$/g, '');
|
||||
}
|
||||
else if (typeof node.innerText != 'undefined' && !hasInputs) {
|
||||
return node.innerText.replace(/^\s+|\s+$/g, '');
|
||||
}
|
||||
else if (typeof node.text != 'undefined' && !hasInputs) {
|
||||
return node.text.replace(/^\s+|\s+$/g, '');
|
||||
}
|
||||
else {
|
||||
switch (node.nodeType) {
|
||||
case 3:
|
||||
if (node.nodeName.toLowerCase() == 'input') {
|
||||
return node.value.replace(/^\s+|\s+$/g, '');
|
||||
}
|
||||
case 4:
|
||||
return node.nodeValue.replace(/^\s+|\s+$/g, '');
|
||||
break;
|
||||
case 1:
|
||||
case 11:
|
||||
var innerText = '';
|
||||
for (var i = 0; i < node.childNodes.length; i++) {
|
||||
innerText += sorttable.getInnerText(node.childNodes[i]);
|
||||
}
|
||||
return innerText.replace(/^\s+|\s+$/g, '');
|
||||
break;
|
||||
default:
|
||||
return '';
|
||||
}
|
||||
}
|
||||
},
|
||||
|
||||
reverse: function(tbody) {
|
||||
// reverse the rows in a tbody
|
||||
newrows = [];
|
||||
for (var i=0; i<tbody.rows.length; i++) {
|
||||
newrows[newrows.length] = tbody.rows[i];
|
||||
}
|
||||
for (var i=newrows.length-1; i>=0; i--) {
|
||||
tbody.appendChild(newrows[i]);
|
||||
}
|
||||
delete newrows;
|
||||
},
|
||||
|
||||
/* sort functions
|
||||
each sort function takes two parameters, a and b
|
||||
you are comparing a[0] and b[0] */
|
||||
sort_numeric: function(a,b) {
|
||||
aa = parseFloat(a[0].replace(/[^0-9.-]/g,''));
|
||||
if (isNaN(aa)) aa = 0;
|
||||
bb = parseFloat(b[0].replace(/[^0-9.-]/g,''));
|
||||
if (isNaN(bb)) bb = 0;
|
||||
return aa-bb;
|
||||
},
|
||||
sort_alpha: function(a,b) {
|
||||
if (a[0]==b[0]) return 0;
|
||||
if (a[0]<b[0]) return -1;
|
||||
return 1;
|
||||
},
|
||||
sort_ddmm: function(a,b) {
|
||||
mtch = a[0].match(sorttable.DATE_RE);
|
||||
y = mtch[3]; m = mtch[2]; d = mtch[1];
|
||||
if (m.length == 1) m = '0'+m;
|
||||
if (d.length == 1) d = '0'+d;
|
||||
dt1 = y+m+d;
|
||||
mtch = b[0].match(sorttable.DATE_RE);
|
||||
y = mtch[3]; m = mtch[2]; d = mtch[1];
|
||||
if (m.length == 1) m = '0'+m;
|
||||
if (d.length == 1) d = '0'+d;
|
||||
dt2 = y+m+d;
|
||||
if (dt1==dt2) return 0;
|
||||
if (dt1<dt2) return -1;
|
||||
return 1;
|
||||
},
|
||||
sort_mmdd: function(a,b) {
|
||||
mtch = a[0].match(sorttable.DATE_RE);
|
||||
y = mtch[3]; d = mtch[2]; m = mtch[1];
|
||||
if (m.length == 1) m = '0'+m;
|
||||
if (d.length == 1) d = '0'+d;
|
||||
dt1 = y+m+d;
|
||||
mtch = b[0].match(sorttable.DATE_RE);
|
||||
y = mtch[3]; d = mtch[2]; m = mtch[1];
|
||||
if (m.length == 1) m = '0'+m;
|
||||
if (d.length == 1) d = '0'+d;
|
||||
dt2 = y+m+d;
|
||||
if (dt1==dt2) return 0;
|
||||
if (dt1<dt2) return -1;
|
||||
return 1;
|
||||
},
|
||||
|
||||
shaker_sort: function(list, comp_func) {
|
||||
// A stable sort function to allow multi-level sorting of data
|
||||
// see: http://en.wikipedia.org/wiki/Cocktail_sort
|
||||
// thanks to Joseph Nahmias
|
||||
var b = 0;
|
||||
var t = list.length - 1;
|
||||
var swap = true;
|
||||
|
||||
while(swap) {
|
||||
swap = false;
|
||||
for(var i = b; i < t; ++i) {
|
||||
if ( comp_func(list[i], list[i+1]) > 0 ) {
|
||||
var q = list[i]; list[i] = list[i+1]; list[i+1] = q;
|
||||
swap = true;
|
||||
}
|
||||
} // for
|
||||
t--;
|
||||
|
||||
if (!swap) break;
|
||||
|
||||
for(var i = t; i > b; --i) {
|
||||
if ( comp_func(list[i], list[i-1]) < 0 ) {
|
||||
var q = list[i]; list[i] = list[i-1]; list[i-1] = q;
|
||||
swap = true;
|
||||
}
|
||||
} // for
|
||||
b++;
|
||||
|
||||
} // while(swap)
|
||||
}
|
||||
}
|
||||
|
||||
/* ******************************************************************
|
||||
Supporting functions: bundled here to avoid depending on a library
|
||||
****************************************************************** */
|
||||
|
||||
// Dean Edwards/Matthias Miller/John Resig
|
||||
|
||||
/* for Mozilla/Opera9 */
|
||||
if (document.addEventListener) {
|
||||
document.addEventListener("DOMContentLoaded", sorttable.init, false);
|
||||
}
|
||||
|
||||
/* for Internet Explorer */
|
||||
/*@cc_on @*/
|
||||
/*@if (@_win32)
|
||||
document.write("<script id=__ie_onload defer src=javascript:void(0)><\/script>");
|
||||
var script = document.getElementById("__ie_onload");
|
||||
script.onreadystatechange = function() {
|
||||
if (this.readyState == "complete") {
|
||||
sorttable.init(); // call the onload handler
|
||||
}
|
||||
};
|
||||
/*@end @*/
|
||||
|
||||
/* for Safari */
|
||||
if (/WebKit/i.test(navigator.userAgent)) { // sniff
|
||||
var _timer = setInterval(function() {
|
||||
if (/loaded|complete/.test(document.readyState)) {
|
||||
sorttable.init(); // call the onload handler
|
||||
}
|
||||
}, 10);
|
||||
}
|
||||
|
||||
/* for other browsers */
|
||||
window.onload = sorttable.init;
|
||||
|
||||
// written by Dean Edwards, 2005
|
||||
// with input from Tino Zijdel, Matthias Miller, Diego Perini
|
||||
|
||||
// http://dean.edwards.name/weblog/2005/10/add-event/
|
||||
|
||||
function dean_addEvent(element, type, handler) {
|
||||
if (element.addEventListener) {
|
||||
element.addEventListener(type, handler, false);
|
||||
} else {
|
||||
// assign each event handler a unique ID
|
||||
if (!handler.$$guid) handler.$$guid = dean_addEvent.guid++;
|
||||
// create a hash table of event types for the element
|
||||
if (!element.events) element.events = {};
|
||||
// create a hash table of event handlers for each element/event pair
|
||||
var handlers = element.events[type];
|
||||
if (!handlers) {
|
||||
handlers = element.events[type] = {};
|
||||
// store the existing event handler (if there is one)
|
||||
if (element["on" + type]) {
|
||||
handlers[0] = element["on" + type];
|
||||
}
|
||||
}
|
||||
// store the event handler in the hash table
|
||||
handlers[handler.$$guid] = handler;
|
||||
// assign a global event handler to do all the work
|
||||
element["on" + type] = handleEvent;
|
||||
}
|
||||
};
|
||||
// a counter used to create unique IDs
|
||||
dean_addEvent.guid = 1;
|
||||
|
||||
function removeEvent(element, type, handler) {
|
||||
if (element.removeEventListener) {
|
||||
element.removeEventListener(type, handler, false);
|
||||
} else {
|
||||
// delete the event handler from the hash table
|
||||
if (element.events && element.events[type]) {
|
||||
delete element.events[type][handler.$$guid];
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
function handleEvent(event) {
|
||||
var returnValue = true;
|
||||
// grab the event object (IE uses a global event object)
|
||||
event = event || fixEvent(((this.ownerDocument || this.document || this).parentWindow || window).event);
|
||||
// get a reference to the hash table of event handlers
|
||||
var handlers = this.events[event.type];
|
||||
// execute each event handler
|
||||
for (var i in handlers) {
|
||||
this.$$handleEvent = handlers[i];
|
||||
if (this.$$handleEvent(event) === false) {
|
||||
returnValue = false;
|
||||
}
|
||||
}
|
||||
return returnValue;
|
||||
};
|
||||
|
||||
function fixEvent(event) {
|
||||
// add W3C standard event methods
|
||||
event.preventDefault = fixEvent.preventDefault;
|
||||
event.stopPropagation = fixEvent.stopPropagation;
|
||||
return event;
|
||||
};
|
||||
fixEvent.preventDefault = function() {
|
||||
this.returnValue = false;
|
||||
};
|
||||
fixEvent.stopPropagation = function() {
|
||||
this.cancelBubble = true;
|
||||
}
|
||||
|
||||
// Dean's forEach: http://dean.edwards.name/base/forEach.js
|
||||
/*
|
||||
forEach, version 1.0
|
||||
Copyright 2006, Dean Edwards
|
||||
License: http://www.opensource.org/licenses/mit-license.php
|
||||
*/
|
||||
|
||||
// array-like enumeration
|
||||
if (!Array.forEach) { // mozilla already supports this
|
||||
Array.forEach = function(array, block, context) {
|
||||
for (var i = 0; i < array.length; i++) {
|
||||
block.call(context, array[i], i, array);
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
// generic enumeration
|
||||
Function.prototype.forEach = function(object, block, context) {
|
||||
for (var key in object) {
|
||||
if (typeof this.prototype[key] == "undefined") {
|
||||
block.call(context, object[key], key, object);
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
// character enumeration
|
||||
String.forEach = function(string, block, context) {
|
||||
Array.forEach(string.split(""), function(chr, index) {
|
||||
block.call(context, chr, index, string);
|
||||
});
|
||||
};
|
||||
|
||||
// globally resolve forEach enumeration
|
||||
var forEach = function(object, block, context) {
|
||||
if (object) {
|
||||
var resolve = Object; // default
|
||||
if (object instanceof Function) {
|
||||
// functions have a "length" property
|
||||
resolve = Function;
|
||||
} else if (object.forEach instanceof Function) {
|
||||
// the object implements a custom forEach method so use that
|
||||
object.forEach(block, context);
|
||||
return;
|
||||
} else if (typeof object == "string") {
|
||||
// the object is a string
|
||||
resolve = String;
|
||||
} else if (typeof object.length == "number") {
|
||||
// the object is array-like
|
||||
resolve = Array;
|
||||
}
|
||||
resolve.forEach(object, block, context);
|
||||
}
|
||||
};
|
||||
|
||||
148
collects/meta/planet2-index/official/static/style.css
Normal file
148
collects/meta/planet2-index/official/static/style.css
Normal file
|
|
@ -0,0 +1,148 @@
|
|||
html {
|
||||
overflow-y: scroll;
|
||||
}
|
||||
|
||||
a img {
|
||||
border: 0;
|
||||
}
|
||||
|
||||
body {
|
||||
color: black;
|
||||
background-color: white;
|
||||
font-family: Optima, Arial, Verdana, Helvetica, sans-serif;
|
||||
margin: 0px;
|
||||
padding: 0px;
|
||||
}
|
||||
|
||||
.breadcrumb {
|
||||
padding-left: 1em;
|
||||
padding-right: 1em;
|
||||
background: #FFCC66;
|
||||
font-size: 120%;
|
||||
font-weight: bold;
|
||||
}
|
||||
|
||||
.breadcrumb a,span.not-this {
|
||||
color: black;
|
||||
text-decoration: none;
|
||||
font-weight: normal;
|
||||
}
|
||||
|
||||
.breadcrumb a:hover {
|
||||
color: blue;
|
||||
text-decoration: underline;
|
||||
}
|
||||
|
||||
#logout {
|
||||
float: right;
|
||||
}
|
||||
|
||||
.content {
|
||||
margin-left: auto;
|
||||
margin-right: auto;
|
||||
width: 95%;
|
||||
}
|
||||
|
||||
table.packages {
|
||||
width: 100%;
|
||||
}
|
||||
|
||||
table.packages thead tr {
|
||||
background: #FFCC66;
|
||||
}
|
||||
|
||||
table.packages tbody tr:nth-child(2n) {
|
||||
background: #F5F5DC;
|
||||
}
|
||||
|
||||
.recent td:nth-child(1):before {
|
||||
content: "*";
|
||||
color: red;
|
||||
}
|
||||
|
||||
#menu {
|
||||
text-align: center;
|
||||
width: 100%;
|
||||
margin-top: 1em;
|
||||
margin-bottom: 1em;
|
||||
}
|
||||
|
||||
.menu_option {
|
||||
margin-right: 4em;
|
||||
}
|
||||
|
||||
.package {
|
||||
margin-top: 1em;
|
||||
margin-bottom: 1em;
|
||||
width: 100%;
|
||||
text-align: center;
|
||||
}
|
||||
|
||||
.package table {
|
||||
width: 70%;
|
||||
margin-left: 15%;
|
||||
margin-right: 15%;
|
||||
border: 1px dotted;
|
||||
}
|
||||
.package table tr {
|
||||
width: 100%;
|
||||
}
|
||||
.package table td {
|
||||
vertical-align: top;
|
||||
height: 2em;
|
||||
}
|
||||
.package table tr:nth-child(3) td {
|
||||
height: 2.5em;
|
||||
}
|
||||
.package table tr:nth-child(7) td {
|
||||
height: 3.5em;
|
||||
}
|
||||
.package table td:nth-child(1) {
|
||||
text-align: right;
|
||||
font-weight: bold;
|
||||
width: 15%;
|
||||
}
|
||||
.package table td:nth-child(2) {
|
||||
text-align: left;
|
||||
}
|
||||
.package table td.submit {
|
||||
text-align: center;
|
||||
}
|
||||
.package input {
|
||||
width: 100%;
|
||||
}
|
||||
.package textarea {
|
||||
width: 100%;
|
||||
height: 4em;
|
||||
}
|
||||
|
||||
#footer {
|
||||
width: 95%;
|
||||
text-align: right;
|
||||
background: #F5F5DC;
|
||||
padding-right: 3em;
|
||||
}
|
||||
|
||||
span.tooltip {
|
||||
position: relative;
|
||||
}
|
||||
|
||||
span.tooltip > a + span {
|
||||
display: none;
|
||||
}
|
||||
|
||||
span.tooltip > a:hover {
|
||||
font-size: 99%;
|
||||
font-color: #000000;
|
||||
}
|
||||
|
||||
span.tooltip > a:hover + span {
|
||||
display: block;
|
||||
position: absolute;
|
||||
margin-top: 10px;
|
||||
margin-left: -10px;
|
||||
width: 250px; padding: 5px;
|
||||
z-index: 100;
|
||||
background: #F5F5DC;
|
||||
text-align: left;
|
||||
}
|
||||
1
collects/meta/planet2-index/planet-compat/.gitignore
vendored
Normal file
1
collects/meta/planet2-index/planet-compat/.gitignore
vendored
Normal file
|
|
@ -0,0 +1 @@
|
|||
/root
|
||||
3
collects/meta/planet2-index/planet-compat/info.rkt
Normal file
3
collects/meta/planet2-index/planet-compat/info.rkt
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define compile-omit-paths '("root"))
|
||||
395
collects/meta/planet2-index/planet-compat/main.rkt
Normal file
395
collects/meta/planet2-index/planet-compat/main.rkt
Normal file
|
|
@ -0,0 +1,395 @@
|
|||
#lang racket/base
|
||||
(require net/url
|
||||
racket/file
|
||||
web-server/http
|
||||
web-server/servlet-env
|
||||
meta/planet2-index/basic/main
|
||||
racket/port
|
||||
racket/match
|
||||
racket/runtime-path
|
||||
planet/config
|
||||
racket/system
|
||||
racket/path
|
||||
racket/list)
|
||||
|
||||
(module+ main
|
||||
(define-runtime-path root "root")
|
||||
(make-directory* root))
|
||||
|
||||
(define (delete-directory/files* p)
|
||||
(when (or (file-exists? p) (directory-exists? p))
|
||||
(delete-directory/files p)))
|
||||
|
||||
(require (prefix-in p:
|
||||
(combine-in
|
||||
planet/private/parsereq
|
||||
planet/private/data)))
|
||||
(define (substring* s st end)
|
||||
(substring s st (+ (string-length s) end)))
|
||||
(define (remove-suffix s)
|
||||
(regexp-replace #rx"\\.([^\\.]*?)$" s ""))
|
||||
(define (convert-one-planet-req pkgs orig-bs)
|
||||
(define orig-bs-i (open-input-bytes orig-bs))
|
||||
(define-values (new-byte new-dep)
|
||||
(with-handlers ([exn?
|
||||
(λ (x)
|
||||
(eprintf "skipping possible planet dep ~e because of exception ~e\n"
|
||||
orig-bs (exn-message x))
|
||||
(define here (file-position orig-bs-i))
|
||||
(file-position orig-bs-i 0)
|
||||
(values (read-bytes here orig-bs-i)
|
||||
empty))]
|
||||
[list?
|
||||
(λ (x)
|
||||
(apply error x))])
|
||||
(define orig-v (read orig-bs-i))
|
||||
(define orig-r (p:spec->req orig-v #'error))
|
||||
(define spec (p:request-full-pkg-spec orig-r))
|
||||
(define user (first (p:pkg-spec-path spec)))
|
||||
(define pkg
|
||||
(format "~a~a"
|
||||
(remove-suffix (p:pkg-spec-name spec))
|
||||
(verify-package-exists pkgs spec)))
|
||||
(values
|
||||
(string->bytes/utf-8
|
||||
(format "~a/~a/~a~a"
|
||||
user
|
||||
pkg
|
||||
(if (empty? (p:request-path orig-r))
|
||||
""
|
||||
(string-append
|
||||
(apply string-append
|
||||
(add-between (p:request-path orig-r) "/"))
|
||||
"/"))
|
||||
(remove-suffix (p:request-file orig-r))))
|
||||
(list
|
||||
(format "planet-~a-~a"
|
||||
user pkg)))))
|
||||
(define-values (new-bytes new-deps)
|
||||
(update-planet-reqs pkgs (port->bytes orig-bs-i)))
|
||||
(values (bytes-append
|
||||
new-byte new-bytes)
|
||||
(append
|
||||
new-dep new-deps)))
|
||||
|
||||
(define (update-planet-reqs pkgs orig)
|
||||
(match (regexp-match-positions #px#"\\(\\s*planet\\s+.*\\s*\\)" orig)
|
||||
[#f
|
||||
(values orig
|
||||
empty)]
|
||||
[(cons (cons start end) _)
|
||||
(define-values (new-bytes new-deps)
|
||||
(convert-one-planet-req pkgs (subbytes orig start)))
|
||||
(values (bytes-append (subbytes orig 0 start)
|
||||
new-bytes)
|
||||
new-deps)]))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define fake-pkgs
|
||||
(list (list "mcdonald" "farm.plt" (list 1 0))
|
||||
(list "mcdonald" "glue-factory.plt" (list 1 0))))
|
||||
(define-syntax-rule (p in exp-bs exp-deps)
|
||||
(let ()
|
||||
(define-values (act-bs act-deps) (update-planet-reqs fake-pkgs in))
|
||||
(check-equal? act-bs exp-bs)
|
||||
(check-equal? act-deps exp-deps)))
|
||||
|
||||
(p #"planet mcdonald/farm"
|
||||
#"planet mcdonald/farm"
|
||||
'())
|
||||
(p #"(planet mcdonald/farm)"
|
||||
#"mcdonald/farm1/main"
|
||||
'("planet-mcdonald-farm1"))
|
||||
(p #"ababab (planet mcdonald/farm) ababab"
|
||||
#"ababab mcdonald/farm1/main ababab"
|
||||
'("planet-mcdonald-farm1"))
|
||||
(p #"(planet mcdonald/farm) (planet mcdonald/farm)"
|
||||
#"mcdonald/farm1/main mcdonald/farm1/main"
|
||||
'("planet-mcdonald-farm1" "planet-mcdonald-farm1"))
|
||||
(p #"(planet mcdonald/farm) (planet mcdonald/glue-factory)"
|
||||
#"mcdonald/farm1/main mcdonald/glue-factory1/main"
|
||||
'("planet-mcdonald-farm1" "planet-mcdonald-glue-factory1"))
|
||||
(p #"(planet mcdonald/farm/duck)"
|
||||
#"mcdonald/farm1/duck"
|
||||
'("planet-mcdonald-farm1"))
|
||||
(p #"(planet mcdonald/farm:1)"
|
||||
#"mcdonald/farm1/main"
|
||||
'("planet-mcdonald-farm1"))
|
||||
(p #"(planet mcdonald/farm:1:5)"
|
||||
#"mcdonald/farm1/main"
|
||||
'("planet-mcdonald-farm1"))
|
||||
(p #"(planet mcdonald/farm:1:5/duck)"
|
||||
#"mcdonald/farm1/duck"
|
||||
'("planet-mcdonald-farm1"))
|
||||
(p #"(planet mcdonald/farm/duck/quack)"
|
||||
#"mcdonald/farm1/duck/quack"
|
||||
'("planet-mcdonald-farm1"))
|
||||
(p #"(planet \"mcdonald/farm/duck/quack\")"
|
||||
#"mcdonald/farm1/duck/quack"
|
||||
'("planet-mcdonald-farm1"))
|
||||
(p #"(planet \"quack.rkt\" (\"mcdonald\" \"farm.plt\") \"duck\")"
|
||||
#"mcdonald/farm1/duck/quack"
|
||||
'("planet-mcdonald-farm1"))
|
||||
(p #"(planet \"quack.rkt\" (\"mcdonald\" \"farm.plt\") \"duck\" \"mallard\")"
|
||||
#"mcdonald/farm1/duck/mallard/quack"
|
||||
'("planet-mcdonald-farm1")))
|
||||
|
||||
(module+ main
|
||||
;; Initialize the root on boot
|
||||
(define mins
|
||||
(build-path root "mins"))
|
||||
(make-directory* mins)
|
||||
(define orig-pkg
|
||||
(build-path root "orig-pkg"))
|
||||
(make-directory* orig-pkg)
|
||||
(define orig
|
||||
(build-path root "orig"))
|
||||
(make-directory* orig)
|
||||
(define work
|
||||
(build-path root "work"))
|
||||
(make-directory* work)
|
||||
(define pkg-depo
|
||||
(build-path root "pkgs"))
|
||||
(make-directory* pkg-depo)
|
||||
(define pkg-depo-dir "static")
|
||||
(make-directory* (build-path pkg-depo pkg-depo-dir))
|
||||
|
||||
(define pkg-info-url
|
||||
(string->url "http://planet.racket-lang.org/servlets/pkg-info.ss"))
|
||||
(define pkgs
|
||||
(call/input-url pkg-info-url get-pure-port (λ (p) (read p) (read p))))
|
||||
(define planet-download-url
|
||||
(string->url (HTTP-DOWNLOAD-SERVLET-URL))))
|
||||
|
||||
(define (verify-package-exists pkgs spec)
|
||||
(or
|
||||
(for/or ([p (in-list pkgs)])
|
||||
(match-define (list user pkg (list max-maj min)) p)
|
||||
(and (equal? (p:pkg-spec-name spec) pkg)
|
||||
(equal? (p:pkg-spec-path spec) (list user))
|
||||
(if (p:pkg-spec-maj spec)
|
||||
(and
|
||||
;; This is too restrictive given the number of errors in Planet packages
|
||||
(<= (p:pkg-spec-maj spec) max-maj)
|
||||
(p:pkg-spec-maj spec))
|
||||
max-maj)))
|
||||
;; Hacks
|
||||
(let ()
|
||||
(define hack-v
|
||||
(list (p:pkg-spec-name spec)
|
||||
(p:pkg-spec-path spec)
|
||||
(p:pkg-spec-maj spec)))
|
||||
(cond
|
||||
[(member hack-v
|
||||
(list
|
||||
;; These packages straight-up don't exist
|
||||
'("displayz.plt" ("synx") #f) ;; from synx/xml-writer
|
||||
'("galore.plt" ("cce") 1) ;; from soegaard/galore (it's in a comment about avoiding collisions)
|
||||
'("combinators.plt" ("cce") 1) ;; from soegaard/galore (it's in a comment about avoiding collisions)
|
||||
;; These are errors in a package's documnetation
|
||||
'("aspectscheme.plt" ("dutchyn") 4) ;; maj should be 1
|
||||
'("divascheme.plt" ("dyoo") 1) ;; user should be divascheme
|
||||
'("diff.plt" ("wmfarr") 1) ;; pkg should be deriv
|
||||
'("tetris.plt" ("dvanhorn") 5) ;; maj should be 3
|
||||
'("file-utils.plt" ("erast") #f) ;; pkg should be fileutils
|
||||
;; These are from packages about planet features
|
||||
'("sqld-psql-ffi.plt" ("planet") 1)
|
||||
'("sqlid.plt" ("planet") 1)
|
||||
'("package-from-local-filesystem.plt" ("fake-author") 1)
|
||||
'("package-from-svn.plt" ("fake-author") 1)
|
||||
'("module.plt" ("package") #f)
|
||||
'("mcfly-scribble.plt" ("~A") #f)
|
||||
'("mcfly-expand.plt" ("~A") #f)
|
||||
'("bar.plt" ("untyped") 1)))
|
||||
(error 'verify-package-exists "hack!")]
|
||||
[else #f]))
|
||||
;; End Hacks
|
||||
(raise (list 'verify-package-exists "Cannot determine newest major for ~e ~e"
|
||||
spec
|
||||
(list (p:pkg-spec-name spec)
|
||||
(p:pkg-spec-path spec)
|
||||
(p:pkg-spec-maj spec))))))
|
||||
|
||||
(module+ main
|
||||
(define all-pkg-list
|
||||
(for/list ([p (in-list pkgs)])
|
||||
(match-define (list user pkg (list max-maj min)) p)
|
||||
|
||||
(define last-min-p (build-path mins (format "~a:~a" user pkg)))
|
||||
(define last-min
|
||||
(if (file-exists? last-min-p)
|
||||
(file->value last-min-p)
|
||||
-inf.0))
|
||||
(define delete?
|
||||
(not (= last-min min)))
|
||||
|
||||
(begin0
|
||||
(for/list ([maj (in-range 1 (add1 max-maj))])
|
||||
(let/ec esc
|
||||
(define dl-url
|
||||
(struct-copy url planet-download-url
|
||||
[query
|
||||
(let ([get (lambda (access) (format "~s" access))])
|
||||
`((lang . ,(get (DEFAULT-PACKAGE-LANGUAGE)))
|
||||
(name . ,(get pkg))
|
||||
(maj . ,(get maj))
|
||||
(min-lo . "0" #;,(get min))
|
||||
(min-hi . "#f" #;,(get min))
|
||||
(path . ,(get (list user)))))]))
|
||||
(define pkg-short
|
||||
(format "~a:~a:~a" user maj pkg))
|
||||
|
||||
(define-syntax-rule (when-delete? e ...)
|
||||
(with-handlers ([exn:fail? void])
|
||||
(when delete?
|
||||
e ...)))
|
||||
|
||||
(define dest
|
||||
(build-path orig-pkg pkg-short))
|
||||
(when-delete?
|
||||
(delete-file dest))
|
||||
(unless (file-exists? dest)
|
||||
(printf "Downloading ~a\n"
|
||||
pkg-short)
|
||||
(define pkg-bs
|
||||
(call/input-url dl-url get-impure-port
|
||||
(λ (in)
|
||||
(define hs (purify-port in))
|
||||
(when (string=? "404" (substring hs 9 12))
|
||||
(esc #f))
|
||||
(port->bytes in))))
|
||||
(call-with-output-file dest
|
||||
(λ (out) (write-bytes pkg-bs out))))
|
||||
|
||||
(define dest-dir
|
||||
(build-path orig pkg-short))
|
||||
(when-delete?
|
||||
(delete-directory/files dest-dir))
|
||||
(unless (directory-exists? dest-dir)
|
||||
(printf "Unpacking ~a\n" pkg-short)
|
||||
(make-directory dest-dir)
|
||||
(local-require planet2/util-plt)
|
||||
(unplt dest dest-dir))
|
||||
|
||||
(define pkg/no-plt
|
||||
(format "~a~a"
|
||||
(regexp-replace* #rx"\\.plt$" pkg "")
|
||||
maj))
|
||||
(define pkg-name
|
||||
(format "planet-~a-~a" user pkg/no-plt))
|
||||
(define pkg-name.plt
|
||||
(format "~a.plt" pkg-name))
|
||||
(define pkg-dir
|
||||
(build-path work pkg-name))
|
||||
|
||||
(when-delete?
|
||||
(delete-directory/files pkg-dir))
|
||||
|
||||
(with-handlers
|
||||
([exn? (λ (x)
|
||||
(delete-directory/files pkg-dir)
|
||||
(raise x))])
|
||||
(unless (directory-exists? pkg-dir)
|
||||
(printf "Translating ~a\n" pkg-short)
|
||||
(make-directory* pkg-dir)
|
||||
(define files-dir
|
||||
(build-path pkg-dir user pkg/no-plt))
|
||||
(make-directory* files-dir)
|
||||
|
||||
(define all-deps
|
||||
(fold-files
|
||||
(λ (p ty deps)
|
||||
(define rp
|
||||
(find-relative-path dest-dir p))
|
||||
(define fp
|
||||
(if (equal? p rp)
|
||||
files-dir
|
||||
(build-path files-dir rp)))
|
||||
(match ty
|
||||
['dir
|
||||
(make-directory* fp)
|
||||
deps]
|
||||
['file
|
||||
(match (filename-extension rp)
|
||||
[(or #"ss" #"scrbl" #"rkt" #"scs" #"scm" #"scribl")
|
||||
(define orig (file->bytes p))
|
||||
(define-values (changed new-deps)
|
||||
(update-planet-reqs pkgs orig))
|
||||
(display-to-file changed fp)
|
||||
(append new-deps deps)]
|
||||
[_
|
||||
(copy-file p fp)
|
||||
deps])]))
|
||||
empty
|
||||
dest-dir
|
||||
#f))
|
||||
(define deps
|
||||
(remove pkg-name
|
||||
(remove-duplicates
|
||||
all-deps)))
|
||||
|
||||
(printf "\tdeps ~a\n" deps)
|
||||
(write-to-file
|
||||
`((dependency ,@deps))
|
||||
(build-path pkg-dir "METADATA.rktd"))))
|
||||
|
||||
(define pkg-pth (build-path pkg-depo pkg-depo-dir pkg-name.plt))
|
||||
(when-delete?
|
||||
(delete-file pkg-pth)
|
||||
(delete-file (string-append (path->string pkg-pth) ".CHECKSUM")))
|
||||
(unless (file-exists? pkg-pth)
|
||||
(printf "Packaging ~a\n" pkg-short)
|
||||
(parameterize ([current-directory work])
|
||||
(system (format "raco pkg create ~a" pkg-name))
|
||||
(rename-file-or-directory
|
||||
(build-path work pkg-name.plt)
|
||||
pkg-pth)
|
||||
(rename-file-or-directory
|
||||
(string-append (path->string (build-path work pkg-name.plt)) ".CHECKSUM")
|
||||
(string-append (path->string pkg-pth) ".CHECKSUM"))))
|
||||
|
||||
pkg-name))
|
||||
|
||||
(write-to-file min last-min-p
|
||||
#:exists 'replace))))
|
||||
|
||||
(define pkg-list
|
||||
;; No idea why there are duplicates
|
||||
(remove-duplicates
|
||||
(filter-map (λ (x) x)
|
||||
(append* all-pkg-list)))))
|
||||
|
||||
(module+ main
|
||||
(define (go port)
|
||||
(printf "Launching server on port ~a\n" port)
|
||||
(serve/servlet
|
||||
(planet2-index/basic
|
||||
(λ () pkg-list)
|
||||
(λ (pkg-name)
|
||||
(and
|
||||
(directory-exists? (build-path work pkg-name))
|
||||
(hasheq 'checksum
|
||||
(file->string
|
||||
(build-path pkg-depo pkg-depo-dir (format "~a.plt.CHECKSUM" pkg-name)))
|
||||
'source
|
||||
(format "https://plt-etc.byu.edu:~a/~a/~a.plt"
|
||||
port pkg-depo-dir pkg-name)
|
||||
'url
|
||||
(let ()
|
||||
(match-define (regexp #rx"^planet-([^-]+)-([^0-9]+)[0-9]+"
|
||||
(list _ user pkg))
|
||||
pkg-name)
|
||||
(format "http://planet.racket-lang.org/display.ss?package=~a.plt&owner=~a"
|
||||
pkg user))))))
|
||||
#:ssl? #t
|
||||
#:ssl-cert (build-path root "server-cert.pem")
|
||||
#:ssl-key (build-path root "private-key.pem")
|
||||
#:command-line? #t
|
||||
#:extra-files-paths
|
||||
(list pkg-depo)
|
||||
#:servlet-regexp #rx""
|
||||
#:listen-ip #f
|
||||
#:port port))
|
||||
|
||||
(go 9003))
|
||||
12
collects/meta/planet2-index/sync.sh
Executable file
12
collects/meta/planet2-index/sync.sh
Executable file
|
|
@ -0,0 +1,12 @@
|
|||
#!/bin/sh
|
||||
|
||||
for i in planet2 tests/planet2 meta/planet2-index ; do
|
||||
rsync -n -a --progress -h --delete --exclude root --exclude compiled --exclude doc ../../$i/ plt-etc:local/galaxy/$i/
|
||||
done
|
||||
|
||||
exit 1
|
||||
|
||||
for i in official planet-compat ; do
|
||||
rsync -a --progress -h --delete plt-etc:local/galaxy/meta/planet2-index/$i/root/ $i/root/
|
||||
done
|
||||
|
||||
|
|
@ -806,6 +806,9 @@ path/s is either such a string or a list of them.
|
|||
"collects/meta/drdr2" responsible (jay) drdr:command-line #f
|
||||
"collects/meta/images/mkheart.rkt" drdr:command-line #f
|
||||
"collects/meta/images/taking-screenshots/racket-widget.scm" drdr:command-line #f
|
||||
"collects/meta/planet2-index" responsible (jay)
|
||||
"collects/meta/planet2-index/official/main.rkt" drdr:command-line (raco "test" *)
|
||||
"collects/meta/planet2-index/planet-compat/main.rkt" drdr:command-line (raco "test" *)
|
||||
"collects/meta/props" responsible (eli jay) drdr:command-line (racket "-um" * "verify")
|
||||
"collects/meta/web" drdr:command-line #f
|
||||
"collects/mred" responsible (mflatt)
|
||||
|
|
@ -858,6 +861,7 @@ path/s is either such a string or a list of them.
|
|||
"collects/picturing-programs" responsible (sbloch)
|
||||
"collects/plai" responsible (jay)
|
||||
"collects/planet" responsible (robby)
|
||||
"collects/planet2" responsible (jay)
|
||||
"collects/plot" responsible (ntoronto)
|
||||
"collects/plot/scribblings/plot.scrbl" drdr:timeout 180
|
||||
"collects/plot/tests/extreme-bounds-tests.rkt" drdr:timeout 150
|
||||
|
|
@ -1146,6 +1150,8 @@ path/s is either such a string or a list of them.
|
|||
"collects/tests/planet/test-docs-complete.rkt" drdr:command-line (raco "make" *)
|
||||
"collects/tests/planet/thread-safe-resolver.rkt" drdr:command-line (raco "make" *) drdr:timeout 1000
|
||||
"collects/tests/planet/version.rkt" drdr:command-line (raco "make" *)
|
||||
"collects/tests/planet2" responsible (jay) drdr:command-line (mzc *)
|
||||
"collects/tests/planet2/test-pkgs" drdr:command-line #f
|
||||
"collects/tests/profile" responsible (eli)
|
||||
"collects/tests/r6rs" responsible (mflatt)
|
||||
"collects/tests/racket" responsible (mflatt)
|
||||
|
|
|
|||
1
collects/planet2/.gitignore
vendored
Normal file
1
collects/planet2/.gitignore
vendored
Normal file
|
|
@ -0,0 +1 @@
|
|||
/doc
|
||||
101
collects/planet2/commands.rkt
Normal file
101
collects/planet2/commands.rkt
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
#lang racket/base
|
||||
(require racket/cmdline
|
||||
planet/private/command
|
||||
raco/command-name
|
||||
racket/function
|
||||
(for-syntax racket/base
|
||||
racket/list
|
||||
racket/syntax
|
||||
syntax/parse))
|
||||
|
||||
(begin-for-syntax
|
||||
(define symbol->keyword
|
||||
(compose string->keyword symbol->string))
|
||||
|
||||
(define-syntax-class kind
|
||||
#:attributes (default fun (arg-val 1))
|
||||
[pattern #:bool
|
||||
#:attr (arg-val 1) empty
|
||||
#:attr default #'#f
|
||||
#:attr fun #'(λ () #t)]
|
||||
[pattern (#:sym default:expr)
|
||||
#:attr (arg-val 1) (list #'string)
|
||||
#:attr fun #'string->symbol]
|
||||
[pattern (#:str default:expr)
|
||||
#:attr (arg-val 1) (list #'string)
|
||||
#:attr fun #'identity])
|
||||
|
||||
(define-syntax-class option
|
||||
#:attributes (command-line variable (param 1) (call 1))
|
||||
[pattern (k:kind arg:id (alias:str ...) doc:expr)
|
||||
#:do
|
||||
[(define arg-kw (symbol->keyword (syntax->datum #'arg)))
|
||||
(define arg-str (format "--~a" (syntax->datum #'arg)))
|
||||
(define arg-var (generate-temporary #'arg))]
|
||||
#:attr variable
|
||||
(quasisyntax/loc #'arg
|
||||
(define #,arg-var k.default))
|
||||
#:attr (param 1)
|
||||
(syntax-e
|
||||
(quasisyntax/loc #'arg
|
||||
[#,arg-kw [arg k.default]]))
|
||||
#:attr (call 1)
|
||||
(syntax-e
|
||||
(quasisyntax/loc #'arg
|
||||
[#,arg-kw #,arg-var]))
|
||||
#:attr command-line
|
||||
(quasisyntax/loc #'arg
|
||||
[(alias ... #,arg-str)
|
||||
k.arg-val ...
|
||||
doc
|
||||
(set! #,arg-var (k.fun k.arg-val ...))])])
|
||||
|
||||
(define-syntax-class command
|
||||
#:attributes (name function variables command-line)
|
||||
[pattern (name:id doc:expr o:option ... #:args args body:expr ...)
|
||||
#:do
|
||||
[(define name-str (symbol->string (syntax->datum #'name)))]
|
||||
#:attr function
|
||||
(syntax/loc #'name
|
||||
(define (name o.param ... ... . args)
|
||||
body ...))
|
||||
#:attr variables
|
||||
(syntax/loc #'name
|
||||
(begin o.variable ...))
|
||||
#:attr command-line
|
||||
(quasisyntax/loc #'name
|
||||
[#,name-str
|
||||
doc doc
|
||||
#:once-each
|
||||
o.command-line ...
|
||||
#:args args
|
||||
(args-app args (name o.call ... ...))])]))
|
||||
|
||||
(define-syntax (args-app stx)
|
||||
(syntax-parse stx
|
||||
[(_ () (call ...))
|
||||
(syntax/loc stx
|
||||
(call ...))]
|
||||
[(_ rest:id (call ...))
|
||||
(syntax/loc stx
|
||||
(apply call ... rest))]
|
||||
[(_ (fst . snd) (call ...))
|
||||
(syntax/loc stx
|
||||
(args-app snd (call ... fst)))]))
|
||||
|
||||
(define-syntax (commands stx)
|
||||
(syntax-parse stx
|
||||
[(_ main-doc:expr c:command ...)
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
c.function ...
|
||||
(provide c.name ...)
|
||||
(module+ main
|
||||
c.variables ...
|
||||
(svn-style-command-line
|
||||
#:program (short-program+command-name)
|
||||
#:argv (current-command-line-arguments)
|
||||
main-doc
|
||||
c.command-line ...))))]))
|
||||
|
||||
(provide commands)
|
||||
7
collects/planet2/info.rkt
Normal file
7
collects/planet2/info.rkt
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define name "Planet2")
|
||||
(define scribblings
|
||||
'(("scribblings/planet2.scrbl" (multi-page) (tool 100))))
|
||||
(define raco-commands
|
||||
'(("pkg" planet2/raco "manage packages" 81)))
|
||||
809
collects/planet2/lib.rkt
Normal file
809
collects/planet2/lib.rkt
Normal file
|
|
@ -0,0 +1,809 @@
|
|||
#lang racket/base
|
||||
(require net/url
|
||||
json
|
||||
openssl/sha1
|
||||
racket/contract
|
||||
racket/match
|
||||
racket/system
|
||||
racket/path
|
||||
racket/file
|
||||
setup/link
|
||||
setup/pack
|
||||
setup/unpack
|
||||
setup/dirs
|
||||
racket/port
|
||||
racket/list
|
||||
racket/function
|
||||
racket/dict
|
||||
racket/set
|
||||
unstable/debug
|
||||
racket/string
|
||||
"util.rkt"
|
||||
"util-plt.rkt")
|
||||
|
||||
(define current-install-system-wide?
|
||||
(make-parameter #f))
|
||||
|
||||
(define (file->value* pth def)
|
||||
(with-handlers ([exn:fail? (λ (x) def)])
|
||||
(file->value pth)))
|
||||
|
||||
(define (path->bytes* pkg)
|
||||
(cond
|
||||
[(path? pkg)
|
||||
(path->bytes pkg)]
|
||||
[(string? pkg)
|
||||
(path->bytes (string->path pkg))]
|
||||
[(bytes? pkg)
|
||||
pkg]))
|
||||
|
||||
(define (directory-path-no-slash pkg)
|
||||
(bytes->path (regexp-replace* #rx#"/$" (path->bytes* pkg) #"")))
|
||||
|
||||
(define (absolute-collects-dir)
|
||||
(path->complete-path
|
||||
(find-system-path 'collects-dir)
|
||||
(path-only (find-executable-path (find-system-path 'exec-file)))))
|
||||
|
||||
(define (directory-list* d)
|
||||
(append-map
|
||||
(λ (pp)
|
||||
(define p (build-path d pp))
|
||||
(if (directory-exists? p)
|
||||
(map (curry build-path pp)
|
||||
(directory-list* p))
|
||||
(list pp)))
|
||||
(directory-list d)))
|
||||
|
||||
(define (simple-form-path* p)
|
||||
(path->string (simple-form-path p)))
|
||||
|
||||
(define (untar pkg pkg-dir #:strip-components [strip-components 0])
|
||||
(make-directory* pkg-dir)
|
||||
(system* (find-executable-path "tar") "-C" pkg-dir "-xvzf" pkg
|
||||
"--strip-components" (number->string strip-components)))
|
||||
|
||||
(define (download-file! url file #:fail-okay? [fail-okay? #f])
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(λ (x)
|
||||
(unless fail-okay?
|
||||
(raise x)))])
|
||||
(make-parent-directory* file)
|
||||
(dprintf "\t\tDownloading ~a to ~a\n" (url->string url) file)
|
||||
(call-with-output-file file
|
||||
(λ (op)
|
||||
(call/input-url+200
|
||||
url
|
||||
(λ (ip) (copy-port ip op)))))))
|
||||
|
||||
(define (pkg-dir)
|
||||
(build-path (if (current-install-system-wide?)
|
||||
(find-lib-dir)
|
||||
(find-system-path 'addon-dir))
|
||||
"pkgs"))
|
||||
(define (pkg-config-file)
|
||||
(build-path (pkg-dir) "config.rktd"))
|
||||
(define (pkg-db-file)
|
||||
(build-path (pkg-dir) "pkgs.rktd"))
|
||||
(define (pkg-installed-dir)
|
||||
(build-path (pkg-dir) "installed"))
|
||||
(define (pkg-lock-file)
|
||||
(make-lock-file-name (pkg-db-file)))
|
||||
|
||||
(for-each make-directory*
|
||||
(list (pkg-dir) (pkg-installed-dir)))
|
||||
|
||||
(define (with-package-lock* t)
|
||||
(make-directory* (pkg-dir))
|
||||
(call-with-file-lock/timeout
|
||||
#f 'exclusive
|
||||
t
|
||||
(λ () (error 'planet2 "Could not acquire package lock: ~e"
|
||||
(pkg-lock-file)))
|
||||
#:lock-file (pkg-lock-file)))
|
||||
(define-syntax-rule (with-package-lock e ...)
|
||||
(with-package-lock* (λ () e ...)))
|
||||
|
||||
(define (read-pkg-cfg/def k)
|
||||
(define c (read-pkg-cfg))
|
||||
(hash-ref c k
|
||||
(λ ()
|
||||
(match k
|
||||
["indexes"
|
||||
(list "https://plt-etc.byu.edu:9004"
|
||||
"https://plt-etc.byu.edu:9003")]))))
|
||||
|
||||
(define (package-index-lookup pkg)
|
||||
(or
|
||||
(for/or ([i (in-list (read-pkg-cfg/def "indexes"))])
|
||||
(call/input-url+200
|
||||
(combine-url/relative
|
||||
(string->url i)
|
||||
(format "/pkg/~a" pkg))
|
||||
read))
|
||||
(error 'planet2 "Cannot find package ~a on indexes" pkg)))
|
||||
|
||||
(define (remote-package-checksum pkg)
|
||||
(match pkg
|
||||
[`(pns ,pkg-name)
|
||||
(hash-ref (package-index-lookup pkg-name) 'checksum)]
|
||||
[`(url ,pkg-url-str)
|
||||
(package-url->checksum pkg-url-str)]))
|
||||
|
||||
(define (read-file-hash file)
|
||||
(define the-db
|
||||
(with-handlers ([exn? (λ (x) (hash))])
|
||||
(file->value file)))
|
||||
the-db)
|
||||
(define (write-file-hash! file new-db)
|
||||
(make-parent-directory* file)
|
||||
(with-output-to-file file
|
||||
#:exists 'replace
|
||||
(λ () (write new-db))))
|
||||
|
||||
(define (read-pkg-db)
|
||||
(read-file-hash (pkg-db-file)))
|
||||
|
||||
(define (package-info pkg-name [fail? #t])
|
||||
(define db (read-pkg-db))
|
||||
(define pi (hash-ref db pkg-name #f))
|
||||
(cond
|
||||
[pi
|
||||
pi]
|
||||
[(not fail?)
|
||||
#f]
|
||||
[else
|
||||
(error 'planet2 "Package ~e not currently installed; ~e are installed"
|
||||
pkg-name
|
||||
(hash-keys db))]))
|
||||
|
||||
(define (update-pkg-db! pkg-name info)
|
||||
(write-file-hash!
|
||||
(pkg-db-file)
|
||||
(hash-set (read-pkg-db) pkg-name info)))
|
||||
(define (remove-from-pkg-db! pkg-name)
|
||||
(write-file-hash!
|
||||
(pkg-db-file)
|
||||
(hash-remove (read-pkg-db) pkg-name)))
|
||||
(define (read-pkg-cfg)
|
||||
(read-file-hash (pkg-config-file)))
|
||||
(define (update-pkg-cfg! key val)
|
||||
(write-file-hash!
|
||||
(pkg-config-file)
|
||||
(hash-set (read-pkg-cfg) key val)))
|
||||
|
||||
(struct pkg-info (orig-pkg checksum auto?) #:prefab)
|
||||
(struct install-info (name orig-pkg directory clean? checksum))
|
||||
|
||||
(define (update-install-info-orig-pkg if op)
|
||||
(struct-copy install-info if
|
||||
[orig-pkg op]))
|
||||
(define (update-install-info-checksum if op)
|
||||
(struct-copy install-info if
|
||||
[checksum op]))
|
||||
|
||||
|
||||
|
||||
(define (package-directory pkg-name)
|
||||
(match-define (pkg-info orig-pkg checksum _)
|
||||
(package-info pkg-name))
|
||||
(match orig-pkg
|
||||
[`(link ,orig-pkg-dir)
|
||||
orig-pkg-dir]
|
||||
[_
|
||||
(build-path (pkg-installed-dir) pkg-name)]))
|
||||
|
||||
(define (remove-package pkg-name)
|
||||
(match-define (pkg-info orig-pkg checksum _)
|
||||
(package-info pkg-name))
|
||||
(define pkg-dir (package-directory pkg-name))
|
||||
(remove-from-pkg-db! pkg-name)
|
||||
(match orig-pkg
|
||||
[`(link ,_)
|
||||
(links pkg-dir
|
||||
#:remove? #t
|
||||
#:user? (not (current-install-system-wide?))
|
||||
#:root? #t)]
|
||||
[_
|
||||
(links pkg-dir
|
||||
#:remove? #t
|
||||
#:user? (not (current-install-system-wide?))
|
||||
#:root? #t)
|
||||
(delete-directory/files pkg-dir)]))
|
||||
|
||||
(define (remove-packages in-pkgs
|
||||
#:force? [force? #f]
|
||||
#:auto? [auto? #f])
|
||||
(define db (read-pkg-db))
|
||||
(define all-pkgs
|
||||
(hash-keys db))
|
||||
(define all-pkgs-set
|
||||
(list->set all-pkgs))
|
||||
(define pkgs
|
||||
(if auto?
|
||||
(set->list
|
||||
(set-subtract
|
||||
(list->set
|
||||
(filter
|
||||
(λ (p) (pkg-info-auto? (hash-ref db p)))
|
||||
all-pkgs))
|
||||
(list->set
|
||||
(append-map package-dependencies
|
||||
all-pkgs))))
|
||||
in-pkgs))
|
||||
(unless force?
|
||||
(define pkgs-set (list->set pkgs))
|
||||
(define remaining-pkg-db-set
|
||||
(set-subtract all-pkgs-set
|
||||
pkgs-set))
|
||||
(define deps-to-be-removed
|
||||
(set-intersect
|
||||
pkgs-set
|
||||
(list->set
|
||||
(append-map package-dependencies
|
||||
(set->list
|
||||
remaining-pkg-db-set)))))
|
||||
(unless (set-empty? deps-to-be-removed)
|
||||
(error 'planet2 "Cannot remove packages that are dependencies of other packages: ~e"
|
||||
(set->list deps-to-be-removed))))
|
||||
(for-each remove-package pkgs))
|
||||
|
||||
(define (install-packages
|
||||
#:old-infos [old-infos empty]
|
||||
#:old-auto+pkgs [old-auto+pkgs empty]
|
||||
#:pre-succeed [pre-succeed void]
|
||||
#:dep-behavior [dep-behavior #f]
|
||||
#:updating? [updating? #f]
|
||||
#:ignore-checksums? [ignore-checksums? #f]
|
||||
#:link? [link? #f]
|
||||
#:force? [force? #f]
|
||||
auto+pkgs)
|
||||
(define check-sums? (not ignore-checksums?))
|
||||
(define (install-package pkg
|
||||
#:pkg-name [given-pkg-name #f])
|
||||
(define pkg-url (and (string? pkg) (string->url pkg)))
|
||||
(cond
|
||||
[(file-exists? pkg)
|
||||
(define checksum-pth (format "~a.CHECKSUM" pkg))
|
||||
(define expected-checksum
|
||||
(and (file-exists? checksum-pth)
|
||||
check-sums?
|
||||
(file->string checksum-pth)))
|
||||
(define actual-checksum
|
||||
(with-input-from-file pkg
|
||||
(λ ()
|
||||
(sha1 (current-input-port)))))
|
||||
(unless (or (not expected-checksum)
|
||||
(string=? expected-checksum actual-checksum))
|
||||
(error 'pkg "Incorrect checksum on package: expected ~e, got ~e"
|
||||
expected-checksum actual-checksum))
|
||||
(define checksum
|
||||
actual-checksum)
|
||||
(define pkg-format (filename-extension pkg))
|
||||
(define pkg-name
|
||||
(or given-pkg-name
|
||||
(regexp-replace
|
||||
(regexp
|
||||
(format "~a$" (regexp-quote (format ".~a" pkg-format))))
|
||||
(path->string (file-name-from-path pkg))
|
||||
"")))
|
||||
(define pkg-dir
|
||||
(make-temporary-file (string-append "~a-" pkg-name)
|
||||
'directory))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(make-directory* pkg-dir)
|
||||
|
||||
(match pkg-format
|
||||
[#"tgz"
|
||||
(untar pkg pkg-dir)]
|
||||
[#"zip"
|
||||
(system* (find-executable-path "unzip")
|
||||
"-n" pkg "-d" pkg-dir)]
|
||||
[#"plt"
|
||||
(unplt pkg pkg-dir)]
|
||||
[x
|
||||
(error 'pkg "Invalid package format: ~e" x)])
|
||||
|
||||
(update-install-info-checksum
|
||||
(update-install-info-orig-pkg
|
||||
(install-package pkg-dir
|
||||
#:pkg-name pkg-name)
|
||||
`(file ,(simple-form-path* pkg)))
|
||||
checksum))
|
||||
(λ ()
|
||||
(delete-directory/files pkg-dir)))]
|
||||
[(directory-exists? pkg)
|
||||
(let ([pkg (directory-path-no-slash pkg)])
|
||||
(define pkg-name
|
||||
(or given-pkg-name (path->string (file-name-from-path pkg))))
|
||||
(cond
|
||||
[link?
|
||||
(install-info pkg-name
|
||||
`(link ,(simple-form-path* pkg))
|
||||
pkg
|
||||
#f #f)]
|
||||
[else
|
||||
(define pkg-dir
|
||||
(make-temporary-file "pkg~a" 'directory))
|
||||
(delete-directory pkg-dir)
|
||||
(make-parent-directory* pkg-dir)
|
||||
(copy-directory/files pkg pkg-dir)
|
||||
(install-info pkg-name
|
||||
`(dir ,(simple-form-path* pkg))
|
||||
pkg-dir
|
||||
#t #f)]))]
|
||||
[(url-scheme pkg-url)
|
||||
=>
|
||||
(lambda (scheme)
|
||||
(define orig-pkg `(url ,pkg))
|
||||
(define checksum (remote-package-checksum orig-pkg))
|
||||
(define info
|
||||
(update-install-info-orig-pkg
|
||||
(match scheme
|
||||
["github"
|
||||
(match-define (list* user repo branch path)
|
||||
(map path/param-path (url-path/no-slash pkg-url)))
|
||||
(define new-url
|
||||
(url "https" #f "github.com" #f #t
|
||||
(map (λ (x) (path/param x empty))
|
||||
(list user repo "tarball" branch))
|
||||
empty
|
||||
#f))
|
||||
(define tmp.tgz
|
||||
(make-temporary-file
|
||||
(string-append
|
||||
"~a-"
|
||||
(format "~a.~a.tgz" repo branch))
|
||||
#f))
|
||||
(delete-file tmp.tgz)
|
||||
(define tmp-dir
|
||||
(make-temporary-file
|
||||
(string-append
|
||||
"~a-"
|
||||
(format "~a.~a" repo branch))
|
||||
'directory))
|
||||
(define package-path
|
||||
(apply build-path tmp-dir path))
|
||||
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(download-file! new-url tmp.tgz)
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(untar tmp.tgz tmp-dir #:strip-components 1)
|
||||
(install-package (path->string package-path)
|
||||
#:pkg-name given-pkg-name))
|
||||
(λ ()
|
||||
(delete-directory/files tmp-dir))))
|
||||
(λ ()
|
||||
(delete-directory/files tmp.tgz)))]
|
||||
[_
|
||||
(define url-last-component
|
||||
(path/param-path (last (url-path pkg-url))))
|
||||
(define url-looks-like-directory?
|
||||
(string=? "" url-last-component))
|
||||
(define-values
|
||||
(package-path package-name download-package!)
|
||||
(cond
|
||||
[url-looks-like-directory?
|
||||
(define package-name
|
||||
(path/param-path
|
||||
(second (reverse (url-path pkg-url)))))
|
||||
(define package-path
|
||||
(make-temporary-file
|
||||
(string-append
|
||||
"~a-"
|
||||
package-name)
|
||||
'directory))
|
||||
(define (path-like f)
|
||||
(build-path package-path f))
|
||||
(define (url-like f)
|
||||
(combine-url/relative pkg-url f))
|
||||
(values package-path
|
||||
package-name
|
||||
(λ ()
|
||||
(printf "\tCloning remote directory\n")
|
||||
(make-directory* package-path)
|
||||
(define manifest
|
||||
(call/input-url+200
|
||||
(url-like "MANIFEST")
|
||||
port->lines))
|
||||
(for ([f (in-list manifest)])
|
||||
(download-file! (url-like f)
|
||||
(path-like f)))))]
|
||||
[else
|
||||
(define package-path
|
||||
(make-temporary-file
|
||||
(string-append
|
||||
"~a-"
|
||||
url-last-component)
|
||||
#f))
|
||||
(delete-file package-path)
|
||||
(values package-path
|
||||
(regexp-replace
|
||||
#rx"\\.[^.]+$"
|
||||
url-last-component
|
||||
"")
|
||||
(λ ()
|
||||
(dprintf "\tAssuming URL names a file\n")
|
||||
(download-file! pkg-url package-path)))]))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(download-package!)
|
||||
(define pkg-name
|
||||
(or given-pkg-name
|
||||
package-name))
|
||||
(dprintf "\tDownloading done, installing ~a as ~a\n"
|
||||
package-path pkg-name)
|
||||
(install-package package-path
|
||||
#:pkg-name
|
||||
pkg-name))
|
||||
(λ ()
|
||||
(when (or (file-exists? package-path)
|
||||
(directory-exists? package-path))
|
||||
(delete-directory/files package-path))))])
|
||||
orig-pkg))
|
||||
(when (and check-sums?
|
||||
(install-info-checksum info)
|
||||
(not checksum))
|
||||
(error 'planet2 "Remote package ~a had no checksum"
|
||||
pkg))
|
||||
(when (and checksum
|
||||
(install-info-checksum info)
|
||||
check-sums?
|
||||
(not (equal? (install-info-checksum info) checksum)))
|
||||
(error 'planet2 "Incorrect checksum on package ~e: expected ~e, got ~e"
|
||||
pkg
|
||||
(install-info-checksum info) checksum))
|
||||
(update-install-info-checksum
|
||||
info
|
||||
checksum))]
|
||||
[else
|
||||
(define index-info (package-index-lookup pkg))
|
||||
(define source (hash-ref index-info 'source))
|
||||
(define checksum (hash-ref index-info 'checksum))
|
||||
(define info (install-package source
|
||||
#:pkg-name (or given-pkg-name pkg)))
|
||||
(when (and (install-info-checksum info)
|
||||
check-sums?
|
||||
(not (equal? (install-info-checksum info) checksum)))
|
||||
(error 'planet2 "Incorrect checksum on package: ~e" pkg))
|
||||
(update-install-info-orig-pkg
|
||||
(update-install-info-checksum
|
||||
info
|
||||
checksum)
|
||||
`(pns ,pkg))]))
|
||||
(define db (read-pkg-db))
|
||||
(define (install-package/outer infos auto+pkg info)
|
||||
(match-define (cons auto? pkg)
|
||||
auto+pkg)
|
||||
(match-define
|
||||
(install-info pkg-name orig-pkg pkg-dir clean? checksum)
|
||||
info)
|
||||
(define pns? (eq? 'pns (first orig-pkg)))
|
||||
(define (clean!)
|
||||
(when clean?
|
||||
(delete-directory/files pkg-dir)))
|
||||
(define simultaneous-installs
|
||||
(list->set (map install-info-name infos)))
|
||||
(cond
|
||||
[(and (not updating?) (package-info pkg-name #f))
|
||||
(clean!)
|
||||
(error 'planet2 "~e is already installed" pkg-name)]
|
||||
[(and
|
||||
(not force?)
|
||||
(for/or ([f (in-list (directory-list* pkg-dir))]
|
||||
#:when (member (filename-extension f)
|
||||
(list #"rkt" #"ss")))
|
||||
(or
|
||||
;; Compare with Racket
|
||||
(and (file-exists? (build-path (absolute-collects-dir) f))
|
||||
(cons "racket" f))
|
||||
;; Compare with installed packages
|
||||
(for/or ([other-pkg (in-hash-keys db)]
|
||||
#:unless (and updating? (equal? other-pkg pkg-name)))
|
||||
(define p (build-path (package-directory other-pkg) f))
|
||||
(and (file-exists? p)
|
||||
(cons other-pkg f)))
|
||||
;; Compare with simultaneous installs
|
||||
(for/or ([other-pkg-info (in-list infos)]
|
||||
#:unless (eq? other-pkg-info info))
|
||||
(define p (build-path (install-info-directory other-pkg-info) f))
|
||||
(and (file-exists? p)
|
||||
(cons (install-info-name other-pkg-info) f))))))
|
||||
=>
|
||||
(λ (conflicting-pkg*file)
|
||||
(clean!)
|
||||
(match-define (cons conflicting-pkg file) conflicting-pkg*file)
|
||||
(error 'planet2 "~e conflicts with ~e: ~e" pkg conflicting-pkg file))]
|
||||
[(and
|
||||
(not (eq? dep-behavior 'force))
|
||||
(let ()
|
||||
(define meta (file->value* (build-path pkg-dir "METADATA.rktd") empty))
|
||||
(define deps (dict-ref meta 'dependency empty))
|
||||
(define unsatisfied-deps
|
||||
(filter-not (λ (dep)
|
||||
(or (set-member? simultaneous-installs dep)
|
||||
(hash-has-key? db dep)))
|
||||
deps))
|
||||
(and (not (empty? unsatisfied-deps))
|
||||
unsatisfied-deps)))
|
||||
=>
|
||||
(λ (unsatisfied-deps)
|
||||
(match
|
||||
(or dep-behavior
|
||||
(if pns?
|
||||
'search-ask
|
||||
'fail))
|
||||
['fail
|
||||
(clean!)
|
||||
(error 'planet2 "missing dependencies: ~e" unsatisfied-deps)]
|
||||
['search-auto
|
||||
(printf "The following packages are listed as dependencies, but are not currently installed, so we will automatically install them.\n")
|
||||
(printf "\t")
|
||||
(for ([p (in-list unsatisfied-deps)])
|
||||
(printf "~a " p))
|
||||
(printf "\n")
|
||||
(raise (vector infos unsatisfied-deps))]
|
||||
['search-ask
|
||||
(printf "The following packages are listed as dependencies, but are not currently installed:\n")
|
||||
(printf "\t")
|
||||
(for ([p (in-list unsatisfied-deps)])
|
||||
(printf "~a " p))
|
||||
(printf "\n")
|
||||
(let loop ()
|
||||
(printf "Would you like to install them via your package indices? [Yn] ")
|
||||
(flush-output)
|
||||
(match (read-line)
|
||||
[(or "y" "Y" "")
|
||||
(raise (vector infos unsatisfied-deps))]
|
||||
[(or "n" "N")
|
||||
(clean!)
|
||||
(error 'planet2 "missing dependencies: ~e" unsatisfied-deps)]
|
||||
[x
|
||||
(eprintf "Invalid input: ~e\n" x)
|
||||
(loop)]))]))]
|
||||
[else
|
||||
(λ ()
|
||||
(define final-pkg-dir
|
||||
(cond
|
||||
[clean?
|
||||
(define final-pkg-dir (build-path (pkg-installed-dir) pkg-name))
|
||||
(make-parent-directory* final-pkg-dir)
|
||||
(copy-directory/files pkg-dir final-pkg-dir)
|
||||
(clean!)
|
||||
final-pkg-dir]
|
||||
[else
|
||||
pkg-dir]))
|
||||
(dprintf "creating link to ~e" final-pkg-dir)
|
||||
(links final-pkg-dir
|
||||
#:user? (not (current-install-system-wide?))
|
||||
#:root? #t)
|
||||
(define this-pkg-info
|
||||
(pkg-info orig-pkg checksum auto?))
|
||||
(dprintf "updating db with ~e to ~e" pkg-name this-pkg-info)
|
||||
(update-pkg-db! pkg-name this-pkg-info))]))
|
||||
(define infos
|
||||
(map install-package (map cdr auto+pkgs)))
|
||||
(define do-its
|
||||
(map (curry install-package/outer (append old-infos infos))
|
||||
(append old-auto+pkgs auto+pkgs)
|
||||
(append old-infos infos)))
|
||||
(pre-succeed)
|
||||
(for-each (λ (t) (t)) do-its))
|
||||
|
||||
(define (install-cmd pkgs
|
||||
#:old-infos [old-infos empty]
|
||||
#:old-auto+pkgs [old-auto+pkgs empty]
|
||||
#:force? [force #f]
|
||||
#:link? [link #f]
|
||||
#:ignore-checksums? [ignore-checksums #f]
|
||||
#:pre-succeed [pre-succeed void]
|
||||
#:dep-behavior [dep-behavior #f]
|
||||
#:updating? [updating? #f])
|
||||
(with-handlers ([vector?
|
||||
(match-lambda
|
||||
[(vector new-infos deps)
|
||||
(dprintf "\nInstallation failed with new deps: ~a\n\n"
|
||||
deps)
|
||||
|
||||
(install-cmd
|
||||
#:old-infos new-infos
|
||||
#:old-auto+pkgs (append old-auto+pkgs pkgs)
|
||||
#:force? force
|
||||
#:link? link
|
||||
#:ignore-checksums? ignore-checksums
|
||||
#:dep-behavior dep-behavior
|
||||
#:pre-succeed pre-succeed
|
||||
#:updating? updating?
|
||||
(map (curry cons #t) deps))])])
|
||||
(install-packages
|
||||
#:old-infos old-infos
|
||||
#:old-auto+pkgs old-auto+pkgs
|
||||
#:force? force
|
||||
#:link? link
|
||||
#:ignore-checksums? ignore-checksums
|
||||
#:dep-behavior dep-behavior
|
||||
#:pre-succeed pre-succeed
|
||||
#:updating? updating?
|
||||
pkgs)))
|
||||
|
||||
(define (update-is-possible? pkg-name)
|
||||
(match-define (pkg-info orig-pkg checksum _)
|
||||
(package-info pkg-name))
|
||||
(define ty (first orig-pkg))
|
||||
(not (member ty '(link dir file))))
|
||||
|
||||
(define (update-package pkg-name)
|
||||
(match-define (pkg-info orig-pkg checksum auto?)
|
||||
(package-info pkg-name))
|
||||
(match orig-pkg
|
||||
[`(link ,_)
|
||||
(error 'planet2 "Cannot update linked packages (~e is linked to ~e)"
|
||||
pkg-name
|
||||
orig-pkg)]
|
||||
[`(dir ,_)
|
||||
(error 'planet2 "Cannot update packages installed locally. (~e was installed via a local directory.)"
|
||||
pkg-name)]
|
||||
[`(file ,_)
|
||||
(error 'planet2 "Cannot update packages installed locally. (~e was installed via a local file.)"
|
||||
pkg-name)]
|
||||
[`(,_ ,orig-pkg-desc)
|
||||
(define new-checksum
|
||||
(remote-package-checksum orig-pkg))
|
||||
(and new-checksum
|
||||
(not (equal? checksum new-checksum))
|
||||
(cons pkg-name (cons auto? orig-pkg-desc)))]))
|
||||
|
||||
(define (package-dependencies pkg-name)
|
||||
(define pkg-dir (package-directory pkg-name))
|
||||
(define meta (file->value* (build-path pkg-dir "METADATA.rktd") empty))
|
||||
(dict-ref meta 'dependency empty))
|
||||
|
||||
(define (update-packages in-pkgs
|
||||
#:dep-behavior [dep-behavior #f]
|
||||
#:deps? [deps? #f])
|
||||
(define pkgs
|
||||
(cond
|
||||
[(empty? in-pkgs)
|
||||
(filter update-is-possible? (hash-keys (read-pkg-db)))]
|
||||
[deps?
|
||||
(append-map
|
||||
package-dependencies
|
||||
in-pkgs)]
|
||||
[else
|
||||
in-pkgs]))
|
||||
(define to-update (filter-map update-package pkgs))
|
||||
(cond
|
||||
[(empty? to-update)
|
||||
(printf "No updates available\n")]
|
||||
[else
|
||||
(install-cmd
|
||||
#:updating? #t
|
||||
#:pre-succeed (λ () (for-each (compose remove-package car) to-update))
|
||||
#:dep-behavior dep-behavior
|
||||
(map cdr to-update))]))
|
||||
|
||||
(define (show-cmd)
|
||||
(let ()
|
||||
(define db (read-pkg-db))
|
||||
(define pkgs (sort (hash-keys db) string-ci<=?))
|
||||
(table-display
|
||||
(list*
|
||||
(list "Package(auto?)" "Checksum" "Source")
|
||||
(for/list ([pkg (in-list pkgs)])
|
||||
(match-define (pkg-info orig-pkg checksum auto?) (hash-ref db pkg))
|
||||
(list (format "~a~a"
|
||||
pkg
|
||||
(if auto?
|
||||
"*"
|
||||
""))
|
||||
(format "~a" checksum)
|
||||
(format "~a" orig-pkg)))))))
|
||||
|
||||
(define (config-cmd config:set key+vals)
|
||||
(cond
|
||||
[config:set
|
||||
(match key+vals
|
||||
[(list* (and key "indexes") val)
|
||||
(update-pkg-cfg! "indexes" val)]
|
||||
[(list key)
|
||||
(error 'planet2 "unsupported config key: ~e" key)]
|
||||
[(list)
|
||||
(error 'planet2 "must provide config key")])]
|
||||
[else
|
||||
(match key+vals
|
||||
[(list key)
|
||||
(match key
|
||||
["indexes"
|
||||
(for ([s (in-list (read-pkg-cfg/def "indexes"))])
|
||||
(printf "~a\n" s))]
|
||||
[_
|
||||
(error 'planet2 "unsupported config key: ~e" key)])]
|
||||
[(list)
|
||||
(error 'planet2 "must provide config key")]
|
||||
[_
|
||||
(error 'planet2 "must provide only config key")])]))
|
||||
|
||||
(define (create-cmd create:format maybe-dir)
|
||||
(begin
|
||||
(define dir (regexp-replace* #rx"/$" maybe-dir ""))
|
||||
(unless (directory-exists? dir)
|
||||
(error 'planet2 "directory does not exist: ~e" dir))
|
||||
(match create:format
|
||||
["MANIFEST"
|
||||
(with-output-to-file
|
||||
(build-path dir "MANIFEST")
|
||||
#:exists 'replace
|
||||
(λ ()
|
||||
(for ([f (in-list (parameterize ([current-directory dir])
|
||||
(find-files file-exists?)))])
|
||||
(display f)
|
||||
(newline))))]
|
||||
[else
|
||||
(define pkg (format "~a.~a" dir create:format))
|
||||
(define pkg-name
|
||||
(regexp-replace
|
||||
(regexp (format "~a$" (regexp-quote (format ".~a" create:format))))
|
||||
(path->string (file-name-from-path pkg))
|
||||
""))
|
||||
(match create:format
|
||||
["tgz"
|
||||
(unless (system* (find-executable-path "tar") "-cvzf" pkg "-C" dir ".")
|
||||
(delete-file pkg)
|
||||
(error 'planet2 "Package creation failed"))]
|
||||
["zip"
|
||||
(define orig-pkg (normalize-path pkg))
|
||||
(parameterize ([current-directory dir])
|
||||
(unless (system* (find-executable-path "zip") "-r" orig-pkg ".")
|
||||
(delete-file pkg)
|
||||
(error 'planet2 "Package creation failed")))]
|
||||
["plt"
|
||||
(pack-plt pkg pkg-name (list dir)
|
||||
#:as-paths (list "."))]
|
||||
[x
|
||||
(error 'pkg "Invalid package format: ~e" x)])
|
||||
(define chk (format "~a.CHECKSUM" pkg))
|
||||
(with-output-to-file chk #:exists 'replace
|
||||
(λ () (display (call-with-input-file pkg sha1))))])))
|
||||
|
||||
(define dep-behavior/c
|
||||
(or/c false/c
|
||||
(symbols 'fail 'force 'search-ask 'search-auto)))
|
||||
|
||||
(provide
|
||||
with-package-lock
|
||||
(contract-out
|
||||
[current-install-system-wide?
|
||||
(parameter/c boolean?)]
|
||||
[config-cmd
|
||||
(-> boolean? list?
|
||||
void)]
|
||||
[create-cmd
|
||||
(-> string? path-string?
|
||||
void)]
|
||||
[update-packages
|
||||
(->* ((listof string?))
|
||||
(#:dep-behavior dep-behavior/c
|
||||
#:deps? boolean?)
|
||||
void)]
|
||||
[remove-packages
|
||||
(->* ((listof string?))
|
||||
(#:auto? boolean?
|
||||
#:force? boolean?)
|
||||
void)]
|
||||
[show-cmd
|
||||
(-> void)]
|
||||
[install-cmd
|
||||
(->* ((listof (cons/c boolean? string?)))
|
||||
(#:dep-behavior dep-behavior/c
|
||||
#:force? boolean?
|
||||
#:link? boolean?
|
||||
#:ignore-checksums? boolean?)
|
||||
void)]))
|
||||
91
collects/planet2/main.rkt
Normal file
91
collects/planet2/main.rkt
Normal file
|
|
@ -0,0 +1,91 @@
|
|||
#lang racket/base
|
||||
(require racket/function
|
||||
racket/system
|
||||
"lib.rkt"
|
||||
"commands.rkt")
|
||||
|
||||
(define (setup dont-setup)
|
||||
(unless (or dont-setup
|
||||
(equal? "1" (getenv "PLT_PLANET2_DONTSETUP")))
|
||||
(system "raco setup")))
|
||||
|
||||
(commands
|
||||
"This tool is used for managing installed packages."
|
||||
[install
|
||||
"Install packages"
|
||||
[#:bool dont-setup () "Don't run 'raco setup' after changing packages (generally not a good idea)"]
|
||||
[#:bool installation ("-i") "Operate on the installation-wide package database"]
|
||||
[(#:sym #f) deps ()
|
||||
("Specify the behavior for dependencies."
|
||||
"Options are: fail, force, search-ask, search-auto."
|
||||
" 'fail' cancels the installation if dependencies are unmet (default for most packages)."
|
||||
" 'force' installs the package despite missing dependencies."
|
||||
" 'search-ask' looks for the dependencies on your package naming services (default if package is an indexed name) and asks if you would like it installed."
|
||||
" 'search-auto' is like 'search-ask' but does not ask for permission to install.")]
|
||||
[#:bool force () "Ignores conflicts"]
|
||||
[#:bool ignore-checksums () "Ignores checksums"]
|
||||
[#:bool link () "When used with a directory package, leave the directory in place, but add a link to it in the package directory. This is a global setting for all installs for this command, which means it affects dependencies... so make sure the dependencies exist first."]
|
||||
#:args pkgs
|
||||
(parameterize ([current-install-system-wide? installation])
|
||||
(with-package-lock
|
||||
(install-cmd #:dep-behavior deps
|
||||
#:force? force
|
||||
#:link? link
|
||||
#:ignore-checksums? ignore-checksums
|
||||
(map (curry cons #f) pkgs))
|
||||
(setup dont-setup)))]
|
||||
[update
|
||||
"Update packages"
|
||||
[#:bool dont-setup () "Don't run 'raco setup' after changing packages (generally not a good idea)"]
|
||||
[#:bool installation ("-i") "Operate on the installation-wide package database"]
|
||||
[(#:sym #f) deps ()
|
||||
("Specify the behavior for dependencies."
|
||||
"Options are: fail, force, search-ask, search-auto."
|
||||
" 'fail' cancels the installation if dependencies are unmet (default for most packages)."
|
||||
" 'force' installs the package despite missing dependencies."
|
||||
" 'search-ask' looks for the dependencies on your package naming services (default if package is an indexed name) and asks if you would like it installed."
|
||||
" 'search-auto' is like 'search-ask' but does not ask for permission to install.")]
|
||||
[#:bool update-deps () "Check named packages' dependencies for updates"]
|
||||
#:args pkgs
|
||||
(parameterize ([current-install-system-wide? installation])
|
||||
(with-package-lock
|
||||
(update-packages pkgs
|
||||
#:dep-behavior deps
|
||||
#:deps? update-deps)
|
||||
(setup dont-setup)))]
|
||||
[remove
|
||||
"Remove packages"
|
||||
[#:bool dont-setup () "Don't run 'raco setup' after changing packages (generally not a good idea)"]
|
||||
[#:bool installation ("-i") "Operate on the installation-wide package database"]
|
||||
[#:bool force () "Force removal of packages"]
|
||||
[#:bool auto () "Remove automatically installed packages with no dependencies"]
|
||||
#:args pkgs
|
||||
(parameterize ([current-install-system-wide? installation])
|
||||
(with-package-lock
|
||||
(remove-packages pkgs
|
||||
#:auto? auto
|
||||
#:force? force)
|
||||
(setup dont-setup)))]
|
||||
[show
|
||||
"Show information about installed packages"
|
||||
[#:bool installation ("-i") "Operate on the installation-wide package database"]
|
||||
#:args ()
|
||||
(parameterize ([current-install-system-wide? installation])
|
||||
(with-package-lock
|
||||
(show-cmd)))]
|
||||
[config
|
||||
"View and modify the package configuration"
|
||||
[#:bool installation ("-i") "Operate on the installation-wide package database"]
|
||||
[#:bool set () "Completely replace the value"]
|
||||
#:args key+vals
|
||||
(parameterize ([current-install-system-wide? installation])
|
||||
(with-package-lock
|
||||
(config-cmd set key+vals)))]
|
||||
[create
|
||||
"Bundle a new package"
|
||||
[(#:str "plt") format ()
|
||||
("Select the format of the package to be created."
|
||||
"Options are: tgz, zip, plt")]
|
||||
[#:bool manifest () "Creates a manifest file for a directory, rather than an archive"]
|
||||
#:args (maybe-dir)
|
||||
(create-cmd (if manifest "MANIFEST" format) maybe-dir)])
|
||||
2
collects/planet2/raco.rkt
Normal file
2
collects/planet2/raco.rkt
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
#lang racket/base
|
||||
(require (submod "main.rkt" main))
|
||||
667
collects/planet2/scribblings/planet2.scrbl
Normal file
667
collects/planet2/scribblings/planet2.scrbl
Normal file
|
|
@ -0,0 +1,667 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(define pkgname onscreen)
|
||||
@(define reponame litchar)
|
||||
|
||||
@title{Planet 2: Package Distribution (Beta)}
|
||||
@author[@author+email["Jay McCarthy" "jay@racket-lang.org"]]
|
||||
|
||||
Planet 2 is a system for managing the use of external code packages in
|
||||
your Racket installation.
|
||||
|
||||
@table-of-contents[]
|
||||
|
||||
@section{Planet 2 Concepts}
|
||||
|
||||
A @deftech{package} is a set of modules from some number of
|
||||
collections. @tech{Packages} also have associated @tech{package
|
||||
metadata}.
|
||||
|
||||
@deftech{Package metadata} is:
|
||||
@itemlist[
|
||||
@item{a name -- a string made of the characters: @litchar{a-zA-Z0-9_-}.}
|
||||
@item{a list of dependencies -- a list of strings that name other packages that must be installed simultaneously.}
|
||||
@item{a checksum -- a string that identifies different releases of a package.}
|
||||
]
|
||||
|
||||
A @tech{package} is typically represented by a directory with the same
|
||||
name as the package which contains a file named
|
||||
@filepath{METADATA.rktd} formatted as:
|
||||
@verbatim{
|
||||
((dependency "dependency1" ... "dependencyn"))
|
||||
}
|
||||
The checksum is typically left implicit.
|
||||
|
||||
A @deftech{package source} identifies a @tech{package}
|
||||
representation. Each package source type has a different way of
|
||||
storing the checksum. The valid package source types are:
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{a local file path naming an archive -- The name of the package
|
||||
is the basename of the archive file. The checksum for archive
|
||||
@filepath{f.ext} is given by the file @filepath{f.ext.CHECKSUM}. For
|
||||
example, @filepath{~/tic-tac-toe.zip}'s checksum would be inside
|
||||
@filepath{~/tic-tac-toe.zip.CHECKSUM}. The valid archive formats
|
||||
are (currently): @filepath{.zip}, @filepath{.tgz}, and
|
||||
@filepath{.plt}. }
|
||||
|
||||
@item{a local directory -- The name of the package is the name of the
|
||||
directory. The checksum is not present. For example,
|
||||
@filepath{~/tic-tac-toe}.}
|
||||
|
||||
@item{a remote URL naming an archive -- This type follows the same
|
||||
rules as a local file path, but the archive and checksum files are
|
||||
accessed via HTTP(S). For example,
|
||||
@filepath{http://game.com/tic-tac-toe.zip} and
|
||||
@filepath{http://game.com/tic-tac-toe.zip.CHECKSUM}.}
|
||||
|
||||
@item{a remote URL naming a directory -- The remote directory must
|
||||
contain a file named @filepath{MANIFEST} that lists all the contingent
|
||||
files. These are downloaded into a local directory and then the rules
|
||||
for local directory paths are followed. However, if the remote
|
||||
directory contains a file named @filepath{.CHECKSUM}, then it is used
|
||||
to determine the checksum. For example,
|
||||
@filepath{http://game.com/tic-tac-toe/} and
|
||||
@filepath{http://game.com/tic-tac-toe/.CHECKSUM}}
|
||||
|
||||
@item{a remote URL naming a GitHub repository -- The format for such
|
||||
URLs is:
|
||||
@filepath{github://github.com/<user>/<repository>/<branch>/<path>/<to>/<package>/<directory>}. The
|
||||
Zip formatted archive for the repository (generated by GitHub for
|
||||
every branch) is used as a remote URL archive path, except the
|
||||
checksum is the hash identifying the branch. For example,
|
||||
@filepath{github://github.com/game/tic-tac-toe/master/}.}
|
||||
|
||||
@item{a bare package name -- The local list of @tech{package name
|
||||
services} is consulted to determine the source and checksum for the
|
||||
package. For example, @pkgname{tic-tac-toe}.}
|
||||
|
||||
]
|
||||
|
||||
A @deftech{package name service} (PNS) is a string representing a URL,
|
||||
such that appending @filepath{/pkg/<package-name>} to it will respond
|
||||
with a @racket[read]-able hash table with the keys: @racket['source]
|
||||
bound to the source and @racket['checksum] bound to the
|
||||
checksum. Typically, the source will be a remote URL string.
|
||||
|
||||
PLT supports two @tech{package name services}, which are enabled by
|
||||
default: @filepath{https://plt-etc.cs.byu.edu:9004} for new Planet 2
|
||||
packages and @filepath{https://plt-etc.cs.byu.edu:9003} for
|
||||
automatically generated Planet 2 packages for old Planet 1
|
||||
packages. Anyone may host their own @tech{package name service}. The
|
||||
source for the PLT-hosted servers is in the
|
||||
@racket[(build-path (find-collects-dir) "meta" "planet2-index")]
|
||||
directory.
|
||||
|
||||
After a package is installed, the original source of its installation
|
||||
is recorded, as well as if it was an @tech{automatic installation}. An
|
||||
@deftech{automatic installation} is one that was installed because it
|
||||
was a dependency of a non-@tech{automatic installation} package.
|
||||
|
||||
Two packages are in @deftech{conflict} if they contain the same
|
||||
module. For example, if the package @pkgname{tic-tac-toe} contains the
|
||||
module file @filepath{data/matrix.rkt} and the package
|
||||
@pkgname{factory-optimize} contains the module file
|
||||
@filepath{data/matrix.rkt}, then @pkgname{tic-tac-toe} and
|
||||
@pkgname{factory-optimize} are in conflict. A package may also be in
|
||||
conflict with Racket itself, if it contains a module file that is part
|
||||
of the core Racket distribution. For example, any package that
|
||||
contains @filepath{racket/list.rkt} is in conflict with Racket. For
|
||||
the purposes of conflicts, a module is a file that ends in
|
||||
@litchar{.rkt} or @litchar{.ss}.
|
||||
|
||||
Package A is a @deftech{package update} of Package B if (1) B is
|
||||
installed, (2) A and B have the same name, and (3) A's checksum is
|
||||
different than B's.
|
||||
|
||||
@section{Using Planet 2}
|
||||
|
||||
Planet 2 has two user interfaces: a command line @exec{raco}
|
||||
sub-command and a library. They have the exact same capabilities, as
|
||||
the command line interface invokes the library functions and
|
||||
reprovides all their options.
|
||||
|
||||
@subsection{Command Line}
|
||||
|
||||
The @exec{raco pkg} sub-command provides the following
|
||||
sub-sub-commands:
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{@exec{install pkg ...} -- Installs the list of packages. It accepts the following options:
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{@DFlag{dont-setup} -- Does not run @exec{raco setup} after installation. This behavior is also the case if the environment variable @envvar{PLT_PLANET2_DONTSETUP} is set to @litchar{1}.}
|
||||
|
||||
@item{@DFlag{installation} -- Install system-wide rather than user-local.}
|
||||
|
||||
@item{@Flag{i} -- Alias for @DFlag{installation}.}
|
||||
|
||||
@item{@DFlag{deps} @exec{dep-behavior} -- Selects the behavior for dependencies. The options are:
|
||||
@itemlist[
|
||||
@item{@exec{fail} -- Cancels the installation if dependencies are unmet (default for most packages)}
|
||||
@item{@exec{force} -- Installs the package(s) despite missing dependencies (unsafe)}
|
||||
@item{@exec{search-ask} -- Looks for the dependencies on the configured @tech{package name services} (default if the dependency is an indexed name) but asks if you would like it installed.}
|
||||
@item{@exec{search-auto} --- Like @exec{search-ask}, but does not ask for permission to install.}
|
||||
]}
|
||||
|
||||
@item{@DFlag{force} -- Ignores conflicts (unsafe.)}
|
||||
|
||||
@item{@DFlag{ignore-checksums} -- Ignores errors verifying package checksums (unsafe.)}
|
||||
|
||||
@item{@DFlag{link} -- When used with a directory package, leave the directory in place, but add a link to it in the package directory. This is a global setting for all installs for this command instance, which means it affects dependencies... so make sure the dependencies exist first.}
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@item{@exec{update pkg ...} -- Checks the list of packages for
|
||||
@tech{package updates}. If no packages are given, checks every
|
||||
installed package. If an update is found, but it cannot be
|
||||
installed (e.g. it is conflicted with another installed package), then
|
||||
this command fails atomically. It accepts the following options:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{dont-setup} -- Same as for @exec{install}.}
|
||||
@item{@DFlag{installation} -- Same as for @exec{install}.}
|
||||
@item{@Flag{i} -- Same as for @exec{install}.}
|
||||
@item{@DFlag{deps} @exec{dep-behavior} -- Same as for @exec{install}.}
|
||||
@item{@DFlag{update-deps} -- Checks the named packages, and their dependencies (transitively) for updates.}
|
||||
]
|
||||
}
|
||||
|
||||
@item{@exec{remove pkg ...} -- Attempts to remove the packages. If a package is the dependency of another package that is not listed, this command fails atomically. It accepts the following options:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{dont-setup} -- Same as for @exec{install}.}
|
||||
@item{@DFlag{installation} -- Same as for @exec{install}.}
|
||||
@item{@Flag{i} -- Same as for @exec{install}.}
|
||||
@item{@DFlag{force} -- Ignore dependencies when removing packages.}
|
||||
@item{@DFlag{auto} -- Remove packages that were installed by the @exec{search-auto} and @exec{search-ask} dependency behavior that are no longer required.}
|
||||
]
|
||||
}
|
||||
|
||||
@item{@exec{show} -- Print information about currently installed packages. It accepts the following options:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{installation} -- Same as for @exec{install}.}
|
||||
@item{@Flag{i} -- Same as for @exec{install}.}
|
||||
]
|
||||
}
|
||||
|
||||
@item{@exec{config key val ...} -- View and modify Planet 2 configuration options. It accepts the following options:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{installation} -- Same as for @exec{install}.}
|
||||
@item{@Flag{i} -- Same as for @exec{install}.}
|
||||
@item{@DFlag{set} -- Sets an option, rather than printing it.}
|
||||
]
|
||||
|
||||
The valid keys are:
|
||||
@itemlist[
|
||||
@item{@exec{indexes} -- A list of URLs for @tech{package name services}.}
|
||||
]
|
||||
}
|
||||
|
||||
@item{@exec{create package-directory} -- Bundles a package. It accepts the following options:
|
||||
|
||||
@itemlist[
|
||||
@item{@DFlag{format str} -- Specifies the archive format. The options are: @exec{tgz}, @exec{zip}, and @exec{plt} (default.)}
|
||||
@item{@DFlag{manifest} -- Creates a manifest file for a directory, rather than an archive.}
|
||||
]
|
||||
}
|
||||
]
|
||||
|
||||
@subsection{Programmatic}
|
||||
@(require (for-label planet2))
|
||||
|
||||
@defmodule[planet2]
|
||||
|
||||
The @racketmodname[planet2] module provides a programmatic interface to
|
||||
the command sub-sub-commands. Each long form option is keyword
|
||||
argument. @DFlag{deps} accepts its argument as a symbol and
|
||||
@DFlag{format} accepts its argument as a string. All other options
|
||||
accept booleans, where @racket[#t] is equivalent to the presence of
|
||||
the option.
|
||||
|
||||
@deftogether[
|
||||
(@defthing[install procedure?]
|
||||
@defthing[update procedure?]
|
||||
@defthing[remove procedure?]
|
||||
@defthing[show procedure?]
|
||||
@defthing[config procedure?]
|
||||
@defthing[create procedure?])
|
||||
]{
|
||||
Duplicates the command line interface.
|
||||
}
|
||||
|
||||
@section{Developing Planet 2 Packages}
|
||||
|
||||
This section walks through the setup for a basic Planet 2 package.
|
||||
|
||||
First, make a directory for your package and select its name:
|
||||
|
||||
@commandline{mkdir <package-name>}
|
||||
|
||||
Next, link your development directory to your local package
|
||||
repository:
|
||||
|
||||
@commandline{raco pkg install --link <package-name>}
|
||||
|
||||
Next, enter your directory and create a basic @tech{package metadata}
|
||||
file:
|
||||
|
||||
@commandline{cd <package-name>}
|
||||
@commandline{echo "((dependency))" > METADATA.rktd}
|
||||
|
||||
Next, inside this directory, create directories for the collections
|
||||
and modules that your package will provide. For example,
|
||||
the developer of @pkgname{tic-tac-toe} might do:
|
||||
|
||||
@commandline{mkdir -p games/tic-tac-toe}
|
||||
@commandline{touch games/tic-tac-toe/info.rkt}
|
||||
@commandline{touch games/tic-tac-toe/main.rkt}
|
||||
@commandline{mkdir -p data}
|
||||
@commandline{touch data/matrix.rkt}
|
||||
|
||||
After your package is ready to deploy choose one of the following
|
||||
options:
|
||||
|
||||
@subsection{Github Deployment}
|
||||
|
||||
First, create a free account on
|
||||
Github (@link["https://github.com/signup/free"]{signup here}). Then
|
||||
create a repository for your
|
||||
package (@link["https://github.com/new"]{here} (@link["https://help.github.com/articles/create-a-repo"]{documentation}).)
|
||||
Then initialize the Git repository locally and do your first push:
|
||||
|
||||
@commandline{git init}
|
||||
@commandline{git add *}
|
||||
@commandline{git commit -m "First commit"}
|
||||
@commandline{git remote add origin https://github.com/<username>/<package-name>.git}
|
||||
@commandline{git push origin master}
|
||||
|
||||
Now, publish your package source as:
|
||||
|
||||
@exec{github://github.com/<username>/<package-name>/<branch>}
|
||||
|
||||
(Typically, <branch> will be @litchar{master}, but you may wish to use
|
||||
different branches for releases and development.)
|
||||
|
||||
Now, whenever you
|
||||
|
||||
@commandline{git push}
|
||||
|
||||
Your changes will automatically be discovered by those who used your
|
||||
package source.
|
||||
|
||||
@subsection{Manual Deployment}
|
||||
|
||||
Alternatively, you can deploy your package by publishing it on a URL
|
||||
you control. If you do this, it is preferable to create an archive
|
||||
first:
|
||||
|
||||
@commandline{raco pkg create <package-name>}
|
||||
|
||||
And then upload the archive and its checksum to your site:
|
||||
|
||||
@commandline{scp <package-name>.plt <package-name>.plt.CHECKSUM your-host:public_html/}
|
||||
|
||||
Now, publish your package source as:
|
||||
|
||||
@exec{http://your-host/~<username>/<package-name>.plt}
|
||||
|
||||
Now, whenever you want to release a new version, recreate and reupload
|
||||
the package archive (and checksum). Your changes will automatically be
|
||||
discovered by those who used your package source.
|
||||
|
||||
@subsection{Helping Others Discover Your Package}
|
||||
|
||||
By using either of the above deployment techniques, anyone will be
|
||||
able to use your package. However, they will not be able to refer to
|
||||
it by name until it is listed on a @tech{package name service}.
|
||||
|
||||
If you'd like to use the official @tech{package name service}, browse
|
||||
to
|
||||
@link["https://plt-etc.byu.edu:9004/manage/upload"]{https://plt-etc.byu.edu:9004/manage/upload}
|
||||
and upload a new package. You will need to create an account and log
|
||||
in first.
|
||||
|
||||
You only need to go to this site @emph{once} to list your package. The
|
||||
server will periodically check the package source you designate for
|
||||
updates.
|
||||
|
||||
If you use this server, and use Github for deployment, then you will
|
||||
never need to open a Web browser to update your package for end
|
||||
users. You just need to push to your Github repository, then within 24
|
||||
hours, the official @tech{package name service} will notice, and
|
||||
@exec{raco pkg update} will work on your user's machines.
|
||||
|
||||
@subsection{Naming and Designing Packages}
|
||||
|
||||
Although of course not required, we suggest the following system for
|
||||
naming and designing packages:
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{Packages should not include the name of the author or
|
||||
organization that produces them, but be named based on the content of
|
||||
the package. For example, @pkgname{data-priority-queue} is preferred
|
||||
to @pkgname{johns-amazing-queues}.}
|
||||
|
||||
@item{Packages that provide an interface to a foreign library or
|
||||
service should be named the same as the service. For example,
|
||||
@pkgname{cairo} is preferred to @pkgname{Racket-cairo} or a similar
|
||||
name.}
|
||||
|
||||
@item{Packages should not generally contain version-like elements in
|
||||
their names, initially. Instead, version-like elements should be added
|
||||
when backwards incompatible changes are necessary. For example,
|
||||
@pkgname{data-priority-queue} is preferred to
|
||||
@pkgname{data-priority-queue1}. Exceptions include packages that
|
||||
present interfaces to external, versioned things, such as
|
||||
@pkgname{sqlite3} or @pkgname{libgtk2}.}
|
||||
|
||||
@item{Packages should not include large sets of utilities libraries
|
||||
that are likely to cause conflicts. For example, packages should not
|
||||
contain many extensions to the @filepath{racket} collection, like
|
||||
@filepath{racket/more-lists.rkt} and
|
||||
@filepath{racket/more-bools.rkt}. Instead, such as extensions should
|
||||
be separated into their own packages.}
|
||||
|
||||
@item{Packages should generally provide one collection with a name
|
||||
similar to the name of the package. For example, @pkgname{libgtk1}
|
||||
should provide a collection named @filepath{libgtk}. Exceptions
|
||||
include extensions to existing collection, such as new data-structures
|
||||
for the @filepath{data} collection, DrRacket tools, new games for PLT
|
||||
Games, etc. But see the next bullet as well.}
|
||||
|
||||
@item{Packages should make use of general collections, such as
|
||||
@filepath{tests} and @filepath{typed}, rather than including their own
|
||||
sub-collections for tests, typed interfaces, documentation, etc.}
|
||||
|
||||
@item{Packages are not allowed to start with @pkgname{plt},
|
||||
@pkgname{racket}, or @pkgname{planet} without special approval from
|
||||
PLT curation.}
|
||||
|
||||
]
|
||||
|
||||
@section{Planet 1 Compatibility}
|
||||
|
||||
PLT maintains a Planet 1 compatibility @tech{package name service} at
|
||||
@link["https://plt-etc.byu.edu:9003/"]{https://plt-etc.byu.edu:9003/}. This
|
||||
PNS is included by default in the Planet search path.
|
||||
|
||||
Planet 2 copies of Planet 1 packages are automatically created by this
|
||||
server according to the following system: for all packages that are in
|
||||
the @litchar{4.x} Planet 1 repository, the latest minor version of
|
||||
@tt{<user>/<package>.plt/<major-version>} will be available as
|
||||
@pkgname{planet-<user>-<package><major-version>}. For example,
|
||||
@tt{jaymccarthy/opencl.plt/1} minor version @tt{2}, will be available as
|
||||
@pkgname{planet-jaymccarthy-opencl1}.
|
||||
|
||||
The contents of these copies is a single collection with the name
|
||||
@filepath{<user>/<package><major-version>} with all the files from the
|
||||
original Planet 1 package in it.
|
||||
|
||||
Each file has been transliterated to use direct Racket-style requires
|
||||
rather than Planet 1-style requires. For example, if any file contains
|
||||
@racket[(planet jaymccarthy/opencl/module)], then it is transliterated
|
||||
to @racket[jaymccarthy/opencl1/module]. @emph{This transliteration is
|
||||
purely syntactic and is trivial to confuse, but works for most
|
||||
packages, in practice.}
|
||||
|
||||
Any transliterations that occurred are automatically added as
|
||||
dependencies for the Planet 2 compatibility package.
|
||||
|
||||
We do not intend to improve this compatibility system much more over
|
||||
time, because it is simply a stop-gap as developers port their
|
||||
packages to Planet 2.
|
||||
|
||||
@section{FAQ}
|
||||
|
||||
This section answers anticipated frequently asked questions about
|
||||
Planet 2.
|
||||
|
||||
@subsection{Are package installations versioned with respect to the
|
||||
Racket version?}
|
||||
|
||||
No. When you install a Planet 2 package, it is installed for all
|
||||
versions of Racket until you remove it. (In contrast, Planet 1
|
||||
requires reinstallation of all packages every version change.)
|
||||
|
||||
@subsection{Where and how are packages installed?}
|
||||
|
||||
User-local packages are in @racket[(build-path (find-system-path
|
||||
'addon-dir) "pkgs")] and installation-wide packages are in
|
||||
@racket[(build-path (find-lib-dir) "pkgs")]. They are linked as
|
||||
collection roots with @exec{raco link}.
|
||||
|
||||
@subsection{How are user-local and installation-wide packages
|
||||
related?}
|
||||
|
||||
They are totally distinct: packages are not compared with one another
|
||||
for conflicts.
|
||||
|
||||
This is because it would be in-feasible to check them reliably. For
|
||||
example, if a system package is being installed by user A, then how
|
||||
could the system know that user B exists so B's packages could be
|
||||
checked for conflicts?
|
||||
|
||||
We anticipate that most users will only one kind of package. The
|
||||
majority of users will employ user-local packages but classes or other
|
||||
shared workspaces might exclusively employ installation-wide packages.
|
||||
|
||||
@subsection{If packages have no version numbers, how can I update
|
||||
packages with error fixes, etc?}
|
||||
|
||||
If you have a new version of the code for a package, then it will have
|
||||
a new checksum. When package updates are searched for, the checksum of
|
||||
the installed package is compared with the checksum of the source, if
|
||||
they are different, then the source is re-installed. This allows code
|
||||
changes to be distributed.
|
||||
|
||||
@subsection{If packages have no version numbers, how can I specify
|
||||
which version of a package I depend on if its interface has changed
|
||||
and I need an old version?}
|
||||
|
||||
In such a situation, the author of the package has released a
|
||||
backwards incompatible edition of a package. It is not possible in
|
||||
Planet 2 to deal with this situation. (Other than, of course, not
|
||||
installing the "update".) Therefore, package authors should not make
|
||||
backwards incompatible changes to packages. Instead, they should
|
||||
release a new package with a new name. For example, package
|
||||
@pkgname{libgtk} might become @pkgname{libgtk2}. These packages
|
||||
should be designed to not conflict with each other, as well.
|
||||
|
||||
@subsection{Why is Planet 2 so different than Planet 1?}
|
||||
|
||||
There are two fundamental differences between Planet 1 and Planet 2.
|
||||
|
||||
The first is that Planet 1 uses "internal linking" whereas Planet 2
|
||||
uses "external linking". For example, an individual module requires a
|
||||
Planet 1 package directly in a require statement:
|
||||
|
||||
@racketblock[
|
||||
(require (planet game/tic-tac-toe/data/matrix))
|
||||
]
|
||||
|
||||
whereas in Planet 2, the module would simply require the module of
|
||||
interest:
|
||||
|
||||
@racketblock[
|
||||
(require data/matrix)
|
||||
]
|
||||
|
||||
and would rely on the external system having the
|
||||
@pkgname{tic-tac-toe} package installed.
|
||||
|
||||
This change is good because it makes the origin of modules more
|
||||
flexible---so that code can migrate in and out of the core, packages
|
||||
can easily be split up, combined, or taken over by other authors, etc.
|
||||
|
||||
This change is bad because it makes the meaning of your program
|
||||
dependent on the state of the system. (This is already true of Racket
|
||||
code in general, because there's no way to make the required core
|
||||
version explicit, but the problem will be exacerbated by Planet 2.)
|
||||
|
||||
The second major difference is that Planet 1 is committed to
|
||||
guaranteeing that packages that never conflict with one another, so
|
||||
that any number of major and minor versions of the same package can be
|
||||
installed and used simultaneously. Planet 2 does not share this
|
||||
commitment, so package authors and users must be mindful of potential
|
||||
conflicts and plan around them.
|
||||
|
||||
This change is good because it is simpler and lowers the burden of
|
||||
maintenance (provided most packages don't conflict.)
|
||||
|
||||
The change is bad because users must plan around potential conflicts.
|
||||
|
||||
In general, the goal of Planet 2 is to be a lower-level package
|
||||
system, more like the package systems used by operating systems. The
|
||||
goals of Planet 1 are not bad, but we believe they are needed
|
||||
infrequently and a system like Planet 1 could be more easily built
|
||||
atop Planet 2 than the reverse.
|
||||
|
||||
In particular, our plans to mitigate the downsides of these changes
|
||||
are documented in @secref["short-term"].
|
||||
|
||||
@section{Future Plans}
|
||||
|
||||
@subsection[#:tag "short-term"]{Short Term}
|
||||
|
||||
This section lists some short term plans for Planet 2. These are
|
||||
important, but didn't block its release. Planet 2 will be considered
|
||||
out of beta when these are completed.
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{It has not been tested on Windows or Mac OS X.}
|
||||
|
||||
@item{The official PNS will divide packages into three
|
||||
categories: @reponame{planet}, @reponame{solar-system}, and @reponame{galaxy}. The definitions
|
||||
for these categories are:
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{@reponame{galaxy} -- No restrictions.}
|
||||
|
||||
@item{@reponame{solar-system} -- Must not conflict any package
|
||||
in @reponame{solar-system} or @reponame{planet}.}
|
||||
|
||||
@item{@reponame{planet} -- Must not conflict any package in @reponame{solar-system}
|
||||
or @reponame{planet}. Must have documentation and tests. The author must be
|
||||
responsive about fixing regressions against changes in Racket, etc.}
|
||||
|
||||
]
|
||||
|
||||
This categories will be curated by PLT.
|
||||
|
||||
Our goal is for all packages to be in the @reponame{solar-system}, with
|
||||
the @reponame{galaxy} as a temporary place while the curators work with the
|
||||
authors of conflicting packages to determine how modules should be
|
||||
renamed for unity.
|
||||
|
||||
However, before curation is complete, each package will be
|
||||
automatically placed in @reponame{galaxy} or @reponame{solar-system}
|
||||
depending on its conflicts, with preference being given to older
|
||||
packages. (For example, if a new package B conflicts with an old
|
||||
package A, then A will be in @reponame{solar-system}, but B will be in
|
||||
@reponame{galaxy}.) During curation, however, it is not necessarily
|
||||
the case that older packages have preference. (For example,
|
||||
@pkgname{tic-tac-toe} should probably not provide
|
||||
@filepath{data/matrix.rkt}, but that could be spun off into another
|
||||
package used by both @pkgname{tic-tac-toe} and
|
||||
@pkgname{factory-optimize}.)
|
||||
|
||||
In contrast, the @reponame{planet} category will be a special category that
|
||||
authors may apply for. Admission requires a code audit and implies
|
||||
a "stamp of approval" from PLT. In the future, packages in this
|
||||
category will have more benefits, such as automatic regression testing
|
||||
on DrDr, testing during releases, provided binaries, and advertisement
|
||||
during installation.
|
||||
|
||||
The Planet 1 compatibility packages will also be included in
|
||||
the @reponame{solar-system} category, automatically.
|
||||
|
||||
}
|
||||
|
||||
@item{In order to mitigate the costs of external linking vis a vis the
|
||||
inability to understand code in isolation, we will create a module
|
||||
resolver that searches for providers of modules on the configured
|
||||
@tech{package name services}. For example, if a module requires
|
||||
@filepath{data/matrix.rkt}, and it is not available, then the PNS will
|
||||
be consulted to discover what packages provide it. @emph{Only packages
|
||||
in @reponame{solar-system} or @reponame{planet} will be returned.}
|
||||
Users can configure their systems to then automatically install the
|
||||
package provide is has the appropriate category (i.e., some users may
|
||||
wish to automatically install @reponame{planet} packages but not
|
||||
@reponame{solar-system} packages, while others may not want to install
|
||||
any.)
|
||||
|
||||
This feature will be generalized across all @tech{package name
|
||||
services}, so users could maintain their own category definitions with
|
||||
different policies.}
|
||||
|
||||
]
|
||||
|
||||
@subsection{Long Term}
|
||||
|
||||
This section lists some long term plans for Planet 2. Many of these
|
||||
require a lot of cross-Racket integration.
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{The official PNS is bare bones. It could conceivably do a lot
|
||||
more: keep track of more statistics, enable "social" interactions
|
||||
about packages, link to documentation, problem reports, licenses,
|
||||
etc. Some of this is easy and obvious, but the community's needs are
|
||||
unclear.}
|
||||
|
||||
@item{It would be nice to encrypt information from the official
|
||||
@tech{package name service} with a public key shipped with Racket, and
|
||||
allow other services to implement a similar security scheme.}
|
||||
|
||||
@item{Packages in the @reponame{planet} category should be tested on
|
||||
DrDr. This would require a way to communicate information about how
|
||||
they should be run to DrDr. This is currently done via the
|
||||
@filepath{meta/props} script for things in the core. We should
|
||||
generalize this script to a @filepath{meta/props.d} directory so that
|
||||
packages can install DrDr metadata to it.}
|
||||
|
||||
@item{Packages can contain any kinds of files, including bytecode and
|
||||
documentation, which would reduce the time required to install a
|
||||
package (since we must run @exec{raco setup}). However, packages with
|
||||
these included are painful to maintain and unreliable given users with
|
||||
different versions of Racket installed.
|
||||
|
||||
One solution is to have a separate place where such "binary" packages
|
||||
are available. For example, PLT could run a PNS for every Racket
|
||||
version, i.e., @filepath{https://binaries.racket-lang.org/5.3.1.4},
|
||||
that would contain the binaries for all the packages in the
|
||||
@reponame{planet} category. Thus, when you install package
|
||||
@pkgname{tic-tac-toe} you could also install the binary version from
|
||||
the appropriate PNS.
|
||||
|
||||
There are obvious problems with this... it could be expensive for PLT
|
||||
in terms of space and time... Racket compilation is not necessarily
|
||||
deterministic or platform-independent.
|
||||
|
||||
This problem requires more thought.}
|
||||
|
||||
@item{The user interface could be improved, including integration with
|
||||
DrRacket and a GUI. For example, it would be good if DrRacket would
|
||||
poll for package updates periodically and if when it was first started
|
||||
it would display available, popular packages.}
|
||||
|
||||
@item{The core distribution should be split apart into many more
|
||||
packages. For example, Redex, Plot, the Web Server, and the teaching
|
||||
languages are natural candidates for being broken off.}
|
||||
|
||||
@item{The core should be able to be distributed with packages that
|
||||
will be installed as soon as the system is installed. Ideally, this
|
||||
would be customizable by instructors so they could share small
|
||||
distributions with just the right packages for their class.}
|
||||
|
||||
]
|
||||
46
collects/planet2/util-plt.rkt
Normal file
46
collects/planet2/util-plt.rkt
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
#lang racket/base
|
||||
(require racket/list
|
||||
racket/port
|
||||
racket/file
|
||||
racket/contract
|
||||
setup/unpack)
|
||||
|
||||
;; After PR12904 is fixed, hopefully I won't need this.
|
||||
|
||||
(define (unplt pkg pkg-dir)
|
||||
(define (path-descriptor->path pd)
|
||||
(if (or (eq? 'same pd)
|
||||
(path? pd))
|
||||
pd
|
||||
(second pd)))
|
||||
(define (write-file file* content-p)
|
||||
(define file (path-descriptor->path file*))
|
||||
#;(printf "\twriting ~a\n" file)
|
||||
(with-output-to-file
|
||||
(build-path pkg-dir file)
|
||||
(λ () (copy-port content-p (current-output-port)))))
|
||||
|
||||
(fold-plt-archive pkg
|
||||
void
|
||||
void
|
||||
(λ (dir* _a)
|
||||
(define dir (path-descriptor->path dir*))
|
||||
#;(printf "\tmaking ~a\n" dir)
|
||||
(define new-dir
|
||||
(build-path pkg-dir
|
||||
dir))
|
||||
(unless (or (equal? (build-path 'same)
|
||||
dir)
|
||||
(directory-exists? new-dir))
|
||||
(make-directory* new-dir)))
|
||||
(case-lambda
|
||||
[(file content-p _a)
|
||||
(write-file file content-p)]
|
||||
[(file content-p _m _a)
|
||||
(write-file file content-p)])
|
||||
(void)))
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
[unplt (-> path-string? path-string?
|
||||
void?)]))
|
||||
68
collects/planet2/util.rkt
Normal file
68
collects/planet2/util.rkt
Normal file
|
|
@ -0,0 +1,68 @@
|
|||
#lang racket/base
|
||||
(require racket/path
|
||||
racket/list
|
||||
racket/function
|
||||
racket/file
|
||||
racket/port
|
||||
racket/match
|
||||
net/url
|
||||
json)
|
||||
|
||||
(define (make-parent-directory* p)
|
||||
(define parent (path-only p))
|
||||
(make-directory* parent))
|
||||
|
||||
(define (table-display l)
|
||||
(define how-many-cols (length (first l)))
|
||||
(define max-widths
|
||||
(for/list ([col (in-range how-many-cols)])
|
||||
(apply max (map (compose string-length (curryr list-ref col)) l))))
|
||||
(for ([row (in-list l)])
|
||||
(for ([col (in-list row)]
|
||||
[i (in-naturals 1)]
|
||||
[width (in-list max-widths)])
|
||||
(printf "~a~a"
|
||||
col
|
||||
(if (= i how-many-cols)
|
||||
""
|
||||
(make-string (+ (- width (string-length col)) 4) #\space))))
|
||||
(printf "\n")))
|
||||
|
||||
(define (call/input-url+200 u fun)
|
||||
#;(printf "\t\tReading ~a\n" (url->string u))
|
||||
(define-values (ip hs) (get-pure-port/headers u #:redirections 25 #:status? #t))
|
||||
(and (string=? "200" (substring hs 9 12))
|
||||
(fun ip)))
|
||||
|
||||
(define (url-path/no-slash url)
|
||||
(define p (url-path url))
|
||||
(define rp (reverse p))
|
||||
(reverse
|
||||
(match rp
|
||||
[(list* (path/param "" _) rest)
|
||||
rest]
|
||||
[_ rp])))
|
||||
|
||||
(define (package-url->checksum pkg-url-str)
|
||||
(define pkg-url
|
||||
(string->url pkg-url-str))
|
||||
(match (url-scheme pkg-url)
|
||||
["github"
|
||||
(match-define (list* user repo branch path)
|
||||
(map path/param-path (url-path/no-slash pkg-url)))
|
||||
(define branches
|
||||
(call/input-url+200
|
||||
(url "https" #f "api.github.com" #f #t
|
||||
(map (λ (x) (path/param x empty))
|
||||
(list "repos" user repo "branches"))
|
||||
empty
|
||||
#f)
|
||||
read-json))
|
||||
(for/or ([b (in-list branches)])
|
||||
(and (equal? (hash-ref b 'name) branch)
|
||||
(hash-ref (hash-ref b 'commit) 'sha)))]
|
||||
[_
|
||||
(call/input-url+200 (string->url (string-append pkg-url-str ".CHECKSUM"))
|
||||
port->string)]))
|
||||
|
||||
(provide (all-defined-out))
|
||||
3
collects/tests/planet2/info.rkt
Normal file
3
collects/tests/planet2/info.rkt
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define compile-omit-paths '("test-pkgs"))
|
||||
134
collects/tests/planet2/shelly.rkt
Normal file
134
collects/tests/planet2/shelly.rkt
Normal file
|
|
@ -0,0 +1,134 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/port
|
||||
racket/system
|
||||
unstable/debug
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse))
|
||||
|
||||
;; {{ Shelly
|
||||
;; This macro is intended to make Eli proud.
|
||||
|
||||
;; Wow, RackUnit really sucks that test-begin/case don't work inside
|
||||
;; each other like this already
|
||||
(define (wrapping-test-case-around thunk)
|
||||
(with-handlers ([exn:test:check?
|
||||
(λ (e)
|
||||
(raise (struct-copy
|
||||
exn:test:check e
|
||||
[stack (list* (make-check-name (current-test-name))
|
||||
(exn:test:check-stack e))])))])
|
||||
(thunk)))
|
||||
(define-syntax-rule (check-begin e ...)
|
||||
(parameterize ([current-test-case-around wrapping-test-case-around])
|
||||
(test-begin e ...)))
|
||||
(define-syntax-rule (check-case m e ...)
|
||||
(parameterize ([current-test-case-around wrapping-test-case-around])
|
||||
(test-case m e ...)))
|
||||
|
||||
(define-syntax-rule (check-similar? act exp name)
|
||||
(let ()
|
||||
(define exp-v exp)
|
||||
(define act-v act)
|
||||
(if (regexp? exp-v)
|
||||
(check-regexp-match exp-v act-v name)
|
||||
(check-equal? act-v exp-v name))))
|
||||
|
||||
(define (exn:input-port-closed? x)
|
||||
(and (exn:fail? x)
|
||||
(regexp-match #rx"input port is closed" (exn-message x))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-splicing-syntax-class shelly-case
|
||||
#:attributes (code)
|
||||
(pattern (~seq (~datum $) command-line:expr
|
||||
(~optional (~seq (~datum =exit>) exit-cond:expr)
|
||||
#:defaults ([exit-cond #'0]))
|
||||
(~optional (~seq (~datum =stdout>) output-str:expr)
|
||||
#:defaults ([output-str #'#f]))
|
||||
(~optional (~seq (~datum =stderr>) error-str:expr)
|
||||
#:defaults ([error-str #'#f]))
|
||||
(~optional (~seq (~datum <input=) input-str:expr)
|
||||
#:defaults ([input-str #'#f])))
|
||||
#:attr
|
||||
code
|
||||
(quasisyntax/loc
|
||||
#'command-line
|
||||
(let ([cmd command-line])
|
||||
(check-case
|
||||
cmd
|
||||
(define output-port (open-output-string))
|
||||
(define error-port (open-output-string))
|
||||
(printf "$ ~a\n" cmd)
|
||||
(match-define
|
||||
(list stdout stdin pid stderr to-proc)
|
||||
(process/ports #f
|
||||
(and input-str
|
||||
(open-input-string input-str))
|
||||
#f
|
||||
cmd))
|
||||
(define stdout-t
|
||||
(thread
|
||||
(λ ()
|
||||
(with-handlers ([exn:input-port-closed? void])
|
||||
(copy-port stdout output-port
|
||||
(current-output-port))))))
|
||||
(define stderr-t
|
||||
(thread
|
||||
(λ ()
|
||||
(with-handlers ([exn:input-port-closed? void])
|
||||
(copy-port stderr error-port
|
||||
(current-error-port))))))
|
||||
(to-proc 'wait)
|
||||
(define cmd-status (to-proc 'exit-code))
|
||||
(when stdout (close-input-port stdout))
|
||||
(when stderr (close-input-port stderr))
|
||||
(when stdin (close-output-port stdin))
|
||||
(thread-wait stdout-t)
|
||||
(thread-wait stderr-t)
|
||||
(define actual-output
|
||||
(get-output-string output-port))
|
||||
(define actual-error
|
||||
(get-output-string error-port))
|
||||
#,(syntax/loc #'command-line
|
||||
(when output-str
|
||||
(check-similar? actual-output output-str "stdout")))
|
||||
#,(syntax/loc #'command-line
|
||||
(when error-str
|
||||
(check-similar? actual-error error-str "stderr")))
|
||||
#,(syntax/loc #'command-line
|
||||
(check-equal? cmd-status exit-cond "exit code"))))))
|
||||
(pattern (~and (~not (~datum $))
|
||||
code:expr))))
|
||||
|
||||
(define-syntax (shelly-begin stx)
|
||||
(syntax-parse
|
||||
stx
|
||||
[(_ case:shelly-case ...)
|
||||
(syntax/loc stx (test-begin case.code ...))]))
|
||||
(define-syntax (shelly-case stx)
|
||||
(syntax-parse
|
||||
stx
|
||||
[(_ m:expr case:shelly-case ...)
|
||||
(syntax/loc stx
|
||||
(let ()
|
||||
(define mv m)
|
||||
(check-case mv
|
||||
(printf "# Starting... ~a\n" mv)
|
||||
case.code ...
|
||||
(printf "# Ending... ~a\n" mv))))]))
|
||||
(define-syntax (shelly-wind stx)
|
||||
(syntax-parse
|
||||
stx
|
||||
[(_ e:expr ... ((~datum finally) after:expr ...))
|
||||
(syntax/loc stx
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(shelly-begin e ...))
|
||||
(λ ()
|
||||
(shelly-begin after ...))))]))
|
||||
;; }}
|
||||
|
||||
(provide (all-defined-out))
|
||||
5
collects/tests/planet2/test-pkgs/.gitignore
vendored
Normal file
5
collects/tests/planet2/test-pkgs/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
MANIFEST
|
||||
*tgz
|
||||
*zip
|
||||
*plt
|
||||
*CHECKSUM
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#lang racket/base
|
||||
(printf "pkg-a\n")
|
||||
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
#lang racket/base
|
||||
(printf "pkg-a\n")
|
||||
(exit 43)
|
||||
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#lang racket/base
|
||||
(printf "pkg-a\n")
|
||||
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#lang racket/base
|
||||
(printf "Evil conflict!\n")
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#lang racket/base
|
||||
(printf "pkg-b first main\n")
|
||||
(exit 42)
|
||||
|
|
@ -0,0 +1 @@
|
|||
((dependency "pkg-a"))
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
#lang racket/base
|
||||
|
||||
(with-handlers ([exn?
|
||||
(λ (x)
|
||||
(exit 42))])
|
||||
(dynamic-require 'pkg-a #f))
|
||||
|
||||
(printf "pkg-b dep\n")
|
||||
(exit 0)
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#lang racket/base
|
||||
(printf "pkg-b second main\n")
|
||||
(exit 43)
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#lang racket
|
||||
(exit 43)
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
#lang racket/base
|
||||
|
||||
(printf "planet2-test1/main loaded\n")
|
||||
(exit 0)
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#lang racket
|
||||
(exit 42)
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
#lang racket/base
|
||||
|
||||
(printf "planet2-test1/main loaded\n")
|
||||
(exit 0)
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#lang racket
|
||||
(exit 42)
|
||||
|
|
@ -0,0 +1 @@
|
|||
This file doesn't conflict with the README in planet2-test1.
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
#lang racket/base
|
||||
|
||||
(printf "planet2-test1-staging/a loaded\n")
|
||||
(exit 0)
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#lang racket
|
||||
(exit 42)
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
#lang racket/base
|
||||
|
||||
(printf "planet2-test1/main loaded\n")
|
||||
(exit 0)
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#lang racket
|
||||
(exit 43)
|
||||
1
collects/tests/planet2/test-pkgs/planet2-test1/README
Normal file
1
collects/tests/planet2/test-pkgs/planet2-test1/README
Normal file
|
|
@ -0,0 +1 @@
|
|||
This is an example non-module file.
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#lang racket
|
||||
(exit 42)
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
#lang racket/base
|
||||
|
||||
(printf "planet2-test1/main loaded\n")
|
||||
(exit 0)
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#lang racket
|
||||
(exit 42)
|
||||
|
|
@ -0,0 +1 @@
|
|||
((dependency "planet2-test1"))
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#lang racket
|
||||
(require planet2-test1)
|
||||
(exit 0)
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
#lang racket/base
|
||||
|
||||
(printf "planet2-test2/main loaded\n")
|
||||
(exit 0)
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#lang racket
|
||||
(error 'die!)
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define name "raco example")
|
||||
(define raco-commands
|
||||
'(("raco-pkg" raco-pkg/main "be an example of raco in a package" 81)))
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#lang racket/base
|
||||
(printf "raco-pkg\n")
|
||||
(exit 0)
|
||||
42
collects/tests/planet2/test.rkt
Normal file
42
collects/tests/planet2/test.rkt
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
"util.rkt")
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
;; By making these syntax-time includes, it made it so they would be
|
||||
;; rebuilt and register as real dependencies.
|
||||
(define-syntax (run-tests stx)
|
||||
(syntax-case stx ()
|
||||
[(_ f ...)
|
||||
(with-syntax
|
||||
([(tests-f ...)
|
||||
(for/list ([f-stx (in-list (syntax->list #'(f ...)))])
|
||||
(define f (syntax->datum f-stx))
|
||||
`(file ,(path->string (build-path test-directory (format "tests-~a.rkt" f)))))])
|
||||
(syntax/loc stx
|
||||
(run-tests*
|
||||
(list (let ()
|
||||
(local-require (only-in tests-f run-pkg-tests))
|
||||
run-pkg-tests)
|
||||
...))))]))
|
||||
|
||||
(define (run-tests* l)
|
||||
(run-pkg-tests*
|
||||
(λ ()
|
||||
(shelly-case "All tests"
|
||||
(for-each (λ (x) (x)) l)))))
|
||||
|
||||
(run-tests
|
||||
"basic" "create" "install"
|
||||
"network" "conflicts" "checksums"
|
||||
"deps" "update"
|
||||
"remove"
|
||||
"locking"
|
||||
"overwrite"
|
||||
"config"
|
||||
"planet"
|
||||
"update-deps"
|
||||
"update-auto"
|
||||
"raco"
|
||||
"main-server")
|
||||
25
collects/tests/planet2/tests-basic.rkt
Normal file
25
collects/tests/planet2/tests-basic.rkt
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
unstable/debug
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/file
|
||||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
planet2/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(shelly-case
|
||||
"Each command has an associated help"
|
||||
$ "raco pkg -h"
|
||||
$ "raco pkg install -h"
|
||||
$ "raco pkg update -h"
|
||||
$ "raco pkg remove -h"
|
||||
$ "raco pkg show -h"
|
||||
$ "raco pkg create -h"
|
||||
$ "raco pkg config -h"))
|
||||
72
collects/tests/planet2/tests-checksums.rkt
Normal file
72
collects/tests/planet2/tests-checksums.rkt
Normal file
|
|
@ -0,0 +1,72 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
unstable/debug
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/file
|
||||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
planet2/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(shelly-begin
|
||||
(initialize-indexes)
|
||||
|
||||
(shelly-case
|
||||
"checksums"
|
||||
$ "test -f test-pkgs/planet2-test1.zip"
|
||||
$ "cp -f test-pkgs/planet2-test1.zip test-pkgs/planet2-test1-bad-checksum.zip"
|
||||
$ "test -f test-pkgs/planet2-test1-conflict.zip.CHECKSUM"
|
||||
$ "cp -f test-pkgs/planet2-test1-conflict.zip.CHECKSUM test-pkgs/planet2-test1-bad-checksum.zip.CHECKSUM"
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"checksums are checked if present (local)"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ "raco pkg install test-pkgs/planet2-test1-bad-checksum.zip" =exit> 1
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1))
|
||||
$ "cp -f test-pkgs/planet2-test1.zip test-pkgs/planet2-test1-no-checksum.zip"
|
||||
|
||||
(shelly-install* "checksums are ignored if missing by default (local)"
|
||||
"test-pkgs/planet2-test1-no-checksum.zip"
|
||||
"planet2-test1-no-checksum")
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"checksums are checked (remote, indexed)"
|
||||
(hash-set!
|
||||
*index-ht-1* "planet2-test1"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/planet2-test1-bad-checksum.zip.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/planet2-test1-bad-checksum.zip"))
|
||||
$ "raco pkg config --set indexes http://localhost:9990 http://localhost:9991"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ "raco pkg install planet2-test1" =exit> 1
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"checksums are checked (remote)"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ "raco pkg install http://localhost:9999/planet2-test1-bad-checksum.zip" =exit> 1
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1))
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"checksums are required by default remotely (remote)"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ "raco pkg install http://localhost:9999/planet2-test1-no-checksum.zip" =exit> 1
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1))
|
||||
(shelly-install* "but, bad checksums can be ignored (local)"
|
||||
"--ignore-checksums test-pkgs/planet2-test1-bad-checksum.zip"
|
||||
"planet2-test1-bad-checksum")
|
||||
(shelly-install* "but, bad checksums can be ignored (remote)"
|
||||
"--ignore-checksums http://localhost:9999/planet2-test1-bad-checksum.zip"
|
||||
"planet2-test1-bad-checksum")
|
||||
(shelly-install* "but, checksums can be missing if ignored (remote)"
|
||||
"--ignore-checksums http://localhost:9999/planet2-test1-no-checksum.zip"
|
||||
"planet2-test1-no-checksum"))))
|
||||
11
collects/tests/planet2/tests-config.rkt
Normal file
11
collects/tests/planet2/tests-config.rkt
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
#lang racket/base
|
||||
(require "shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"reading and writing configs"
|
||||
$ "raco pkg config indexes" =stdout> "https://plt-etc.byu.edu:9004\nhttps://plt-etc.byu.edu:9003\n"
|
||||
$ "raco pkg config --set indexes http://localhost:9000"
|
||||
$ "raco pkg config indexes" =stdout> "http://localhost:9000\n")))
|
||||
61
collects/tests/planet2/tests-conflicts.rkt
Normal file
61
collects/tests/planet2/tests-conflicts.rkt
Normal file
|
|
@ -0,0 +1,61 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
unstable/debug
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/file
|
||||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
planet2/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(shelly-begin
|
||||
(initialize-indexes)
|
||||
|
||||
$ "raco pkg create test-pkgs/planet2-test1"
|
||||
$ "raco pkg create test-pkgs/planet2-test1-not-conflict"
|
||||
(shelly-install "only modules are considered for conflicts"
|
||||
"test-pkgs/planet2-test1.plt"
|
||||
$ "raco pkg install test-pkgs/planet2-test1-not-conflict.plt")
|
||||
|
||||
(shelly-case
|
||||
"conflicts"
|
||||
(shelly-install "double install fails" "test-pkgs/planet2-test1.zip"
|
||||
$ "raco pkg install test-pkgs/planet2-test1.zip" =exit> 1)
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"conflicts with racket fail"
|
||||
$ "test -f test-pkgs/racket-conflict.tgz"
|
||||
$ "raco pkg install test-pkgs/racket-conflict.tgz" =exit> 1))
|
||||
|
||||
(shelly-install "conflicts are caught" "test-pkgs/planet2-test1.zip"
|
||||
$ "test -f test-pkgs/planet2-test1-conflict.zip"
|
||||
$ "raco pkg install test-pkgs/planet2-test1-conflict.zip" =exit> 1)
|
||||
|
||||
(shelly-wind
|
||||
$ "cp -r test-pkgs/planet2-test1 test-pkgs/planet2-test1-linking"
|
||||
(shelly-install* "conflicts are caught, even with a link"
|
||||
"--link test-pkgs/planet2-test1-linking"
|
||||
"planet2-test1-linking"
|
||||
$ "test -f test-pkgs/planet2-test1-conflict.zip"
|
||||
$ "raco pkg install test-pkgs/planet2-test1-conflict.zip" =exit> 1)
|
||||
(finally
|
||||
$ "rm -fr test-pkgs/planet2-test1-linking"))
|
||||
|
||||
(shelly-install "conflicts can be forced" "test-pkgs/planet2-test1.zip"
|
||||
$ "racket -e '(require planet2-test1/conflict)'" =exit> 42
|
||||
$ "raco pkg install --force test-pkgs/planet2-test1-conflict.zip" =exit> 0
|
||||
$ "racket -e '(require planet2-test1/conflict)'" =exit> 42
|
||||
$ "raco pkg remove planet2-test1-conflict")
|
||||
|
||||
(shelly-install "conflicts can be forced" "test-pkgs/planet2-test1-conflict.zip"
|
||||
$ "racket -e '(require planet2-test1/conflict)'" =exit> 43
|
||||
$ "raco pkg install --force test-pkgs/planet2-test1.zip" =exit> 0
|
||||
$ "racket -e '(require planet2-test1/conflict)'" =exit> 43
|
||||
$ "raco pkg remove planet2-test1-conflict"))))
|
||||
59
collects/tests/planet2/tests-create.rkt
Normal file
59
collects/tests/planet2/tests-create.rkt
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
unstable/debug
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/file
|
||||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
planet2/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(shelly-begin
|
||||
(shelly-case
|
||||
"create"
|
||||
|
||||
(shelly-case
|
||||
"create fails on missing directories"
|
||||
$ "rm -fr test-pkgs/does-not-exist test-pkgs/does-not-exist.tgz"
|
||||
$ "raco pkg create --format tgz test-pkgs/does-not-exist" =exit> 1
|
||||
$ "test -f test-pkgs/does-not-exist.tgz" =exit> 1)
|
||||
|
||||
(define-syntax-rule (shelly-create pkg fmt)
|
||||
(shelly-case
|
||||
(format "create format ~a" fmt)
|
||||
$ (format "rm -f test-pkgs/~a.~a test-pkgs/~a.~a.CHECKSUM"
|
||||
pkg fmt pkg fmt)
|
||||
$ (format "raco pkg create --format ~a test-pkgs/~a"
|
||||
fmt pkg)
|
||||
$ (format "test -f test-pkgs/~a.~a" pkg fmt)
|
||||
$ (format "test -f test-pkgs/~a.~a.CHECKSUM" pkg fmt)))
|
||||
|
||||
(shelly-create "planet2-test1" "tgz")
|
||||
(shelly-create "planet2-test1" "zip")
|
||||
(shelly-create "planet2-test1-v2" "zip")
|
||||
(shelly-create "planet2-test1-conflict" "zip")
|
||||
(shelly-create "planet2-test1" "plt")
|
||||
(shelly-create "racket-conflict" "tgz")
|
||||
|
||||
$ "raco pkg create --format txt test-pkgs/planet2-test1" =exit> 1
|
||||
|
||||
(shelly-create "planet2-test2" "zip")
|
||||
|
||||
(shelly-case
|
||||
"create is robust against ending /s"
|
||||
$ "rm -f test-pkgs/planet2-test1.tgz test-pkgs/planet2-test1.tgz.CHECKSUM"
|
||||
$ "raco pkg create --format tgz test-pkgs/planet2-test1/"
|
||||
$ "test -f test-pkgs/planet2-test1.tgz"
|
||||
$ "test -f test-pkgs/planet2-test1.tgz.CHECKSUM"))
|
||||
|
||||
(shelly-case
|
||||
"create MANIFESTs"
|
||||
$ "rm -f test-pkgs/planet2-test1/MANIFEST"
|
||||
$ "raco pkg create --manifest test-pkgs/planet2-test1/"
|
||||
$ "test -f test-pkgs/planet2-test1/MANIFEST")))
|
||||
119
collects/tests/planet2/tests-deps.rkt
Normal file
119
collects/tests/planet2/tests-deps.rkt
Normal file
|
|
@ -0,0 +1,119 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
unstable/debug
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/file
|
||||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
planet2/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(shelly-begin
|
||||
(initialize-indexes)
|
||||
|
||||
(shelly-case
|
||||
"dependencies"
|
||||
|
||||
$ "test -f test-pkgs/planet2-test2.zip"
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"local - fail (default)"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install test-pkgs/planet2-test2.zip" =exit> 1
|
||||
$ "raco pkg install test-pkgs/planet2-test1.zip" =exit> 0
|
||||
$ "raco pkg install test-pkgs/planet2-test2.zip" =exit> 0
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 0
|
||||
$ "racket -e '(require planet2-test2/contains-dep)'" =exit> 0
|
||||
$ "raco pkg remove planet2-test2"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"local - looks at all packages given on cmdline"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install test-pkgs/planet2-test2.zip test-pkgs/planet2-test1.zip" =exit> 0
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 0
|
||||
$ "racket -e '(require planet2-test2/contains-dep)'" =exit> 0
|
||||
$ "raco pkg remove planet2-test2"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"local - fail"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install --deps fail test-pkgs/planet2-test2.zip" =exit> 1
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"local - force"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install --deps force test-pkgs/planet2-test2.zip"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 0
|
||||
$ "racket -e '(require planet2-test2/contains-dep)'" =exit> 1
|
||||
$ "raco pkg remove planet2-test2"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"local - search-ask [y]"
|
||||
$ "raco pkg config --set indexes http://localhost:9990"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install --deps search-ask test-pkgs/planet2-test2.zip" =exit> 0 <input= "y\n"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 0
|
||||
$ "racket -e '(require planet2-test2/contains-dep)'" =exit> 0
|
||||
$ "raco pkg remove planet2-test2"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"local - search-ask []"
|
||||
$ "raco pkg config --set indexes http://localhost:9990"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install --deps search-ask test-pkgs/planet2-test2.zip" =exit> 0 <input= "\n"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 0
|
||||
$ "racket -e '(require planet2-test2/contains-dep)'" =exit> 0
|
||||
$ "raco pkg remove planet2-test2"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"local - search-ask [n]"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install --deps search-ask test-pkgs/planet2-test2.zip" =exit> 1 <input= "n\n"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"local - search-auto"
|
||||
$ "raco pkg config --set indexes http://localhost:9990"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install --deps search-auto test-pkgs/planet2-test2.zip" =exit> 0
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 0
|
||||
$ "racket -e '(require planet2-test2/contains-dep)'" =exit> 0
|
||||
$ "raco pkg remove planet2-test2"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"remote - search-ask (default) [y]"
|
||||
$ "raco pkg config --set indexes http://localhost:9990"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install planet2-test2" =exit> 0 <input= "y\n"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 0
|
||||
$ "racket -e '(require planet2-test2/contains-dep)'" =exit> 0
|
||||
$ "raco pkg remove planet2-test2"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"remote - fail"
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install --deps fail planet2-test2" =exit> 1
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1)))))
|
||||
98
collects/tests/planet2/tests-install.rkt
Normal file
98
collects/tests/planet2/tests-install.rkt
Normal file
|
|
@ -0,0 +1,98 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
unstable/debug
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/file
|
||||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
planet2/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(shelly-begin
|
||||
(initialize-indexes)
|
||||
|
||||
(shelly-case
|
||||
"raco pkg install tests"
|
||||
(shelly-install "local package (tgz)" "test-pkgs/planet2-test1.tgz")
|
||||
(shelly-install "local package (zip)" "test-pkgs/planet2-test1.zip")
|
||||
(shelly-install "local package (plt)" "test-pkgs/planet2-test1.plt")
|
||||
|
||||
(shelly-case
|
||||
"invalid package format is an error"
|
||||
$ "raco pkg install test-pkgs/planet2-test1.zip.CHECKSUM" =exit> 1)
|
||||
|
||||
(shelly-install "remote/URL/http package (file, tgz)"
|
||||
"http://localhost:9999/planet2-test1.tgz")
|
||||
(shelly-install "remote/URL/http package (directory)"
|
||||
"http://localhost:9999/planet2-test1/")
|
||||
|
||||
(shelly-case
|
||||
"remote/URL/http directory, non-existant file"
|
||||
$ "raco pkg install http://localhost:9999/planet2-test1.rar" =exit> 1)
|
||||
(shelly-case
|
||||
"remote/URL/http directory, no manifest fail"
|
||||
$ "raco pkg install http://localhost:9999/planet2-test1/planet2-test1"
|
||||
=exit> 1
|
||||
=stderr> #rx"Invalid package format")
|
||||
(shelly-case
|
||||
"remote/URL/http directory, bad manifest"
|
||||
;; XXX why does this error now?
|
||||
$ "raco pkg install http://localhost:9999/planet2-test1-manifest-error" =exit> 1)
|
||||
|
||||
(shelly-case
|
||||
"local directory fails when not there (because interpreted as package name that isn't there)"
|
||||
$ "raco pkg install test-pkgs/planet2-test1-not-there" =exit> 1)
|
||||
|
||||
(shelly-install "local package (directory)" "test-pkgs/planet2-test1")
|
||||
(shelly-install "local package (directory with slash)" "test-pkgs/planet2-test1/")
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"linking local directory"
|
||||
(shelly-wind
|
||||
$ "cp -r test-pkgs/planet2-test1 test-pkgs/planet2-test1-linking"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ "raco pkg install --link test-pkgs/planet2-test1-linking"
|
||||
$ "racket -e '(require planet2-test1)'"
|
||||
$ "racket -e '(require planet2-test1/a)'" =exit> 1
|
||||
$ "cp test-pkgs/planet2-test1-staging/a.rkt test-pkgs/planet2-test1-linking/planet2-test1/a.rkt"
|
||||
$ "racket -e '(require planet2-test1/a)'"
|
||||
$ "rm -f test-pkgs/planet2-test1-linking/planet2-test1/a.rkt"
|
||||
$ "racket -e '(require planet2-test1/a)'" =exit> 1
|
||||
$ "raco pkg remove planet2-test1-linking"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
(finally
|
||||
$ "rm -r test-pkgs/planet2-test1-linking"))))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"remote/name package, doesn't work when no package there"
|
||||
$ "raco pkg config --set indexes http://localhost:9990"
|
||||
$ "raco pkg install planet2-test1-not-there" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"remote/name package"
|
||||
$ "raco pkg config --set indexes http://localhost:9990"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ "raco pkg install planet2-test1"
|
||||
$ "racket -e '(require planet2-test1)'"
|
||||
$ "raco pkg remove planet2-test1"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"remote/name package (multi)"
|
||||
$ "raco pkg config --set indexes http://localhost:9990 http://localhost:9991"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ "raco pkg install --deps search-auto planet2-test2-snd"
|
||||
$ "racket -e '(require planet2-test1)'"
|
||||
$ "racket -e '(require planet2-test2)'"
|
||||
$ "raco pkg remove planet2-test2-snd planet2-test1"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1)))))
|
||||
42
collects/tests/planet2/tests-locking.rkt
Normal file
42
collects/tests/planet2/tests-locking.rkt
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
#lang racket/base
|
||||
(require web-server/http
|
||||
web-server/servlet-env
|
||||
meta/planet2-index/basic/main
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"A lock is used to guarantee serial access to the package database"
|
||||
|
||||
;; Step 1: Start a special server that waits for our signal to respond
|
||||
(initialize-indexes)
|
||||
(define okay-to-respond?-sema (make-semaphore))
|
||||
(thread
|
||||
(λ ()
|
||||
(serve/servlet (planet2-index/basic
|
||||
(λ (pkg-name)
|
||||
(semaphore-wait okay-to-respond?-sema)
|
||||
(define r (hash-ref *index-ht-1* pkg-name #f))
|
||||
r))
|
||||
#:command-line? #t
|
||||
#:servlet-regexp #rx""
|
||||
#:port 9967)
|
||||
(sleep 1)))
|
||||
|
||||
;; Step 2: Assign it as our server
|
||||
$ "raco pkg config --set indexes http://localhost:9967"
|
||||
|
||||
;; Step 3: Start an installation request in the background
|
||||
(thread
|
||||
(λ ()
|
||||
(shelly-begin
|
||||
$ "raco pkg install planet2-test1")))
|
||||
(sleep 1)
|
||||
|
||||
;; Step 4: Start the installation request that will fail
|
||||
$ "raco pkg install planet2-test1" =exit> 1
|
||||
|
||||
;; Step 5: Free the other one
|
||||
(semaphore-post okay-to-respond?-sema))))
|
||||
10
collects/tests/planet2/tests-main-server.rkt
Normal file
10
collects/tests/planet2/tests-main-server.rkt
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
#lang racket/base
|
||||
(require "shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"The main server works"
|
||||
$ "raco pkg install planet2-example"
|
||||
$ "racket -e '(require data/frob-nob)'" =exit> 42)))
|
||||
21
collects/tests/planet2/tests-network.rkt
Normal file
21
collects/tests/planet2/tests-network.rkt
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
unstable/debug
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/file
|
||||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
planet2/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(shelly-begin
|
||||
(shelly-install "remote/github"
|
||||
"github://github.com/jeapostrophe/galaxy/master/tests/planet2/test-pkgs/planet2-test1")
|
||||
(shelly-install "remote/github with slash"
|
||||
"github://github.com/jeapostrophe/galaxy/master/tests/planet2/test-pkgs/planet2-test1/")))
|
||||
16
collects/tests/planet2/tests-overwrite.rkt
Normal file
16
collects/tests/planet2/tests-overwrite.rkt
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
#lang racket/base
|
||||
(require "shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"The installation directory is not touched until a package can definitely be installed AND one fail reverts the whole install"
|
||||
|
||||
;; Step 1. Try to install a package that will fail
|
||||
$ "raco pkg install test-pkgs/planet2-test1.zip test-pkgs/planet2-test1.zip"
|
||||
=exit> 1
|
||||
=stderr> #rx"conflicts with \"planet2-test1\""
|
||||
|
||||
;; Step 2. Try to install safely
|
||||
$ "raco pkg install test-pkgs/planet2-test1.zip")))
|
||||
22
collects/tests/planet2/tests-planet.rkt
Normal file
22
collects/tests/planet2/tests-planet.rkt
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
#lang racket/base
|
||||
(require "shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"planet compatibility tests - no deps"
|
||||
$ "raco pkg install planet-dyoo-stardate1"
|
||||
$ "racket -e '(require dyoo/stardate1/main)'"))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"planet compatibility tests - deps"
|
||||
$ "raco pkg install --deps search-auto planet-dyoo-union-find1"
|
||||
$ "racket -e '(require dyoo/union-find1/test-union-find)'"))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"planet compatibility tests - deps"
|
||||
$ "raco pkg install --deps search-auto planet-neil-rackonsole1"
|
||||
$ "racket -e '(require neil/rackonsole1/test-rackonsole)'")))
|
||||
30
collects/tests/planet2/tests-raco.rkt
Normal file
30
collects/tests/planet2/tests-raco.rkt
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
#lang racket/base
|
||||
(require "shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"raco install/update uses raco setup, unless you turn it off (cmdline)"
|
||||
$ "raco pkg create test-pkgs/raco-pkg"
|
||||
$ "raco raco-pkg" =exit> 1
|
||||
$ "raco pkg install --dont-setup test-pkgs/raco-pkg.plt"
|
||||
$ "raco raco-pkg" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"raco install/update uses raco setup, unless you turn it off (env)"
|
||||
(putenv "PLT_PLANET2_DONTSETUP" "1")
|
||||
$ "raco pkg create test-pkgs/raco-pkg"
|
||||
$ "raco raco-pkg" =exit> 1
|
||||
$ "raco pkg install --dont-setup test-pkgs/raco-pkg.plt"
|
||||
$ "raco raco-pkg" =exit> 1
|
||||
(putenv "PLT_PLANET2_DONTSETUP" "")))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"raco install/update uses raco setup"
|
||||
$ "raco pkg create test-pkgs/raco-pkg"
|
||||
$ "raco raco-pkg" =exit> 1
|
||||
$ "raco pkg install test-pkgs/raco-pkg.plt"
|
||||
$ "raco raco-pkg" =exit> 0)))
|
||||
72
collects/tests/planet2/tests-remove.rkt
Normal file
72
collects/tests/planet2/tests-remove.rkt
Normal file
|
|
@ -0,0 +1,72 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
unstable/debug
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/file
|
||||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
planet2/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(shelly-begin
|
||||
(initialize-indexes)
|
||||
|
||||
(shelly-case
|
||||
"remove and show"
|
||||
(shelly-case "remove of not installed package fails"
|
||||
$ "raco pkg show" =stdout> "Package(auto?) Checksum Source\n"
|
||||
$ "raco pkg remove not-there" =exit> 1)
|
||||
(shelly-install "remove test"
|
||||
"test-pkgs/planet2-test1.zip")
|
||||
(shelly-install "remove of dep fails"
|
||||
"test-pkgs/planet2-test1.zip"
|
||||
$ "raco pkg show" =stdout> #rx"Package\\(auto\\?\\) +Checksum +Source\nplanet2-test1 +[a-f0-9]+ +\\(file .+tests/planet2/test-pkgs/planet2-test1.zip\\)\n"
|
||||
$ "raco pkg install test-pkgs/planet2-test2.zip"
|
||||
$ "raco pkg show" =stdout> #rx"Package\\(auto\\?\\) +Checksum +Source\nplanet2-test1 +[a-f0-9]+ +\\(file .+tests/planet2/test-pkgs/planet2-test1.zip\\)\nplanet2-test2 +[a-f0-9]+ +\\(file .+tests/planet2/test-pkgs/planet2-test2.zip\\)\n"
|
||||
$ "raco pkg remove planet2-test1" =exit> 1
|
||||
$ "raco pkg remove planet2-test2"
|
||||
$ "raco pkg show" =stdout> #rx"Package\\(auto\\?\\) +Checksum +Source\nplanet2-test1 +[a-f0-9]+ +\\(file .+tests/planet2/test-pkgs/planet2-test1.zip\\)\n")
|
||||
(shelly-install "remove of dep can be forced"
|
||||
"test-pkgs/planet2-test1.zip"
|
||||
$ "raco pkg install test-pkgs/planet2-test2.zip"
|
||||
$ "racket -e '(require planet2-test2/contains-dep)'" =exit> 0
|
||||
$ "raco pkg remove --force planet2-test1"
|
||||
$ "racket -e '(require planet2-test2/contains-dep)'" =exit> 1
|
||||
$ "raco pkg install test-pkgs/planet2-test1.zip"
|
||||
$ "raco pkg remove planet2-test2")
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"remove two"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install test-pkgs/planet2-test2.zip test-pkgs/planet2-test1.zip" =exit> 0
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 0
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 0
|
||||
$ "racket -e '(require planet2-test2/contains-dep)'" =exit> 0
|
||||
$ "raco pkg remove planet2-test1 planet2-test2"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1))
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"autoremove"
|
||||
$ "raco pkg config --set indexes http://localhost:9990"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1
|
||||
$ "raco pkg install --deps search-auto test-pkgs/planet2-test2.zip" =exit> 0
|
||||
$ "raco pkg show" =stdout> #rx"Package\\(auto\\?\\) +Checksum +Source\nplanet2-test1\\* +[a-f0-9]+ +\\(pns planet2-test1\\)\nplanet2-test2 +[a-f0-9]+ +\\(file .+tests/planet2/test-pkgs/planet2-test2.zip\\)\n"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 0
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 0
|
||||
$ "racket -e '(require planet2-test2/contains-dep)'" =exit> 0
|
||||
$ "raco pkg remove planet2-test2"
|
||||
$ "raco pkg show" =stdout> #rx"Package\\(auto\\?\\) +Checksum +Source\nplanet2-test1\\* +[a-f0-9]+ +\\(pns planet2-test1\\)\n"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 0
|
||||
$ "raco pkg remove --auto"
|
||||
$ "raco pkg show" =stdout> "Package(auto?) Checksum Source\n"
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ "racket -e '(require planet2-test2)'" =exit> 1)))))
|
||||
71
collects/tests/planet2/tests-update-auto.rkt
Normal file
71
collects/tests/planet2/tests-update-auto.rkt
Normal file
|
|
@ -0,0 +1,71 @@
|
|||
#lang racket/base
|
||||
(require racket/file
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(define (init-update-deps-test)
|
||||
(shelly-begin
|
||||
(hash-set! *index-ht-1* "pkg-b"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/pkg-b-first.plt.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/pkg-b-first.plt"))
|
||||
$ "raco pkg config --set indexes http://localhost:9990"
|
||||
$ "raco pkg install pkg-b"
|
||||
$ "racket -e '(require pkg-b)'" =exit> 42
|
||||
(hash-set! *index-ht-1* "pkg-b"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/pkg-b-second.plt.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/pkg-b-second.plt"))
|
||||
(hash-set! *index-ht-1* "pkg-a"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/pkg-a-first.plt.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/pkg-a-first.plt"))))
|
||||
|
||||
(pkg-tests
|
||||
(shelly-case
|
||||
"create packages"
|
||||
$ "raco pkg create test-pkgs/pkg-b-second"
|
||||
$ "raco pkg create test-pkgs/pkg-a-first"
|
||||
$ "raco pkg create test-pkgs/pkg-a-second")
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"update and then remove an auto"
|
||||
$ "raco pkg config --set indexes http://localhost:9990"
|
||||
(hash-set! *index-ht-1* "pkg-b"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/pkg-b-second.plt.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/pkg-b-second.plt"))
|
||||
(hash-set! *index-ht-1* "pkg-a"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/pkg-a-first.plt.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/pkg-a-first.plt"))
|
||||
$ "raco pkg install --deps search-auto pkg-b" =exit> 0 <input= "y\n"
|
||||
$ "raco pkg show" =stdout> #rx"Package\\(auto\\?\\) Checksum Source\npkg-a\\* [a-f0-9]+ \\(pns pkg-a\\)\npkg-b [a-f0-9]+ \\(pns pkg-b\\)\n"
|
||||
$ "racket -e '(require pkg-b)'" =exit> 43
|
||||
$ "racket -e '(require pkg-a)'" =exit> 0
|
||||
;; remove auto doesn't do anything because everything is needed
|
||||
$ "raco pkg remove --auto"
|
||||
$ "raco pkg show" =stdout> #rx"Package\\(auto\\?\\) Checksum Source\npkg-a\\* [a-f0-9]+ \\(pns pkg-a\\)\npkg-b [a-f0-9]+ \\(pns pkg-b\\)\n"
|
||||
$ "racket -e '(require pkg-b)'" =exit> 43
|
||||
$ "racket -e '(require pkg-a)'" =exit> 0
|
||||
;; pkg-a is now an auto
|
||||
(hash-set! *index-ht-1* "pkg-a"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/pkg-a-second.plt.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/pkg-a-second.plt"))
|
||||
$ "raco pkg update" =exit> 0
|
||||
$ "racket -e '(require pkg-a)'" =exit> 43
|
||||
$ "raco pkg remove pkg-b"
|
||||
$ "raco pkg show" =stdout> #rx"Package\\(auto\\?\\) Checksum Source\npkg-a\\* [a-f0-9]+ \\(pns pkg-a\\)\n"
|
||||
$ "racket -e '(require pkg-b)'" =exit> 1
|
||||
;; pkg-a is now not needed
|
||||
$ "raco pkg remove --auto"
|
||||
$ "raco pkg show" =stdout> "Package(auto?) Checksum Source\n"
|
||||
$ "racket -e '(require pkg-a)'" =exit> 1)))
|
||||
110
collects/tests/planet2/tests-update-deps.rkt
Normal file
110
collects/tests/planet2/tests-update-deps.rkt
Normal file
|
|
@ -0,0 +1,110 @@
|
|||
#lang racket/base
|
||||
(require racket/file
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(define (init-update-deps-test)
|
||||
(shelly-begin
|
||||
(hash-set! *index-ht-1* "pkg-b"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/pkg-b-first.plt.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/pkg-b-first.plt"))
|
||||
$ "raco pkg config --set indexes http://localhost:9990"
|
||||
$ "raco pkg install pkg-b"
|
||||
$ "racket -e '(require pkg-b)'" =exit> 42
|
||||
(hash-set! *index-ht-1* "pkg-b"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/pkg-b-second.plt.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/pkg-b-second.plt"))
|
||||
(hash-set! *index-ht-1* "pkg-a"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/pkg-a-first.plt.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/pkg-a-first.plt"))))
|
||||
|
||||
(pkg-tests
|
||||
(shelly-case
|
||||
"create packages"
|
||||
$ "raco pkg create test-pkgs/pkg-b-first"
|
||||
$ "raco pkg create test-pkgs/pkg-b-second"
|
||||
$ "raco pkg create test-pkgs/pkg-a-first"
|
||||
$ "raco pkg create test-pkgs/pkg-a-second"
|
||||
$ "raco pkg create test-pkgs/pkg-a-third")
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"fail"
|
||||
(init-update-deps-test)
|
||||
$ "raco pkg update --deps fail pkg-b" =exit> 1
|
||||
$ "racket -e '(require pkg-b)'" =exit> 42
|
||||
$ "racket -e '(require pkg-b/contains-dep)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"force"
|
||||
(init-update-deps-test)
|
||||
$ "raco pkg update --deps force pkg-b" =exit> 0
|
||||
$ "racket -e '(require pkg-b)'" =exit> 43
|
||||
$ "racket -e '(require pkg-b/contains-dep)'" =exit> 42))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"search-ask"
|
||||
(init-update-deps-test)
|
||||
$ "raco pkg update --deps search-ask pkg-b" =exit> 1 <input= "n\n"
|
||||
$ "racket -e '(require pkg-b)'" =exit> 42
|
||||
$ "racket -e '(require pkg-b/contains-dep)'" =exit> 1))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"search-ask"
|
||||
(init-update-deps-test)
|
||||
$ "raco pkg update --deps search-ask pkg-b" =exit> 0 <input= "y\n"
|
||||
$ "racket -e '(require pkg-b)'" =exit> 43
|
||||
$ "racket -e '(require pkg-b/contains-dep)'" =exit> 0))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"search-auto"
|
||||
(init-update-deps-test)
|
||||
$ "raco pkg update --deps search-auto pkg-b" =exit> 0
|
||||
$ "racket -e '(require pkg-b)'" =exit> 43
|
||||
$ "racket -e '(require pkg-b/contains-dep)'" =exit> 0))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"update a dependency"
|
||||
(init-update-deps-test)
|
||||
$ "raco pkg update --deps search-auto pkg-b" =exit> 0
|
||||
$ "racket -e '(require pkg-b)'" =exit> 43
|
||||
$ "racket -e '(require pkg-b/contains-dep)'" =exit> 0
|
||||
(hash-set! *index-ht-1* "pkg-a"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/pkg-a-second.plt.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/pkg-a-second.plt"))
|
||||
$ "racket -e '(require pkg-a)'" =exit> 0
|
||||
$ "raco pkg update pkg-a" =exit> 0
|
||||
$ "racket -e '(require pkg-a)'" =exit> 43
|
||||
$ "racket -e '(require pkg-b)'" =exit> 43
|
||||
$ "racket -e '(require pkg-b/contains-dep)'" =exit> 43))
|
||||
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
"update a dependency (and fail) but still work"
|
||||
(init-update-deps-test)
|
||||
$ "raco pkg update --deps search-auto pkg-b" =exit> 0
|
||||
$ "racket -e '(require pkg-b)'" =exit> 43
|
||||
$ "racket -e '(require pkg-b/contains-dep)'" =exit> 0
|
||||
(hash-set! *index-ht-1* "pkg-a"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/pkg-a-third.plt.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/pkg-a-third.plt"))
|
||||
$ "racket -e '(require pkg-a)'" =exit> 0
|
||||
$ "raco pkg update pkg-a" =exit> 1
|
||||
$ "racket -e '(require pkg-a)'" =exit> 0
|
||||
$ "racket -e '(require pkg-b)'" =exit> 43
|
||||
$ "racket -e '(require pkg-b/contains-dep)'" =exit> 0)))
|
||||
100
collects/tests/planet2/tests-update.rkt
Normal file
100
collects/tests/planet2/tests-update.rkt
Normal file
|
|
@ -0,0 +1,100 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
unstable/debug
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/file
|
||||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
planet2/util
|
||||
"shelly.rkt"
|
||||
"util.rkt")
|
||||
|
||||
(pkg-tests
|
||||
(shelly-begin
|
||||
(initialize-indexes)
|
||||
|
||||
(shelly-case
|
||||
"update"
|
||||
(shelly-install "local packages can't be updated (file)"
|
||||
"test-pkgs/planet2-test1.zip"
|
||||
$ "raco pkg update planet2-test1" =exit> 1)
|
||||
(shelly-install "local packages can't be updated (directory)"
|
||||
"test-pkgs/planet2-test1"
|
||||
$ "raco pkg update planet2-test1" =exit> 1)
|
||||
(shelly-wind
|
||||
$ "mkdir -p test-pkgs/update-test"
|
||||
$ "cp -f test-pkgs/planet2-test1.zip test-pkgs/update-test/planet2-test1.zip"
|
||||
$ "cp -f test-pkgs/planet2-test1.zip.CHECKSUM test-pkgs/update-test/planet2-test1.zip.CHECKSUM"
|
||||
(shelly-install* "remote packages can be updated"
|
||||
"http://localhost:9999/update-test/planet2-test1.zip"
|
||||
"planet2-test1"
|
||||
$ "raco pkg update planet2-test1" =exit> 0 =stdout> "No updates available\n"
|
||||
$ "racket -e '(require planet2-test1/update)'" =exit> 42
|
||||
$ "cp -f test-pkgs/planet2-test1-v2.zip test-pkgs/update-test/planet2-test1.zip"
|
||||
$ "cp -f test-pkgs/planet2-test1-v2.zip.CHECKSUM test-pkgs/update-test/planet2-test1.zip.CHECKSUM"
|
||||
$ "raco pkg update planet2-test1" =exit> 0
|
||||
$ "racket -e '(require planet2-test1/update)'" =exit> 43)
|
||||
(finally
|
||||
$ "rm -f test-pkgs/update-test/planet2-test1.zip"
|
||||
$ "rm -f test-pkgs/update-test/planet2-test1.zip.CHECKSUM"))
|
||||
|
||||
(shelly-wind
|
||||
$ "mkdir -p test-pkgs/update-test"
|
||||
$ "cp -f test-pkgs/planet2-test1.zip test-pkgs/update-test/planet2-test1.zip"
|
||||
$ "cp -f test-pkgs/planet2-test1.zip.CHECKSUM test-pkgs/update-test/planet2-test1.zip.CHECKSUM"
|
||||
(shelly-install* "update deps"
|
||||
"http://localhost:9999/update-test/planet2-test1.zip"
|
||||
"planet2-test1"
|
||||
$ "raco pkg install test-pkgs/planet2-test2.zip"
|
||||
$ "raco pkg update --update-deps planet2-test2" =exit> 0 =stdout> "No updates available\n"
|
||||
$ "racket -e '(require planet2-test1/update)'" =exit> 42
|
||||
$ "cp -f test-pkgs/planet2-test1-v2.zip test-pkgs/update-test/planet2-test1.zip"
|
||||
$ "cp -f test-pkgs/planet2-test1-v2.zip.CHECKSUM test-pkgs/update-test/planet2-test1.zip.CHECKSUM"
|
||||
$ "raco pkg update --update-deps planet2-test2" =exit> 0
|
||||
$ "racket -e '(require planet2-test1/update)'" =exit> 43
|
||||
$ "raco pkg remove planet2-test2")
|
||||
(finally
|
||||
$ "rm -f test-pkgs/update-test/planet2-test1.zip"
|
||||
$ "rm -f test-pkgs/update-test/planet2-test1.zip.CHECKSUM"))
|
||||
|
||||
(shelly-wind
|
||||
$ "mkdir -p test-pkgs/update-test"
|
||||
$ "cp -f test-pkgs/planet2-test1.zip test-pkgs/update-test/planet2-test1.zip"
|
||||
$ "cp -f test-pkgs/planet2-test1.zip.CHECKSUM test-pkgs/update-test/planet2-test1.zip.CHECKSUM"
|
||||
(shelly-install* "update all is default"
|
||||
"http://localhost:9999/update-test/planet2-test1.zip"
|
||||
"planet2-test1"
|
||||
$ "raco pkg install test-pkgs/planet2-test2.zip"
|
||||
$ "raco pkg update" =exit> 0 =stdout> "No updates available\n"
|
||||
$ "racket -e '(require planet2-test1/update)'" =exit> 42
|
||||
$ "cp -f test-pkgs/planet2-test1-v2.zip test-pkgs/update-test/planet2-test1.zip"
|
||||
$ "cp -f test-pkgs/planet2-test1-v2.zip.CHECKSUM test-pkgs/update-test/planet2-test1.zip.CHECKSUM"
|
||||
$ "raco pkg update" =exit> 0
|
||||
$ "racket -e '(require planet2-test1/update)'" =exit> 43
|
||||
$ "raco pkg remove planet2-test2")
|
||||
(finally
|
||||
$ "rm -f test-pkgs/update-test/planet2-test1.zip"
|
||||
$ "rm -f test-pkgs/update-test/planet2-test1.zip.CHECKSUM"))
|
||||
|
||||
(shelly-wind
|
||||
$ "cp -f test-pkgs/planet2-test1.zip test-pkgs/planet2-test1.zip.bak"
|
||||
$ "cp -f test-pkgs/planet2-test1.zip.CHECKSUM test-pkgs/planet2-test1.zip.CHECKSUM.bak"
|
||||
(shelly-install**
|
||||
"named remote packages can be update"
|
||||
"planet2-test1" "planet2-test1"
|
||||
($ "raco pkg config --set indexes http://localhost:9990")
|
||||
($ "raco pkg update planet2-test1" =exit> 0 =stdout> "No updates available\n"
|
||||
$ "racket -e '(require planet2-test1/update)'" =exit> 42
|
||||
$ "cp test-pkgs/planet2-test1-v2.zip test-pkgs/planet2-test1.zip"
|
||||
$ "cp test-pkgs/planet2-test1-v2.zip.CHECKSUM test-pkgs/planet2-test1.zip.CHECKSUM"
|
||||
(initialize-indexes)
|
||||
$ "raco pkg update planet2-test1" =exit> 0
|
||||
$ "racket -e '(require planet2-test1/update)'" =exit> 43))
|
||||
(finally
|
||||
$ "cp -f test-pkgs/planet2-test1.zip.bak test-pkgs/planet2-test1.zip"
|
||||
$ "cp -f test-pkgs/planet2-test1.zip.CHECKSUM.bak test-pkgs/planet2-test1.zip.CHECKSUM"
|
||||
(initialize-indexes))))))
|
||||
150
collects/tests/planet2/util.rkt
Normal file
150
collects/tests/planet2/util.rkt
Normal file
|
|
@ -0,0 +1,150 @@
|
|||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/system
|
||||
unstable/debug
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/file
|
||||
racket/runtime-path
|
||||
racket/path
|
||||
racket/list
|
||||
planet2/util
|
||||
"shelly.rkt")
|
||||
|
||||
(define-runtime-path test-directory ".")
|
||||
|
||||
(define (get-info-domain-cache-path)
|
||||
(define c (first (current-library-collection-paths)))
|
||||
(define p (build-path c "info-domain" "compiled" "cache.rktd"))
|
||||
(and (file-exists? p)
|
||||
p))
|
||||
|
||||
(define (with-fake-root* t)
|
||||
(define tmp-dir
|
||||
(make-temporary-file ".racket.fake-root~a" 'directory
|
||||
(find-system-path 'home-dir)))
|
||||
(make-directory* tmp-dir)
|
||||
(define tmp-dir-s
|
||||
(path->string tmp-dir))
|
||||
(define before
|
||||
(or (getenv "PLTADDONDIR")
|
||||
(path->string (find-system-path 'addon-dir))))
|
||||
(dynamic-wind
|
||||
void
|
||||
(λ ()
|
||||
(putenv "PLTADDONDIR"
|
||||
tmp-dir-s)
|
||||
(t))
|
||||
(λ ()
|
||||
(delete-directory/files tmp-dir)
|
||||
(putenv "PLTADDONDIR"
|
||||
before))))
|
||||
(define-syntax-rule (with-fake-root e ...)
|
||||
(with-fake-root* (λ () e ...)))
|
||||
|
||||
(define (with-thread start-thread thunk)
|
||||
(define thread-id (thread start-thread))
|
||||
(dynamic-wind
|
||||
void
|
||||
thunk
|
||||
(λ () (kill-thread thread-id))))
|
||||
|
||||
(require web-server/http
|
||||
web-server/servlet-env)
|
||||
(define (start-file-server)
|
||||
(serve/servlet (λ (req) (response/xexpr "None"))
|
||||
#:command-line? #t
|
||||
#:port 9999
|
||||
#:extra-files-paths (list (build-path test-directory "test-pkgs"))))
|
||||
|
||||
(require meta/planet2-index/basic/main)
|
||||
(define *index-ht-1* (make-hash))
|
||||
(define *index-ht-2* (make-hash))
|
||||
(define (start-planet2-server index-ht port)
|
||||
(serve/servlet (planet2-index/basic
|
||||
(λ ()
|
||||
(hash-keys index-ht))
|
||||
(λ (pkg-name)
|
||||
(define r (hash-ref index-ht pkg-name #f))
|
||||
(printf "[>server ~a] ~a = ~a\n" port pkg-name r)
|
||||
r))
|
||||
#:command-line? #t
|
||||
#:servlet-regexp #rx""
|
||||
#:port port))
|
||||
|
||||
(define servers-on? #f)
|
||||
(define (with-servers* t)
|
||||
(cond
|
||||
[servers-on?
|
||||
(t)]
|
||||
[else
|
||||
(set! servers-on? #t)
|
||||
(with-thread
|
||||
(λ () (start-planet2-server *index-ht-1* 9990))
|
||||
(λ ()
|
||||
(with-thread
|
||||
(λ () (start-planet2-server *index-ht-2* 9991))
|
||||
(λ ()
|
||||
(with-thread (λ () (start-file-server))
|
||||
t)))))]))
|
||||
(define-syntax-rule (with-servers e ...)
|
||||
(with-servers* (λ () e ...)))
|
||||
|
||||
(define-syntax (pkg-tests stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e ...)
|
||||
(with-syntax
|
||||
([run-pkg-tests (datum->syntax #f 'run-pkg-tests)])
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define (run-pkg-tests)
|
||||
(shelly-begin
|
||||
e ...))
|
||||
(provide run-pkg-tests)
|
||||
(module+ main
|
||||
(run-pkg-tests* run-pkg-tests)))))]))
|
||||
|
||||
(define (run-pkg-tests* t)
|
||||
(with-servers
|
||||
(with-fake-root
|
||||
(parameterize ([current-directory test-directory])
|
||||
(t)))))
|
||||
|
||||
(define-syntax-rule (shelly-install** message pkg rm-pkg (pre ...) (more ...))
|
||||
(with-fake-root
|
||||
(shelly-case
|
||||
(format "Test installation of ~a" message)
|
||||
pre ...
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1
|
||||
$ (format "raco pkg install ~a" pkg)
|
||||
$ "racket -e '(require planet2-test1)'"
|
||||
more ...
|
||||
$ (format "raco pkg remove ~a" rm-pkg)
|
||||
$ "racket -e '(require planet2-test1)'" =exit> 1)))
|
||||
|
||||
(define-syntax-rule (shelly-install* message pkg rm-pkg more ...)
|
||||
(shelly-install** message pkg rm-pkg () (more ...)))
|
||||
|
||||
(define-syntax-rule (shelly-install message pkg more ...)
|
||||
(shelly-install* message pkg "planet2-test1" more ...))
|
||||
|
||||
(define (initialize-indexes)
|
||||
(hash-set! *index-ht-1* "planet2-test1"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/planet2-test1.zip.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/planet2-test1.zip"))
|
||||
|
||||
(hash-set! *index-ht-1* "planet2-test2"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/planet2-test2.zip.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/planet2-test2.zip"))
|
||||
(hash-set! *index-ht-2* "planet2-test2-snd"
|
||||
(hasheq 'checksum
|
||||
(file->string "test-pkgs/planet2-test2.zip.CHECKSUM")
|
||||
'source
|
||||
"http://localhost:9999/planet2-test2.zip")))
|
||||
|
||||
(provide (all-defined-out))
|
||||
Loading…
Reference in New Issue
Block a user