mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
removing lib/chibi/snow dir to make it a submodule
This commit is contained in:
Alex Shinn
parent
3000523427
commit
96e3c8f06f
8 changed files with 0 additions and 1879 deletions
File diff suppressed because it is too large
Load diff
|
|
@ -1,50 +0,0 @@
|
||||||
|
|
||||||
(define-library (chibi snow commands)
|
|
||||||
(export command/package
|
|
||||||
command/gen-key
|
|
||||||
command/reg-key
|
|
||||||
command/sign
|
|
||||||
command/verify
|
|
||||||
command/upload
|
|
||||||
command/install
|
|
||||||
command/remove
|
|
||||||
command/search
|
|
||||||
command/show
|
|
||||||
command/status
|
|
||||||
command/update
|
|
||||||
command/upgrade)
|
|
||||||
(import (scheme base)
|
|
||||||
(scheme eval)
|
|
||||||
(scheme file)
|
|
||||||
(scheme process-context)
|
|
||||||
(scheme time)
|
|
||||||
(scheme read)
|
|
||||||
(scheme write)
|
|
||||||
(srfi 1)
|
|
||||||
(srfi 27)
|
|
||||||
(srfi 33)
|
|
||||||
(srfi 95)
|
|
||||||
(chibi snow interface)
|
|
||||||
(chibi snow package)
|
|
||||||
(chibi snow utils)
|
|
||||||
(chibi bytevector)
|
|
||||||
(chibi config)
|
|
||||||
(chibi crypto md5)
|
|
||||||
(chibi crypto rsa)
|
|
||||||
(chibi crypto sha2)
|
|
||||||
(chibi doc)
|
|
||||||
(chibi filesystem)
|
|
||||||
(chibi io)
|
|
||||||
(chibi match)
|
|
||||||
(chibi net http)
|
|
||||||
(chibi process)
|
|
||||||
(chibi pathname)
|
|
||||||
(chibi regexp)
|
|
||||||
(chibi show)
|
|
||||||
(chibi show pretty)
|
|
||||||
(chibi string)
|
|
||||||
(chibi sxml)
|
|
||||||
(chibi system)
|
|
||||||
(chibi tar)
|
|
||||||
(chibi zlib))
|
|
||||||
(include "commands.scm"))
|
|
||||||
|
|
@ -1,97 +0,0 @@
|
||||||
|
|
||||||
;; Abstract user interface for the snow command. This could be
|
|
||||||
;; substituted with a different implementation to provide a GUI.
|
|
||||||
|
|
||||||
(define (message . args)
|
|
||||||
(for-each display args)
|
|
||||||
(newline))
|
|
||||||
|
|
||||||
(define (info . args)
|
|
||||||
(apply message args))
|
|
||||||
|
|
||||||
(define (warn msg . args)
|
|
||||||
(let ((err (current-error-port)))
|
|
||||||
(display "WARNING: " err)
|
|
||||||
(display msg err)
|
|
||||||
(display ": " err)
|
|
||||||
(if (and (pair? args) (null? (cdr args)))
|
|
||||||
(write (car args) err)
|
|
||||||
(for-each (lambda (x) (display "\n " err) (write x err)) args))
|
|
||||||
(newline err)))
|
|
||||||
|
|
||||||
(define (die x . args)
|
|
||||||
(let ((n (if (number? x) x 2))
|
|
||||||
(args (if (number? x) args (cons x args)))
|
|
||||||
(err (current-error-port)))
|
|
||||||
(for-each (lambda (x) (display x err)) args)
|
|
||||||
(newline err)
|
|
||||||
(exit n)))
|
|
||||||
|
|
||||||
(define input-history #f)
|
|
||||||
|
|
||||||
(define (conf-input-history-file cfg)
|
|
||||||
(or (conf-get cfg 'input-history)
|
|
||||||
(string-append (or (conf-get cfg 'snow-dir)
|
|
||||||
(string-append (get-environment-variable "HOME")
|
|
||||||
"/.snow"))
|
|
||||||
"/input-history.scm")))
|
|
||||||
|
|
||||||
(define (restore-history cfg)
|
|
||||||
(let ((history-file (conf-input-history-file cfg)))
|
|
||||||
(set! input-history
|
|
||||||
(or (guard (exn (else #f))
|
|
||||||
(list->history (call-with-input-file history-file read)))
|
|
||||||
(make-history)))))
|
|
||||||
|
|
||||||
(define (save-history cfg)
|
|
||||||
(let ((history-file (conf-input-history-file cfg)))
|
|
||||||
(guard (exn (else (warn "couldn't save history to " history-file)))
|
|
||||||
(call-with-output-file history-file
|
|
||||||
(lambda (out)
|
|
||||||
(write (remove (lambda (x) (equal? x ""))
|
|
||||||
(history->list input-history))
|
|
||||||
out))))))
|
|
||||||
|
|
||||||
(define (input cfg name prompt . o)
|
|
||||||
(let ((proc (or (and (pair? o) (car o)) (lambda (x) x)))
|
|
||||||
(check (or (and (pair? o) (pair? (cdr o)) (cadr o))
|
|
||||||
(lambda (str res lp) res))))
|
|
||||||
(let lp ((reason #f))
|
|
||||||
(cond
|
|
||||||
((and (not reason) (conf-get cfg name))
|
|
||||||
=> (lambda (res) (check "" res lp)))
|
|
||||||
(else
|
|
||||||
(if reason
|
|
||||||
(show #t reason fl))
|
|
||||||
(let ((str (edit-line 'prompt: (lambda () (show #f prompt))
|
|
||||||
'history: input-history)))
|
|
||||||
(history-insert! input-history str)
|
|
||||||
(check str (proc str) lp)))))))
|
|
||||||
|
|
||||||
(define (input-number cfg name prompt . o)
|
|
||||||
(let* ((default (and (pair? o) (car o)))
|
|
||||||
(lo (and (pair? o) (pair? (cdr o)) (cadr o)))
|
|
||||||
(hi (and (pair? o) (pair? (cdr o)) (pair? (cddr o)) (car (cddr o))))
|
|
||||||
(prompt
|
|
||||||
(if default (each prompt " [default=" default "]: ") prompt))
|
|
||||||
(proc (lambda (str)
|
|
||||||
(if (and default (equal? str ""))
|
|
||||||
default
|
|
||||||
(string->number str))))
|
|
||||||
(check
|
|
||||||
(lambda (str res fail)
|
|
||||||
(cond
|
|
||||||
((not (number? res))
|
|
||||||
(fail "not a valid number"))
|
|
||||||
((and lo (< res lo))
|
|
||||||
(fail (each "too low, must be greater than " lo)))
|
|
||||||
((and hi (> res hi))
|
|
||||||
(fail (each "too high, must be less than " hi)))
|
|
||||||
(else
|
|
||||||
res)))))
|
|
||||||
(input cfg name prompt proc check)))
|
|
||||||
|
|
||||||
(define (yes-or-no? cfg . prompt)
|
|
||||||
(define (is-true? str)
|
|
||||||
(and (member (string-downcase str) '("#t" "y" "yes")) #t))
|
|
||||||
(input cfg 'always-yes? (each (each-in-list prompt) " [y/n]: ") is-true?))
|
|
||||||
|
|
@ -1,8 +0,0 @@
|
||||||
|
|
||||||
(define-library (chibi snow interface)
|
|
||||||
(export warn info message die input input-number yes-or-no?
|
|
||||||
restore-history save-history)
|
|
||||||
(import (scheme base) (scheme char) (scheme read) (scheme write)
|
|
||||||
(scheme file) (scheme process-context) (srfi 1)
|
|
||||||
(chibi config) (chibi show) (chibi stty) (chibi term edit-line))
|
|
||||||
(include "interface.scm"))
|
|
||||||
|
|
@ -1,350 +0,0 @@
|
||||||
|
|
||||||
;; general utils
|
|
||||||
|
|
||||||
(define (read-from-string str)
|
|
||||||
(call-with-input-string str read))
|
|
||||||
|
|
||||||
(define (display-to-string x)
|
|
||||||
(cond ((string? x) x)
|
|
||||||
((symbol? x) (symbol->string x))
|
|
||||||
((number? x) (number->string x))
|
|
||||||
(else (call-with-output-string (lambda (out) (display x out))))))
|
|
||||||
|
|
||||||
(define (maybe-parse-hex x)
|
|
||||||
(if (string? x) (hex-string->bytevector x) x))
|
|
||||||
|
|
||||||
;; rsa key utils
|
|
||||||
|
|
||||||
(define (lookup-digest name)
|
|
||||||
(case name
|
|
||||||
((md5) md5)
|
|
||||||
((sha-224) sha-224)
|
|
||||||
((sha-256) sha-256)
|
|
||||||
(else (error "unknown digest: " name))))
|
|
||||||
|
|
||||||
(define (rsa-identity=? email)
|
|
||||||
(lambda (x)
|
|
||||||
(cond ((not email) #f)
|
|
||||||
((assoc-get x 'email eq?)
|
|
||||||
=> (lambda (e) (string-ci=? email e)))
|
|
||||||
(else #f))))
|
|
||||||
|
|
||||||
(define (extract-rsa-key ls name)
|
|
||||||
(define (hex x)
|
|
||||||
(if (integer? x) x (string->number x 16)))
|
|
||||||
(cond
|
|
||||||
((assq name ls)
|
|
||||||
=> (lambda (x)
|
|
||||||
(let ((bits (assoc-get ls 'bits))
|
|
||||||
(modulus (assoc-get (cdr x) 'modulus))
|
|
||||||
(exponent (assoc-get (cdr x) 'exponent)))
|
|
||||||
(and bits modulus exponent
|
|
||||||
(if (eq? name 'private-key)
|
|
||||||
(make-rsa-key (hex bits) (hex modulus) #f (hex exponent))
|
|
||||||
(make-rsa-key (hex bits) (hex modulus)
|
|
||||||
(hex exponent) #f))))))
|
|
||||||
(else #f)))
|
|
||||||
|
|
||||||
(define (extract-rsa-private-key ls)
|
|
||||||
(extract-rsa-key ls 'private-key))
|
|
||||||
|
|
||||||
(define (extract-rsa-public-key ls)
|
|
||||||
(extract-rsa-key ls 'public-key))
|
|
||||||
|
|
||||||
;; repositories
|
|
||||||
|
|
||||||
(define (repo-url repo)
|
|
||||||
(and (pair? repo) (assoc-get (cdr repo) 'url eq?)))
|
|
||||||
|
|
||||||
(define (repo-find-publisher repo email)
|
|
||||||
(find (rsa-identity=? email)
|
|
||||||
(filter (lambda (x) (and (pair? x) (eq? 'publisher (car x))))
|
|
||||||
(cdr repo))))
|
|
||||||
|
|
||||||
;; packages
|
|
||||||
|
|
||||||
(define (package? x)
|
|
||||||
(and (pair? x) (eq? 'package (car x)) (every pair? (cdr x))))
|
|
||||||
|
|
||||||
(define (package-name package)
|
|
||||||
(and (pair? package)
|
|
||||||
(eq? 'package (car package))
|
|
||||||
(cond ((assoc-get (cdr package) 'name)
|
|
||||||
=> (lambda (x) (and (pair? x) x)))
|
|
||||||
((assq 'library (cdr package))
|
|
||||||
=> (lambda (x) (library-name x)))
|
|
||||||
((assq 'progam (cdr package))
|
|
||||||
=> (lambda (x) (program-name x)))
|
|
||||||
(else #f))))
|
|
||||||
|
|
||||||
(define (package-email pkg)
|
|
||||||
(and (package? pkg)
|
|
||||||
(let ((sig (assq 'signature (cdr pkg))))
|
|
||||||
(and (pair? sig)
|
|
||||||
(assoc-get (cdr sig) 'email eq?)))))
|
|
||||||
|
|
||||||
(define (package-author repo pkg . o)
|
|
||||||
(and (package? pkg)
|
|
||||||
(let ((email (package-email pkg))
|
|
||||||
(show-email? (and (pair? o) (car o))))
|
|
||||||
(or (cond
|
|
||||||
((repo-find-publisher repo email)
|
|
||||||
=> (lambda (pub)
|
|
||||||
(let ((name (assoc-get pub 'name)))
|
|
||||||
(if (and name show-email?)
|
|
||||||
(string-append name " <" (or email "") ">")
|
|
||||||
(or name email "")))))
|
|
||||||
(else #f))
|
|
||||||
email))))
|
|
||||||
|
|
||||||
(define (package-url repo pkg)
|
|
||||||
(let ((url (and (pair? pkg) (assoc-get (cdr pkg) 'url eq?))))
|
|
||||||
(and url
|
|
||||||
(uri-resolve url (string->path-uri 'http (repo-url repo))))))
|
|
||||||
|
|
||||||
(define (package-version pkg)
|
|
||||||
(and (pair? pkg) (assoc-get (cdr pkg) 'version eq?)))
|
|
||||||
|
|
||||||
(define (package-digest-mismatches cfg pkg raw)
|
|
||||||
(let ((size (assoc-get (cdr pkg) 'size))
|
|
||||||
(actual-size (bytevector-length raw)))
|
|
||||||
(if (and (integer? size) (not (= size actual-size)))
|
|
||||||
`(size: expected: ,size actual: ,actual-size)
|
|
||||||
(let* ((digest-name (assoc-get (cdr pkg) 'digest #f 'sha-256))
|
|
||||||
(digest (assoc-get (cdr pkg) digest-name))
|
|
||||||
(actual-digest ((lookup-digest digest-name) raw)))
|
|
||||||
(and digest
|
|
||||||
(not (equal? digest actual-digest))
|
|
||||||
`(digest: ,digest-name expected: ,digest
|
|
||||||
actual: ,actual-digest))))))
|
|
||||||
|
|
||||||
(define (package-digest-ok? cfg pkg raw)
|
|
||||||
(not (package-digest-mismatches cfg pkg raw)))
|
|
||||||
|
|
||||||
(define (package-signature-mismatches repo cfg pkg raw)
|
|
||||||
(let* ((sig-spec (assoc-get-list (cdr pkg) 'signature))
|
|
||||||
(digest-name (assoc-get sig-spec 'digest #f 'sha-256))
|
|
||||||
(digest (assoc-get sig-spec digest-name))
|
|
||||||
(sig (assoc-get sig-spec 'rsa))
|
|
||||||
(email (assoc-get sig-spec 'email))
|
|
||||||
(rsa-key-sexp (repo-find-publisher repo email))
|
|
||||||
(rsa-key (and (pair? rsa-key-sexp)
|
|
||||||
(extract-rsa-public-key (cdr rsa-key-sexp)))))
|
|
||||||
(cond
|
|
||||||
((not email)
|
|
||||||
`(sign: missing-email ,sig-spec))
|
|
||||||
((not rsa-key)
|
|
||||||
`(sign: unknown-publisher: ,email))
|
|
||||||
((not (rsa-verify? rsa-key
|
|
||||||
(maybe-parse-hex digest)
|
|
||||||
(maybe-parse-hex sig)))
|
|
||||||
`(sign: rsa-signature-invalid: digest: ,digest sig: ,sig
|
|
||||||
actual: ,(rsa-verify rsa-key (maybe-parse-hex digest))))
|
|
||||||
(else #f))))
|
|
||||||
|
|
||||||
(define (package-signature-ok? cfg pkg raw)
|
|
||||||
(not (package-signature-mismatches cfg pkg raw)))
|
|
||||||
|
|
||||||
(define (failure str . args)
|
|
||||||
(let ((out (open-output-string)))
|
|
||||||
(display str out)
|
|
||||||
(cond
|
|
||||||
((pair? args)
|
|
||||||
(display ":" out)
|
|
||||||
(for-each (lambda (x) (display " " out) (write x out)) args)))
|
|
||||||
(get-output-string out)))
|
|
||||||
|
|
||||||
(define (invalid-library-reason lib)
|
|
||||||
(cond
|
|
||||||
((not (list? lib)) "library must be a list")
|
|
||||||
((not (list? (library-name lib)))
|
|
||||||
(failure "library name must be a list" (library-name lib)))
|
|
||||||
((not (every (lambda (x) (or (symbol? x) (integer? x))) (library-name lib)))
|
|
||||||
(failure "library name must contain only symbols or integers"
|
|
||||||
(library-name lib)))
|
|
||||||
(else #f)))
|
|
||||||
|
|
||||||
(define (valid-library? lib)
|
|
||||||
(not (invalid-library-reason lib)))
|
|
||||||
|
|
||||||
(define (invalid-package-reason pkg)
|
|
||||||
(cond
|
|
||||||
((not (list? pkg))
|
|
||||||
"package must be a list")
|
|
||||||
((not (string? (package-version pkg)))
|
|
||||||
(failure "package-version is not a string" (package-version pkg)))
|
|
||||||
(else
|
|
||||||
(let ((libs (package-libraries pkg)))
|
|
||||||
(cond
|
|
||||||
((not (pair? libs)) "package must contain at least one library")
|
|
||||||
((any invalid-library-reason libs))
|
|
||||||
(else #f))))))
|
|
||||||
|
|
||||||
(define (valid-package? pkg)
|
|
||||||
(not (invalid-package-reason pkg)))
|
|
||||||
|
|
||||||
(define (package-libraries package)
|
|
||||||
(and (package? package) (filter library? (cdr package))))
|
|
||||||
|
|
||||||
(define (package-programs package)
|
|
||||||
(and (package? package) (filter program? (cdr package))))
|
|
||||||
|
|
||||||
(define (package-provides? package name)
|
|
||||||
(and (pair? package)
|
|
||||||
(eq? 'package (car package))
|
|
||||||
(or (equal? name (assoc-get (cdr package) 'name))
|
|
||||||
(find (lambda (x) (equal? name (library-name x)))
|
|
||||||
(package-libraries package)))))
|
|
||||||
|
|
||||||
(define (package-dependencies package)
|
|
||||||
(append-map library-dependencies
|
|
||||||
(package-libraries package)))
|
|
||||||
|
|
||||||
(define (package-installed-files pkg)
|
|
||||||
(or (and (pair? pkg) (assoc-get-list (cdr pkg) 'installed-files)) '()))
|
|
||||||
|
|
||||||
(define (library-name->path name)
|
|
||||||
(if (null? name)
|
|
||||||
""
|
|
||||||
(call-with-output-string
|
|
||||||
(lambda (out)
|
|
||||||
(let lp ((name name))
|
|
||||||
(display (car name) out)
|
|
||||||
(cond ((pair? (cdr name))
|
|
||||||
(write-char #\/ out)
|
|
||||||
(lp (cdr name)))))))))
|
|
||||||
|
|
||||||
;; map a library to the path name it would be found in (sans extension)
|
|
||||||
(define (library->path library)
|
|
||||||
(library-name->path (library-name library)))
|
|
||||||
|
|
||||||
;; find the library declaration file for the given library
|
|
||||||
(define (get-library-file cfg library)
|
|
||||||
(or (assoc-get library 'path)
|
|
||||||
(string-append (library->path library) "."
|
|
||||||
(conf-get cfg 'library-extension "sld"))))
|
|
||||||
|
|
||||||
(define (package->path pkg)
|
|
||||||
(library-name->path (package-name pkg)))
|
|
||||||
|
|
||||||
(define (package-name->meta-file cfg name)
|
|
||||||
(let ((path (library-name->path name)))
|
|
||||||
(string-append (path-directory path) "/."
|
|
||||||
(path-strip-directory path) ".meta")))
|
|
||||||
|
|
||||||
(define (get-package-meta-file cfg pkg)
|
|
||||||
(package-name->meta-file cfg (package-name pkg)))
|
|
||||||
|
|
||||||
(define (get-library-meta-file cfg lib)
|
|
||||||
(package-name->meta-file cfg (library-name lib)))
|
|
||||||
|
|
||||||
;; libraries
|
|
||||||
|
|
||||||
(define (library? x)
|
|
||||||
(and (pair? x) (eq? 'library (car x)) (every pair? (cdr x))))
|
|
||||||
|
|
||||||
(define (library-name lib)
|
|
||||||
(and (pair? lib) (assoc-get (cdr lib) 'name eq?)))
|
|
||||||
|
|
||||||
(define (library-url lib)
|
|
||||||
(and (pair? lib) (assoc-get (cdr lib) 'url eq?)))
|
|
||||||
|
|
||||||
(define (library-dependencies lib)
|
|
||||||
(cond ((assq 'depends (cdr lib)) => cdr)
|
|
||||||
(else '())))
|
|
||||||
|
|
||||||
(define (parse-library-name str)
|
|
||||||
(cond
|
|
||||||
((pair? str) str)
|
|
||||||
((equal? "" str) (error "empty library name"))
|
|
||||||
((eqv? #\( (string-ref str 0)) (read-from-string str))
|
|
||||||
(else (map (lambda (x) (or (string->number x) (string->symbol x)))
|
|
||||||
(string-split str #\.)))))
|
|
||||||
|
|
||||||
(define (check-cond-expand config test)
|
|
||||||
(define (library-installed? config name)
|
|
||||||
;; assume it could be installed for now
|
|
||||||
#t)
|
|
||||||
(cond
|
|
||||||
((symbol? test)
|
|
||||||
(or (eq? 'else test) (memq test (conf-get-list config 'features))))
|
|
||||||
((pair? test)
|
|
||||||
(case (car test)
|
|
||||||
((not) (not (check-cond-expand config (cadr test))))
|
|
||||||
((and) (every (lambda (x) (check-cond-expand config x)) (cdr test)))
|
|
||||||
((or) (any (lambda (x) (check-cond-expand config x)) (cdr test)))
|
|
||||||
((library) (every (lambda (x) (library-installed? config x)) (cdr test)))
|
|
||||||
(else
|
|
||||||
(warn "unknown cond-expand form" test)
|
|
||||||
#f)))
|
|
||||||
(else #f)))
|
|
||||||
|
|
||||||
;; We can't use the native library system introspection since we may
|
|
||||||
;; be analyzing a library which can't be loaded in the native system.
|
|
||||||
(define (library-analyze config file)
|
|
||||||
(let ((sexp (call-with-input-file file read)))
|
|
||||||
(and (list? sexp)
|
|
||||||
(memq (car sexp) '(define-library library define-module module))
|
|
||||||
(let analyze ((ls (cddr sexp)))
|
|
||||||
(cond
|
|
||||||
((null? ls) '())
|
|
||||||
(else
|
|
||||||
(append
|
|
||||||
(case (caar ls)
|
|
||||||
((cond-expand)
|
|
||||||
(cond
|
|
||||||
((find (lambda (x) (check-cond-expand config (car x))) (cdar ls))
|
|
||||||
=> (lambda (x) (analyze (cdr x))))
|
|
||||||
(else (analyze (cdr ls)))))
|
|
||||||
(else (list (car ls))))
|
|
||||||
(analyze (cdr ls)))))))))
|
|
||||||
|
|
||||||
(define (library-include-files config file)
|
|
||||||
(let ((lib (library-analyze config file))
|
|
||||||
(dir (path-directory file)))
|
|
||||||
(append-map
|
|
||||||
(lambda (x) (map (lambda (y) (make-path dir y)) (cdr x)))
|
|
||||||
(filter (lambda (x) (and (pair? x) (memq (car x) '(include include-ci))))
|
|
||||||
lib))))
|
|
||||||
|
|
||||||
(define (library-rewrite-includes x rules)
|
|
||||||
(define (recurse x) (library-rewrite-includes x rules))
|
|
||||||
(define (rewrite x)
|
|
||||||
(cond ((any (lambda (r) (and (pair? r) (equal? x (car r)))) rules) => cdr)
|
|
||||||
(else x)))
|
|
||||||
(cond
|
|
||||||
((pair? x)
|
|
||||||
(case (car x)
|
|
||||||
((include include-ci)
|
|
||||||
(cons (car x) (map rewrite (cdr x))))
|
|
||||||
((cond-expand)
|
|
||||||
(cons (car x)
|
|
||||||
(map (lambda (y) (cons (car y) (map recurse (cdr y)))) (cdr x))))
|
|
||||||
((define-library library)
|
|
||||||
(cons (car x) (map recurse (cdr x))))
|
|
||||||
(else x)))
|
|
||||||
(else x)))
|
|
||||||
|
|
||||||
;; programs
|
|
||||||
|
|
||||||
(define (program? x)
|
|
||||||
(and (pair? x) (eq? 'program (car x)) (every pair? (cdr x))))
|
|
||||||
|
|
||||||
(define (program-name prog)
|
|
||||||
(and (pair? prog)
|
|
||||||
(cond ((assoc-get (cdr prog) 'name eq?))
|
|
||||||
((assoc-get (cdr prog) 'path eq?)
|
|
||||||
=> (lambda (p) (list (string->symbol (path-strip-directory p)))))
|
|
||||||
(else #f))))
|
|
||||||
|
|
||||||
(define (get-program-file cfg prog)
|
|
||||||
(cond ((assoc-get prog 'path))
|
|
||||||
((assoc-get prog 'name)
|
|
||||||
=> (lambda (name) (library-name->path (last name))))
|
|
||||||
(else (error "program missing path: " prog))))
|
|
||||||
|
|
||||||
(define (program-install-name prog)
|
|
||||||
(or (assoc-get (cdr prog) 'install-name eq?)
|
|
||||||
(path-strip-extension
|
|
||||||
(path-strip-directory
|
|
||||||
(assoc-get (cdr prog) 'path eq?)))))
|
|
||||||
|
|
@ -1,32 +0,0 @@
|
||||||
|
|
||||||
(define-library (chibi snow package)
|
|
||||||
(export package? library? program?
|
|
||||||
package-name package-email package-url package-version
|
|
||||||
package-libraries package-programs
|
|
||||||
package-provides? package-dependencies
|
|
||||||
package-installed-files package-author
|
|
||||||
package-digest-mismatches package-signature-mismatches
|
|
||||||
package-digest-ok? package-signature-ok?
|
|
||||||
package->path package-name->meta-file
|
|
||||||
get-package-meta-file get-library-meta-file
|
|
||||||
library-name->path library->path get-library-file
|
|
||||||
library-url library-name parse-library-name library-name->path
|
|
||||||
library-analyze library-include-files library-dependencies
|
|
||||||
library-rewrite-includes
|
|
||||||
get-program-file program-name program-install-name
|
|
||||||
invalid-package-reason valid-package?
|
|
||||||
invalid-library-reason valid-library?
|
|
||||||
repo-find-publisher lookup-digest rsa-identity=?
|
|
||||||
extract-rsa-private-key extract-rsa-public-key)
|
|
||||||
(import (chibi)
|
|
||||||
(srfi 1)
|
|
||||||
(chibi snow interface)
|
|
||||||
(chibi bytevector)
|
|
||||||
(chibi config)
|
|
||||||
(chibi crypto md5)
|
|
||||||
(chibi crypto rsa)
|
|
||||||
(chibi crypto sha2)
|
|
||||||
(chibi pathname)
|
|
||||||
(chibi string)
|
|
||||||
(chibi uri))
|
|
||||||
(include "package.scm"))
|
|
||||||
|
|
@ -1,53 +0,0 @@
|
||||||
|
|
||||||
;;> Copies the file \var{from} to \var{to}.
|
|
||||||
|
|
||||||
(define (copy-file from to)
|
|
||||||
(let ((in (open-binary-input-file from))
|
|
||||||
(out (open-binary-output-file to)))
|
|
||||||
(let lp ()
|
|
||||||
(let ((n (read-u8 in)))
|
|
||||||
(cond ((eof-object? n) (close-input-port in) (close-output-port out))
|
|
||||||
(else (write-u8 n out) (lp)))))))
|
|
||||||
|
|
||||||
(define (call-with-temp-file template proc)
|
|
||||||
(let ((base (string-append
|
|
||||||
"/tmp/" (path-strip-extension template)
|
|
||||||
"-" (number->string (current-process-id)) "-"
|
|
||||||
(number->string (exact (round (current-second)))) "-"))
|
|
||||||
(ext (or (path-extension template) "tmp")))
|
|
||||||
(let lp ((i 0))
|
|
||||||
(let ((path (string-append base (number->string i) "." ext)))
|
|
||||||
(cond
|
|
||||||
((> i 100) ;; give up after too many tries regardless
|
|
||||||
(die 2 "Repeatedly failed to generate temp file in /tmp"))
|
|
||||||
((file-exists? path)
|
|
||||||
(lp (+ i 1)))
|
|
||||||
(else
|
|
||||||
(let ((fd (open path
|
|
||||||
(bitwise-ior open/write open/create open/exclusive))))
|
|
||||||
(if (not fd)
|
|
||||||
(if (file-exists? path) ;; created between test and open
|
|
||||||
(lp (+ i 1))
|
|
||||||
(die 2 "Couldn't generate temp file in /tmp " path))
|
|
||||||
(let* ((out (open-output-file-descriptor fd #o700))
|
|
||||||
(res (proc path out)))
|
|
||||||
(close-output-port out)
|
|
||||||
(delete-file path)
|
|
||||||
res)))))))))
|
|
||||||
|
|
||||||
(define (call-with-temp-dir template proc)
|
|
||||||
(let ((base (string-append
|
|
||||||
"/tmp/" template
|
|
||||||
"-" (number->string (current-process-id)) "-"
|
|
||||||
(number->string (exact (round (current-second)))) "-")))
|
|
||||||
(let lp ((i 0))
|
|
||||||
(let ((path (string-append base (number->string i))))
|
|
||||||
(cond
|
|
||||||
((> i 100) ;; give up after too many tries
|
|
||||||
(die 2 "Repeatedly failed to generate temp dir in /tmp " path))
|
|
||||||
((file-exists? path)
|
|
||||||
(lp (+ i 1)))
|
|
||||||
((create-directory path #o700)
|
|
||||||
(let ((res (proc path)))
|
|
||||||
(delete-file-hierarchy path)
|
|
||||||
res)))))))
|
|
||||||
|
|
@ -1,12 +0,0 @@
|
||||||
|
|
||||||
(define-library (chibi snow utils)
|
|
||||||
(export copy-file call-with-temp-file call-with-temp-dir)
|
|
||||||
(import (scheme base)
|
|
||||||
(scheme file)
|
|
||||||
(scheme time)
|
|
||||||
(srfi 33)
|
|
||||||
(chibi filesystem)
|
|
||||||
(chibi pathname)
|
|
||||||
(chibi process)
|
|
||||||
(chibi snow interface))
|
|
||||||
(include "utils.scm"))
|
|
||||||
Loading…
Add table
Reference in a new issue