Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

removing lib/chibi/snow dir to make it a submodule

Browse source
This commit is contained in:
Alex Shinn 2015-03-17 21:52:09 +09:00
parent 3000523427
commit 96e3c8f06f
8 changed files with 0 additions and 1879 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1277
lib/chibi/snow/commands.scm
View file

File diff suppressed because it is too large Load diff

50
lib/chibi/snow/commands.sld
View file

@ -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"))

97
lib/chibi/snow/interface.scm
View file

@ -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?))

8
lib/chibi/snow/interface.sld
View file

@ -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"))

350
lib/chibi/snow/package.scm
View file

@ -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?)))))

32
lib/chibi/snow/package.sld
View file

@ -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"))

53
lib/chibi/snow/utils.scm
View file

@ -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)))))))

12
lib/chibi/snow/utils.sld
View file

@ -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"))