diff --git a/lib/snow/commands.scm b/lib/snow/commands.scm new file mode 100644 index 00000000..4bfc23df --- /dev/null +++ b/lib/snow/commands.scm @@ -0,0 +1,1020 @@ +;; commands.scm -- snow commands +;; +;; This code was written by Alex Shinn in 2014 and placed in the +;; Public Domain. All warranties are disclaimed. + +(define (find-in-path file . o) + (any (lambda (dir) + (let ((path (make-path dir file))) + (and (file-exists? path) path))) + (if (pair? o) + (car o) + (string-split (get-environment-variable "PATH") #\:)))) + +(define (find-sexp-in-path file dirs . o) + (let ((pred (if (pair? o) (car o) (lambda (x) #t)))) + (any (lambda (dir) + (let ((path (make-path dir file))) + (and (file-exists? path) + (guard (exn (else #f)) + (let ((x (call-with-input-file path read))) + (and (pred x) x)))))) + dirs))) + +(define (available-implementations cfg) + (define (find prog name) (if (find-in-path prog) (list name) '())) + (append (find "chibi-scheme" 'chibi) + (find "foment" 'foment) + (find "sagittarius" 'sagittarius))) + +(define (conf-selected-implementations cfg) + (let ((requested (conf-get-list cfg 'implementations '(all))) + (available (available-implementations cfg))) + (if (memq 'all requested) + available + (lset-intersection eq? requested available)))) + +(define (conf-for-implementation cfg impl) + (conf-specialize cfg 'implementation impl)) + +(define (write-to-string x) + (call-with-output-string (lambda (out) (write x out)))) + +(define (file->sexp-list file) + (call-with-input-file file + (lambda (in) + (let lp ((res '())) + (let ((x (read in))) + (if (eof-object? x) + (reverse res) + (lp (cons x res)))))))) + +(define (version-split str) + (if str + (map (lambda (x) (or (string->number x) x)) + (string-split str #\.)) + '())) + +(define (version-compare a b) + (define (less? x y) + (cond ((number? x) (if (number? y) (< x y) 1)) + ((number? y) -1) + (else (string? a b) (> (version-compare a b) 0)) +(define (version>=? a b) (>= (version-compare a b) 0)) + +;; Hack to evaluate an expression in a separate process with a larger +;; default heap. The expression and result must be serializable with +;; write, and imports should be an argument list for environment. +;; Currently only used when generating keys and signing. +(define (fast-eval expr imports . o) + (let* ((heap-size (if (pair? o) (car o) 500)) + (cmd + `("chibi-scheme" + ,(string-append "-h" (number->string heap-size) "M") + ,@(map + (lambda (i) + (string-append "-m" (string-join (map write-to-string i) "."))) + imports) + "-p" ,(write-to-string expr)))) + (let ((res (process->sexp cmd))) + (if (eof-object? res) ; process error + (eval expr (apply environment imports)) + res)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Package - generate a package from one or more libraries. + +(define (tar-file? file) + (or (equal? (path-extension file) "tgz") + (and (member (path-extension file) '("gz" "bz2")) + (equal? (path-extension (path-strip-extension file)) "tar")))) + +(define (package-file-meta file) + (and + (tar-file? file) + (let* ((unzipped-file + (if (member (path-extension file) '("tgz" "gz")) + (gunzip (let* ((in (open-binary-input-file file)) + (res (port->bytevector in))) + (close-input-port in) + res)) + file)) + (package-file + (find + (lambda (x) + (and (equal? "package.scm" (path-strip-directory x)) + (equal? "." (path-directory (path-directory x))))) + (tar-files unzipped-file)))) + (and package-file + (guard (exn (else (print-exception exn) #f)) + (let* ((str (utf8->string + (tar-extract-file unzipped-file package-file))) + (package (call-with-input-string str read))) + (and (pair? package) + (eq? 'package (car package)) + package))))))) + +(define (package-file? file) + (and (package-file-meta file) #t)) + +(define (x->string x) + (cond ((string? x) x) + ((symbol? x) (symbol->string x)) + ((number? x) (number->string x)) + (else (error "not a valid path component" x)))) + +(define (library-path-base file name) + (let lp ((ls (cdr (reverse name))) (dir (path-directory file))) + (cond + ((null? ls) dir) + ((equal? (x->string (car ls)) (path-strip-directory dir)) + (lp (cdr ls) (path-directory dir))) + (else dir)))) + +(define (path-relative file dir) + (let ((file (path-normalize file)) + (dir (string-trim-right (path-normalize dir) #\/))) + (string-trim-left + (if (string-prefix? dir file) + (substring file (string-length dir)) + file) + #\/))) + +(define (extract-library cfg file) + (let ((lib (read-from-file file))) + (match lib + (('define-library (name ...) + declarations ...) + (let* ((dir (library-path-base file name)) + (lib-file (path-relative file dir)) + (lib-dir (path-directory lib-file))) + (define (resolve file) + (let ((dest-path (make-path lib-dir file))) + (list 'rename (make-path dir dest-path) dest-path))) + (define (import-name import) + (cond + ((and (pair? import) + (memq (car import) '(only except prefix drop-prefix rename)) + (pair? (cadr import))) + (import-name (cadr import))) + (else import))) + (let lp ((ls declarations) + (info `(,@(cond + ((conf-get cfg '(command package author)) + => (lambda (x) (list (list 'author x)))) + (else '())) + (path ,lib-file) + (name ,name))) + (files `((rename ,file ,lib-file))) + (dirs '())) + (cond + ((null? ls) + (cons `(library ,@(reverse info)) + (cons `(rename ,dir "") + (append (map resolve (delete-duplicates dirs equal?)) + files)))) + (else + (match (car ls) + (((or 'include 'include-ci) includes ...) + (lp (cdr ls) + info + (append (map resolve includes) files) + (append (map path-directory includes) dirs))) + (('include-library-declarations includes ...) + (lp (append (append-map file->sexp-list includes) (cdr ls)) + info + (append (map resolve includes) files) + dirs)) + (('import libs ...) + (lp (cdr ls) + (cons (cons 'depends (map import-name libs)) info) + files + dirs)) + (('cond-expand clauses ...) + (lp (append (append-map cdr clauses) (cdr ls)) info files dirs)) + (else + (lp (cdr ls) info files dirs)))))))) + (else + (die 2 "not a valid library declaration " lib " in file " file))))) + +(define (make-package-name cfg libs . o) + (let ((name (assq 'name (car libs))) + (version (and (pair? o) (car o)))) + (cond + ((not (and (pair? name) (pair? (cdr name)))) + (die 2 "Unnamed library")) + ((not (and (pair? (cadr name)) (list? (cadr name)))) + (die 2 "Invalid library name" (cadr name))) + (else + (let lp ((ls (if version (append (cadr name) (list version)) (cadr name))) + (res '())) + (if (null? ls) + (string-concatenate (reverse (cons ".tgz" res))) + (lp (cdr ls) + (cons (x->string (car ls)) + (if (null? res) res (cons "-" res)))))))))) + +(define (check-overwrite cfg file type-pred type-name) + (let ((mode (conf-get cfg '(command package overwrite) 'same-type))) + (cond + ((eq? mode 'always)) + ((file-exists? file) + (case mode + ((never) + (die 2 "Destination " file " already exists, not overwriting")) + ((same-type) + (if (not (type-pred file)) + (die 2 "Destination " file " doesn't look like a " type-name + ", not overwriting"))) + ((confirm) + (if (not (yes-or-no? cfg "Overwrite existing " file "?")) + (die 2 "Not overwriting " file)))))))) + +;; 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))))) + +;; We want to automatically bundle (foo bar *) when packaging (foo bar) +;; if it's already in the same directory. +(define (submodule->path base file lib dep) + (and base + (> (length dep) (length base)) + (equal? base (take dep (length base))) + ;; TODO: find-library(-relative) + (let* ((dir (library-path-base file lib)) + (dep-file (make-path dir (library-name->path dep)))) + (and (file-exists? dep-file) dep-file)))) + +(define (package-doc cfg) + ;; TODO: Add scribble extraction. + (conf-get cfg '(command package doc))) + +(define (package-test cfg) + (conf-get cfg '(command package test))) + +(define (package-output-version cfg) + (cond ((conf-get cfg '(command package version))) + ((conf-get cfg '(command package version-file)) + => (lambda (file) (call-with-input-file file read-line))) + ((conf-get cfg '(command upload version))) + ((conf-get cfg '(command upload version-file)) + => (lambda (file) (call-with-input-file file read-line))) + (else #f))) + +(define (package-output-path cfg package-spec) + (or (conf-get cfg 'output) + (make-package-name + cfg + (filter (lambda (x) (and (pair? x) (eq? 'library (car x)))) package-spec) + (package-output-version cfg)))) + +(define (package-spec+files cfg spec libs) + (let ((recursive? (conf-get cfg '(command package recursive?))) + (doc (package-doc cfg)) + (test (package-test cfg)) + (version (package-output-version cfg))) + (let lp ((ls (map (lambda (x) (cons x #f)) libs)) + (res + `(,@(if doc `((doc ,(path-strip-leading-parents doc))) '()) + ,@(if test `((test ,(path-strip-leading-parents test))) '()) + ,@(if version `((version ,version)) '()))) + (files + `(,@(if doc (list doc) '()) + ,@(if test (list test) '())))) + (cond + ((and (null? ls) (null? res)) + (die 2 "No packages generated")) + ((null? ls) + (cons (cons 'package (reverse res)) files)) + (else + (let* ((lib+files (extract-library cfg (caar ls))) + (lib (car lib+files)) + (name (library-name lib)) + (base (or (cdar ls) name)) + (subdeps (if recursive? + (filter-map + (lambda (x) + (submodule->path base (caar ls) name x)) + (cond ((assq 'depends (cdr lib)) => cdr) + (else '()))) + '()))) + (lp (append (map (lambda (x) (cons x base)) subdeps) (cdr ls)) + (cons lib res) + (append (cdr lib+files) files)))))))) + +(define (create-package spec files path) + (gzip + (tar-create #f `(,@files + (inline "package.scm" + ,(call-with-output-string + (lambda (out) (write-simple-pretty spec out))))) + (let ((dir (path-strip-extension (path-strip-directory path)))) + (lambda (f) (make-path dir f))) + #t))) + +(define (command/package cfg spec . libs) + (let* ((spec+files (package-spec+files cfg spec libs)) + (output (package-output-path cfg (car spec+files))) + (tarball (create-package (car spec+files) (cdr spec+files) output))) + (check-overwrite cfg output package-file? "package") + (let ((out (open-binary-output-file output))) + (write-bytevector tarball out) + (close-output-port out)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gen-key - generate a new RSA key pair. + +(define (conf-get-snow-dir cfg) + (or (conf-get cfg 'snow-dir) + (string-append (get-environment-variable "HOME") "/.snow"))) + +(define (rsa-key->sexp key name email) + `((name ,name) + (email ,email) + (bits ,(rsa-key-bits key)) + ,@(cond + ((rsa-key-e key) + => (lambda (e) + `((public-key + (modulus ,(integer->hex-string (rsa-key-n key))) + (exponent ,e))))) + (else '())) + ,@(cond + ((rsa-key-d key) + => (lambda (d) + `((private-key + (modulus ,(integer->hex-string (rsa-key-n key))) + (exponent ,d))))) + (else '())))) + +(define (conf-gen-key cfg bits) + (show #t "Generating a new key, this may take quite a while...\n") + (if (conf-get cfg 'gen-key-in-process?) + (rsa-key-gen bits) + (let* ((lo (max 3 (expt 2 (- bits 1)))) + (hi (expt 2 bits)) + (p (fast-eval `(random-prime ,lo ,hi) + '((chibi math prime)))) + (q (fast-eval `(random-prime-distinct-from ,p ,lo ,hi) + '((chibi math prime))))) + (rsa-key-gen-from-primes bits p q)))) + +(define (command/gen-key cfg spec) + (show #t + "Generate a new RSA key for signing packages.\n" + "We need a descriptive name, and an email address to " + "uniquely identify the key.\n") + (let* ((name (input cfg '(gen-key name) "Name: ")) + (email (input cfg '(gen-key email) "Email: ")) + (bits (input-number cfg '(gen-key bits) + "RSA key size in bits: " 1024 64 20148)) + (key (conf-gen-key cfg bits)) + (snow-dir (conf-get-snow-dir cfg)) + (key-file (or (conf-get cfg 'key-file) + (string-append snow-dir "/priv-key.scm"))) + (old-keys (guard (exn (else '())) + (call-with-input-file key-file read))) + (new-keys + (cons (rsa-key->sexp key name email) + ;; TODO: confirm overwrite, preserve old keys + (remove (rsa-identity=? email) old-keys)))) + (if (not (file-directory? snow-dir)) + (create-directory snow-dir)) + (let* ((fd (open key-file (bitwise-ior open/write open/create) #o600)) + (out (open-output-file-descriptor fd))) + (show out "(" + (joined (lambda (x) + (if (pair? x) + (each "(" (joined written x "\n ") ")") + (written x))) + new-keys + "\n ") + ")" nl) + (close-output-port out)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reg-key - register an RSA key pair with a repository. + +(define (remote-uri cfg path) + (make-path (or (conf-get cfg 'host) "http://snow-fort.org") + path)) + +(define (remote-command cfg path params) + (let ((uri (remote-uri cfg path))) + (sxml-display-as-text (read (http-post uri (cons '(fmt . "sexp") params)))) + (newline))) + +(define (command/reg-key cfg spec) + (let* ((keys (call-with-input-file + (or (conf-get cfg 'key-file) + (string-append (conf-get-snow-dir cfg) "/priv-key.scm")) + read)) + (email (or (conf-get cfg 'email) + (assoc-get (car keys) 'email))) + (rsa-key-sexp (or (find (rsa-identity=? email) keys) + (and (not email) (car keys)))) + (name (assoc-get rsa-key-sexp 'name)) + (rsa-pub-key (extract-rsa-public-key rsa-key-sexp)) + (rsa-pub-key-str + (write-to-string (rsa-key->sexp rsa-pub-key name email)))) + (remote-command cfg + "/pkg/reg" + `((u (file . "pub-key.scm") + (value . ,rsa-pub-key-str)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Sign - sign a package. + +(define (generate-signature cfg package) + (let* ((digest-name (conf-get cfg 'digest 'sha-256)) + (digest-func (lookup-digest digest-name)) + (digest (if (string? package) + (call-with-input-file package digest-func) + (digest-func package))) + (keys (call-with-input-file + (or (conf-get cfg 'key-file) + (string-append (conf-get-snow-dir cfg) "/priv-key.scm")) + read)) + (email (or (conf-get cfg 'email) + (assoc-get (car keys) 'email))) + (rsa-key-sexp (find (rsa-identity=? email) keys)) + (rsa-key (extract-rsa-private-key rsa-key-sexp)) + (sig (fast-eval `(rsa-sign (make-rsa-key ,(rsa-key-bits rsa-key) + ,(rsa-key-n rsa-key) + #f + ,(rsa-key-d rsa-key)) + ,(hex-string->integer digest)) + '((chibi crypto rsa)))) + (hex-sig (integer->hex-string sig))) + (if (not (equal? sig (hex-string->integer hex-sig))) + (error "hex-string conversion invalid" sig hex-sig)) + `(signature + (email ,email) + (digest ,digest-name) + (,digest-name ,digest) + (rsa ,hex-sig)))) + +(define (command/sign cfg spec package) + (let* ((dst (or (conf-get cfg 'output) + (path-replace-extension package "sig"))) + (sig (generate-signature cfg package))) + (call-with-output-file dst + (lambda (out) (write sig out))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Verify - verify a signature. + +(define (command/verify cfg spec sig) + (let* ((sig-spec (cdr (call-with-input-file sig read))) + (keys (call-with-input-file + (or (conf-get cfg 'key-file) + (string-append (conf-get-snow-dir cfg) "/priv-key.scm")) + read)) + (email (assoc-get sig-spec 'email)) + (digest-name (assoc-get sig-spec 'digest #f 'sha-256)) + (digest (assoc-get sig-spec digest-name)) + (sig (assoc-get sig-spec 'rsa)) + (rsa-key-sexp (or (and (string? email) + (find (rsa-identity=? email) keys)) + (car keys))) + (rsa-key (extract-rsa-public-key rsa-key-sexp)) + (cipher (rsa-encrypt rsa-key (hex-string->integer sig)))) + ;; (rsa-verify? rsa-key + ;; (hex-string->integer digest) + ;; (hex-string->integer sig)) + (if (equal? cipher (hex-string->integer digest)) + (show #t "signature valid " nl) + (show #t "signature invalid " + cipher " " (hex-string->integer digest) nl)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Upload - upload a package. + +(define (upload-package cfg spec package . o) + (let ((pkg (if (string? package) + `(u (file . ,package)) + `(u (file . ,(if (pair? o) (car o) "package.tgz")) + (value . ,package)))) + (sig + (cond + ((conf-get cfg 'sig-file) + => (lambda (sig-file) `(sig (file . ,sig-file)))) + (else + `(sig (file . "package.sig") + (value . ,(write-to-string + (generate-signature cfg package)))))))) + (remote-command cfg "/pkg/put" (list pkg sig)))) + +(define (command/upload cfg spec . o) + (define (non-homogeneous) + (die 1 "upload arguments must all be packages or all be libraries, " + "but got " o)) + (cond + ((null? o) + (die 1 "upload requires at least one input argument")) + ((package-file? (car o)) + (if (not (every package-file? (cdr o))) + (non-homogeneous)) + (for-each + (lambda (package) (upload-package cfg spec package)) + o)) + (else + (if (any package-file? (cdr o)) + (non-homogeneous)) + (let* ((spec+files (package-spec+files cfg spec o)) + (package-file (package-output-path cfg (car spec+files))) + (package (create-package (car spec+files) + (cdr spec+files) + package-file))) + (upload-package cfg spec package package-file))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Remove - removes the listed libraries. +;; +;; Provides a summary of the libraries to remove along with any +;; dependencies they have which were not explicitly installed. + +(define (warn-delete-file file) + (guard (exn (else (warn "couldn't delete file: " file))) + (delete-file file))) + +(define (delete-library-files impl cfg pkg lib-name) + (for-each warn-delete-file (package-installed-files pkg)) + (warn-delete-file (make-path (get-install-source-dir impl cfg) + (get-package-meta-file cfg pkg))) + (let ((dir (make-path (get-install-source-dir impl cfg) + (package->path pkg)))) + (if (and (file-directory? dir) + (= 2 (length (directory-files dir)))) + (delete-directory dir)))) + +(define (command/remove cfg spec . args) + (let* ((impls (conf-selected-implementations cfg)) + (impl-cfgs (map (lambda (impl) + (conf-for-implementation cfg impl)) + impls)) + (lib-names (map parse-library-name args))) + (for-each + (lambda (impl impl-cfg) + (for-each (lambda (pkg lib-name) + (delete-library-files impl impl-cfg (cdr pkg) lib-name)) + (lookup-installed-libraries impl impl-cfg lib-names) + lib-names)) + impls + impl-cfgs))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Search - search for libraries matching keywords. +;; +;; Prints a list of libraries whose meta-info contain any of the given +;; keywords. Returns in sorted order or match score, with highest +;; rank given to matches in the library name, followed by title, +;; followed by full description other fields, with seconday sorting on +;; rating and tertiary sorting on lexicographic order. + +(define (summarize-libraries cfg lib-names+pkgs) + (for-each describe-library + (map car lib-names+pkgs) + (map cdr lib-names+pkgs))) + +(define (extract-sorted-libraries cfg keywords) + '()) + +(define (command/search cfg spec keywords) + (maybe-update-repository cfg) + (let ((libraries (extract-sorted-libraries cfg keywords))) + (if (pair? libraries) + (summarize-libraries cfg libraries) + (display "No libraries matched your query.")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Show - show detailed information for the given libraries +;; +;; The typical pattern is to use search to find the names of libraries +;; of interest, and show to see detailed information to decide whether +;; or not to install them. + +(define (describe-library library-name pkg) + (display library-name) + (display "\t") + (display (package-version pkg)) + (newline)) + +(define (command/show cfg spec . args) + (maybe-update-repository cfg) + (let* ((impls (conf-selected-implementations cfg)) + (impl-cfgs (map (lambda (impl) + (conf-for-implementation cfg impl)) + impls)) + (lib-names (map parse-library-name args))) + (for-each + (lambda (impl impl-cfg) + (for-each describe-library + (lookup-installed-libraries impl impl-cfg lib-names) + lib-names)) + impls + impl-cfgs))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Update - update the repository. + +(define (valid-repository? repo) + (and (pair? repo) (list? repo) (eq? 'repository (car repo)))) + +(define (repository-dir cfg) + (cond + ((zero? (current-user-id)) + (or (conf-get cfg 'local-root-repository) + "/usr/local/share/snow/repo")) + (else + (or (conf-get cfg 'local-user-repository) + (make-path (conf-get-snow-dir cfg) "repo"))))) + +(define (update-repository cfg) + (let* ((local-dir (repository-dir cfg)) + (local-path (make-path local-dir "repo.scm")) + (local-tmp (string-append local-path ".tmp." + (number->string (current-second)))) + (repo-uri (remote-uri cfg "/s/repo.scm")) + (repo-str (call-with-input-url repo-uri port->string)) + (repo (guard (exn (else #f)) + (let ((repo (call-with-input-string repo-str read))) + `(,(car repo) (url ,repo-uri) ,@(cdr repo)))))) + (cond + ((not (valid-repository? repo)) + (die 2 "not a valid repository: " repo-uri)) + ((not (create-directory* local-dir)) + (die 2 "can't create directory: " local-dir )) + (else + (guard (exn (else (die 2 "couldn't write repository"))) + (call-with-output-file local-tmp + (lambda (out) (write repo out))) + (if (file-exists? local-path) + (rename-file local-path (string-append local-path ".bak"))) + (rename-file local-tmp local-path) + repo))))) + +(define (repository-stale? cfg) + (let ((path (make-path (repository-dir cfg) "repo.scm"))) + (guard (exn (else #t)) + (> (current-second) + (+ (file-modification-time path) + ;; by default update once every 3 hours + (conf-get cfg 'update-refresh (* 3 60 60))))))) + +(define (should-update-repository? cfg) + (case (conf-get cfg 'update-strategy 'cache) + ((always) #t) + ((never) #f) + ((cache) + (repository-stale? cfg)) + ((confirm) + (and (repository-stale? cfg) + (yes-or-no? cfg "Update repository info?"))) + (else + (warn "unknown update-stategy: " (conf-get cfg 'update-strategy)) + #f))) + +(define (maybe-update-repository cfg) + (if (should-update-repository? cfg) + (update-repository cfg) + (call-with-input-file (make-path (repository-dir cfg) "repo.scm") + read))) + +(define (command/update cfg spec) + (update-repository cfg)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Install - install one or more libraries. +;; +;; Installs the listed libraries along with their transitive closure +;; of dependencies. For each library to install we confirm the +;; current status (skipping if already installed), the signature and +;; trust (optionally updating the trust level), and the default tests. +;; If multiple implementations are targeted, we install separately but +;; use the same confirmations for each. + +(define (get-install-dirs impl cfg) + (define (guile-eval expr) + (guard (exn (else #f)) + (process->sexp `(guile -c ,(write-to-string `(write ,expr)))))) + (case impl + ((chibi) + (let* ((dirs (reverse (current-module-path))) + (share-dir (find (lambda (d) (string-contains d "/share/")) dirs))) + (if share-dir + (cons share-dir (delete share-dir dirs)) + dirs))) + ((guile) + (let ((path + (guile-eval + '(string-append (cdr (assq 'pkgdatadir %guile-build-info)) + (string (integer->char 47)) + (effective-version))))) + (if (string? path) + path + "/usr/local/share/guile/"))) + (else (list (make-path "/usr/local/share/snow" impl))))) + +(define (get-install-search-dirs impl cfg) + (let ((install-dir (get-install-source-dir impl cfg)) + (other-dirs (get-install-dirs impl cfg))) + (cons install-dir (delete install-dir other-dirs)))) + +(define (find-library-meta impl cfg name) + (let ((dirs (get-install-search-dirs impl cfg))) + (let lp ((subname name)) + (or (find-sexp-in-path + (package-name->meta-file cfg subname) + dirs + (lambda (x) + (and (package? x) + (any (lambda (y) (equal? name (library-name y))) + (package-libraries x))))) + (and (pair? (cdr subname)) + (lp (drop-right subname 1))))))) + +(define (test-library impl cfg library dir) + #t) + +(define (lookup-installed-libraries impl cfg names) + (map (lambda (name) + (cons name + (or (find-library-meta impl cfg name) + `(not-installed ,name)))) + names)) + +(define (installed-libraries impl cfg) + (delete-duplicates + (directory-fold-tree + (get-install-source-dir impl cfg) + #f #f + (lambda (file acc) + (cond + ((and (equal? "meta" (path-extension file)) + (guard (exn (else #f)) + (let ((pkg (call-with-input-file file read))) + (and (package? pkg) pkg)))) + => (lambda (pkg) + (append + (map + (lambda (lib) (cons (library-name lib) pkg)) + (package-libraries pkg)) + acc))) + (else acc))) + '()) + (lambda (a b) (equal? (car a) (car b))))) + +(define (get-install-source-dir impl cfg) + (cond + ((conf-get cfg 'install-source-dir)) + ((conf-get cfg 'install-prefix) + => (lambda (prefix) (make-path prefix "share/snow" impl))) + (else (car (get-install-dirs impl cfg))))) + +(define (install-package-meta-info impl cfg pkg) + (let* ((meta-file (get-package-meta-file cfg pkg)) + (install-dir (get-install-source-dir impl cfg)) + (path (make-path install-dir meta-file))) + ;; write the package name + (call-with-output-file path + (lambda (out) (write-simple-pretty pkg out))) + ;; symlink utility libraries for which the package can't be inferred + (let ((pkg-name (package-name pkg))) + (for-each + (lambda (lib) + (let ((lib-name (library-name lib))) + (if (not (equal? pkg-name (take lib-name (length pkg-name)))) + (let ((lib-meta (get-library-meta-file cfg lib))) + (symbolic-link-file path (make-path install-dir lib-meta)))))) + (package-libraries pkg))))) + +;; The default installer just copies the library file and any included +;; source files to an installation directory, optionally mapping +;; extensions to the implementations preferred value. +(define (default-installer impl cfg library dir) + (let* ((library-file (get-library-file cfg library)) + (ext (conf-get cfg 'library-extension "sld")) + (dest-library-file (path-replace-extension library-file ext)) + (include-files + (library-include-files cfg (make-path dir library-file))) + (rewrite-include-files + ;; Rewrite if any include has the same path as the library + ;; declaration file after extension renaming. + ;; TODO: Also rewrite if multiple libs use same file names? + (map + (lambda (x) + (if (equal? x dest-library-file) + (cons x (string-append x "." ext)) + x)) + include-files)) + (install-dir (get-install-source-dir impl cfg))) + ;; install the library file + (let ((path (make-path install-dir dest-library-file))) + (create-directory* (path-directory path)) + (if (any pair? rewrite-include-files) + (call-with-output-file path + (lambda (out) + (write (library-rewrite-includes library rewrite-include-files) + out))) + (copy-file (make-path dir library-file) path)) + ;; install any includes + (cons + path + (map + (lambda (x) + (let ((dest-file + (make-path install-dir + (path-relative (if (pair? x) (cdr x) x) dir)))) + (create-directory* (path-directory dest-file)) + (copy-file (if (pair? x) (car x) x) dest-file) + dest-file)) + rewrite-include-files))))) + +;; installers should return the list of installed files +(define (lookup-installer installer) + (case installer + (else default-installer))) + +(define (install-library impl cfg library dir) + (let ((installer (lookup-installer (conf-get cfg 'installer)))) + (installer impl cfg library dir))) + +(define (build-library impl cfg library dir) + ;; the currently supported implementations don't require building + #t) + +(define (fetch-package cfg url) + (call-with-input-url url port->bytevector)) + +(define (path-strip-top file) + (let ((pos (string-find file #\/))) + (if (string-cursor (lambda (x) (die 2 "package checksum didn't match: " x))) + ((package-signature-mismatches repo cfg pkg raw) + => (lambda (x) (die 2 "package signature didn't match: " x))) + (else + (let ((snowball (maybe-gunzip raw))) + (call-with-temp-dir + "pkg" + (lambda (dir) + (tar-extract snowball (lambda (f) (make-path dir (path-strip-top f)))) + (let ((installed-files + (append-map + (lambda (lib) + (build-library impl cfg lib dir) + (test-library impl cfg lib dir) + (install-library impl cfg lib dir)) + (package-libraries pkg)))) + (install-package-meta-info + impl cfg + `(,@pkg (installed-files ,@installed-files))))))))))) + +(define (install-for-implementation repo impl cfg pkgs) + (for-each (lambda (pkg) (install-package repo impl cfg pkg)) pkgs)) + +(define (select-best-candidate impl cfg candidates) + (if (null? (cdr candidates)) + (car candidates) + ;; TODO: prompt if multiple candidates + (car candidates))) + +;; Choose packages for the corresponding libraries, and recursively +;; select uninstalled packages. Verifies and records preferences for +;; trusting publishers for different library prefixes. +(define (expand-package-dependencies repo impl cfg lib-names) + (let ((current (installed-libraries impl cfg))) + (let lp ((ls lib-names) (res '())) + (cond + ((null? ls) res) + ((find (lambda (pkg) (package-provides? pkg (car ls))) res) + (lp (cdr ls) res)) + (else + (let* ((current-version + (cond ((assoc (car ls) current) + => (lambda (x) (package-version (cdr x)))) + (else #f))) + (candidates + (filter + (lambda (pkg) + (and (package-provides? pkg (car ls)) + (or (not current-version) + (version>? (package-version pkg) + current-version)))) + (cdr repo)))) + (cond + ((and (null? candidates) (assoc (car ls) current)) + (if (member (car ls) lib-names) + (warn "skipping already installed library" (car ls))) + (lp (cdr ls) res)) + ((and (null? candidates) (member (car ls) lib-names)) + (die 2 "Can't find package: " (car ls))) + ((null? candidates) + (if (yes-or-no? cfg "Can't find package: " (car ls) + ". Proceed anyway?") + (lp (cdr ls) res) + (exit 2))) + (else + (let ((pkg (select-best-candidate impl cfg candidates))) + (lp (append (package-dependencies pkg) (cdr ls)) + (cons pkg res))))))))))) + +;; First lookup dependencies for all implementations so we can +;; download in a single batch. Then perform the installations a +;; single implementation at a time. +(define (command/install cfg spec . args) + (let* ((repo (maybe-update-repository cfg)) + (impls (conf-selected-implementations cfg)) + (impl-cfgs (map (lambda (impl) + (conf-for-implementation cfg impl)) + impls)) + (lib-names (map parse-library-name args)) + (impl-pkgs + (map (lambda (impl cfg) + (expand-package-dependencies repo impl cfg lib-names)) + impls + impl-cfgs))) + (for-each + (lambda (impl cfg pkgs) + (install-for-implementation repo impl cfg pkgs)) + impls + impl-cfgs + impl-pkgs))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Upgrade - upgrade installed packages. + +;; With explicit packages same as install, but by default upgrade all +;; available packages. +(define (command/upgrade cfg spec . args) + (if (pair? args) + (apply command/install cfg spec args) + (let* ((repo (maybe-update-repository cfg)) + (impls (conf-selected-implementations cfg)) + (impl-cfgs (map (lambda (impl) + (conf-for-implementation cfg impl)) + impls))) + (for-each + (lambda (impl cfg) + (let ((pkgs (map cdr (installed-libraries impl cfg)))) + (install-for-implementation repo impl cfg pkgs))) + impls + impl-cfgs)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Status - show the status of installed libraries. + +(define (command/status cfg spec . args) + (let* ((impls (conf-selected-implementations cfg)) + (impl-cfgs (map (lambda (impl) + (conf-for-implementation cfg impl)) + impls))) + (for-each + (lambda (impl impl-cfg) + (cond + ((pair? (cdr impls)) + (if (not (eq? impl (car impls))) + (display "\n")) + (display impl) + (display ":\n"))) + (summarize-libraries + impl-cfg + (if (pair? args) + (lookup-installed-libraries + impl impl-cfg (map parse-library-name args)) + (installed-libraries impl impl-cfg)))) + impls + impl-cfgs))) diff --git a/lib/snow/commands.sld b/lib/snow/commands.sld new file mode 100644 index 00000000..b4d07d1f --- /dev/null +++ b/lib/snow/commands.sld @@ -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")) diff --git a/lib/snow/interface.scm b/lib/snow/interface.scm new file mode 100644 index 00000000..fd44f255 --- /dev/null +++ b/lib/snow/interface.scm @@ -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?)) diff --git a/lib/snow/interface.sld b/lib/snow/interface.sld new file mode 100644 index 00000000..a64128fb --- /dev/null +++ b/lib/snow/interface.sld @@ -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")) diff --git a/lib/snow/package.scm b/lib/snow/package.scm new file mode 100644 index 00000000..0750ca09 --- /dev/null +++ b/lib/snow/package.scm @@ -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))) diff --git a/lib/snow/package.sld b/lib/snow/package.sld new file mode 100644 index 00000000..0921273d --- /dev/null +++ b/lib/snow/package.sld @@ -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")) diff --git a/lib/snow/snow b/lib/snow/snow new file mode 100755 index 00000000..a847ac9d --- /dev/null +++ b/lib/snow/snow @@ -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: +;; +;; [...] [...] ... +;; +;; 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) diff --git a/lib/snow/utils.scm b/lib/snow/utils.scm new file mode 100644 index 00000000..8f53c31b --- /dev/null +++ b/lib/snow/utils.scm @@ -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)) diff --git a/lib/snow/utils.sld b/lib/snow/utils.sld new file mode 100644 index 00000000..5f52f0b3 --- /dev/null +++ b/lib/snow/utils.sld @@ -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"))