403 lines
15 KiB
Racket
403 lines
15 KiB
Racket
#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
|
|
setup/unpack)
|
|
|
|
(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)
|
|
(unpack dest pkg-dir
|
|
(lambda (x) (printf "~a\n" x))
|
|
(lambda () dest-dir)
|
|
#f
|
|
(lambda (auto-dir main-dir file) 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)
|
|
(call-with-output-file*
|
|
(build-path pkg-dir "info.rkt")
|
|
(lambda (o)
|
|
(fprintf o "#lang setup/infotab\n")
|
|
(write `(define deps ',deps) o)))))
|
|
|
|
|
|
(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 --format plt ~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://planet-compat.racket-lang.org/~a/~a.plt"
|
|
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))
|