Projects : gbw-signer : gbw-signer_static_bit_ops_reindent
| 1 | ;;;; gbw-signer.scm: Gales Bitcoin Wallet offline key generation and transaction signing |
| 2 | ;;; J. Welsh, October 2017 - March 2020 |
| 3 | |
| 4 | ;;; Knobs |
| 5 | |
| 6 | (define *install-path* "/package/gbw-signer-3") |
| 7 | |
| 8 | (define *rng-port* (delay (open-input-file "/dev/urandom"))) |
| 9 | |
| 10 | ;; Minimum value for which to generate change outputs, as lubricant for sabotaged network that stifles transactions with small outputs regardless of fee. Per commits: |
| 11 | ;; 8de9bb53af32f7f6b09c06f831f2c0a7b4e95303 ( http://archive.is/tE6nK ) |
| 12 | ;; 6a4c196dd64da2fd33dc7ae77a8cdd3e4cf0eff1 ( http://archive.is/rALd9 ) |
| 13 | (define *dust-threshold* 546) |
| 14 | |
| 15 | ;;; Libraries |
| 16 | |
| 17 | (define (resource path) |
| 18 | (string-append *install-path* "/library/" path)) |
| 19 | |
| 20 | ;; Public EC precomputations ("make-cache" to generate) |
| 21 | (define *cache-path* (resource "secp256k1.cache")) |
| 22 | |
| 23 | (load (resource "pkg.scm")) |
| 24 | |
| 25 | (define bignum (load-pkg (resource "bignum.scm"))) |
| 26 | (import bignum |
| 27 | decdigit->fix |
| 28 | bn->hex hex->bn bytes->bn bn->fix fix->bn |
| 29 | bn-zero? bn-even? |
| 30 | bn-divrem rand-bn) |
| 31 | |
| 32 | (define ecdsa (load-pkg (resource "ecdsa.scm") bignum)) |
| 33 | (import ecdsa secp256k1) |
| 34 | |
| 35 | (define bit-ops (load-pkg (resource "bit-ops.scm"))) |
| 36 | (import bit-ops hex->bytes bytes->hex) |
| 37 | |
| 38 | (define hashes (load-pkg (resource "hashes.scm") bit-ops)) |
| 39 | (import hashes ripemd160 sha256) |
| 40 | |
| 41 | ;;; Helpers |
| 42 | |
| 43 | ;; Poor man's debugger |
| 44 | (define (trace . args) |
| 45 | (write args) |
| 46 | (newline) |
| 47 | (flush-output-port)) |
| 48 | |
| 49 | (define *null-byte* (integer->char 0)) |
| 50 | |
| 51 | (define (left-pad s len char) |
| 52 | (string-append (make-string (- len (string-length s)) char) s)) |
| 53 | |
| 54 | (define (pad-hex-256be s) (left-pad s 64 #\0)) ;; 256 bits = 64 nibbles |
| 55 | |
| 56 | (define (pad-bytes-256be s) (left-pad s 32 *null-byte*)) |
| 57 | |
| 58 | (define (string-head s n) (substring s 0 n)) |
| 59 | |
| 60 | (define (string-tail s n) (substring s n (string-length s))) |
| 61 | |
| 62 | (define (string-reverse s) |
| 63 | (let ((r (make-string (string-length s))) |
| 64 | (last (- (string-length s) 1))) |
| 65 | (do ((i 0 (+ i 1))) ((> i last) r) |
| 66 | (string-set! r i (string-ref s (- last i)))))) |
| 67 | |
| 68 | (define (string-find s start chars) |
| 69 | (let loop ((i start)) |
| 70 | (cond ((= i (string-length s)) #f) |
| 71 | ((memv (string-ref s i) chars) i) |
| 72 | (else (loop (+ i 1)))))) |
| 73 | |
| 74 | (define (string-split s chars) |
| 75 | (let loop ((i 0)) |
| 76 | (let ((cut (string-find s i chars))) |
| 77 | (cond ((not cut) (if (= i (string-length s)) '() |
| 78 | (list (string-tail s i)))) |
| 79 | ((= i cut) (loop (+ i 1))) |
| 80 | (else (cons (substring s i cut) (loop (+ cut 1)))))))) |
| 81 | |
| 82 | (define (bn->bytes n) |
| 83 | ;; hacky... |
| 84 | (hex->bytes (bn->hex n))) |
| 85 | |
| 86 | (define (integer->bytes n) |
| 87 | ;; hacky... |
| 88 | (hex->bytes (number->string n 16))) |
| 89 | |
| 90 | (define (bn-pack-le nbytes) |
| 91 | (let ((nibbles (* nbytes 2))) |
| 92 | (lambda (n) |
| 93 | (string-reverse (hex->bytes (left-pad (bn->hex n) nibbles #\0)))))) |
| 94 | |
| 95 | (define (string->bytevec s) |
| 96 | (let* ((len (string-length s)) |
| 97 | (v (make-vector len))) |
| 98 | (do ((i 0 (+ i 1))) ((= i len) v) |
| 99 | (vector-set! v i (char->integer (string-ref s i)))))) |
| 100 | |
| 101 | (define (byte-string->bn s) |
| 102 | (bytes->bn (string->bytevec s))) |
| 103 | |
| 104 | (define (byte-string . bytes) |
| 105 | (list->string (map integer->char bytes))) |
| 106 | |
| 107 | (define (display-line x) |
| 108 | (display x) |
| 109 | (newline) |
| 110 | (flush-output-port)) |
| 111 | |
| 112 | (define (read-line port) |
| 113 | (let loop ((acc '())) |
| 114 | (let ((c (read-char port))) |
| 115 | (cond ((eof-object? c) (if (null? acc) c |
| 116 | (list->string (reverse acc)))) |
| 117 | ((char=? c #\newline) (list->string (reverse acc))) |
| 118 | (else (loop (cons c acc))))))) |
| 119 | |
| 120 | (define (read-all port) |
| 121 | (do ((c (read-char port) (read-char port)) |
| 122 | (acc '() (cons c acc))) |
| 123 | ((eof-object? c) (list->string (reverse acc))))) |
| 124 | |
| 125 | ;; gscm so far has a subprocess extension but not a full POSIX or condition system. |
| 126 | (define (file-exists? path) |
| 127 | (call-with-values |
| 128 | (lambda () (open-subprocess "/usr/bin/test" "test" "-e" path)) |
| 129 | (lambda (pid i o) |
| 130 | (close-output-port o) |
| 131 | (read-all i) |
| 132 | (close-input-port i) |
| 133 | (zero? (wait-subprocess pid))))) |
| 134 | |
| 135 | (define (read-priv-key-hex port) |
| 136 | (let ((k (read-line port))) |
| 137 | (if (not (= (string-length k) 64)) (error "ill-formed key")) |
| 138 | k)) |
| 139 | |
| 140 | (define (get-priv-key-by-address addr) |
| 141 | (hex->bn (call-with-input-file (string-append "keys/" addr) |
| 142 | read-priv-key-hex))) |
| 143 | |
| 144 | (define (have-key? addr) (file-exists? (string-append "keys/" addr))) |
| 145 | |
| 146 | (define (sha256d x) (sha256 (sha256 x))) |
| 147 | |
| 148 | (define (hash160 x) (ripemd160 (sha256 x))) |
| 149 | |
| 150 | (define (shuffle l) |
| 151 | (define v (list->vector l)) |
| 152 | ;; Knuth/Fisher-Yates shuffle in place |
| 153 | (do ((i (- (vector-length v) 1) (- i 1))) ((negative? i)) |
| 154 | (let ((j (bn->fix ((rand-bn (fix->bn (+ i 1))) |
| 155 | (force *rng-port*)))) |
| 156 | (t (vector-ref v i))) |
| 157 | (vector-set! v i (vector-ref v j)) |
| 158 | (vector-set! v j t))) |
| 159 | (vector->list v)) |
| 160 | |
| 161 | (define *cache* (delay ((secp256k1 'read-cache) *cache-path*))) |
| 162 | |
| 163 | (define (pop-arg) |
| 164 | (if (null? *args*) (error "too few arguments")) |
| 165 | (let ((a (car *args*))) |
| 166 | (set! *args* (cdr *args*)) |
| 167 | a)) |
| 168 | |
| 169 | ;;; Base58 [TRB/base58.h] |
| 170 | |
| 171 | (define *bn58* (fix->bn 58)) |
| 172 | |
| 173 | (define (b58digit i) ;; alphanumeric - 0OIl |
| 174 | (string-ref "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" i)) |
| 175 | |
| 176 | (define b58digit->integer |
| 177 | (let ((inverse (make-vector 256 #f))) |
| 178 | (do ((i 0 (+ i 1))) ((= i 58)) |
| 179 | (vector-set! inverse (char->integer (b58digit i)) i)) |
| 180 | (lambda (d) |
| 181 | (or (vector-ref inverse (char->integer d)) |
| 182 | (error "invalid base58 digit:" d))))) |
| 183 | |
| 184 | (define (encode-base58 data) |
| 185 | (let loop ((n (byte-string->bn data)) |
| 186 | (acc '())) |
| 187 | (if (not (bn-zero? n)) |
| 188 | (bn-divrem n *bn58* (lambda (q r) |
| 189 | (loop q (cons (bn->fix r) acc)))) |
| 190 | ;; Leading zero bytes pass through one-to-one |
| 191 | (do ((i 0 (+ i 1)) |
| 192 | (acc acc (cons 0 acc))) |
| 193 | ((or (= i (string-length data)) |
| 194 | (not (zero? (char->integer (string-ref data i))))) |
| 195 | (list->string (map b58digit acc))))))) |
| 196 | |
| 197 | (define (decode-base58 data) |
| 198 | (do ((digits (map b58digit->integer (string->list data)) (cdr digits)) |
| 199 | (zeros 0 (+ 1 zeros))) |
| 200 | ((or (null? digits) (not (zero? (car digits)))) |
| 201 | (if (null? digits) (make-string zeros *null-byte*) |
| 202 | (do ((acc (car digits) (+ (* acc 58) (car digits))) |
| 203 | (digits (cdr digits) (cdr digits))) |
| 204 | ((null? digits) (string-append (make-string zeros *null-byte*) |
| 205 | (integer->bytes acc)))))))) |
| 206 | |
| 207 | ;; Well-known Base58Check payload type tags |
| 208 | (define *b58-version-p2pkh* 0) |
| 209 | (define *b58-version-p2sh* 5) |
| 210 | (define *b58-version-secret* 128) |
| 211 | (define *b58-version-testnet-p2pkh* 111) |
| 212 | (define *b58-version-testnet-p2sh* 196) |
| 213 | (define *b58-version-testnet-secret* 239) |
| 214 | |
| 215 | (define (encode-base58check version data) |
| 216 | (let ((data (string-append (byte-string version) data))) |
| 217 | (encode-base58 |
| 218 | (string-append data (string-head (sha256d data) 4))))) |
| 219 | |
| 220 | (define (decode-base58check data) |
| 221 | (let* ((data (decode-base58 data)) |
| 222 | (cut (- (string-length data) 4))) |
| 223 | (if (negative? cut) (error "decode-base58check: checksum too short")) |
| 224 | (let ((payload (string-head data cut)) |
| 225 | (check (string-tail data cut))) |
| 226 | (if (not (string=? check (string-head (sha256d payload) 4))) |
| 227 | (error "decode-base58check: bad checksum")) |
| 228 | payload))) |
| 229 | |
| 230 | (define (point->address p form) |
| 231 | (encode-base58check *b58-version-p2pkh* (hash160 (encode-point p form)))) |
| 232 | |
| 233 | ;;; OpenSSL binary encodings |
| 234 | |
| 235 | ;; EC point (public key) [1] |
| 236 | ;; Leading byte encodes form: |
| 237 | ;; (0) the point at infinity |
| 238 | ;; (2 x) compressed, even y |
| 239 | ;; (3 x) compressed, odd y |
| 240 | ;; (4 x y) uncompressed |
| 241 | ;; (6 x y) hybrid, even y |
| 242 | ;; (7 x y) hybrid, odd y |
| 243 | (define (encode-point p form) |
| 244 | (if (eq? p 'inf) (byte-string 0) |
| 245 | (let ((x (car p)) |
| 246 | (y (cdr p)) |
| 247 | (pack (lambda (n) (pad-bytes-256be (bn->bytes n))))) |
| 248 | (case form |
| 249 | ((compressed) |
| 250 | (string-append (byte-string (if (bn-even? y) 2 3)) (pack x))) |
| 251 | ((uncompressed) |
| 252 | (string-append (byte-string 4) (pack x) (pack y))) |
| 253 | ((hybrid) |
| 254 | ;; Hybrid form seems entirely pointless to me, but is included for completeness. |
| 255 | (string-append (byte-string (if (bn-even? y) 6 7)) |
| 256 | (pack x) (pack y))) |
| 257 | (else (error "encode-point: bad form:" form)))))) |
| 258 | |
| 259 | ;; DERP encoding: a subset of the Distinguished Encoding Rules of Abstract Syntax Notation One |
| 260 | |
| 261 | (define (derp-encapsulate tag constructed? contents) |
| 262 | ;; Class assumed to be 0 (universal) |
| 263 | ;; Tag assumed to be 0-30 |
| 264 | ;; Length assumed to be 0-127 |
| 265 | (string-append (byte-string (if constructed? (+ tag 32) tag) |
| 266 | (string-length contents)) |
| 267 | contents)) |
| 268 | |
| 269 | (define (derp-contents s) |
| 270 | (string-tail s 2)) |
| 271 | |
| 272 | (define (encode-derp-integer n) |
| 273 | ;; INTEGER is encoded base 256, two's complement, big endian, with the minimal number of octets, except zero which is a single zero octet |
| 274 | (let* ((b (bn->bytes n)) |
| 275 | (pad? (or (zero? (string-length b)) |
| 276 | (> (char->integer (string-ref b 0)) 127)))) |
| 277 | (derp-encapsulate 2 #f (if pad? (string-append (byte-string 0) b) b)))) |
| 278 | |
| 279 | (define (decode-derp-integer s start) |
| 280 | (byte-string->bn (derp-contents s))) |
| 281 | |
| 282 | (define (encode-derp-sequence . items) |
| 283 | ;; SEQUENCE is encoded as the concatenation of the respective encoded items |
| 284 | (derp-encapsulate 16 #t (apply string-append items))) |
| 285 | |
| 286 | (define (encode-derp-sig r s) |
| 287 | ;; [SSL/crypto/ecdsa/ecs_asn1.c], [SSL/crypto/asn1/x_bignum.c] |
| 288 | (encode-derp-sequence (encode-derp-integer r) (encode-derp-integer s))) |
| 289 | |
| 290 | ;;; Bitcoin transactions |
| 291 | |
| 292 | (define (alist fields) |
| 293 | (lambda vals |
| 294 | (map list fields vals))) |
| 295 | |
| 296 | (define (alist-get l field . default) |
| 297 | (let ((l (assq field l))) |
| 298 | (if l (cadr l) |
| 299 | (if (null? default) (error "field not found" field) |
| 300 | (car default))))) |
| 301 | |
| 302 | (define (alist-extend l field val) |
| 303 | (cons (list field val) l)) |
| 304 | |
| 305 | (define make-input (alist '(txid index value sig-script))) |
| 306 | (define make-output (alist '(value address))) |
| 307 | (define make-prevout (alist '(txid index value address))) |
| 308 | |
| 309 | (define (prevout->unsigned-input p) |
| 310 | (alist-extend p 'sig-script '())) |
| 311 | |
| 312 | (define *tx-version* (byte-string 1 0 0 0)) |
| 313 | (define *lock-time* (byte-string 0 0 0 0)) |
| 314 | |
| 315 | (define (sign-transaction prev-outputs new-outputs) |
| 316 | ;; [TRB/script.cpp] SignatureHash, SignSignature, Solver |
| 317 | ;; [TRB/key.h] CKey::Sign |
| 318 | (force *cache*) |
| 319 | (let ((unsig-ins (map prevout->unsigned-input prev-outputs)) |
| 320 | (encoded-prefix (string-append *tx-version* |
| 321 | (encode-var-int (length prev-outputs)))) |
| 322 | (encoded-suffix (string-append (encode-outputs new-outputs) |
| 323 | *lock-time*))) |
| 324 | (do ((unsig-ins unsig-ins (cdr unsig-ins)) |
| 325 | (prev-outputs prev-outputs (cdr prev-outputs)) |
| 326 | (enc-unsig-ins (map encode-input unsig-ins) (cdr enc-unsig-ins)) |
| 327 | (enc-unsig-ins-head '() `(,@enc-unsig-ins-head ,(car enc-unsig-ins))) |
| 328 | (signed-ins |
| 329 | '() |
| 330 | (let* ((prev-addr (alist-get (car prev-outputs) 'address)) |
| 331 | (m (apply string-append |
| 332 | `(,encoded-prefix |
| 333 | ,@enc-unsig-ins-head |
| 334 | ,(encode-input |
| 335 | (alist-extend (car unsig-ins) 'sig-script |
| 336 | (output-script prev-addr))) |
| 337 | ,@(cdr enc-unsig-ins) |
| 338 | ,encoded-suffix |
| 339 | ,*sighash-all/u32*))) |
| 340 | (hash (string->bytevec (sha256d m))) |
| 341 | (priv (get-priv-key-by-address prev-addr)) |
| 342 | (pub ((secp256k1 'priv->pub) priv)) |
| 343 | (sig-script ((secp256k1 'sign) |
| 344 | hash priv (force *rng-port*) |
| 345 | (lambda (r s) |
| 346 | (input-script r s pub 'uncompressed))))) |
| 347 | (cons (alist-extend (car unsig-ins) 'sig-script sig-script) |
| 348 | signed-ins)))) |
| 349 | ((null? unsig-ins) (apply string-append |
| 350 | `(,encoded-prefix |
| 351 | ,@(map encode-input (reverse signed-ins)) |
| 352 | ,encoded-suffix)))))) |
| 353 | |
| 354 | (define (estimate-tx-size prev-outputs new-outputs) |
| 355 | (let ((n-ins (length prev-outputs))) |
| 356 | (+ 8 ;; version, locktime |
| 357 | (string-length (encode-var-int n-ins)) |
| 358 | (* 181 n-ins) ;; txid, index, r, s, x, y, overhead |
| 359 | (string-length (encode-outputs new-outputs))))) |
| 360 | |
| 361 | ;;; Script, per [TRB/script.h] |
| 362 | |
| 363 | (define (enumerate start items . more) |
| 364 | (let loop ((i start) (l items) (more more) (acc '())) |
| 365 | (if (null? l) (if (null? more) (reverse acc) |
| 366 | (loop (car more) (cadr more) (cddr more) acc)) |
| 367 | (loop (+ i 1) (cdr l) more (cons (list (car l) i) acc))))) |
| 368 | |
| 369 | (define *script-ops* |
| 370 | (enumerate |
| 371 | 0 |
| 372 | '(op_0) ;; aka false |
| 373 | ;; 1-75 indicate length of following string to push |
| 374 | 76 |
| 375 | '(op_pushdata1 op_pushdata2 op_pushdata4 op_1negate op_reserved |
| 376 | 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 |
| 377 | op_14 op_15 op_16 |
| 378 | ;; control |
| 379 | op_nop op_ver op_if op_notif op_verif op_vernotif op_else op_endif |
| 380 | op_verify op_return |
| 381 | ;; stack ops |
| 382 | op_toaltstack op_fromaltstack op_2drop op_2dup op_3dup op_2over op_2rot |
| 383 | op_2swap op_ifdup op_depth op_drop op_dup op_nip op_over op_pick op_roll |
| 384 | op_rot op_swap op_tuck |
| 385 | ;; splice ops |
| 386 | op_cat op_substr op_left op_right op_size |
| 387 | ;; bit logic |
| 388 | op_invert op_and op_or op_xor op_equal op_equalverify op_reserved1 |
| 389 | op_reserved2 |
| 390 | ;; numeric |
| 391 | op_1add op_1sub op_2mul op_2div op_negate op_abs op_not op_0notequal |
| 392 | op_add op_sub op_mul op_div op_mod op_lshift op_rshift op_booland |
| 393 | op_boolor op_numequal op_numequalverify op_numnotequal op_lessthan |
| 394 | op_greaterthan op_lessthanorequal op_greaterthanorequal op_min op_max |
| 395 | op_within |
| 396 | ;; crypto |
| 397 | op_ripemd160 op_sha1 op_sha256 op_hash160 op_hash256 op_codeseparator |
| 398 | op_checksig op_checksigverify op_checkmultisig op_checkmultisigverify |
| 399 | ;; expansion |
| 400 | op_nop1 op_nop2 op_nop3 op_nop4 op_nop5 op_nop6 op_nop7 op_nop8 op_nop9 |
| 401 | op_nop10) |
| 402 | 253 ;; template matching params |
| 403 | '(op_pubkeyhash op_pubkey op_invalidopcode))) |
| 404 | |
| 405 | ;; Human-readable, bijective script decoding |
| 406 | (define (encode-script s) |
| 407 | (define (encode-op name) |
| 408 | (byte-string (cadr (or (assoc name *script-ops*) |
| 409 | (error "bad opcode name" name))))) |
| 410 | (let loop ((s s) (acc '())) |
| 411 | (if (null? s) (apply string-append (reverse acc)) |
| 412 | (let ((op (car s))) |
| 413 | (if (integer? op) |
| 414 | (loop (cddr s) (cons (hex->bytes (cadr s)) |
| 415 | (cons (byte-string op) acc))) |
| 416 | (let ((acc (cons (encode-op op) acc))) |
| 417 | (if (memq op '(op_pushdata1 op_pushdata2 op_pushdata4)) |
| 418 | (let* ((data (hex->bytes (cadr s))) |
| 419 | (len (pack-ule (cond ((eq? op 'op_pushdata1) 1) |
| 420 | ((eq? op 'op_pushdata2) 2) |
| 421 | (else 4)) |
| 422 | (string-length data)))) |
| 423 | (loop (cddr s) (cons data (cons len acc)))) |
| 424 | (loop (cdr s) acc)))))))) |
| 425 | |
| 426 | (define (script-push bytes) |
| 427 | (let ((len (string-length bytes))) |
| 428 | (list (cond ((< len 76) len) |
| 429 | ((< len (expt 2 8)) op_pushdata1) |
| 430 | ((< len (expt 2 16)) op_pushdata2) |
| 431 | ((< len (expt 2 32)) op_pushdata4) |
| 432 | (else (error "script-push overflow"))) |
| 433 | (bytes->hex bytes)))) |
| 434 | |
| 435 | (define (output-script address) |
| 436 | (let ((address (decode-base58check address))) |
| 437 | (if (not (= (string-length address) 21)) (error "bad address length")) |
| 438 | (let ((version (char->integer (string-ref address 0))) |
| 439 | (hash (string-tail address 1))) |
| 440 | (cond ((or (= version *b58-version-p2pkh*) |
| 441 | (= version *b58-version-testnet-p2pkh*)) |
| 442 | `(op_dup op_hash160 ,@(script-push hash) op_equalverify |
| 443 | op_checksig)) |
| 444 | (else (error "bad address type")))))) |
| 445 | |
| 446 | (define *sighash-all/u32* (byte-string 1 0 0 0)) |
| 447 | (define *sighash-all/u8* (byte-string 1)) |
| 448 | |
| 449 | (define (input-script r s pubkey form) |
| 450 | ;; [TRB/script.cpp] Solver (5-arg form) and related |
| 451 | (append (script-push (string-append (encode-derp-sig r s) *sighash-all/u8*)) |
| 452 | (script-push (encode-point pubkey form)))) |
| 453 | |
| 454 | ;;; Wire protocol |
| 455 | |
| 456 | (define (pack-ule nbytes n) |
| 457 | (do ((k nbytes (- k 1)) |
| 458 | (n n (quotient n 256)) |
| 459 | (bytes '() (cons (integer->char (remainder n 256)) bytes))) |
| 460 | ((zero? k) |
| 461 | (if (zero? n) (list->string (reverse bytes)) |
| 462 | (error "pack-ule: overflow"))))) |
| 463 | |
| 464 | ;; Encode an unsigned integer under 2^64 in Bitcoin's variable-length format |
| 465 | (define encode-var-int |
| 466 | (let ((pack (lambda (tag nbytes) |
| 467 | (let ((tag (byte-string tag))) |
| 468 | (lambda (n) (string-append tag (pack-ule nbytes n))))))) |
| 469 | (let ((c2 (expt 2 16)) |
| 470 | (c3 (expt 2 32)) |
| 471 | (c4 (expt 2 64)) |
| 472 | (pack2 (pack 253 2)) |
| 473 | (pack4 (pack 254 4)) |
| 474 | (pack8 (pack 255 8))) |
| 475 | (lambda (n) |
| 476 | (cond ((< n 253) (byte-string n)) |
| 477 | ((< n c2) (pack2 n)) |
| 478 | ((< n c3) (pack4 n)) |
| 479 | ((< n c4) (pack8 n)) |
| 480 | (else (error "encode-var-int overflow"))))))) |
| 481 | |
| 482 | (define (encode-var-str s) |
| 483 | (string-append (encode-var-int (string-length s)) s)) |
| 484 | |
| 485 | (define *input-seq-final* (byte-string 255 255 255 255)) |
| 486 | (define (encode-input i) |
| 487 | ;; [TRB/main.h] CTxIn |
| 488 | (string-append |
| 489 | (alist-get i 'txid) |
| 490 | (pack-ule 4 (alist-get i 'index)) |
| 491 | (encode-var-str (encode-script (alist-get i 'sig-script))) |
| 492 | *input-seq-final*)) |
| 493 | |
| 494 | (define (encode-output o) |
| 495 | ;; [TRB/main.h] CTxOut |
| 496 | (string-append |
| 497 | (pack-ule 8 (alist-get o 'value)) |
| 498 | (encode-var-str (encode-script (output-script (alist-get o 'address)))))) |
| 499 | |
| 500 | (define (encode-outputs outs) |
| 501 | (apply string-append |
| 502 | (encode-var-int (length outs)) |
| 503 | (map encode-output outs))) |
| 504 | |
| 505 | ;;; "Human" encodings |
| 506 | |
| 507 | (define *satoshi/coin* (expt 10 8)) |
| 508 | |
| 509 | ;; Quadratic algorithm! |
| 510 | (define (dec->integer s) |
| 511 | (do ((i 0 (+ i 1)) |
| 512 | (acc 0 (+ (* acc 10) |
| 513 | (decdigit->fix (string-ref s i))))) |
| 514 | ((= i (string-length s)) acc))) |
| 515 | |
| 516 | ;; Losslessly convert BTC value from unsigned decimal string to satoshi integer |
| 517 | (define (coin->integer s) |
| 518 | (let ((cut (string-find s 0 '(#\.)))) |
| 519 | (let ((ipart (if cut (string-head s cut) s)) |
| 520 | (fpart (if cut (string-tail s (+ cut 1)) ""))) |
| 521 | (let ((flen (string-length fpart))) |
| 522 | (if (= 0 (string-length ipart) flen) (error "not a number:" s)) |
| 523 | (if (> flen 8) (error "excess coin precision:" s)) |
| 524 | (+ (* (dec->integer ipart) *satoshi/coin*) |
| 525 | (* (dec->integer fpart) (expt 10 (- 8 flen)))))))) |
| 526 | |
| 527 | (define (integer->coin i) |
| 528 | (if (negative? i) |
| 529 | (string-append "-" (integer->coin (- i))) |
| 530 | (string-append (number->string (quotient i *satoshi/coin*)) "." |
| 531 | (left-pad (number->string (remainder i *satoshi/coin*)) |
| 532 | 8 #\0)))) |
| 533 | |
| 534 | (define *tab* (integer->char 9)) |
| 535 | (define *whitespace* (list #\space *tab*)) |
| 536 | |
| 537 | (define (read-prevout port) |
| 538 | (let ((line (read-line port))) |
| 539 | (if (eof-object? line) line |
| 540 | (let ((parts (string-split line *whitespace*))) |
| 541 | (if (< (length parts) 4) |
| 542 | (error "missing field(s) in output:" line)) |
| 543 | (apply (lambda (address value txid index . comment) |
| 544 | (make-prevout (string-reverse (hex->bytes txid)) |
| 545 | (dec->integer index) |
| 546 | (coin->integer value) address)) |
| 547 | parts))))) |
| 548 | |
| 549 | (define (write-new-outputs txid outputs port) |
| 550 | (define hex-txid (bytes->hex (string-reverse txid))) |
| 551 | (do ((index 0 (+ index 1)) |
| 552 | (outputs outputs (cdr outputs))) |
| 553 | ((null? outputs)) |
| 554 | (let* ((o (car outputs)) |
| 555 | (addr (alist-get o 'address))) |
| 556 | (if (have-key? addr) |
| 557 | (begin (for-each |
| 558 | (lambda (x) (display x port) (write-char #\space port)) |
| 559 | (list addr |
| 560 | (integer->coin (alist-get o 'value)) |
| 561 | hex-txid |
| 562 | index)) |
| 563 | (display "#unconfirmed" port) |
| 564 | (newline port)))))) |
| 565 | |
| 566 | (define (update-prevouts saved-lines txid new-outputs) |
| 567 | (call-with-output-file "outputs" |
| 568 | (lambda (port) |
| 569 | (write-new-outputs txid new-outputs port) |
| 570 | (display saved-lines port)))) |
| 571 | |
| 572 | (define (emit-rawtx rtx) |
| 573 | (with-output-to-file "transactions" |
| 574 | (lambda () (display-line (bytes->hex rtx))) |
| 575 | 'append)) |
| 576 | |
| 577 | ;;; Commands |
| 578 | |
| 579 | (define (make-cache) |
| 580 | ((secp256k1 'write-cache) *cache-path*)) |
| 581 | |
| 582 | (define (gen-key) |
| 583 | (force *cache*) |
| 584 | (let* ((priv ((secp256k1 'gen-priv-key) (force *rng-port*))) |
| 585 | (addr (point->address ((secp256k1 'priv->pub) priv) 'uncompressed))) |
| 586 | (with-output-to-file |
| 587 | (string-append "keys/" addr) |
| 588 | (lambda () (display-line (pad-hex-256be (bn->hex priv))))) |
| 589 | (display-line addr))) |
| 590 | |
| 591 | (define (send) |
| 592 | (define (get-value o) (alist-get o 'value)) |
| 593 | (define outputs |
| 594 | (do ((acc '() (let* ((addr (pop-arg)) |
| 595 | (val (coin->integer (pop-arg)))) |
| 596 | (cons (make-output val addr) acc)))) |
| 597 | ((null? *args*) (reverse acc)))) |
| 598 | |
| 599 | (define output-subtotal (delay (apply + (map get-value outputs)))) |
| 600 | (define change-addr (call-with-input-file "change" read-line)) |
| 601 | (define outputs+change-dummy (delay (cons (make-output 1 change-addr) |
| 602 | outputs))) |
| 603 | (define fee/kb (coin->integer (call-with-input-file "fee" read-line))) |
| 604 | (define prevouts-port (open-input-file "outputs")) |
| 605 | |
| 606 | (define (add-input prevouts) |
| 607 | (define p (read-prevout prevouts-port)) |
| 608 | (if (eof-object? p) (error "insufficient funds")) |
| 609 | (let* ((prevouts (cons p prevouts)) |
| 610 | (prevout-total (apply + (map get-value prevouts))) |
| 611 | (size (estimate-tx-size prevouts (force outputs+change-dummy))) |
| 612 | ;; fee computation per wallet.cpp CWallet::CreateTransaction |
| 613 | (fee (* fee/kb (+ 1 (quotient size 1000)))) |
| 614 | (change-val (- prevout-total (force output-subtotal) fee))) |
| 615 | (if (negative? change-val) (add-input prevouts) |
| 616 | (let* ((outputs (shuffle |
| 617 | (if (< change-val *dust-threshold*) outputs |
| 618 | (cons (make-output change-val change-addr) |
| 619 | outputs)))) |
| 620 | (rawtx (sign-transaction (reverse prevouts) outputs))) |
| 621 | (emit-rawtx rawtx) |
| 622 | (update-prevouts (read-all prevouts-port) (sha256d rawtx) |
| 623 | outputs) |
| 624 | (close-input-port prevouts-port))))) |
| 625 | (add-input '())) |
| 626 | |
| 627 | (define (priv2addr) |
| 628 | (force *cache*) |
| 629 | (display-line |
| 630 | (point->address ((secp256k1 'priv->pub) |
| 631 | (hex->bn (read-priv-key-hex (current-input-port)))) |
| 632 | 'uncompressed))) |
| 633 | |
| 634 | (define (priv2wif) |
| 635 | (display-line |
| 636 | (encode-base58check *b58-version-secret* |
| 637 | (hex->bytes |
| 638 | (read-priv-key-hex (current-input-port)))))) |
| 639 | |
| 640 | (define (import-wif) |
| 641 | (force *cache*) |
| 642 | (let ((line (read-line (current-input-port)))) |
| 643 | (if (not (eof-object? line)) |
| 644 | (let* ((data (decode-base58check line)) |
| 645 | (form (case (string-length data) |
| 646 | ((33) 'uncompressed) |
| 647 | ((34) (if (= (char->integer (string-ref data 33)) 1) |
| 648 | 'compressed |
| 649 | (error "bad WIF compression tag"))) |
| 650 | (else (error "bad WIF key length"))))) |
| 651 | (let ((version (char->integer (string-ref data 0))) |
| 652 | (key-bytes (substring data 1 33))) |
| 653 | (if (not (or (= version *b58-version-secret*) |
| 654 | (= version *b58-version-testnet-secret*))) |
| 655 | (error "bad WIF version byte")) |
| 656 | (let ((addr (point->address |
| 657 | ((secp256k1 'priv->pub) (byte-string->bn key-bytes)) |
| 658 | form))) |
| 659 | (with-output-to-file |
| 660 | (string-append "keys/" addr) |
| 661 | (lambda () |
| 662 | (display-line (bytes->hex |
| 663 | (if (eq? form 'uncompressed) key-bytes |
| 664 | (string-append key-bytes |
| 665 | (byte-string 1))))))) |
| 666 | (display-line addr) |
| 667 | (import-wif))))))) |
| 668 | |
| 669 | (define (test) |
| 670 | (define (test-equal a b) |
| 671 | (display-line |
| 672 | (if (equal? a b) |
| 673 | 'pass |
| 674 | `(fail ,a != ,b)))) |
| 675 | |
| 676 | ;; [TRB/test/base58_tests.cpp] |
| 677 | (display-line "Base58 encode and decode:") |
| 678 | (for-each |
| 679 | (lambda (r) |
| 680 | (let* ((bytes (hex->bytes (car r))) |
| 681 | (enc (encode-base58 bytes)) |
| 682 | (dec (decode-base58 enc))) |
| 683 | (test-equal enc (cadr r)) |
| 684 | (test-equal dec bytes))) |
| 685 | '(("" "") |
| 686 | ("61" "2g") |
| 687 | ("626262" "a3gV") |
| 688 | ("636363" "aPEr") |
| 689 | ("73696d706c792061206c6f6e6720737472696e67" "2cFupjhnEsSn59qHXstmK2ffpLv2") |
| 690 | ("00eb15231dfceb60925886b67d065299925915aeb172c06647" "1NS17iag9jJgTHD1VXjvLCEnZuQ3rJDE9L") |
| 691 | ("516b6fcd0f" "ABnLTmg") |
| 692 | ("bf4f89001e670274dd" "3SEo3LWLoPntC") |
| 693 | ("572e4794" "3EFU7m") |
| 694 | ("ecac89cad93923c02321" "EJDM8drfXA6uyA") |
| 695 | ("10c8511e" "Rt5zm") |
| 696 | ("00000000000000000000" "1111111111"))) |
| 697 | |
| 698 | (force *cache*) |
| 699 | |
| 700 | ;; [PRB/test/key_tests.cpp] |
| 701 | (display-line "Key and address generation:") |
| 702 | (for-each |
| 703 | (lambda (r) |
| 704 | (let* ((key-bytes (string-tail (decode-base58check (car r)) 1)) |
| 705 | (addr (point->address ((secp256k1 'priv->pub) |
| 706 | (byte-string->bn key-bytes)) |
| 707 | 'uncompressed))) |
| 708 | (test-equal addr (cadr r)))) |
| 709 | '(("5HxWvvfubhXpYYpS3tJkw6fq9jE9j18THftkZjHHfmFiWtmAbrj" "1QFqqMUD55ZV3PJEJZtaKCsQmjLT6JkjvJ") |
| 710 | ("5KC4ejrDjv152FGwP386VD1i2NYc5KkfSMyv1nGy1VGDxGHqVY3" "1F5y5E5FMc5YzdJtB9hLaUe43GDxEKXENJ")))) |
| 711 | |
| 712 | (define (help) |
| 713 | (display-line "Usage: gbw-signer COMMAND [ARGS]") |
| 714 | (newline) |
| 715 | (display-line "Available commands:") |
| 716 | (for-each (lambda (c) |
| 717 | (newline) |
| 718 | (display (car c)) |
| 719 | (display " - ") |
| 720 | (display-line (caddr c))) |
| 721 | commands)) |
| 722 | |
| 723 | ;;; CLI dispatch |
| 724 | |
| 725 | (define commands |
| 726 | `(("make-cache" ,make-cache "Generate the required cache file of public elliptic curve precomputations (power-of-2 powers of the generator point).") |
| 727 | ("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.") |
| 728 | ("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.") |
| 729 | ("priv2addr" ,priv2addr "Print address computed from a hex private key fed to standard input.") |
| 730 | ("priv2wif" ,priv2wif "Print WIF encoding of a hex private key fed to standard input.") |
| 731 | ("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).") |
| 732 | ("test" ,test "Run the (rather limited) test suite.") |
| 733 | ("help" ,help "Show this usage."))) |
| 734 | |
| 735 | (if (not (null? *args*)) ;; allows loading at REPL |
| 736 | (let* ((prog-name (pop-arg)) |
| 737 | (cmd (if (null? *args*) "help" (pop-arg))) |
| 738 | (entry (assoc cmd commands))) |
| 739 | (if entry ((cadr entry)) |
| 740 | (error "gbw-signer: command not found:" cmd)))) |
| 741 | |
| 742 | ;;; Notes |
| 743 | |
| 744 | ; [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: |
| 745 | ; |
| 746 | ; [TRB/key.h] CKey::GetPubKey calls |
| 747 | ; [SSL/crypto/ec/ec_asn1.c] i2o_ECPublicKey (which, filename notwithstanding, does not involve ASN.1), which calls |
| 748 | ; [SSL/crypto/ec/ec_oct.c] EC_POINT_point2oct, which calls |
| 749 | ; [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 |
| 750 | ; [TRB/key.h] CKey::CKey by calling |
| 751 | ; [SSL/crypto/ec/ec_key.c] EC_KEY_new_by_curve_name(NID_secp256k1), which initializes group by calling |
| 752 | ; [SSL/crypto/ec/ec_curve.c] EC_GROUP_new_by_curve_name on the same NID, which calls |
| 753 | ; [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 |
| 754 | ; [SSL/crypto/ec/ec_cvt.c] EC_GROUP_new_curve_GFp, which initializes meth to either |
| 755 | ; [SSL/crypto/ec/ecp_nist.c] EC_GFp_nist_method() or |
| 756 | ; [SSL/crypto/ec/ecp_mont.c] EC_GFp_mont_method(), by calling |
| 757 | ; [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. |
| 758 | ; |
| 759 | ; Even this does not constitute a proof, due to the possibility of mutation by seemingly-unrelated functions. |
| 760 | ; |
| 761 | ; 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. |
| 762 | |
| 763 | ;;; References |
| 764 | |
| 765 | ; [TRB] The Real Bitcoin, version 0.5.4-RELEASE. http://thebitcoin.foundation/ |
| 766 | ; [SSL] OpenSSL, version 1.0.1g. |
| 767 | ; [PRB] Power Ranger Bitcoin, version 0.11. |