mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
342 lines
12 KiB
Scheme
342 lines
12 KiB
Scheme
|
|
(define (static-url cfg path)
|
|
(make-path "/s" path))
|
|
|
|
(define (static-local-path cfg path)
|
|
(make-path (conf-get cfg 'doc-root ".") "s" path))
|
|
|
|
(define (maybe-parse-hex x)
|
|
(if (string? x) (hex-string->bytevector x) x))
|
|
|
|
(define valid-email?
|
|
;; Conservatively match local parts allowed by hotmail, removing
|
|
;; the restriction on ".." as allowed by Japanese phone providers.
|
|
(let ((re (regexp
|
|
'(: (+ (or alphanumeric #\_ #\- #\. #\+ #\= #\& #\'))
|
|
"@" (+ (or alphanumeric #\_ #\-))
|
|
(+ "." (+ (or alphanumeric #\_ #\-)))))))
|
|
(lambda (str) (regexp-matches? re str))))
|
|
|
|
(define (extract-snowball-package bv)
|
|
(define (path-top path)
|
|
(substring-cursor path (string-cursor-start path) (string-find path #\/)))
|
|
(guard (exn
|
|
(else
|
|
(log-error "couldn't extract package.scm: " exn)
|
|
#f))
|
|
(cond
|
|
((tar-safe? bv)
|
|
(let* ((files (tar-files bv))
|
|
(dir (path-top (car files)))
|
|
(pkg-path (make-path dir "package.scm")))
|
|
(cond
|
|
((member pkg-path files)
|
|
(read (open-input-bytevector
|
|
(tar-extract-file bv pkg-path))))
|
|
(else
|
|
(log-error "no package.scm in " dir)
|
|
#f))))
|
|
(else
|
|
(log-error "tar-bomb")
|
|
#f))))
|
|
|
|
(define escape-path
|
|
(lambda (str)
|
|
(let ((re (regexp '(w/ascii (~ (or alphanumeric #\_ #\- #\.))))))
|
|
(regexp-replace
|
|
re
|
|
str
|
|
(lambda (m)
|
|
(let ((n (char->integer
|
|
(string-ref (regexp-match-submatch m 0) 0))))
|
|
(string-append
|
|
"%"
|
|
(if (< n 16) "0" "")
|
|
(number->string n 16))))))))
|
|
|
|
(define (x->string x)
|
|
(cond ((string? x) x)
|
|
((symbol? x) (symbol->string x))
|
|
((number? x) (number->string x))
|
|
(else (error "not stringable" x))))
|
|
|
|
(define (email->path str)
|
|
(let ((ls (string-split str #\@)))
|
|
(make-path (escape-path (cadr ls)) (escape-path (car ls)))))
|
|
|
|
(define (repo-publishers cfg)
|
|
(filter (lambda (x) (and (pair? x) (eq? 'publisher (car x))))
|
|
(cdr (current-repo cfg))))
|
|
|
|
(define (invalid-signature-reason cfg sig-spec snowball)
|
|
(let* ((digest-name (assoc-get (cdr sig-spec) 'digest #f 'sha-256))
|
|
(digest (assoc-get (cdr sig-spec) digest-name))
|
|
(actual-digest ((lookup-digest digest-name) snowball))
|
|
(sig (assoc-get (cdr sig-spec) 'rsa))
|
|
(email (assoc-get (cdr sig-spec) 'email))
|
|
(publisher (find (rsa-identity=? email)
|
|
(repo-publishers cfg)))
|
|
(verify-rsa? (conf-get cfg 'verify-signatures?))
|
|
(rsa-key (and verify-rsa?
|
|
(pair? publisher)
|
|
(extract-rsa-public-key (cdr publisher)))))
|
|
(cond
|
|
((not (equal? digest actual-digest))
|
|
(string-append "the " digest-name " digest in the signature <" digest
|
|
"> didn't match the actual value: <" actual-digest ">"))
|
|
((not publisher)
|
|
(string-append "unknown publisher: " email))
|
|
((and verify-rsa?
|
|
(not (rsa-verify? rsa-key
|
|
(maybe-parse-hex digest)
|
|
(maybe-parse-hex sig))))
|
|
(log-error "digest: " digest " sig: " (maybe-parse-hex sig)
|
|
" verify: " (rsa-encrypt rsa-key digest))
|
|
"rsa signature did not match")
|
|
(else
|
|
#f))))
|
|
|
|
(define (get-user-password cfg email)
|
|
(let* ((user-dir (static-local-path cfg (email->path email)))
|
|
(key-file (make-path user-dir "pub-key"))
|
|
(key (guard (exn (else #f)) (call-with-input-file key-file read))))
|
|
(and (pair? key) (assoc-get key 'password))))
|
|
|
|
(define (package-dir email pkg . o)
|
|
(make-path
|
|
(email->path email)
|
|
(string-join (map escape-path (map x->string (package-name pkg))) "/")
|
|
(escape-path (if (pair? o) (car o) (package-version pkg)))))
|
|
|
|
;; Simplistic pretty printing for package/repository/config declarations.
|
|
(define (write-simple-pretty pkg out)
|
|
(let wr ((ls pkg) (indent 0) (tails 0))
|
|
(cond
|
|
((and (pair? ls)
|
|
(pair? (cdr ls))
|
|
(pair? (cadr ls)))
|
|
(display (make-string indent #\space) out)
|
|
(write-char #\( out)
|
|
(write (car ls) out)
|
|
(newline out)
|
|
(for-each (lambda (x) (wr x (+ indent 2) 0)) (drop-right (cdr ls) 1))
|
|
(wr (last ls) (+ indent 2) (+ tails 1)))
|
|
(else
|
|
(display (make-string indent #\space) out)
|
|
(write ls out)
|
|
(display (make-string tails #\)) out)
|
|
(newline out)))))
|
|
|
|
(define (file-lock-loop port-or-fd mode)
|
|
(let lp ()
|
|
(cond
|
|
((file-lock port-or-fd mode))
|
|
((memv (errno) '(11 35)) (thread-sleep! 0.01) (lp))
|
|
(else (error "couldn't lock file" (integer->error-string))))))
|
|
|
|
(define (call-with-locked-file path proc . o)
|
|
(let ((fd (open path
|
|
(+ open/create open/read-write)
|
|
(if (pair? o) (car o) #o644))))
|
|
(file-lock-loop fd (+ lock/exclusive lock/non-blocking))
|
|
(exception-protect (proc fd) (file-lock fd lock/unlock))))
|
|
|
|
;; Rewrites file in place with the result of (proc orig-contents),
|
|
;; synchronized with file-lock.
|
|
(define (synchronized-rewrite-text-file path proc . o)
|
|
(call-with-locked-file
|
|
path
|
|
(lambda (fd)
|
|
(let* ((in (open-input-file-descriptor fd))
|
|
(out (open-output-file-descriptor fd))
|
|
(str (port->string in))
|
|
(res (proc str)))
|
|
(set-file-position! out seek/set 0)
|
|
(display res out)
|
|
(file-truncate out (string-size res))
|
|
(close-output-port out)
|
|
res))))
|
|
|
|
(define (synchronized-rewrite-sexp-file path proc . o)
|
|
(apply synchronized-rewrite-text-file
|
|
path
|
|
(lambda (str)
|
|
(let ((x (call-with-input-string str read)))
|
|
(call-with-output-string
|
|
(lambda (out) (write-simple-pretty (proc x) out)))))
|
|
o))
|
|
|
|
(define (current-repo cfg)
|
|
(call-with-input-file (static-local-path cfg "repo.scm") read))
|
|
|
|
(define (rewrite-repo cfg proc)
|
|
(synchronized-rewrite-sexp-file
|
|
(static-local-path cfg "repo.scm")
|
|
proc
|
|
"(repository)"))
|
|
|
|
(define (update-repo cfg rem-pred value)
|
|
(rewrite-repo
|
|
cfg
|
|
(lambda (repo)
|
|
(let*-values (((repo) (if (pair? repo) repo '(repository)))
|
|
((drop keep) (partition rem-pred (cdr repo))))
|
|
`(,(car repo)
|
|
,(if (procedure? value) (value repo drop) value)
|
|
,@keep)))))
|
|
|
|
(define (update-repo-object cfg key-field value)
|
|
(let* ((type (car value))
|
|
(key-value (assoc-get (cdr value) key-field eq?))
|
|
(pred
|
|
(lambda (x)
|
|
(and (pair? x)
|
|
(eq? type (car x))
|
|
(equal? key-value (assoc-get (cdr x) key-field eq?))))))
|
|
(update-repo cfg pred value)))
|
|
|
|
(define (update-repo-package cfg pkg . o)
|
|
(let* ((email (package-email pkg))
|
|
(auth-pred (lambda (x) (equal? email (package-email x))))
|
|
(pkg-pred
|
|
(cond
|
|
((package-name pkg)
|
|
=> (lambda (name)
|
|
(lambda (x) (equal? name (package-name x)))))
|
|
(else
|
|
(let ((libs (map (lambda (x) (assoc-get (cdr x) 'name eq?))
|
|
(package-libraries pkg))))
|
|
(lambda (x)
|
|
(every (lambda (y)
|
|
(member (assoc-get (cdr x) 'name eq?) libs))
|
|
(package-libraries x)))))))
|
|
(rem-pred
|
|
(lambda (x)
|
|
(and (pair? x) (eq? 'package (car x))
|
|
(auth-pred x) (pkg-pred x))))
|
|
(value (if (pair? o) (lambda (repo drop) ((car o) repo drop pkg)) pkg)))
|
|
(update-repo cfg rem-pred value)))
|
|
|
|
(define (fail msg . args)
|
|
`(span (@ (style . "background:red")) ,msg ,@args))
|
|
|
|
(define (page body . o)
|
|
`(html
|
|
(head
|
|
(title "Snow")
|
|
(meta (@ (charset . "utf-8")))
|
|
(link (@ (type . "text/css")
|
|
(rel . "stylesheet")
|
|
(href . "/s/snow.css")))
|
|
(link (@ (rel . "shortcut icon")
|
|
(href . "/s/favicon.ico")))
|
|
,@o)
|
|
(body
|
|
(div (@ (id . "head"))
|
|
(div (@ (id . "head_pic")) "☃")
|
|
(div (@ (id . "head_name")) (b "Snow")))
|
|
(div (@ (id . "toolbar"))
|
|
(nav (@ (id . "menu"))
|
|
(a (@ (href . "/")) "Home")
|
|
(a (@ (href . "/pkg")) "Libraries")
|
|
(a (@ (href . "/doc")) "Docs")
|
|
(a (@ (href . "/link")) "Resources")
|
|
(a (@ (href . "/faq")) "FAQ"))
|
|
(div (@ (id . "search"))
|
|
(form
|
|
(@ (action . "http://www.google.com/search"))
|
|
(input (@ (type . "text") (name . "q")))
|
|
(input (@ (type . "hidden")
|
|
(name . "domains")
|
|
(value . "snow-fort.org")))
|
|
(input (@ (type . "hidden")
|
|
(name . "sitesearch")
|
|
(value . "snow-fort.org")))
|
|
(input (@ (type . "submit")
|
|
(name . "search")
|
|
(value . "Search Libraries"))))))
|
|
,body)))
|
|
|
|
(define (dependency-url cfg dep . o)
|
|
(if (and (eq? 'srfi (car dep))
|
|
(pair? (cdr dep))
|
|
(integer? (cadr dep))
|
|
(null? (cddr dep)))
|
|
(string-append "https://srfi.schemers.org/srfi-"
|
|
(number->string (cadr dep))
|
|
"/")
|
|
;; TODO: alternative impls
|
|
(let* ((repo (if (pair? o) (car o) (current-repo cfg)))
|
|
(pkg (find (lambda (p)
|
|
(and (package? p)
|
|
(any (lambda (m) (equal? dep (library-name m)))
|
|
(package-libraries p))))
|
|
(cdr repo))))
|
|
(and pkg
|
|
(make-path "/s" (package-dir (package-email pkg) pkg "latest"))))))
|
|
|
|
(define (package-page pkg files . o)
|
|
(let* ((cfg (if (pair? o) (car o) (make-conf '() #f #f 0)))
|
|
(repo (if (and (pair? o) (pair? (cdr o)))
|
|
(cadr o)
|
|
(current-repo cfg))))
|
|
`(div
|
|
(div "☃ " (b ,(package-name pkg)) " - " (i ,(package-version pkg)))
|
|
(div ,(or (assoc-get pkg 'description) ""))
|
|
,(let ((auth (package-author '() pkg))
|
|
(maint (package-maintainer '() pkg)))
|
|
`(div ,auth
|
|
,@(if (and maint (not (equal? maint auth)))
|
|
`((" (" ,maint ")"))
|
|
'())
|
|
,(cond ((assoc-get pkg 'license)
|
|
=> (lambda (x)
|
|
(string-append " - " (write-to-string x))))
|
|
(else ""))))
|
|
,@(cond
|
|
((assq 'manual (cdr pkg))
|
|
=> (lambda (ls)
|
|
(if (and (pair? ls) (pair? (cdr ls)))
|
|
(if (or (string-prefix? "http:" (cadr ls))
|
|
(string-prefix? "https:" (cadr ls)))
|
|
`((a (@ (href . ,(cadr ls))) "doc"))
|
|
`((a (@ (href . ,(make-path "files" (cadr ls))))
|
|
"Documentation")))
|
|
'())))
|
|
(else '()))
|
|
(div
|
|
(b "Dependencies")
|
|
(ul
|
|
,@(map
|
|
(lambda (dep)
|
|
`(li (a (@ (href . ,(dependency-url cfg dep repo)))
|
|
,(write-to-string dep))))
|
|
(filter
|
|
(lambda (dep)
|
|
(and (pair? dep) (not (eq? 'scheme (car dep)))))
|
|
(package-dependencies 'chibi cfg pkg)))))
|
|
(div
|
|
(b "Files")
|
|
(ul
|
|
,@(map
|
|
(lambda (file) `(li (a (@ (href . ,(make-path "files" file))) ,file)))
|
|
(filter
|
|
(lambda (file)
|
|
(and (string? file)
|
|
(not (equal? "" file))
|
|
(not (string-prefix? "." file))))
|
|
files)))))))
|
|
|
|
(define (respond cfg request proc)
|
|
(let ((sexp? (equal? "sexp" (request-param request "fmt"))))
|
|
(servlet-write
|
|
request
|
|
(cond
|
|
(sexp?
|
|
(call-with-current-continuation proc))
|
|
(else
|
|
(let ((res (sxml->xml (proc (lambda (x) x)))))
|
|
(servlet-respond request 200 "OK"
|
|
'((Content-Type . "text/html; charset=utf-8")))
|
|
res))))
|
|
(if sexp? (servlet-write request "\n"))))
|