Initial snow libs.

This commit is contained in:
Alex Shinn 2014-06-11 00:58:29 +09:00
parent 91ba422430
commit c4c85a5e19
9 changed files with 1739 additions and 0 deletions

1020
lib/snow/commands.scm Normal file

File diff suppressed because it is too large Load diff

51
lib/snow/commands.sld Normal file
View file

@ -0,0 +1,51 @@
(define-library (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
die
installed-libraries)
(import (except (chibi) equal? write display)
(scheme base)
(scheme eval)
(scheme write)
(scheme file)
(scheme time)
(srfi 1)
(srfi 27)
(srfi 33)
(srfi 95)
(srfi 98)
(snow interface)
(snow package)
(snow utils)
(chibi bytevector)
(chibi config)
(chibi crypto md5)
(chibi crypto rsa)
(chibi crypto sha2)
(chibi filesystem)
(chibi io)
(chibi match)
(chibi net http)
(chibi process)
(chibi pathname)
(chibi show)
(chibi show pretty)
(chibi string)
(chibi sxml)
(chibi system)
(chibi tar)
(chibi zlib))
(include "commands.scm"))

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

@ -0,0 +1,97 @@
;; 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/snow/interface.sld Normal file
View file

@ -0,0 +1,8 @@
(define-library (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"))

274
lib/snow/package.scm Normal file
View file

@ -0,0 +1,274 @@
;; 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) (string->number x 16) 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))
(or (assoc-get (cdr package) 'name)
;; TODO: longest common prefix
(let ((lib (assq 'library (cdr package))))
(and lib (library-name lib))))))
(define (package-email pkg)
(and (pair? pkg)
(let ((sig (assq 'signature (cdr pkg))))
(and (pair? sig)
(assoc-get (cdr sig) 'email eq?)))))
(define (package-url repo pkg)
(let ((url (and (pair? pkg) (assoc-get (cdr pkg) 'url eq?))))
(if (and url (uri-has-scheme? url))
url
(uri-with-path (string->path-uri 'http (repo-url repo)) url))))
(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-encrypt rsa-key digest)))
(else #f))))
(define (package-signature-ok? cfg pkg raw)
(not (package-signature-mismatches cfg pkg raw)))
(define (package-libraries package)
(and (package? package) (filter library? (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)
(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)
(assoc-get-list (cdr lib) 'depends))
(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 (library-name->path name)
(and (pair? name)
(let lp ((ls (cdr name)) (res (list (car name))))
(if (null? ls)
(apply string-append
(map display-to-string (reverse (cons ".sld" res))))
(lp (cdr ls) (cons (car ls) (cons "/" res)))))))
(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)))

27
lib/snow/package.sld Normal file
View file

@ -0,0 +1,27 @@
(define-library (snow package)
(export package? library?
package-name package-email package-url package-version
package-libraries package-provides? package-dependencies
package-installed-files
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
repo-find-publisher lookup-digest rsa-identity=?
extract-rsa-private-key extract-rsa-public-key)
(import (chibi)
(srfi 1)
(snow interface)
(chibi config)
(chibi crypto md5)
(chibi crypto rsa)
(chibi crypto sha2)
(chibi pathname)
(chibi string)
(chibi uri))
(include "package.scm"))

183
lib/snow/snow Executable file
View file

@ -0,0 +1,183 @@
#!/usr/bin/env chibi-scheme
;; This code was written by Alex Shinn in 2013 and placed in the
;; Public Domain. All warranties are disclaimed.
(import (scheme base) (scheme char) (scheme read) (scheme write)
(scheme file) (scheme process-context) (srfi 1)
(snow commands) (snow library) (snow utils) (snow interface)
(chibi app) (chibi config) (chibi match) (chibi string)
(chibi pathname) (chibi filesystem) (chibi process))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define repo-spec
'((repository
(conf
(sibling
(conf
(name string)
(url string)))
(package
(conf
(name (list (or symbol integer)))
(url string)
(size integer)
(checksums (alist symbol string))
(signature (alist symbol string))
(library
(conf
(name (list (or symbol integer)))
(path string)
(depends
(list (list (or symbol integer string
(list (member < > <= >=) string)))))
(provides (list (list (or symbol string))))
(platforms (list (or symbol (list symbol))))
(features (list symbol))
(authors (list string))
(maintainers (list string))
(description string)
(created string)
(updated string)
(version string)
(licenses
(list
(or (member gpl2 gpl3 lgpl mit bsd artistic apache public-domain)
(list 'license
(conf (name string)
(url string)
(checksums (alist symbol string)))))))))))))))
(define conf-spec
;; name type aliases doc
'((verbose? boolean (#\v "verbose") "...")
(silent? boolean (#\s "silent") "...")
(action? boolean ((not #\n) "action") "...")
(keep-files? boolean (#\k "keep-files") "...")
(force-build? boolean (#\f "force-build") "...")
(always-yes? boolean (#\y "always-yes") "...")
(test? boolean)
(implementation string)
(repository string)
(config filename)
(admin-dir dirname)
(temp-dir dirname)
(install-dir dirname)
(host string)
(local-root-repository dirname)
(local-user-repository dirname)
(install-prefix string)
(install-source-dir dirname)
(install-library-dir dirname)
(install-binary-dir dirname)
(install-doc-dir dirname)
(install-meta-dir dirname)
(library-extension string)
(installer symbol)
(implementations (list symbol))
))
(define (conf-default-path name)
(make-path (get-environment-variable "HOME")
(string-append "." name)
"config.scm"))
;; We need to support:
;;
;; <prog> [<options>...] <command> [<command-options>...] <args>...
;;
;; up to arbitrarily nested sub-commands and with option parsing and
;; argument count verification.
;;
;; Furthermore, it should be possible to build this programmatically,
;; for example by searching a directory for extensions/plugins. Thus
;; even if a convenience syntax is provided it should be a thin layer
;; over a procedural interface.
(define search-spec '())
(define show-spec '())
(define install-spec '())
(define upgrade-spec '())
(define remove-spec '())
(define status-spec '())
(define gen-key-spec
'((bits integer)
(validity-period string)
(name string)
(library-prefix (list symbol))
(email string)))
(define reg-key-spec
'((email string)))
(define sign-spec
'((output filename #\o)
(digest symbol #\d)
(email string)))
(define verify-spec
'())
(define package-spec
'((author string)
(recursive? boolean (#\r "recursive") "...")
(version string)
(version-file existing-filename)
(doc existing-filename)
(test existing-filename)
(sig-file existing-filename)
))
(define upload-spec
package-spec)
(define update-spec
'())
(define app-spec
`(snow
"Snow package management"
(@ ,conf-spec)
(begin: ,(lambda (cfg) (restore-history cfg)))
(end: ,(lambda (cfg) (save-history cfg)))
(or
(search
"search for packages"
(@ ,search-spec) (,command/search terms ...))
(show
"show package descriptions"
(@ ,show-spec) (,command/show names ...))
(install
"install packages"
(@ ,install-spec) (,command/install names ...))
(upgrade
"upgrade installed packages"
(@ ,upgrade-spec) (,command/upgrade names ...))
(remove
"remove packages"
(@ ,remove-spec) (,command/remove names ...))
(status
"print package status"
(@ ,status-spec) (,command/status names ...))
(package
"create a package"
(@ ,package-spec) (,command/package files ...))
(gen-key
"create an RSA key pair"
(@ ,gen-key-spec) (,command/gen-key))
(reg-key
"register an RSA key pair"
(@ ,reg-key-spec) (,command/reg-key))
(sign
"sign a package"
(@ ,sign-spec) (,command/sign file))
(verify
"verify a signature"
(@ ,verify-spec) (,command/verify file))
(upload
"upload a package"
(@ ,upload-spec) (,command/upload files ...))
(update
"update available package status"
(@ ,update-spec) (,command/update))
(help
"print help"
(,app-help-command args ...))
)))
(run-application app-spec)

67
lib/snow/utils.scm Normal file
View file

@ -0,0 +1,67 @@
(define (file-sha256 file)
;; openssl dgst -sha256 file
(let ((ls (string-split (process->string `("shasum" "-a" "256" ,file)))))
(and (pair? ls) (car ls))))
(define (copy-file src dst)
(system "cp" src dst))
(define (move-file src dst)
(system "mv" src dst))
;; TODO: check if the upstream has been modified
(define http-get-to-file/cached http-get-to-file)
(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 (path-extension template)))
(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)))))))
(define (system-from-dir dir . cmd)
;; alternately fork+cd+exec, or run a subshell with cd
(with-directory dir (lambda () (apply system cmd))))
(define (gzip-file src)
(system "gzip" "-c" src))
(define (gunzip-file src)
(system "gzip" "-d" "-c" src))

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

@ -0,0 +1,12 @@
(define-library (snow utils)
(export copy-file move-file http-get-to-file/cached
call-with-temp-file call-with-temp-dir create-directory*
path-strip-leading-parents
file-sha256)
(import (scheme base) (scheme char) (scheme write) (scheme time)
(snow interface)
(srfi 1) (srfi 33)
(chibi string) (chibi pathname) (chibi uri)
(chibi filesystem) (chibi process) (chibi net http))
(include "utils.scm"))