Flattening submodule.

lib/chibi/snow/commands.sld

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

lib/chibi/snow/fort.scm

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

lib/chibi/snow/fort.sld

@@ -0,0 +1,71 @@
+;; utilities for the snow repo server
+
+(define-library (chibi snow fort)
+  (export fail page respond static-url static-local-path
+          escape-path email->path maybe-parse-hex
+          valid-email? valid-package?
+          extract-snowball-package package-dir
+          invalid-signature-reason
+          rewrite-repo update-repo
+          update-repo-package update-repo-object
+          repo-publishers current-repo get-user-password)
+  (import (scheme base)
+          (scheme read)
+          (scheme write)
+          (scheme file)
+          (srfi 1)
+          (srfi 18)
+          (srfi 33)
+          (chibi snow package)
+          (chibi bytevector)
+          (chibi config)
+          (chibi crypto rsa)
+          (chibi filesystem)
+          (chibi io)
+          (chibi log)
+          (chibi net servlet)
+          (chibi pathname)
+          (chibi regexp)
+          (chibi string)
+          (chibi sxml)
+          (chibi tar))
+  (cond-expand
+   (chibi
+    (import (only (chibi ast)
+                  errno integer->error-string)
+            (only (chibi)
+                  string-size exception-protect
+                  call-with-input-string call-with-output-string)))
+   (else
+    (begin
+      (define (errno) 0)
+      (define (integer->error-string n)
+        (string-append "errno: " (number->string n)))
+      (define string-size string-length)
+      (define (call-with-input-string str proc)
+        (let* ((in (open-input-string str))
+               (res (proc in)))
+          (close-input-port in)
+          res))
+      (define (call-with-output-string proc)
+        (let ((out (open-output-string)))
+          (proc out)
+          (let ((res (get-output-string out)))
+            (close-output-port out)
+            res)))
+      (define (with-exception-protect thunk final)
+        (let* ((finalized? #f)
+               (run-finalize
+                (lambda ()
+                  (cond ((not finalized?)
+                         (set! finalized? #t)
+                         (final))))))
+          (guard (exn (else (run-finalize) (raise exn)))
+            (let ((res (thunk)))
+              (run-finalize)
+              res))))
+      (define-syntax exception-protect
+        (syntax-rules ()
+          ((exception-protect expr final)
+           (with-exception-protect (lambda () expr)  (lambda () final))))))))
+  (include "fort.scm"))

lib/chibi/snow/interface.scm

@@ -0,0 +1,122 @@
+
+;; 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-hidden prompt)
+  (show #t prompt)
+  (flush-output-port)
+  (let ((res (with-stty '(not echo) (lambda () (read-line)))))
+    (show #t "\n")
+    res))
+
+(define (input-password cfg name prompt1 . o)
+  (let ((prompt2 (or (and (pair? o) (car o))
+                     (string-append prompt1 " (confirmation): "))))
+    (let lp ()
+      (let ((password (input-hidden prompt1)))
+        (cond
+         ((equal? password "")
+          (show #t "password must be non-empty\n")
+          (lp))
+         (else
+          (let ((conf (input-hidden prompt2)))
+            (cond
+             ((not (equal? password conf))
+              (show #t "password didn't match\n")
+              (lp))
+             (else
+              password)))))))))
+
+(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?))

lib/chibi/snow/interface.sld

@@ -0,0 +1,8 @@
+
+(define-library (chibi snow interface)
+  (export warn info message die input input-password 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"))

lib/chibi/snow/package.scm

@@ -0,0 +1,369 @@
+
+;; 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 impl cfg package)
+  (append-map (lambda (lib) (library-dependencies cfg impl lib))
+              (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-for-impl impl cfg lib)
+  (append
+   lib
+   (append-map
+    (lambda (x)
+      (or (and (pair? x) (eq? 'cond-expand (car x))
+               (cond
+                ((find
+                  (lambda (clause) (check-cond-expand impl cfg (car clause)))
+                  (cdr x))
+                 => cdr)
+                (else #f)))
+          '()))
+    (cdr lib))))
+
+(define (library-dependencies impl cfg lib)
+  (append-map
+   (lambda (x) (or (and (pair? x) (eq? 'depends (car x)) (cdr x)) '()))
+   (cdr (library-for-impl impl cfg lib))))
+
+(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 impl config test)
+  (define (library-installed? config name)
+    ;; assume it could be installed for now... this is effectively a
+    ;; "suggested" package rather than a required one
+    #t)
+  (cond
+   ((symbol? test)
+    (or (eq? 'else test) (eq? impl test)
+        (memq test (conf-get-list config 'features))))
+   ((pair? test)
+    (case (car test)
+      ((not) (not (check-cond-expand impl config (cadr test))))
+      ((and) (every (lambda (x) (check-cond-expand impl config x)) (cdr test)))
+      ((or) (any (lambda (x) (check-cond-expand impl 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 impl 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 impl 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 impl config file)
+  (let ((lib (library-analyze impl 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?)))))

lib/chibi/snow/package.sld

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

lib/chibi/snow/utils.scm

@@ -0,0 +1,53 @@
+
+;;> 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)))))))

lib/chibi/snow/utils.sld

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

tools/snow-chibi

@@ -0,0 +1,174 @@
+#!/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 process-context)
+        (chibi snow commands)
+        (chibi snow interface)
+        (chibi app)
+        (chibi config)
+        (chibi pathname)
+        (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") "print additional informative messages")
+    (always-yes? boolean (#\y "always-yes") "answer all questions with yes")
+    (ignore-signature? boolean ("ignore-sig") "don't verify package signatures")
+    (ignore-digest? boolean ("ignore-digest") "don't verify package checksums")
+    ;;(config filename "path to configuration file")
+    (host string "base uri of snow repository")
+    (repository-uri string "uri of snow repository file")
+    (local-root-repository dirname "repository cache dir for root")
+    (local-user-repository dirname "repository cache dir for non-root users")
+    (install-prefix string "prefix directory for installation")
+    (install-source-dir dirname "directory to install library source in")
+    (library-extension string "the extension to use for library files")
+    (installer symbol "name of installer to use")
+    (implementations (list symbol) "impls to install for, or 'all'")
+    (chibi-path filename "path to chibi-scheme executable")
+    ))
+
+(define (conf-default-path name)
+  (make-path (or (get-environment-variable "HOME") ".")
+             (string-append "." name)
+             "config.scm"))
+
+(define search-spec '())
+(define show-spec '())
+(define install-spec
+  '((show-tests? boolean ("show-tests") "show test output even on success")))
+(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
+  '((uri string)
+    (email string)))
+(define sign-spec
+  '((output filename #\o)
+    (digest symbol #\d)
+    (email string)))
+(define verify-spec
+  '())
+(define package-spec
+  '((programs (list existing-filename))
+    (authors (list string))
+    (maintainers (list string))
+    (recursive? boolean (#\r "recursive") "...")
+    (version string)
+    (version-file existing-filename)
+    (license symbol)
+    (doc existing-filename)
+    (doc-from-scribble boolean)
+    (description string)
+    (test existing-filename)
+    (sig-file existing-filename)
+    ))
+(define upload-spec
+  `((uri string)
+    ,@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
+                 (command-line)
+                 (conf-load (conf-default-path "snow")))