diff -uNr a/gbw-signer/README b/gbw-signer/README --- a/gbw-signer/README false +++ b/gbw-signer/README 1141e9723b67e7ef8a409c889f9ccf2d308bfce9f9674fd68aa51ed5feb34904d5a31994a9682c9b55670d0c807d0d1ba92c57e62ccf417541f82a04ee022cb1 @@ -0,0 +1,106 @@ +About +----- + +This is gbw-signer, the offline signing component of Gales Bitcoin Wallet as described at http://fixpoint.welshcomputing.com/2019/gales-bitcoin-wallet-spec-and-battle-plan/ , written by Jacob Welsh for JWRD Computing. + +It is written in Scheme with original implementations of the cryptographic primitives, and shell functions to simplify full wallet encryption using GPG. + +Prerequisites +------------- + +gscm : the Gales Scheme interpreter. + +Installation +------------ + +This software sheds some historical Unix conventions in favor of Bernstein's /package scheme ( http://cr.yp.to/slashpackage.html ), which I find meshes fairly well with the ideas of V. If this is your first time using it, you may need to create the /package directory and add /command to your shell's PATH variable. + +1. Press or otherwise install the tree at the path: + + /package/gbw-signer-1 + +The installation path is not configurable. This amounts to a claim on the global namespace, as command names always do. People and programs can count on finding components at known paths if they are to be found at all, as surely as with /bin/sh. This doesn't mean the files must physically exist under /package; for example, a symlink from there could ease working on the code as a non-root user. + +2. From the above directory, run (as root): + + sh package/install + +ECC cache generation will take a noticeable time, depending on hardware, though hopefully not so much as to suggest preparing a beverage. + +3. Run the test suite: + + sh package/check + +Ensure there are no failures indicated. It should take about the same time. + +Operation +--------- + +A wallet is represented as a filesystem tree serving as key-value store, arranged as follows: + + wallet/ + keys/ + address : hex-encoded private key + ... + change : change address + fee : transaction fee in BTC/kB + outputs : unspent outputs table + transactions : linefeed-delimited raw transaction list + +The outputs table is awk-style, that is, with fields separated by one or more space or tab characters and records separated by linefeeds. It can be constructed by hand or using the companion "gbw-node" tools to collect it from the blockchain. Fields are, in order: + + Address : address to which the output was sent, in the usual Base58 + Value : monetary value of the output, in decimal BTC (see Warnings below) + TXID : hash of transaction containing the output, in the "little-endian" hex format used by bitcoind + Index : position in the transaction's output vector, as decimal integer + +Any further text in a line is considered comment. + +An initial wallet tree must be constructed including empty keys directory, change, fee, and outputs. "gbw-init" described below can assist with all but the outputs part. + +The main program is "gbw-signer", which provides subcommands for key generation or import and transaction issuance. Run "gbw-signer help" for details. + +GPG integration: setup +---------------------- + +Wallet encryption is managed by working with a tree in memory then saving to a GPG encrypted tar file. Tools are included to facilitate this; they operate through the shell environment and thus are configured using it. Presumably you will want to do this in your shell startup (~/.bashrc or equivalent) to make it permanent. + +1. Set GBW_RECIPIENT to your desired GPG key ID for wallet encryption. + +2. Set GBW_TMPDIR to an absolute path to a writeable temporary directory. To avoid spilling plaintext keys to permanent storage, this must be on a tmpfs and the machine must not have swap enabled. + +3. Source the file /package/gbw-signer/library/gbw-shell.sh to load its function definitions. + +Example: + + GBW_RECIPIENT=0123456789ABCDEF + GBW_TMPDIR=/tmp + . /package/gbw-signer/library/gbw-shell.sh + +GPG integration: operation +-------------------------- + +gbw-init PATH : creates a new wallet tree under GBW_TMPDIR and moves the shell to its root. PATH specifies where the GPG-encrypted archive will be later saved. + +gbw-save : saves an encrypted copy of the tree, leaving the plaintext open. + +gbw-close : saves and deletes the plaintext tree. + +gbw-discard : deletes the plaintext tree without saving. + +gbw-open PATH : decrypts a saved wallet from PATH into a tree under GBW_TMPDIR and moves the shell to its root. + +Shell variables prefixed with GBW_ are used to coordinate these commands; see source for details. The save process is believed to be atomic but as always, keep backups, and verify that you can re-open an encrypted wallet before counting on it. + +Warnings +-------- + +A strong entropy source is required in /dev/urandom. + +Compromised inputs can drain your funds even without disclosure of private keys. The most obvious case would be sending to a valid but incorrect address. More subtle is that, because Bitcoin transactions do not explicitly specify fee and input values, an incorrect value field in "outputs" can result in excess input consumption and incorrect change computation, causing loss through exhorbitant transaction fee. + +The cryptographic operations do not use constant-time algorithms, thus side channel attacks (timing, electromagnetic, sonic, power, thermal) are possible. Fixing this is in scope for future revisions; meanwhile, use appropriate precautions. + +The signer does not include checking for hardware faults, which while rare are not impossible. Fixing this is in scope for future revisions; meanwhile, it may be prudent to decode raw transactions after signing to verify addresses and amounts prior to broadcasting. + +Enjoy your new nuclear briefcase ( http://trilema.com/2016/how-to-cut-the-wallet/#footnote_1_69751 ) ! diff -uNr a/gbw-signer/command/gbw-signer b/gbw-signer/command/gbw-signer --- a/gbw-signer/command/gbw-signer false +++ b/gbw-signer/command/gbw-signer fe89e71c698ecc796962c1d0e98ee4b73002542510711f3f3a6143a882947cadfc58eae83f54a7e658aea2ce3beb9d336a6cd3c1f67a5bde3e4cb8753db10aec @@ -0,0 +1,2 @@ +#!/bin/sh +exec /command/gscm /package/gbw-signer-1/library/gbw-signer.scm "$@" diff -uNr a/gbw-signer/library/bignum.scm b/gbw-signer/library/bignum.scm --- a/gbw-signer/library/bignum.scm false +++ b/gbw-signer/library/bignum.scm 0bd863c9b49953c72746f27f671837b5b773d010b93fe6a2fa0a4a7eae00a4e6148873eae0f8290e30949ac091340e13b35cfb73a8ab386de587b5bf6faa0e5e @@ -0,0 +1,450 @@ +;;;; bignum.scm: A user-level unsigned bignum arithmetic library +;;; J. Welsh, August 2017 +;;; Trimmed for gbw, March 2020 + +;; A bignum is a list of words, least significant first. It must not have trailing zeros. Thus each number has a unique representation, and zero is the empty list. + +(lambda () + + ;;; Constants + (define base-nibbles (quotient *fixnum-width* 8)) + (define base-bits (delay (fx*/wrap base-nibbles 4))) + (define base/2 (delay (expt 2 (- base-bits 1)))) + (define base (delay (* 2 base/2))) ;; must be <= sqrt of largest fixnum + (define base-1 (delay (- base 1))) + (define neg-base-bits (delay (- base-bits))) + + (define - fx-/wrap) + (define + fx+/wrap) + (define * fx*/wrap) + (define (zero? x) (fx= x 0)) + (define (even? x) (fx= (fxand x 1) 0)) + (define = fx=) + (define < fx<) + (define <= fx<=) + (define hex "0123456789abcdef") + (define char0 (char->integer #\0)) + (define char10-A (fx-/wrap 10 (char->integer #\A))) + (define bn0 '()) + (define bn1 '(1)) + + ;;; Helpers + + (define (fix->hex n) ;; note 0 -> empty string + (do ((n n (fxshift n -4)) + (acc '() (cons (string-ref hex (fxand n 15)) acc))) + ((zero? n) (list->string acc)))) + + (define (hexdigit->fix c) + (if (char-numeric? c) (- (char->integer c) char0) + (let ((i (+ (char->integer (char-upcase c)) char10-A))) + (if (and (<= 10 i) (< i 16)) i + (error "bad hex digit:" c))))) + + (define (decdigit->fix c) + (if (char-numeric? c) (- (char->integer c) char0) + (error "bad decimal digit:" c))) + + (define (left-pad s len char) + (string-append (make-string (- len (string-length s)) char) s)) + + (define (bn-pad-word->hex w) + (left-pad (fix->hex w) base-nibbles #\0)) + + (define (word->bn w) + (if (zero? w) '() (list w))) + + ;; Construct bignum from big-endian, vector-like sequence of nibbles. Ugly, but linear time. + (define (nibbles->bn nibble-ref len) + (define (loop-words start acc) + (if (= start len) acc + (let* ((next (+ start base-nibbles)) + (word (get-word start (- next 1)))) + (loop-words next (if (and (null? acc) (zero? word)) acc + (cons word acc)))))) + (define (get-word start stop) + (define (loop start acc) + (if (< stop start) acc + (loop (+ start 1) (+ (* 16 acc) (nibble-ref start))))) + (loop (+ start 1) (nibble-ref start))) + (if (zero? len) '() + (let* ((msw-end (remainder (- len 1) base-nibbles)) + (msw (get-word 0 msw-end))) + (loop-words (+ msw-end 1) (word->bn msw))))) + + ;; Rather than "shift left/right", which unnecessarily invoke endianness, I'm using "shift" for multiplications and "unshift" for divisions. + (define (shift-words a k) + (if (null? a) a (shift-words-nz a k))) + + (define (shift-words-nz a k) + (if (zero? k) a + (shift-words-nz (cons 0 a) (- k 1)))) + + (define (unshift-words a k) + (if (or (zero? k) (null? a)) a + (unshift-words (cdr a) (- k 1)))) + + ;;; Type conversion + + (define (bn->hex n) + (let ((n (reverse n))) + (if (null? n) "0" + (apply string-append (fix->hex (car n)) ;; optimize? + (map bn-pad-word->hex (cdr n)))))) + + (define (hex->bn s) + (nibbles->bn (lambda (k) (hexdigit->fix (string-ref s k))) + (string-length s))) + + (define (bytes->bn v) + (nibbles->bn (lambda (k) + (let ((byte (vector-ref v (fxshift k -1)))) + (if (even? k) + (fxshift byte -4) ;; big-endian + (fxand byte 15)))) + (* 2 (vector-length v)))) + + ;; ~Cubic algorithm! + (define (bn->dec n) + (let loop ((n n) (acc '())) + (if (null? n) (list->string acc) + (bn-divrem n '(10) + (lambda (q r) + (loop q (cons (string-ref hex (bn->fix r)) acc))))))) + + ;; Quadratic algorithm! + (define (dec->bn s) + (do ((i 0 (+ i 1)) + (acc bn0 (bn+fix (bn*fix acc 10) + (decdigit->fix (string-ref s i))))) + ((= i (string-length s)) acc))) + + ;; Can overflow (obviously) + (define (bn->fix n) + (do ((n (reverse n) (cdr n)) + (acc 0 (+ (* acc base) (car n)))) + ((null? n) acc))) + + (define (fix->bn n) + (do ((n n (fxshift n neg-base-bits)) + (acc '() (cons (fxand n base-1) acc))) + ((zero? n) (reverse acc)))) + + ;;; Predicates + + (define bn-zero? null?) + + (define (bn-even? a) (or (null? a) (even? (car a)))) + (define (bn-odd? a) (not (bn-even? a))) + + (define (cmp a b) + (cond ((< a b) -1) + ((< b a) 1) + (else 0))) + + (define (bn-cmp a b) + (cond ((null? a) (if (null? b) 0 -1)) + ((null? b) 1) + (else (let ((c (bn-cmp (cdr a) (cdr b)))) + (if (zero? c) (cmp (car a) (car b)) + c))))) + + (define bn= equal?) + (define (bn< a b) (< (bn-cmp a b) 0)) + (define (bn> a b) (< 0 (bn-cmp a b))) + (define (bn<= a b) (<= (bn-cmp a b) 0)) + (define (bn>= a b) (<= 0 (bn-cmp a b))) + + ;;; Addition + + (define (bn+1 a) + (if (null? a) bn1 + (let ((head (car a))) + (if (= head base-1) + (cons 0 (bn+1 (cdr a))) + (cons (+ head 1) (cdr a)))))) + + (define (bn+ a b) + (cond ((null? a) b) + ((null? b) a) + (else (let ((sum (+ (car a) (car b)))) + (if (< sum base) + (cons sum (bn+ (cdr a) (cdr b))) + (cons (- sum base) (bn+carry (cdr a) (cdr b)))))))) + + (define (bn+carry a b) + (cond ((null? a) (bn+1 b)) + ((null? b) (bn+1 a)) + (else (let ((sum (+ (car a) (car b) 1))) + (if (< sum base) + (cons sum (bn+ (cdr a) (cdr b))) + (cons (- sum base) (bn+carry (cdr a) (cdr b)))))))) + + ;; CAUTION: assumes 0 <= b < base + (define (bn+fix a b) + (cond ((zero? b) a) + ((null? a) (list b)) + (else (let ((sum (+ (car a) b))) + (if (< sum base) + (cons sum (cdr a)) + (cons (- sum base) (bn+1 (cdr a)))))))) + + ;;; Subtraction + + (define (bn-1 a) + (if (null? a) (error "bn-1: subtract from zero")) + (let ((head (car a)) (tail (cdr a))) + (cond ((zero? head) (cons base-1 (bn-1 tail))) + ((and (= head 1) (null? tail)) '()) + (else (cons (- head 1) tail))))) + + (define (bn- a b) + (cond ((null? a) (if (null? b) b (error "bn-: subtract from zero"))) + ((null? b) a) + (else (let ((diff (- (car a) (car b)))) + (if (< diff 0) + (cons (+ diff base) (bn-sub-borrow (cdr a) (cdr b))) + (let ((tail (bn- (cdr a) (cdr b)))) + (if (and (= diff 0) (null? tail)) '() + (cons diff tail)))))))) + + (define (bn-sub-borrow a b) + (cond ((null? a) (error "bn-: subtract from zero")) + ((null? b) (bn-1 a)) + (else (let ((diff (- (car a) (car b) 1))) + (if (< diff 0) + (let ((tail (bn-sub-borrow (cdr a) (cdr b))) + (diff (+ diff base))) + (if (and (= diff 0) (null? tail)) '() + (cons diff tail))) + (let ((tail (bn- (cdr a) (cdr b)))) + (if (and (= diff 0) (null? tail)) '() + (cons diff tail)))))))) + + ;;; Multiplication + + (define (bn*2 a) + (if (null? a) '() + (let ((product (* (car a) 2))) + (if (< product base) + (cons product (bn*2 (cdr a))) + (cons (- product base) (bn*2+carry (cdr a))))))) + + (define (bn*2+carry a) + (if (null? a) bn1 + (let ((product (+ (* (car a) 2) 1))) + (if (< product base) + (cons product (bn*2 (cdr a))) + (cons (- product base) (bn*2+carry (cdr a))))))) + + ;; CAUTION: assumes 0 <= scale < base + (define (bn*fix a scale) + (if (or (null? a) (zero? scale)) '() + (let ((product (* (car a) scale))) + (if (< product base) + (cons product (bn*fix (cdr a) scale)) + (cons (fxand product base-1) + (bn*fix+carry (cdr a) scale + (fxshift product neg-base-bits))))))) + + (define (bn*fix+carry a scale carry) + (if (or (null? a) (zero? scale)) (list carry) + (let ((product (+ (* (car a) scale) carry))) + (if (< product base) + (cons product (bn*fix (cdr a) scale)) + (cons (fxand product base-1) + (bn*fix+carry (cdr a) scale + (fxshift product neg-base-bits))))))) + + (define (bn-shift a bits) + (cond ((< bits 0) (error "bn-shift: negative bits")) + ((null? a) a) + (else (bn*fix (shift-words-nz a (quotient bits base-bits)) + (expt 2 (remainder bits base-bits)))))) + + (define (bn* a b) + (define (a* b) + (if (null? b) b + (bn+ (bn*fix a (car b)) + (shift-words (a* (cdr b)) 1)))) + (if (null? a) a (a* b))) + + ;; Still quadratic, but ~30% faster than generic multiplication + (define (bn^2 a) + (if (null? a) '() + (let* ((hd (car a)) + (tl (cdr a)) + (hd^2 (* hd hd)) + (hd^2 (if (< hd^2 base) (word->bn hd^2) + (list (fxand hd^2 base-1) + (fxshift hd^2 neg-base-bits))))) + (if (null? tl) hd^2 + (bn+ hd^2 + (cons 0 (bn+ (cons 0 (bn^2 tl)) + (bn*fix (bn*2 tl) hd)))))))) + + (define (strip-leading-zeros l) + (cond ((null? l) l) + ((zero? (car l)) (strip-leading-zeros (cdr l))) + (else l))) + + (define (bn-split a k cont) + (do ((head '() (cons (car tail) head)) + (tail a (cdr tail)) + (k k (- k 1))) + ((or (null? tail) (zero? k)) + (cont (reverse (strip-leading-zeros head)) tail)))) + + ;;; Division + + (define (bn/2 a) + (if (null? a) a + (cdr (bn*fix a base/2)))) + + (define (bn-unshift a bits) + (if (< bits 0) (error "bn-unshift: negative bits")) + (let* ((full-words (quotient bits base-bits)) + (extra-bits (remainder bits base-bits)) + (a (unshift-words a full-words))) + (if (or (null? a) (zero? extra-bits)) a + (cdr (bn*fix a (expt 2 (- base-bits extra-bits))))))) + + (define (num-bit-shifts start target) ;; optimize? + (define (loop start n) + (if (<= target start) n + (loop (* start 2) (+ n 1)))) + (loop start 0)) + + (define (last l) + (if (null? (cdr l)) (car l) + (last (cdr l)))) + + (define (bn-divrem a b return) + (if (null? b) (error "division by zero")) + ;; Normalize: most sig. bit of most sig. word of divisor must be 1 + (let ((msw (last b))) + (if (<= base/2 msw) (div-normalized a b return) + (let ((s (expt 2 (num-bit-shifts msw base/2)))) + (div-normalized + (bn*fix a s) (bn*fix b s) ;; optimize + (lambda (q r) + (return q (if (null? r) r + (cdr (bn*fix r (quotient base s))))))))))) + + (define (divrem-q q r) q) + (define (divrem-r q r) r) + (define (bn-quotient a b) (bn-divrem a b divrem-q)) ;; optimize? + (define (bn-remainder a b) (bn-divrem a b divrem-r)) + + (define (slice-2 a k) + (if (null? a) 0 + (let ((tail (cdr a))) + (if (zero? k) + (if (null? tail) (car a) + (+ (car a) (* (car tail) base))) + (slice-2 tail (- k 1)))))) + + (define (most-sig-word a) ;; assumes not null + (define (loop a tail) + (if (null? tail) (car a) + (loop tail (cdr tail)))) + (loop a (cdr a))) + + (define (div-normalized A B return) + (let* ((n (length B)) + (m (- (length A) n))) + (if (< m 0) (return '() A) + (let ((n-1 (- n 1)) + (B-msw (most-sig-word B))) + (define (get-qi i Q A) + (define (try-qi qi) + (let ((prod (shift-words (bn*fix B qi) i))) + (if (bn< A prod) + (try-qi (- qi 1)) + (get-qi (- i 1) (cons qi Q) (bn- A prod))))) + (if (< i 0) (return Q A) + (try-qi (min base-1 (quotient (slice-2 A (+ n-1 i)) + B-msw))))) + (let ((B-shift (shift-words B m))) + (if (bn< A B-shift) + (get-qi (- m 1) '() A) + (get-qi (- m 1) '(1) (bn- A B-shift)))))))) + + ;; Multiplicative inverse of a mod n: + ;; (bn-remainder (bn* a (bn-mod-inverse a n)) n) -> bn1 + ;; Assumes reduced input (0 < a < n) + (define (bn-mod-inverse a n) + ;; Extended Euclidean algorithm: find x where ax + by = gcd(a, b) + ;; If the gcd is 1, it follows that ax == 1 mod b + ;; See [HAC] Algorithm 2.142 / 2.107 + ;; Simplified / adjusted for unsigned bignums + ;; Invariants: + ;; [1] 0 <= r < b (loop terminates when b would reach 0) + ;; [2] 0 < b < a (by [1], as b is last r and a is last b) + ;; [3] q > 0 (by [2]) + ;; [4] If x > 0, then last x <= 0 and next x < 0 + ;; If x < 0, then last x > 0 and next x > 0 + ;; (by [3], as next x is last x - qx) + ;; Full proofs (mostly by induction) left as an exercise to the reader. + (define (loop a b x neg last-x) + (bn-divrem a b + (lambda (q r) + (if (bn-zero? r) + (if (bn= b bn1) (if neg (bn- n x) x) + (error "not invertible (modulus not prime?)")) + (loop b r (bn+ last-x (bn* q x)) (not neg) x))))) + (loop n a bn1 #f bn0)) + + ;;; Misc + + ;; Number of significant bits + ;; = least integer b such that 2^b > a + ;; = ceil(log_2(a+1)) + (define (bn-bits a) + (if (null? a) 0 + (+ (num-bit-shifts 1 (+ (last a) 1)) + (* (- (length a) 1) base-bits)))) + + (define (read-bytes n port) + (let ((v (make-vector n))) + (do ((k 0 (+ k 1))) ((= k n) v) + (vector-set! v k (char->integer (read-char port)))))) + + (define (ceil-quotient a b) + (quotient (+ a b -1) b)) + + ; Unbiased random integer generator in the interval [0, n) + (define (rand-bn n) + (if (bn-zero? n) (error "rand-bn: zero range")) + ;; Collecting one more byte than strictly necessary avoids cases where a large part of the range is invalid (e.g. n=130) + (let* ((nbytes (+ (ceil-quotient (bn-bits (bn-1 n)) 8) 1)) + (rand-range (bn-shift bn1 (* nbytes 8))) + (unbiased-range (bn- rand-range (bn-remainder rand-range n)))) + (lambda (rng-port) + (define (retry) + (let ((r (bytes->bn (read-bytes nbytes rng-port)))) + (if (bn< r unbiased-range) + (bn-remainder r n) + (retry)))) + (retry)))) + + ;; Deferred initializations + (set! base-bits (force base-bits)) + (set! base/2 (force base/2)) + (set! base (force base)) + (set! base-1 (force base-1)) + (set! neg-base-bits (force neg-base-bits)) + + (export + bn0 bn1 + hexdigit->fix decdigit->fix ;; not strictly bignum ops, but handy + bn->hex hex->bn bytes->bn + bn->dec dec->bn + bn->fix fix->bn + bn-zero? bn-even? bn-odd? bn= bn< bn> bn<= bn>= + bn+1 bn+ bn-1 bn- + bn*2 bn-shift bn*fix bn* bn^2 + bn/2 bn-unshift bn-divrem bn-quotient bn-remainder + bn-mod-inverse + bn-bits + rand-bn)) diff -uNr a/gbw-signer/library/bit-ops.scm b/gbw-signer/library/bit-ops.scm --- a/gbw-signer/library/bit-ops.scm false +++ b/gbw-signer/library/bit-ops.scm 57fd97273df8a16fedaf0a49d2265b0171e3f09931476b040383052ee08ac29903a6aa29efa2d163187ccf48993fd13b11326bc7a68ede1363dbaa3d03660414 @@ -0,0 +1,270 @@ +(lambda () + + (define (repeat obj count) + (if (<= count 0) '() + (cons obj (repeat obj (- count 1))))) + + (define (fold f init l) + (do ((l l (cdr l)) + (acc init (f acc (car l)))) + ((null? l) acc))) + + (define (assert err-msg proc . args) + (if (not (apply proc args)) (error err-msg args))) + + (define fxwidth-1 (- *fixnum-width* 1)) + + ;; A fixed width integer (fz) is represented as a list of fixnum words, least significant first, wrapped in an outer list to track the width in bits. As the desired width might not be a multiple of the system's fixnum width, the low end of the low word is zero padded. (This choice allows the carry output from the high word to work naturally.) + ;; + ;; Invariant: + ;; (= (+ bits (padding bits)) (* (word-count bits) *fixnum-width*)) + + (define (word-count bits) + (quotient (+ bits fxwidth-1) *fixnum-width*)) + + (define (padding bits) + (- fxwidth-1 (modulo (- bits 1) *fixnum-width*))) + + ;; Construct a fixed width integer (FZ) + (define (make-fz bit-width words) + (assert "make-fz: bad word count for width" + = (length words) (word-count bit-width)) + (list bit-width words)) + + ;; FZ accessors + (define fz-width car) + (define fz-words cadr) + (define (fz-unpack a consumer) (apply consumer a)) + + ;; "Press": construct FZ from reverse-accumulated words, zeroing the pad bits + (define (press-fz bit-width rev-words) + (let* ((p (padding bit-width)) + (head (fxshift/unsigned (fxshift (car rev-words) p) (- p)))) + (make-fz bit-width (reverse (cons head (cdr rev-words)))))) + + (define (fz0 width) + (make-fz width (repeat 0 (word-count width)))) + + (define (word->ufz width w) + (make-fz width (cons w (repeat 0 (- (word-count width) 1))))) + + (define (ufz+/pair a b) + (let ((width (fz-width a))) + (assert "ufz+: unequal width" = width (fz-width b)) + (let loop ((a (fz-words a)) (b (fz-words b)) (carry 0) (acc '())) + (if (null? a) (press-fz width acc) + (call-with-values + (lambda () (fx+/carry-unsigned (car a) (car b) carry)) + (lambda (sum carry) + (loop (cdr a) (cdr b) carry (cons sum acc)))))))) + + ;; !! UNTESTED !! + ;(define (ufz-/pair a b) + ; (let ((width (fz-width a))) + ; (assert "ufz-: unequal width" = width (fz-width b)) + ; (let loop ((a (fz-words a)) (b (fz-words b)) (carry 0) (acc '())) + ; (if (null? a) (press-fz width acc) + ; (call-with-values + ; (lambda () (fx-/carry-unsigned (car a) (car b) carry)) + ; (lambda (diff carry) + ; (loop (cdr a) (cdr b) carry (cons diff acc)))))))) + + (define (ufz+ a . args) (fold ufz+/pair a args)) + + ;; Positive (left) shift: signedness doesn't matter. + ;; Assumes 0 < bits < width. + ;; Constant time w.r.t. words only (NOT bits). + (define (shift width words bits) + (let ((whole-words (quotient bits *fixnum-width*)) + (bits (remainder bits *fixnum-width*))) + (let ((carry-shift (- bits *fixnum-width*))) + (do ((words words (cdr words)) + (carry 0 (fxshift/unsigned (car words) carry-shift)) + (acc (repeat 0 whole-words) + (cons (fxior (fxshift (car words) bits) carry) acc)) + (todo (- (word-count width) whole-words) (- todo 1))) + ((zero? todo) (press-fz width acc)))))) + + ;; Negative (right) shift without sign extension. + ;; Assumes 0 < bits < width. + ;; Constant time w.r.t. words only (NOT bits). + (define (unshift-unsigned width words bits) + (let ((whole-words (quotient bits *fixnum-width*)) + (bits (- (remainder bits *fixnum-width*)))) + (let ((carry-shift (+ bits *fixnum-width*))) + (do ((words (reverse (list-tail words whole-words)) (cdr words)) + (carry 0 (fxshift (car words) carry-shift)) + (acc (repeat 0 whole-words) + (cons (fxior (fxshift/unsigned (car words) bits) carry) + acc))) + ((null? words) (make-fz width acc)))))) + + ;; Front-end for unsigned shifts. + ;; Constant time w.r.t. FZ value only (NOT bits). + (define (ufzshift a bits) + (fz-unpack + a (lambda (width words) + (cond ((zero? bits) a) + ((>= (abs bits) width) (fz0 width)) + ((positive? bits) (shift width words bits)) + (else (unshift-unsigned width words (- bits))))))) + + ;; Bit rotation: signedness doesn't matter. + ;; Rotates to the "left" i.e. more-significant, but can take negative bits. + ;; Constant time w.r.t. FZ value only (NOT bits). + (define (fzrot a bits) + (fz-unpack + a (lambda (width words) + (let ((bits (modulo bits width))) + (if (zero? bits) a + (fzior (shift width words bits) + (unshift-unsigned width words (- width bits)))))))) + + (define (fznot a) + (fz-unpack a (lambda (width a) (press-fz width (reverse (map fxnot a)))))) + + ;; Build new FZ by mapping func across corresponding words of each input. + ;; Assumes func preserves zero padding. + (define (fzmap func a . tail) + (let ((width (fz-width a))) + (if (not (apply = width (map fz-width tail))) + (error "fzmap: unequal widths")) + (make-fz width (apply map func (fz-words a) (map fz-words tail))))) + + (define (fzand . args) (apply fzmap fxand args)) + (define (fzior . args) (apply fzmap fxior args)) + (define (fzxor . args) (apply fzmap fxxor args)) + (define (fzif a b c) (fzmap fxif a b c)) + (define (fzmaj a b c) (fzmap fxmaj a b c)) + + ;;; FZ to octet string I/O, big and little endian. + ;;; Complicated due to non-aligned fixnum width, but linear time. + + ;; Construct (* 8 (string-length BUF)) bit wide FZ from the octets in BUF. + (define (bytes->fz buf big-endian) + (let* ((nbytes (string-length buf)) + (get-char (if big-endian + (lambda (k) (string-ref buf (- nbytes 1 k))) + (lambda (k) (string-ref buf k))))) + (let loop ((bit-pos 0) (k 0) (word 0) (words '())) + (if (= k nbytes) (make-fz (fxshift nbytes 3) + (reverse (cons word words))) + (let ((byte (char->integer (get-char k)))) + (let ((bit-pos (+ bit-pos 8)) + (k (+ k 1)) + (word (fxior word (fxshift byte bit-pos)))) + (if (<= bit-pos *fixnum-width*) + ;; whole byte fits in current word + (loop bit-pos k word words) + ;; else spill to next word + (let ((carry-bits (- bit-pos *fixnum-width*))) + (loop carry-bits k (fxshift/unsigned byte (- carry-bits 8)) + (cons word words)))))))))) + + (define (lsb->char word) + (integer->char (fxand word 255))) + + ;; Construct octet string from a multiple-of-8 bit wide FZ. + (define (fz->bytes a big-endian) + (fz-unpack + a (lambda (width words) + (if (not (zero? (fxand width 7))) + (error "fz->bytes: width not divisible by 8:" width)) + (let* ((nbytes (fxshift width -3)) + (buf (make-string nbytes)) + (set-byte! + (if big-endian + (lambda (k b) (string-set! buf (- nbytes 1 k) + (lsb->char b))) + (lambda (k b) (string-set! buf k (lsb->char b)))))) + (let loop ((bit-pos 0) (k 0) (word (car words)) + (words (cdr words))) + (if (= k nbytes) buf + (let ((byte (fxshift/unsigned word (- bit-pos))) + (bit-pos (+ bit-pos 8))) + (if (<= bit-pos *fixnum-width*) + ;; whole byte contained in current word + (begin (set-byte! k byte) + (loop bit-pos (+ k 1) word words)) + ;; else fill in from next word + (let ((word (car words)) + (peek (- bit-pos *fixnum-width*))) + (set-byte! k (fxior byte (fxshift word (- 8 peek)))) + (loop peek (+ k 1) word (cdr words))))))))))) + + ;;; Constant time word comparison predicates, returning 0 or 1 + + (define (uwordinteger #\0) 1)) + (define num-hi (+ (char->integer #\9) 1)) + (define num-0 (char->integer #\0)) + (define uc-lo (- (char->integer #\A) 1)) + (define uc-hi (+ (char->integer #\F) 1)) + (define lc-lo (- (char->integer #\a) 1)) + (define lc-hi (+ (char->integer #\f) 1)) + (define uc-a-10 (- (char->integer #\A) 10)) + (define lc-a-10 (- (char->integer #\a) 10)) + + (define (hexdigit->integer d) + (let ((i (char->integer d))) + (let ((num (fxand (uwordhexdigit i) + (integer->char (fx+/wrap i (word-mux (uwordbytes h) + (let* ((len (quotient (+ (string-length h) 1) 2)) + (bytes (make-string len))) + (define (loop i j) + (if (= i len) bytes + (let ((hi (string-ref h j)) (lo (string-ref h (+ j 1)))) + (string-set! bytes i + (integer->char + (fxior (fxshift (hexdigit->integer hi) 4) + (hexdigit->integer lo)))) + (loop (+ i 1) (+ j 2))))) + (if (even? (string-length h)) (loop 0 0) + (begin (string-set! bytes 0 (integer->char (hexdigit->integer + (string-ref h 0)))) + (loop 1 1))))) + + (define (bytes->hex b) + (let* ((len (string-length b)) + (h (make-string (* 2 len)))) + (do ((i 0 (+ i 1)) + (j 0 (+ j 2))) ((= i len) h) + (let ((byte (char->integer (string-ref b i)))) + (string-set! h j (integer->hexdigit (fxshift/unsigned byte -4))) + (string-set! h (+ j 1) (integer->hexdigit (fxand byte 15))))))) + + ;; Shortcuts, favoring big-endianism as the conventional digit order in writing and in the intrabyte order of hex encoding. + (define (fz->hex a) (bytes->hex (fz->bytes a #t))) + (define (hex->fz a) (bytes->fz (hex->bytes a) #t)) + + (export fz0 word->ufz ufz+ ufzshift fzrot fznot fzand fzior fzxor fzif + fzmaj bytes->fz fz->bytes hexdigit->integer hex->bytes bytes->hex + fz->hex hex->fz)) diff -uNr a/gbw-signer/library/ecdsa.scm b/gbw-signer/library/ecdsa.scm --- a/gbw-signer/library/ecdsa.scm false +++ b/gbw-signer/library/ecdsa.scm a9824ee5823b000f073bd5e8543362b8a9ad51f7aed1a5e36b1a9a2438185872bd64b6711eeba4068f14b849accc64383c38f174f5e04dc97fc256d0edb0648e @@ -0,0 +1,240 @@ +;;;; ecdsa.scm: Elliptic Curve Digital Signature Algorithm based on bignum.scm +;;; J. Welsh, October 2017 - March 2020 + +(lambda (bn) + (define bytes->bn (bn 'bytes->bn)) + (define unshift (bn 'bn-unshift)) + (define nbits (bn 'bn-bits)) + (define /2 (bn 'bn/2)) + (define bn-1 (bn 'bn-1)) + (define bn0 (bn 'bn0)) + (define bn1 (bn 'bn1)) + (define bn->hex (bn 'bn->hex)) + (define hex->bn (bn 'hex->bn)) + (define rand-bn (bn 'rand-bn)) + (define fix- -) + (define fix-zero? zero?) + + ;; Convert the leftmost max-bits bits of big-endian byte sequence b to bignum + (define (left-bytes->bn b max-bits) + ; Equivalent to [SEC1] section 4.1.3 step 5 + (let ((e (bytes->bn b)) + (bits (* 8 (vector-length b)))) + (if (<= bits max-bits) e + (unshift e (- bits max-bits))))) + + ;; Operations on a Weierstrass elliptic curve, over the prime field of order p, defined by: + ;; + ;; y^2 == x^3 + ax + b mod p + ;; + ;; ("a == b mod m" means modular congruence: a-b is a multiple of m.) + ;; + ;; g -- base point (generator) (cons gx gy) + ;; n -- order of g + ;; h -- cofactor (nh = number of points on the curve) + (define (curve p a b g n h) + (let ((+ (bn 'bn+)) + (- (bn 'bn-)) + (* (bn 'bn*)) + (*fix (bn 'bn*fix)) + (*2 (bn 'bn*2)) + (^2 (bn 'bn^2)) + (zero? (bn 'bn-zero?)) + (even? (bn 'bn-even?)) + (= (bn 'bn=)) + (> (bn 'bn>)) + (< (bn 'bn<)) + (n-bits (nbits n)) + (n/2 (/2 n)) + (remainder (bn 'bn-remainder)) + (mod-inverse (bn 'bn-mod-inverse))) + + (define (modp a) + (remainder a p)) + + (define (modn a) + (remainder a n)) + + ;; Compute a-b mod p, avoiding negatives; output reduced if inputs are + (define (mod- a b) + (if (< a b) (- (+ p a) b) (- a b))) + + ;; Compute 2a mod p; output is reduced if input is + (define (mod*2 a) + (let ((b (*2 a))) + (if (< b p) b (- b p)))) + + (define (mod^2 a) (modp (^2 a))) + (define (mod* a b) (modp (* a b))) + + ;; Saves a reduction compared to (= (modp a) (modp b)) + (define (congruent? a b) + (zero? (modp (if (< a b) (- b a) (- a b))))) + + (define (on-curve? point) + (if (eq? point 'inf) #t + (let ((x (car point)) (y (cdr point))) + (and (< x p) + (< y p) + (congruent? (^2 y) + (+ (* (mod^2 x) x) (+ (* a x) b))))))) + + ;; EC group operation, per [SEC1] section 2.2.1 + (define (ec+ p1 p2) + (if (eq? p1 'inf) p2 ; adding the identity + (if (eq? p2 'inf) p1 + (let ((x1 (car p1)) + (y1 (cdr p1)) + (x2 (car p2)) + (y2 (cdr p2))) + (let ((x2-x1 (mod- x2 x1))) + (if (and (zero? x2-x1) + (or (zero? y1) (not (= y1 y2)))) + 'inf ; adding the inverse + (let* ((slope (if (zero? x2-x1) + ; same point (doubling) + (mod* (modp (+ (*fix (^2 x1) 3) a)) + (mod-inverse (mod*2 y1) p)) + (mod* (mod- y2 y1) + (mod-inverse x2-x1 p)))) + (x3 (mod- (mod- (mod^2 slope) x1) x2))) + (cons x3 (mod- (mod* slope (mod- x1 x3)) y1))))))))) + + ;; Supposedly doubling can be faster than general addition but I'm not seeing how... + (define (ec*2 p1) + (if (eq? p1 'inf) p1 + (let ((x (car p1)) + (y (cdr p1))) + (if (zero? y) 'inf + (let ((slope (mod* (modp (+ (*fix (^2 x) 3) a)) + (mod-inverse (mod*2 y) p)))) + (let ((x3 (mod- (mod^2 slope) (mod*2 x)))) + (cons x3 (mod- (mod* slope (mod- x x3)) y)))))))) + + ;; Scalar multiplication: computes the equivalent of k repeated additions of point p, in O(log k) time. + (define (scalar* k p) + (do ((k k (/2 k)) + (acc 'inf (if (even? k) acc (ec+ acc p*2^bits))) + (p*2^bits p (ec*2 p*2^bits))) + ((zero? k) acc))) + + ;; Optimize products of g by precomputation + (define (scalar*g k) + (do ((k k (/2 k)) + (acc 'inf (if (even? k) acc (ec+ acc (car doublings)))) + (doublings (force doublings-of-g) (cdr doublings))) + ((zero? k) acc))) + + (define doublings-of-g + (delay + (do ((k (nbits (bn-1 n)) (fix- k 1)) + (g*2^bits g (ec*2 g*2^bits)) + (doublings '() (cons g*2^bits doublings))) + ((fix-zero? k) (reverse doublings))))) + + (define gen-priv-key + (let ((get-rand-int (rand-bn n))) + (lambda (rng-port) + (let ((k (get-rand-int rng-port))) + (if (zero? k) + (error "generated all-zero key?!") + k))))) + + (define (valid-pub-key? point) + ;; Per [SEC1] section 3.2.2.1 + (and (not (eq? point 'inf)) + (on-curve? point) + (or (= h bn1) (eq? (scalar* n point) 'inf)))) + + ;; Return an ECDSA signature of a message hash via (cont r s). Always succeeds, assuming valid inputs and properly functioning RNG. + ;; + ;; As (r, -s mod n) is also a valid signature, the result is canonicalized to use the lesser of the two possible s-values. + ;; + ;; Note the sharp edge of the scheme: you do need a good RNG here, as knowledge of the ephemeral key compromises the private key. Repeated r-values make it trivial to compute, and other forms of predictability may well do the same. + (define (sign hash private-key rng-port cont) + ; Per [SEC1] section 4.1.3 + (let ((e (left-bytes->bn hash n-bits))) + (define (find-temp-key) + (let* ((k (gen-priv-key rng-port)) + (r (modn (car (scalar*g k))))) + (if (zero? r) (find-temp-key) + (let ((s (modn (* (mod-inverse k n) + (+ e (modn (* r private-key))))))) + (if (zero? s) (find-temp-key) + (cont r (if (< n/2 s) (- n s) s))))))) + (find-temp-key))) + + ;; Return whether (r, s) is a valid ECDSA signature of hash by pub-key. + ;; WARNING: you might also have to ensure (valid-pub-key? pub-key)! + (define (valid-sig? r s hash pub-key) + ;; Per [SEC1] section 4.1.4 + (and + (< bn0 r) (< r n) (< bn0 s) (< s n) + (let ((e (left-bytes->bn hash n-bits)) + (s-inv (mod-inverse s n))) + (let ((u1 (modn (* e s-inv))) + (u2 (modn (* r s-inv)))) + (let ((bigR (ec+ (scalar*g u1) + (scalar* u2 pub-key)))) + (and (not (eq? bigR 'inf)) + (= (modn (car bigR)) r))))))) + + (define (point->hex p) + (if (eq? p 'inf) p + (cons (bn->hex (car p)) + (bn->hex (cdr p))))) + + (define (hex->point p) + (if (eq? p 'inf) p + (cons (hex->bn (car p)) + (hex->bn (cdr p))))) + + (define (read-cache file) + ;; I'd rather this be automatic, but no standard way in R5RS to check if a file exists or handle errors if not... + (let* ((data (with-input-from-file file read)) + (doublings (map hex->point data))) + (set! doublings-of-g (delay doublings)))) + + (define (write-cache file) + (with-output-to-file + file (lambda () (write (map point->hex (force doublings-of-g)))))) + + (lambda (message) + (case message + ((ec+) ec+) + ((gen-priv-key) gen-priv-key) + ((priv->pub) scalar*g) + ((valid-pub-key?) valid-pub-key?) + ((sign) sign) + ((valid-sig?) valid-sig?) + ((read-cache) read-cache) + ((write-cache) write-cache) + (else (error "bad message:" message)))))) + + ;;; Well-known curve parameters + + (define (from-hex o) + (cond ((string? o) (hex->bn o)) + ((pair? o) (cons (from-hex (car o)) (from-hex (cdr o)))) + (else o))) + + (define (curve-from-hex . args) + (apply curve (from-hex args))) + + ;; Generalized Koblitz curve over a 256-bit prime field, per [SEC2] + (let ((secp256k1 + (curve-from-hex + "fffffffffffffffffffffffffffffffffffffffffffffffffffffffefffffc2f" + "0" + "7" + '("79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" . "483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8") + "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141" + "1"))) + + (export curve secp256k1))) + +;;; References + +;; [SEC1] Certicom Research 2009. "Standards for Efficient Cryptography: SEC 1: Elliptic Curve Cryptography". Certicom Corp. Version 2.0. http://www.secg.org/sec1-v2.pdf +;; [SEC2] Certicom Research 2010. "Standards for Efficient Cryptography: SEC 2: Recommended Elliptic Curve Domain Parameters". Certicom Corp. Version 2.0. http://www.secg.org/sec2-v2.pdf +;; [HAC] Menezes, A., van Oorshot, P. and Vanstone, S. 1996. "Handbook of Applied Cryptography". CRC Press. http://www.cacr.math.uwaterloo.ca/hac diff -uNr a/gbw-signer/library/gbw-shell.sh b/gbw-signer/library/gbw-shell.sh --- a/gbw-signer/library/gbw-shell.sh false +++ b/gbw-signer/library/gbw-shell.sh bb862e99e6371a5a69f0485035062fbe1164e9bee636afd1f8540ab718608bcd689ce5af1ede9e54b89453b361aabc3ea14fd21989cd0d850e2d8a524f279f24 @@ -0,0 +1,85 @@ +# Gales Bitcoin Wallet: GPG integration +# J. Welsh, March 2020 + +gbw-init () { + if [ -n "$GBW_DIR" ]; then + echo 'gbw-init: already opened (GBW_DIR set)' + return 1 + fi + + if [ -z "$1" ]; then + echo 'gbw-init: missing filename for encrypted archive' + return 1 + fi + + GBW_DIR=`mktemp -d -p "$GBW_TMPDIR"` || return + GBW_FILENAME="$1" + GBW_OLDPWD="$PWD" + + printf 'Entering GBW_DIR %s\n' "$GBW_DIR" + cd "$GBW_DIR" + mkdir -p wallet/keys + cd wallet + + printf 'Transaction fee to pay, in BTC/kB : ' + read GBW_FEE + printf '%s\n' "$GBW_FEE" > fee + unset GBW_FEE + + echo 'Generating change address...' + gbw-signer gen-key > change +} + +gbw-open () { + if [ -n "$GBW_DIR" ]; then + echo 'gbw-open: already opened (GBW_DIR set)' + return 1 + fi + + if [ -z "$1" ]; then + echo 'gbw-open: missing filename' + return 1 + fi + + if ! [ -e "$1" ]; then + printf 'gbw-open: not found: %s\n' "$1" + return 1 + fi + + GBW_DIR=`mktemp -d -p "$GBW_TMPDIR"` || return + GBW_FILENAME="$1" + GBW_OLDPWD="$PWD" + + gpg --decrypt "$1" | tar -xf - -C "$GBW_DIR" + + printf 'Entering GBW_DIR %s\n' "$GBW_DIR" + cd "$GBW_DIR/wallet" +} + +gbw-save () { + if [ -z "$GBW_DIR" ]; then + echo 'gbw-save: not opened (GBW_DIR unset)' + return 1 + fi + + (cd "$GBW_OLDPWD" && + tar -cf - -C "$GBW_DIR" wallet | gpg --encrypt --armor --recipient "$GBW_RECIPIENT" --output "$GBW_FILENAME{new}" && + sync && + mv -f "$GBW_FILENAME{new}" "$GBW_FILENAME") +} + +gbw-discard () { + if [ -z "$GBW_DIR" ]; then + echo 'gbw-discard: not opened (GBW_DIR unset)' + return 1 + fi + + printf 'Returning to %s\n' "$GBW_OLDPWD" + cd "$GBW_OLDPWD" + rm -rf "$GBW_DIR" + unset GBW_OLDPWD GBW_DIR GBW_FILENAME +} + +gbw-close () { + gbw-save && gbw-discard +} diff -uNr a/gbw-signer/library/gbw-signer.scm b/gbw-signer/library/gbw-signer.scm --- a/gbw-signer/library/gbw-signer.scm false +++ b/gbw-signer/library/gbw-signer.scm fc9095bd85abbc5accaddce67e6c38a7b1618c190fe12b969591752940b4433fc85eee9c877a7f8df3f7f96c1d83db7ef6af33b7072f34e23ba92d10b3935349 @@ -0,0 +1,767 @@ +;;;; gbw-signer.scm: Gales Bitcoin Wallet offline key generation and transaction signing +;;; J. Welsh, October 2017 - March 2020 + +;;; Knobs + +(define *install-path* "/package/gbw-signer-1") + +(define *rng-port* (delay (open-input-file "/dev/urandom"))) + +;; Minimum value for which to generate change outputs, as lubricant for sabotaged network that stifles transactions with small outputs regardless of fee. Per commits: +;; 8de9bb53af32f7f6b09c06f831f2c0a7b4e95303 ( http://archive.is/tE6nK ) +;; 6a4c196dd64da2fd33dc7ae77a8cdd3e4cf0eff1 ( http://archive.is/rALd9 ) +(define *dust-threshold* 546) + +;;; Libraries + +(define (resource path) + (string-append *install-path* "/library/" path)) + +;; Public EC precomputations ("make-cache" to generate) +(define *cache-path* (resource "secp256k1.cache")) + +(load (resource "pkg.scm")) + +(define bignum (load-pkg (resource "bignum.scm"))) +(import bignum + decdigit->fix + bn->hex hex->bn bytes->bn bn->fix fix->bn + bn-zero? bn-even? + bn-divrem rand-bn) + +(define ecdsa (load-pkg (resource "ecdsa.scm") bignum)) +(import ecdsa secp256k1) + +(define bit-ops (load-pkg (resource "bit-ops.scm"))) +(import bit-ops hex->bytes bytes->hex) + +(define hashes (load-pkg (resource "hashes.scm") bit-ops)) +(import hashes ripemd160 sha256) + +;;; Helpers + +;; Poor man's debugger +(define (trace . args) + (write args) + (newline) + (flush-output-port)) + +(define *null-byte* (integer->char 0)) + +(define (left-pad s len char) + (string-append (make-string (- len (string-length s)) char) s)) + +(define (pad-hex-256be s) (left-pad s 64 #\0)) ;; 256 bits = 64 nibbles + +(define (pad-bytes-256be s) (left-pad s 32 *null-byte*)) + +(define (string-head s n) (substring s 0 n)) + +(define (string-tail s n) (substring s n (string-length s))) + +(define (string-reverse s) + (let ((r (make-string (string-length s))) + (last (- (string-length s) 1))) + (do ((i 0 (+ i 1))) ((> i last) r) + (string-set! r i (string-ref s (- last i)))))) + +(define (string-find s start chars) + (let loop ((i start)) + (cond ((= i (string-length s)) #f) + ((memv (string-ref s i) chars) i) + (else (loop (+ i 1)))))) + +(define (string-split s chars) + (let loop ((i 0)) + (let ((cut (string-find s i chars))) + (cond ((not cut) (if (= i (string-length s)) '() + (list (string-tail s i)))) + ((= i cut) (loop (+ i 1))) + (else (cons (substring s i cut) (loop (+ cut 1)))))))) + +(define (bn->bytes n) + ;; hacky... + (hex->bytes (bn->hex n))) + +(define (integer->bytes n) + ;; hacky... + (hex->bytes (number->string n 16))) + +(define (bn-pack-le nbytes) + (let ((nibbles (* nbytes 2))) + (lambda (n) + (string-reverse (hex->bytes (left-pad (bn->hex n) nibbles #\0)))))) + +(define (string->bytevec s) + (let* ((len (string-length s)) + (v (make-vector len))) + (do ((i 0 (+ i 1))) ((= i len) v) + (vector-set! v i (char->integer (string-ref s i)))))) + +(define (byte-string->bn s) + (bytes->bn (string->bytevec s))) + +(define (byte-string . bytes) + (list->string (map integer->char bytes))) + +(define (display-line x) + (display x) + (newline) + (flush-output-port)) + +(define (read-line port) + (let loop ((acc '())) + (let ((c (read-char port))) + (cond ((eof-object? c) (if (null? acc) c + (list->string (reverse acc)))) + ((char=? c #\newline) (list->string (reverse acc))) + (else (loop (cons c acc))))))) + +(define (read-all port) + (do ((c (read-char port) (read-char port)) + (acc '() (cons c acc))) + ((eof-object? c) (list->string (reverse acc))))) + +;; gscm so far has a subprocess extension but not a full POSIX or condition system. +(define (file-exists? path) + (call-with-values + (lambda () (open-subprocess "/usr/bin/test" "test" "-e" path)) + (lambda (pid i o) + (close-output-port o) + (read-all i) + (close-input-port i) + (zero? (wait-subprocess pid))))) + +(define (read-priv-key-hex port) + (let ((k (read-line port))) + (if (not (= (string-length k) 64)) (error "ill-formed key")) + k)) + +(define (get-priv-key-by-address addr) + (hex->bn (call-with-input-file (string-append "keys/" addr) + read-priv-key-hex))) + +(define (have-key? addr) (file-exists? (string-append "keys/" addr))) + +(define (sha256d x) (sha256 (sha256 x))) + +(define (hash160 x) (ripemd160 (sha256 x))) + +(define (shuffle l) + (define v (list->vector l)) + ;; Knuth/Fisher-Yates shuffle in place + (do ((i (- (vector-length v) 1) (- i 1))) ((negative? i)) + (let ((j (bn->fix ((rand-bn (fix->bn (+ i 1))) + (force *rng-port*)))) + (t (vector-ref v i))) + (vector-set! v i (vector-ref v j)) + (vector-set! v j t))) + (vector->list v)) + +(define *cache* (delay ((secp256k1 'read-cache) *cache-path*))) + +(define (pop-arg) + (if (null? *args*) (error "too few arguments")) + (let ((a (car *args*))) + (set! *args* (cdr *args*)) + a)) + +;;; Base58 [TRB/base58.h] + +(define *bn58* (fix->bn 58)) + +(define (b58digit i) ;; alphanumeric - 0OIl + (string-ref "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" i)) + +(define b58digit->integer + (let ((inverse (make-vector 256 #f))) + (do ((i 0 (+ i 1))) ((= i 58)) + (vector-set! inverse (char->integer (b58digit i)) i)) + (lambda (d) + (or (vector-ref inverse (char->integer d)) + (error "invalid base58 digit:" d))))) + +(define (encode-base58 data) + (let loop ((n (byte-string->bn data)) + (acc '())) + (if (not (bn-zero? n)) + (bn-divrem n *bn58* (lambda (q r) + (loop q (cons (bn->fix r) acc)))) + ;; Leading zero bytes pass through one-to-one + (do ((i 0 (+ i 1)) + (acc acc (cons 0 acc))) + ((or (= i (string-length data)) + (not (zero? (char->integer (string-ref data i))))) + (list->string (map b58digit acc))))))) + +(define (decode-base58 data) + (do ((digits (map b58digit->integer (string->list data)) (cdr digits)) + (zeros 0 (+ 1 zeros))) + ((or (null? digits) (not (zero? (car digits)))) + (if (null? digits) (make-string zeros *null-byte*) + (do ((acc (car digits) (+ (* acc 58) (car digits))) + (digits (cdr digits) (cdr digits))) + ((null? digits) (string-append (make-string zeros *null-byte*) + (integer->bytes acc)))))))) + +;; Well-known Base58Check payload type tags +(define *b58-version-p2pkh* 0) +(define *b58-version-p2sh* 5) +(define *b58-version-secret* 128) +(define *b58-version-testnet-p2pkh* 111) +(define *b58-version-testnet-p2sh* 196) +(define *b58-version-testnet-secret* 239) + +(define (encode-base58check version data) + (let ((data (string-append (byte-string version) data))) + (encode-base58 + (string-append data (string-head (sha256d data) 4))))) + +(define (decode-base58check data) + (let* ((data (decode-base58 data)) + (cut (- (string-length data) 4))) + (if (negative? cut) (error "decode-base58check: checksum too short")) + (let ((payload (string-head data cut)) + (check (string-tail data cut))) + (if (not (string=? check (string-head (sha256d payload) 4))) + (error "decode-base58check: bad checksum")) + payload))) + +(define (point->address p form) + (encode-base58check *b58-version-p2pkh* (hash160 (encode-point p form)))) + +;;; OpenSSL binary encodings + +;; EC point (public key) [1] +;; Leading byte encodes form: +;; (0) the point at infinity +;; (2 x) compressed, even y +;; (3 x) compressed, odd y +;; (4 x y) uncompressed +;; (6 x y) hybrid, even y +;; (7 x y) hybrid, odd y +(define (encode-point p form) + (if (eq? p 'inf) (byte-string 0) + (let ((x (car p)) + (y (cdr p)) + (pack (lambda (n) (pad-bytes-256be (bn->bytes n))))) + (case form + ((compressed) + (string-append (byte-string (if (bn-even? y) 2 3)) (pack x))) + ((uncompressed) + (string-append (byte-string 4) (pack x) (pack y))) + ((hybrid) + ;; Hybrid form seems entirely pointless to me, but is included for completeness. + (string-append (byte-string (if (bn-even? y) 6 7)) + (pack x) (pack y))) + (else (error "encode-point: bad form:" form)))))) + +;; DERP encoding: a subset of the Distinguished Encoding Rules of Abstract Syntax Notation One + +(define (derp-encapsulate tag constructed? contents) + ;; Class assumed to be 0 (universal) + ;; Tag assumed to be 0-30 + ;; Length assumed to be 0-127 + (string-append (byte-string (if constructed? (+ tag 32) tag) + (string-length contents)) + contents)) + +(define (derp-contents s) + (string-tail s 2)) + +(define (encode-derp-integer n) + ;; INTEGER is encoded base 256, two's complement, big endian, with the minimal number of octets, except zero which is a single zero octet + (let* ((b (bn->bytes n)) + (pad? (or (zero? (string-length b)) + (> (char->integer (string-ref b 0)) 127)))) + (derp-encapsulate 2 #f (if pad? (string-append (byte-string 0) b) b)))) + +(define (decode-derp-integer s start) + (byte-string->bn (derp-contents s))) + +(define (encode-derp-sequence . items) + ;; SEQUENCE is encoded as the concatenation of the respective encoded items + (derp-encapsulate 16 #t (apply string-append items))) + +(define (encode-derp-sig r s) + ;; [SSL/crypto/ecdsa/ecs_asn1.c], [SSL/crypto/asn1/x_bignum.c] + (encode-derp-sequence (encode-derp-integer r) (encode-derp-integer s))) + +;;; Bitcoin transactions + +(define (alist fields) + (lambda vals + (map list fields vals))) + +(define (alist-get l field . default) + (let ((l (assq field l))) + (if l (cadr l) + (if (null? default) (error "field not found" field) + (car default))))) + +(define (alist-extend l field val) + (cons (list field val) l)) + +(define make-input (alist '(txid index value sig-script))) +(define make-output (alist '(value address))) +(define make-prevout (alist '(txid index value address))) + +(define (prevout->unsigned-input p) + (alist-extend p 'sig-script '())) + +(define *tx-version* (byte-string 1 0 0 0)) +(define *lock-time* (byte-string 0 0 0 0)) + +(define (sign-transaction prev-outputs new-outputs) + ;; [TRB/script.cpp] SignatureHash, SignSignature, Solver + ;; [TRB/key.h] CKey::Sign + (force *cache*) + (let ((unsig-ins (map prevout->unsigned-input prev-outputs)) + (encoded-prefix (string-append *tx-version* + (encode-var-int (length prev-outputs)))) + (encoded-suffix (string-append (encode-outputs new-outputs) + *lock-time*))) + (do ((unsig-ins unsig-ins (cdr unsig-ins)) + (prev-outputs prev-outputs (cdr prev-outputs)) + (enc-unsig-ins (map encode-input unsig-ins) (cdr enc-unsig-ins)) + (enc-unsig-ins-head '() `(,@enc-unsig-ins-head ,(car enc-unsig-ins))) + (signed-ins + '() + (let* ((prev-addr (alist-get (car prev-outputs) 'address)) + (m (apply string-append + `(,encoded-prefix + ,@enc-unsig-ins-head + ,(encode-input + (alist-extend (car unsig-ins) 'sig-script + (output-script prev-addr))) + ,@(cdr enc-unsig-ins) + ,encoded-suffix + ,*sighash-all/u32*))) + (hash (string->bytevec (sha256d m))) + (priv (get-priv-key-by-address prev-addr)) + (pub ((secp256k1 'priv->pub) priv)) + (sig-script ((secp256k1 'sign) + hash priv (force *rng-port*) + (lambda (r s) + (input-script r s pub 'uncompressed))))) + (cons (alist-extend (car unsig-ins) 'sig-script sig-script) + signed-ins)))) + ((null? unsig-ins) (apply string-append + `(,encoded-prefix + ,@(map encode-input (reverse signed-ins)) + ,encoded-suffix)))))) + +(define (estimate-tx-size prev-outputs new-outputs) + (let ((n-ins (length prev-outputs))) + (+ 8 ;; version, locktime + (string-length (encode-var-int n-ins)) + (* 181 n-ins) ;; txid, index, r, s, x, y, overhead + (string-length (encode-outputs new-outputs))))) + +;;; Script, per [TRB/script.h] + +(define (enumerate start items . more) + (let loop ((i start) (l items) (more more) (acc '())) + (if (null? l) (if (null? more) (reverse acc) + (loop (car more) (cadr more) (cddr more) acc)) + (loop (+ i 1) (cdr l) more (cons (list (car l) i) acc))))) + +(define *script-ops* + (enumerate + 0 + '(op_0) ;; aka false + ;; 1-75 indicate length of following string to push + 76 + '(op_pushdata1 op_pushdata2 op_pushdata4 op_1negate op_reserved + op_1 op_2 op_3 op_4 op_5 op_6 op_7 op_8 op_9 op_10 op_11 op_12 op_13 + op_14 op_15 op_16 + ;; control + op_nop op_ver op_if op_notif op_verif op_vernotif op_else op_endif + op_verify op_return + ;; stack ops + op_toaltstack op_fromaltstack op_2drop op_2dup op_3dup op_2over op_2rot + op_2swap op_ifdup op_depth op_drop op_dup op_nip op_over op_pick op_roll + op_rot op_swap op_tuck + ;; splice ops + op_cat op_substr op_left op_right op_size + ;; bit logic + op_invert op_and op_or op_xor op_equal op_equalverify op_reserved1 + op_reserved2 + ;; numeric + op_1add op_1sub op_2mul op_2div op_negate op_abs op_not op_0notequal + op_add op_sub op_mul op_div op_mod op_lshift op_rshift op_booland + op_boolor op_numequal op_numequalverify op_numnotequal op_lessthan + op_greaterthan op_lessthanorequal op_greaterthanorequal op_min op_max + op_within + ;; crypto + op_ripemd160 op_sha1 op_sha256 op_hash160 op_hash256 op_codeseparator + op_checksig op_checksigverify op_checkmultisig op_checkmultisigverify + ;; expansion + op_nop1 op_nop2 op_nop3 op_nop4 op_nop5 op_nop6 op_nop7 op_nop8 op_nop9 + op_nop10) + 253 ;; template matching params + '(op_pubkeyhash op_pubkey op_invalidopcode))) + +;; Human-readable, bijective script decoding +(define (encode-script s) + (define (encode-op name) + (byte-string (cadr (or (assoc name *script-ops*) + (error "bad opcode name" name))))) + (let loop ((s s) (acc '())) + (if (null? s) (apply string-append (reverse acc)) + (let ((op (car s))) + (if (integer? op) + (loop (cddr s) (cons (hex->bytes (cadr s)) + (cons (byte-string op) acc))) + (let ((acc (cons (encode-op op) acc))) + (if (memq op '(op_pushdata1 op_pushdata2 op_pushdata4)) + (let* ((data (hex->bytes (cadr s))) + (len (pack-ule (cond ((eq? op 'op_pushdata1) 1) + ((eq? op 'op_pushdata2) 2) + (else 4)) + (string-length data)))) + (loop (cddr s) (cons data (cons len acc)))) + (loop (cdr s) acc)))))))) + +(define (script-push bytes) + (let ((len (string-length bytes))) + (list (cond ((< len 76) len) + ((< len (expt 2 8)) op_pushdata1) + ((< len (expt 2 16)) op_pushdata2) + ((< len (expt 2 32)) op_pushdata4) + (else (error "script-push overflow"))) + (bytes->hex bytes)))) + +(define (output-script address) + (let ((address (decode-base58check address))) + (if (not (= (string-length address) 21)) (error "bad address length")) + (let ((version (char->integer (string-ref address 0))) + (hash (string-tail address 1))) + (cond ((or (= version *b58-version-p2pkh*) + (= version *b58-version-testnet-p2pkh*)) + `(op_dup op_hash160 ,@(script-push hash) op_equalverify + op_checksig)) + (else (error "bad address type")))))) + +(define *sighash-all/u32* (byte-string 1 0 0 0)) +(define *sighash-all/u8* (byte-string 1)) + +(define (input-script r s pubkey form) + ;; [TRB/script.cpp] Solver (5-arg form) and related + (append (script-push (string-append (encode-derp-sig r s) *sighash-all/u8*)) + (script-push (encode-point pubkey form)))) + +;;; Wire protocol + +(define (pack-ule nbytes n) + (do ((k nbytes (- k 1)) + (n n (quotient n 256)) + (bytes '() (cons (integer->char (remainder n 256)) bytes))) + ((zero? k) + (if (zero? n) (list->string (reverse bytes)) + (error "pack-ule: overflow"))))) + +;; Encode an unsigned integer under 2^64 in Bitcoin's variable-length format +(define encode-var-int + (let ((pack (lambda (tag nbytes) + (let ((tag (byte-string tag))) + (lambda (n) (string-append tag (pack-ule nbytes n))))))) + (let ((c2 (expt 2 16)) + (c3 (expt 2 32)) + (c4 (expt 2 64)) + (pack2 (pack 253 2)) + (pack4 (pack 254 4)) + (pack8 (pack 255 8))) + (lambda (n) + (cond ((< n 253) (byte-string n)) + ((< n c2) (pack2 n)) + ((< n c3) (pack4 n)) + ((< n c4) (pack8 n)) + (else (error "encode-var-int overflow"))))))) + +(define (encode-var-str s) + (string-append (encode-var-int (string-length s)) s)) + +(define *input-seq-final* (byte-string 255 255 255 255)) +(define (encode-input i) + ;; [TRB/main.h] CTxIn + (string-append + (alist-get i 'txid) + (pack-ule 4 (alist-get i 'index)) + (encode-var-str (encode-script (alist-get i 'sig-script))) + *input-seq-final*)) + +(define (encode-output o) + ;; [TRB/main.h] CTxOut + (string-append + (pack-ule 8 (alist-get o 'value)) + (encode-var-str (encode-script (output-script (alist-get o 'address)))))) + +(define (encode-outputs outs) + (apply string-append + (encode-var-int (length outs)) + (map encode-output outs))) + +;;; "Human" encodings + +(define *satoshi/coin* (expt 10 8)) + +;; Quadratic algorithm! +(define (dec->integer s) + (do ((i 0 (+ i 1)) + (acc 0 (+ (* acc 10) + (decdigit->fix (string-ref s i))))) + ((= i (string-length s)) acc))) + +;; Losslessly convert BTC value from unsigned decimal string to satoshi integer +(define (coin->integer s) + (let ((cut (string-find s 0 '(#\.)))) + (let ((ipart (if cut (string-head s cut) s)) + (fpart (if cut (string-tail s (+ cut 1)) ""))) + (let ((flen (string-length fpart))) + (if (= 0 (string-length ipart) flen) (error "not a number:" s)) + (if (> flen 8) (error "excess coin precision:" s)) + (+ (* (dec->integer ipart) *satoshi/coin*) + (* (dec->integer fpart) (expt 10 (- 8 flen)))))))) + +(define (integer->coin i) + (if (negative? i) + (string-append "-" (integer->coin (- i))) + (string-append (number->string (quotient i *satoshi/coin*)) "." + (left-pad (number->string (remainder i *satoshi/coin*)) + 8 #\0)))) + +(define *tab* (integer->char 9)) +(define *whitespace* (list #\space *tab*)) + +(define (read-prevout port) + (let ((line (read-line port))) + (if (eof-object? line) line + (let ((parts (string-split line *whitespace*))) + (if (< (length parts) 4) + (error "missing field(s) in output:" line)) + (apply (lambda (address value txid index . comment) + (make-prevout (string-reverse (hex->bytes txid)) + (dec->integer index) + (coin->integer value) address)) + parts))))) + +(define (write-new-outputs txid outputs port) + (define hex-txid (bytes->hex (string-reverse txid))) + (do ((index 0 (+ index 1)) + (outputs outputs (cdr outputs))) + ((null? outputs)) + (let* ((o (car outputs)) + (addr (alist-get o 'address))) + (if (have-key? addr) + (begin (for-each + (lambda (x) (display x port) (write-char #\space port)) + (list addr + (integer->coin (alist-get o 'value)) + hex-txid + index)) + (display "#unconfirmed" port) + (newline port)))))) + +(define (update-prevouts saved-lines txid new-outputs) + (call-with-output-file "outputs" + (lambda (port) + (write-new-outputs txid new-outputs port) + (display saved-lines port)))) + +(define (emit-rawtx rtx) + (with-output-to-file "transactions" + (lambda () (display-line (bytes->hex rtx))) + 'append)) + +;;; Commands + +(define (make-cache) + ((secp256k1 'write-cache) *cache-path*)) + +(define (gen-key) + (force *cache*) + (let* ((priv ((secp256k1 'gen-priv-key) (force *rng-port*))) + (addr (point->address ((secp256k1 'priv->pub) priv) 'uncompressed))) + (with-output-to-file + (string-append "keys/" addr) + (lambda () (display-line (pad-hex-256be (bn->hex priv))))) + (display-line addr))) + +(define (send) + (define (get-value o) (alist-get o 'value)) + (define outputs + (do ((acc '() (let* ((addr (pop-arg)) + (val (coin->integer (pop-arg)))) + (cons (make-output val addr) acc)))) + ((null? *args*) (reverse acc)))) + + (define output-subtotal (delay (apply + (map get-value outputs)))) + (define change-addr (call-with-input-file "change" read-line)) + (define outputs+change-dummy (delay (cons (make-output 1 change-addr) + outputs))) + (define fee/kb (coin->integer (call-with-input-file "fee" read-line))) + (define prevouts-port (open-input-file "outputs")) + + (define (add-input prevouts) + (define p (read-prevout prevouts-port)) + (if (eof-object? p) (error "insufficient funds")) + (let* ((prevouts (cons p prevouts)) + (prevout-total (apply + (map get-value prevouts))) + (size (estimate-tx-size prevouts (force outputs+change-dummy))) + ;; fee computation per wallet.cpp CWallet::CreateTransaction + (fee (* fee/kb (+ 1 (quotient size 1000)))) + (change-val (- prevout-total (force output-subtotal) fee))) + (if (negative? change-val) (add-input prevouts) + (let* ((outputs (shuffle + (if (< change-val *dust-threshold*) outputs + (cons (make-output change-val change-addr) + outputs)))) + (rawtx (sign-transaction (reverse prevouts) outputs))) + (emit-rawtx rawtx) + (update-prevouts (read-all prevouts-port) (sha256d rawtx) + outputs) + (close-input-port prevouts-port))))) + (add-input '())) + +(define (priv2addr) + (force *cache*) + (display-line + (point->address ((secp256k1 'priv->pub) + (hex->bn (read-priv-key-hex (current-input-port)))) + 'uncompressed))) + +(define (priv2wif) + (display-line + (encode-base58check *b58-version-secret* + (hex->bytes + (read-priv-key-hex (current-input-port)))))) + +(define (import-wif) + (force *cache*) + (let ((line (read-line (current-input-port)))) + (if (not (eof-object? line)) + (let* ((data (decode-base58check line)) + (form (case (string-length data) + ((33) 'uncompressed) + ((34) (if (= (char->integer (string-ref data 33)) 1) + 'compressed + (error "bad WIF compression tag"))) + (else (error "bad WIF key length"))))) + (let ((version (char->integer (string-ref data 0))) + (key-bytes (substring data 1 33))) + (if (not (or (= version *b58-version-secret*) + (= version *b58-version-testnet-secret*))) + (error "bad WIF version byte")) + (let ((addr (point->address + ((secp256k1 'priv->pub) (byte-string->bn key-bytes)) + form))) + (with-output-to-file + (string-append "keys/" addr) + (lambda () + (display-line (bytes->hex + (if (eq? form 'uncompressed) key-bytes + (string-append key-bytes + (byte-string 1))))))) + (display-line addr) + (import-wif))))))) + +(define (test) + (define (test-equal a b) + (display-line + (if (equal? a b) + 'pass + `(fail ,a != ,b)))) + + ;; [TRB/test/base58_tests.cpp] + (display-line "Base58 encode and decode:") + (for-each + (lambda (r) + (let* ((bytes (hex->bytes (car r))) + (enc (encode-base58 bytes)) + (dec (decode-base58 enc))) + (test-equal enc (cadr r)) + (test-equal dec bytes))) + '(("" "") + ("61" "2g") + ("626262" "a3gV") + ("636363" "aPEr") + ("73696d706c792061206c6f6e6720737472696e67" "2cFupjhnEsSn59qHXstmK2ffpLv2") + ("00eb15231dfceb60925886b67d065299925915aeb172c06647" "1NS17iag9jJgTHD1VXjvLCEnZuQ3rJDE9L") + ("516b6fcd0f" "ABnLTmg") + ("bf4f89001e670274dd" "3SEo3LWLoPntC") + ("572e4794" "3EFU7m") + ("ecac89cad93923c02321" "EJDM8drfXA6uyA") + ("10c8511e" "Rt5zm") + ("00000000000000000000" "1111111111"))) + + (force *cache*) + + ;; [PRB/test/key_tests.cpp] + (display-line "Key and address generation:") + (for-each + (lambda (r) + (let* ((key-bytes (string-tail (decode-base58check (car r)) 1)) + (addr (point->address ((secp256k1 'priv->pub) + (byte-string->bn key-bytes)) + 'uncompressed))) + (test-equal addr (cadr r)))) + '(("5HxWvvfubhXpYYpS3tJkw6fq9jE9j18THftkZjHHfmFiWtmAbrj" "1QFqqMUD55ZV3PJEJZtaKCsQmjLT6JkjvJ") + ("5KC4ejrDjv152FGwP386VD1i2NYc5KkfSMyv1nGy1VGDxGHqVY3" "1F5y5E5FMc5YzdJtB9hLaUe43GDxEKXENJ")))) + +(define (help) + (display-line "Usage: gbw-signer COMMAND [ARGS]") + (newline) + (display-line "Available commands:") + (for-each (lambda (c) + (newline) + (display (car c)) + (display " - ") + (display-line (caddr c))) + commands)) + +;;; CLI dispatch + +(define commands + `(("make-cache" ,make-cache "Generate the required cache file of public elliptic curve precomputations (power-of-2 powers of the generator point).") + ("gen-key" ,gen-key "Generate a new key/address, storing the hex private key to a file in the 'keys' directory named by the address.") + ("send" ,send "Sign a transaction paying the pairwise (address, value) arguments, spending previous outputs described in the 'outputs' table in order, with change going to the address contained in the 'change' file and fee in BTC/kB indicated in the 'fee' file. Rewrite 'outputs' to replace the spent ones with any new self-outputs (those paying addresses found in the 'keys' directory, such as change). Append the hex raw transaction to the 'transactions' file.") + ("priv2addr" ,priv2addr "Print address computed from a hex private key fed to standard input.") + ("priv2wif" ,priv2wif "Print WIF encoding of a hex private key fed to standard input.") + ("import-wif" ,import-wif "Import WIF private key fed to standard input into the 'keys' directory by converting to hex and computing the address, including any compression tag (though such tag is currently unsupported by other commands).") + ("test" ,test "Run the (rather limited) test suite.") + ("help" ,help "Show this usage."))) + +(if (not (null? *args*)) ;; allows loading at REPL + (let* ((prog-name (pop-arg)) + (cmd (if (null? *args*) "help" (pop-arg))) + (entry (assoc cmd commands))) + (if entry ((cadr entry)) + (error "gbw-signer: command not found:" cmd)))) + +;;; Notes + +; [1] While apparently simple, point encoding is one of the more dangerous parts of the code, as any incompatibility could result in seemingly valid addresses that turn out to be unspendable after you've already buried your treasure there. (Likewise the hash functions.) Verifying requires quite the code walk: +; +; [TRB/key.h] CKey::GetPubKey calls +; [SSL/crypto/ec/ec_asn1.c] i2o_ECPublicKey (which, filename notwithstanding, does not involve ASN.1), which calls +; [SSL/crypto/ec/ec_oct.c] EC_POINT_point2oct, which calls +; [SSL/crypto/ec/ecp_oct.c] ec_GFp_simple_point2oct, in which is found the encoding used here, assuming (group->meth->flags & EC_FLAGS_DEFAULT_OCT) and (group->meth->field_type == NID_X9_62_prime_field). "group" is the group field of the EC_KEY passed to i2o_ECPublicKey, initialized in +; [TRB/key.h] CKey::CKey by calling +; [SSL/crypto/ec/ec_key.c] EC_KEY_new_by_curve_name(NID_secp256k1), which initializes group by calling +; [SSL/crypto/ec/ec_curve.c] EC_GROUP_new_by_curve_name on the same NID, which calls +; [id.] ec_group_new_from_data on the member of the constant curve_list with matching NID. Since the curve_list item in question has a data field of &_EC_SECG_PRIME_256K1.h (an EC_CURVE_DATA constant having field_type of NID_X9_62_prime_field) and meth field of 0, the branch is taken that calls +; [SSL/crypto/ec/ec_cvt.c] EC_GROUP_new_curve_GFp, which initializes meth to either +; [SSL/crypto/ec/ecp_nist.c] EC_GFp_nist_method() or +; [SSL/crypto/ec/ecp_mont.c] EC_GFp_mont_method(), by calling +; [SSL/crypto/ec/ec_lib.c] EC_GROUP_new. In both cases the result is a constant EC_METHOD having the above required flags and field_type, assuming OPENSSL_FIPS is not defined. +; +; Even this does not constitute a proof, due to the possibility of mutation by seemingly-unrelated functions. +; +; An implication of this encoding is that even though [TRB] only emits uncompressed form, and no implementation has ever to my knowledge used hybrid form, there are three P2PKH addresses spendable by any given private key, and a consensus-compatible verifier must support all forms. + +;;; References + +; [TRB] The Real Bitcoin, version 0.5.4-RELEASE. http://thebitcoin.foundation/ +; [SSL] OpenSSL, version 1.0.1g. +; [PRB] Power Ranger Bitcoin, version 0.11. diff -uNr a/gbw-signer/library/hashes.scm b/gbw-signer/library/hashes.scm --- a/gbw-signer/library/hashes.scm false +++ b/gbw-signer/library/hashes.scm d32220767f92fa0e43b85afb33f9910456bc334e351946bb67bf814b54221e5b2b07d765a912d19e81478962c3946845998388245c78ec9b032c87f7d0524554 @@ -0,0 +1,205 @@ +;;;; Cryptographic hash functions in pure Scheme +;;; J. Welsh, November 2017 - May 2018 +;;; Trimmed for gbw, March 2020 + +(lambda (fz-ops) + (define word->ufz (fz-ops 'word->ufz)) + (define ufz+ (fz-ops 'ufz+)) + (define ufzshift (fz-ops 'ufzshift)) + (define fzrot (fz-ops 'fzrot)) + (define fznot (fz-ops 'fznot)) + (define fzior (fz-ops 'fzior)) + (define fzxor (fz-ops 'fzxor)) + (define fzif (fz-ops 'fzif)) + (define fzmaj (fz-ops 'fzmaj)) + (define bytes->fz (fz-ops 'bytes->fz)) + (define fz->bytes (fz-ops 'fz->bytes)) + (define hex->bytes (fz-ops 'hex->bytes)) + (define hex->fz (fz-ops 'hex->fz)) + + (define (compose f g) (lambda (x) (f (g x)))) + + (define null-byte (integer->char 0)) + (define initial-padding (string (integer->char 128))) + + ;; The Merkle-Damgard construction: turns a fixed size compression function into an arbitrary size hash function, by blockwise iteration with padding and length hardening. For simplicity, this implementation requires the full message to fit in a string. + (define (merkle-damgard block-size length-bits big-endian compress offset iv) + (define (finish hash tail packed-bit-length) + (let ((length-size (string-length packed-bit-length)) + (space (- block-size (string-length tail)))) + (if (< space length-size) + (finish (compress hash (string-append + tail (make-string space null-byte))) + "" packed-bit-length) + (compress hash (string-append + ;; assuming length goes at end of block + tail (make-string (- space length-size) null-byte) + packed-bit-length))))) + (lambda (msg) + (let ((len (string-length msg))) + (do ((pos 0 next) + (next block-size (+ next block-size)) + (hash iv (compress hash (substring msg pos next)))) + ((> next len) + (finish hash + (string-append (substring msg pos len) initial-padding) + (fz->bytes (ufzshift (ufz+ (word->ufz length-bits len) + (word->ufz length-bits offset)) + 3) + big-endian))))))) + + (define (append-hex->bytes . args) + (apply string-append (map hex->bytes args))) + (define (hex->fz-vec . args) + (list->vector (map hex->fz args))) + + ;; Load aligned word from byte string, little/big endian + (define (slice s k len) (substring s k (+ k len))) + (define (loadw32 s k) (bytes->fz (slice s (fxshift k 2) 4) #f)) + (define (loadbw32 s k) (bytes->fz (slice s (fxshift k 2) 4) #t)) + + ;; Pack words as byte string, little/big endian + (define (pack-words w) + (apply string-append (map (lambda (w) (fz->bytes w #f)) w))) + (define (packb-words w) + (apply string-append (map (lambda (w) (fz->bytes w #t)) w))) + + ;; The various "sigma" functions from [SHS] for 256-bit hashes + (define (ss0-32 x) (fzxor (fzrot x -2) (fzrot x -13) (fzrot x -22))) + (define (ss1-32 x) (fzxor (fzrot x -6) (fzrot x -11) (fzrot x -25))) + (define (s0-32 x) (fzxor (fzrot x -7) (fzrot x -18) (ufzshift x -3))) + (define (s1-32 x) (fzxor (fzrot x -17) (fzrot x -19) (ufzshift x -10))) + + (let ((rmd160-iv (append-hex->bytes + "01234567" "89abcdef" "fedcba98" "76543210" "f0e1d2c3")) + ;; First 32 fractional bits of square roots of first 8 primes + (sha256-iv (append-hex->bytes + "6a09e667" "bb67ae85" + "3c6ef372" "a54ff53a" + "510e527f" "9b05688c" + "1f83d9ab" "5be0cd19"))) + + (define rmd160-compress + (letrec ((F fzxor) + (G fzif) + (H (lambda (x y z) (fzxor (fzior (fznot y) x) z))) + (I (lambda (x y z) (G z x y))) + (J (lambda (x y z) (H y z x))) + (FF (lambda (a b c d e x s) + (ufz+ (fzrot (ufz+ a (F b c d) x) s) e))) + (make-op (lambda (func const) + (let ((k (hex->fz const))) + (lambda (a b c d e x s) + (ufz+ (fzrot (ufz+ a (func b c d) x k) s) e)))))) + ;; Floor of 2^30 times square and cube roots of (2 3 5 7) + (let ((ops1 (vector FF + (make-op G "5a827999") + (make-op H "6ed9eba1") + (make-op I "8f1bbcdc") + (make-op J "a953fd4e"))) + (ops2 (vector (make-op J "50a28be6") + (make-op I "5c4dd124") + (make-op H "6d703ef3") + (make-op G "7a6d76e9") + FF)) + (rho (lambda (i) + (vector-ref '#(7 4 13 1 10 6 15 3 12 0 9 5 2 14 11 8) i))) + (pi (lambda (i) (fxand (+ (* 9 i) 5) 15))) + (shifts '#(#(11 14 15 12 5 8 7 9 11 13 14 15 6 7 9 8) + #(12 13 11 15 6 9 9 7 12 15 11 13 7 8 7 7) + #(13 15 14 11 7 7 6 8 13 14 13 12 5 5 6 9) + #(14 11 12 14 8 6 5 5 15 12 15 14 9 9 8 6) + #(15 12 13 13 9 5 8 6 14 11 12 11 8 6 5 5))) + (W1 (make-vector 80)) + (W2 (make-vector 80))) + (do ((t 0 (+ t 1))) ((= t 16)) + (vector-set! W1 t t) + (vector-set! W2 t (pi t))) + (do ((t 16 (+ t 1))) ((= t 80)) + (vector-set! W1 t (rho (vector-ref W1 (- t 16)))) + (vector-set! W2 t (rho (vector-ref W2 (- t 16))))) + + (lambda (hash block) + (let ((h0 (loadw32 hash 0)) + (h1 (loadw32 hash 1)) + (h2 (loadw32 hash 2)) + (h3 (loadw32 hash 3)) + (h4 (loadw32 hash 4)) + (X (make-vector 16))) + (do ((t 0 (+ t 1))) ((= t 16)) + (vector-set! X t (loadw32 block t))) + (let loop ((t 0) (a1 h0) (b1 h1) (c1 h2) (d1 h3) (e1 h4) + (a2 h0) (b2 h1) (c2 h2) (d2 h3) (e2 h4)) + (if (= t 80) + (pack-words (map ufz+ (list h1 h2 h3 h4 h0) + (list c1 d1 e1 a1 b1) + (list d2 e2 a2 b2 c2))) + (let ((round (fxshift/unsigned t -4))) + (let ((shifts (vector-ref shifts round)) + (op1 (vector-ref ops1 round)) + (op2 (vector-ref ops2 round)) + (i1 (vector-ref W1 t)) + (i2 (vector-ref W2 t))) + (loop (+ t 1) + e1 (op1 a1 b1 c1 d1 e1 (vector-ref X i1) + (vector-ref shifts i1)) + b1 (fzrot c1 10) d1 + e2 (op2 a2 b2 c2 d2 e2 (vector-ref X i2) + (vector-ref shifts i2)) + b2 (fzrot c2 10) d2)))))))))) + + (define sha256-compress + ;; First 32 fractional bits of cube roots of first 64 primes + (let ((K (hex->fz-vec + "428a2f98" "71374491" "b5c0fbcf" "e9b5dba5" + "3956c25b" "59f111f1" "923f82a4" "ab1c5ed5" + "d807aa98" "12835b01" "243185be" "550c7dc3" + "72be5d74" "80deb1fe" "9bdc06a7" "c19bf174" + "e49b69c1" "efbe4786" "0fc19dc6" "240ca1cc" + "2de92c6f" "4a7484aa" "5cb0a9dc" "76f988da" + "983e5152" "a831c66d" "b00327c8" "bf597fc7" + "c6e00bf3" "d5a79147" "06ca6351" "14292967" + "27b70a85" "2e1b2138" "4d2c6dfc" "53380d13" + "650a7354" "766a0abb" "81c2c92e" "92722c85" + "a2bfe8a1" "a81a664b" "c24b8b70" "c76c51a3" + "d192e819" "d6990624" "f40e3585" "106aa070" + "19a4c116" "1e376c08" "2748774c" "34b0bcb5" + "391c0cb3" "4ed8aa4a" "5b9cca4f" "682e6ff3" + "748f82ee" "78a5636f" "84c87814" "8cc70208" + "90befffa" "a4506ceb" "bef9a3f7" "c67178f2"))) + (lambda (hash block) + (let ((W (make-vector 64)) + (h0 (loadbw32 hash 0)) (h1 (loadbw32 hash 1)) + (h2 (loadbw32 hash 2)) (h3 (loadbw32 hash 3)) + (h4 (loadbw32 hash 4)) (h5 (loadbw32 hash 5)) + (h6 (loadbw32 hash 6)) (h7 (loadbw32 hash 7))) + (do ((t 0 (+ t 1))) ((= t 16)) + (vector-set! W t (loadbw32 block t))) + (do ((t 16 (+ t 1))) ((= t 64)) + (vector-set! W t (ufz+ (s1-32 (vector-ref W (- t 2))) + (vector-ref W (- t 7)) + (s0-32 (vector-ref W (- t 15))) + (vector-ref W (- t 16))))) + (let loop ((t 0) (a h0) (b h1) (c h2) (d h3) (e h4) (f h5) (g h6) + (h h7)) + (if (= t 64) + (packb-words (map ufz+ (list a b c d e f g h) + (list h0 h1 h2 h3 h4 h5 h6 h7))) + (let* ((temp1 (ufz+ (ss1-32 e) + (fzif e f g) + h + (vector-ref K t) + (vector-ref W t))) + (temp2 (ufz+ (ss0-32 a) + (fzmaj a b c) + temp1))) + (loop (+ t 1) temp2 a b c (ufz+ d temp1) e f g)))))))) + + (let ((ripemd160 (merkle-damgard 64 64 #f rmd160-compress 0 rmd160-iv)) + (sha256 (merkle-damgard 64 64 #t sha256-compress 0 sha256-iv))) + (export ripemd160 sha256)))) + +;;; References + +;; H. Dobbertin, A. Bosselaers, B. Preneel 1996. "RIPEMD-160: A Strengthened Version of RIPEMD." http://homes.esat.kuleuven.be/bosselae/ripemd160/pdf/AB-9601/AB-9601.pdf +;; [SHS] Information Technology Laboratory 2015. "FIPS PUB 180-4: Secure Hash Standard." National Institute of Standards and Technology. http://dx.doi.org/10.6028/NIST.FIPS.180-4 diff -uNr a/gbw-signer/library/pkg.scm b/gbw-signer/library/pkg.scm --- a/gbw-signer/library/pkg.scm false +++ b/gbw-signer/library/pkg.scm a5181f4efaf4c057d9ac805edfd60c4965ef7e93cdd32aa4e37516ece39800cda5968dd60d1ab2016ddcf18ae445b2deb1434f34a7bba1d6197b72a3d800a206 @@ -0,0 +1,56 @@ +;;;; Hygienic packages for gscm +;;; J. Welsh, November 2017 + +;;; Usage: +;; +;; ;; mypkg.scm +;; (lambda (yourpkg) +;; (define square (yourpkg 'square)) +;; (define (foo x) (write x) (newline)) +;; (define (bar x) (square (+ x 1))) +;; (export foo bar)) +;; +;; ;; yourpkg.scm +;; (lambda () +;; (define (square x) (* x x)) +;; (export square)) +;; +;; ;; myprog.scm +;; (define + 'weird-custom-thing) +;; (load "pkg.scm") +;; (define mypkg (load-pkg "mypkg.scm" (load-pkg "yourpkg.scm"))) +;; (import mypkg foo bar) +;; (foo (bar 5)) +;; +;; $ gscm myprog.scm +;; 36 +;; +;; Ideally, "import" would work internally too, but the current compiler has a +;; quirk that prevents macros expanding to internal definitions. + +(define (load-pkg path . args) + ;; The package is closed in the immutable gscm environment (r5rs plus + ;; extensions), protecting it from top-level redefinitions. Dependencies can + ;; be injected via args. + (apply (eval (with-input-from-file path read) + (gales-scheme-environment)) + args)) + +(define-syntax import + (syntax-rules () + ((import pkg sym) + (define sym (or (pkg 'sym) + (error "import: not found in package" '(pkg sym))))) + ((import pkg sym . tail) + (begin (import pkg sym) + (import pkg . tail))))) + +(define-syntax export + (syntax-rules () + ((export sym) + (lambda (tmp-1cb5c81c936f8103) + (and (eq? tmp-1cb5c81c936f8103 'sym) sym))) + ((export sym . tail) + (lambda (tmp-1cb5c81c936f8103) + (if (eq? tmp-1cb5c81c936f8103 'sym) sym + ((export . tail) tmp-1cb5c81c936f8103)))))) diff -uNr a/gbw-signer/manifest b/gbw-signer/manifest --- a/gbw-signer/manifest false +++ b/gbw-signer/manifest feff42d76c57ee2da71cdddf2323ce718f5ba272121cf31d45eabd009bacb8646e21005c9f6f2280c2446c5f9c8eba333ee4f67bf8fc310a17966504e38e436d @@ -0,0 +1 @@ +711740 gbw-signer_subdir_genesis jfw Offline signer component of gbw, the Gales Bitcoin Wallet. Reissued to follow various conventions: top-level project subdir, lowercase manifest filename, README at project level. (File renaming only; pending content changes are to follow.) diff -uNr a/gbw-signer/package/check b/gbw-signer/package/check --- a/gbw-signer/package/check false +++ b/gbw-signer/package/check 2ea57e15e61200d162cf62b4bb9087abe2557bbbf541d777035fda3e8d7d5776975e618ec8a2664c84a5f42865a3c6cc0b907598bd26281fe721dd6b261d3561 @@ -0,0 +1,2 @@ +#!/bin/sh +/command/gbw-signer test diff -uNr a/gbw-signer/package/install b/gbw-signer/package/install --- a/gbw-signer/package/install false +++ b/gbw-signer/package/install 6b78513286241c8837d66a6f1e10990e73fac0b154254b50bb2c930af89b7c697fa04b1f78b90cf2ad2dc2341ab5ed1dc84ae17fe969cb5d1b6c4d952c63f599 @@ -0,0 +1,28 @@ +#!/bin/sh +set -e + +V=1 +cd /package/gbw-signer-$V + +# Versioned path duplicated in: +# package/README +# command/gbw-signer +# library/gbw-signer.scm + +echo 'Generating public elliptic curve precomputation cache...' +sh command/gbw-signer make-cache + +echo "Creating symlink gbw-signer -> gbw-signer-$V..." +rm -f gbw-signer +ln -s gbw-signer-$V gbw-signer +mv -f gbw-signer /package + +echo 'Making executable links in /command...' +mkdir -p /command +cd command +for i in * ; do + chmod 755 $i + rm -f /command/$i'{new}' + ln -s ../package/gbw-signer/command/$i /command/$i'{new}' + mv -f /command/$i'{new}' /command/$i +done