8 files changed, 0 insertions(+), 834 deletions(-)
D ballot-tui.rkt
D bulletin.rkt
D client.rkt
D info.rkt
D main.rkt
D merkle.rkt
D poly.rkt
D scribblings/tallyard.scrbl
D ballot-tui.rkt => ballot-tui.rkt +0 -73
@@ 1,73 0,0 @@
-#lang racket/base
-
-(require racket/contract)
-(require racket/list)
-(require racket/set)
-
-(require charterm)
-
-(define/contract (get-vote candidates)
- (-> (non-empty-listof string?) (listof set?))
- (let* ([n (length candidates)]
- [prefs (make-hash (for/list ([i n]) (cons i n)))]
- [data-line 2])
- (with-charterm
- (charterm-clear-screen)
- (for ([i (in-naturals data-line)]
- [cand candidates])
- (charterm-cursor 2 i)
- (charterm-display "[ ] ")
- (charterm-display cand))
- (charterm-cursor 2 (+ 1 n data-line))
- (charterm-display "[Submit]")
- (let loop-fast-next-key ([cursor-line 0])
- (if (>= cursor-line n)
- (begin
- (charterm-cursor 2 (+ 1 n data-line))
- (charterm-display "[")
- (charterm-inverse)
- (charterm-display "Submit]")
- (charterm-normal)
- (charterm-cursor 2 (+ 1 n data-line)))
- (charterm-cursor 3 (+ data-line cursor-line)))
- (let ([keyinfo (charterm-read-keyinfo #:timeout 1)])
- (if keyinfo
- (let* ([keycode (charterm-keyinfo-keycode keyinfo)]
- [keynum (if (char? keycode)
- (char->integer keycode)
- #f)])
- (if (and keynum (<= 49 keynum 57))
- (let ([val (- keynum 49)])
- (when (< cursor-line n)
- (hash-set! prefs cursor-line val)
- (charterm-display (bytes keynum)))
- (loop-fast-next-key cursor-line))
- (case keycode
- [(return)
- (if (>= cursor-line n)
- (let ([prefs (sort (hash->list prefs) < #:key cdr)])
- (let loop ([p (car prefs)]
- [rst (cdr prefs)])
- (let-values
- ([(same-rank rst)
- (partition (λ (e)
- (eqv? (cdr e) (cdr p)))
- rst)])
- (cons (set-add (list->set (map car same-rank))
- (car p))
- (if (empty? rst)
- empty
- (loop (car rst) (cdr rst)))))))
- (loop-fast-next-key cursor-line))]
- [(down #\j)
- (loop-fast-next-key (min n (add1 cursor-line)))]
- [(up #\k)
- (when (>= cursor-line n)
- (charterm-cursor 2 (+ 1 n data-line))
- (charterm-display "[Submit]"))
- (loop-fast-next-key (max 0 (sub1 cursor-line)))]
- [else
- (loop-fast-next-key cursor-line)])))
- (loop-fast-next-key cursor-line)))))))
-
-(provide get-vote)
D bulletin.rkt => bulletin.rkt +0 -307
@@ 1,307 0,0 @@
-#lang racket/base
-(require racket/contract
- (only-in racket/format ~a)
- racket/list
- racket/match
- racket/random
- racket/set
- racket/string)
-(require web-server/servlet
- web-server/servlet-env
- json)
-(require simple-http)
-(require readline/readline)
-(require (only-in openssl/sha1 bytes->hex-string))
-
-(define state 'registering)
-(define _peers (make-hasheq))
-(define _commits (make-hash))
-(define _outputs (make-hash))
-(define _sums (make-hash))
-
-(define (reset)
- (hash-clear! _commits)
- (hash-clear! _outputs)
- (hash-clear! _sums))
-
-(define election 'default)
-(define election->candidates
- (make-hash '((default . ("Emacs" "Vim" "VSCode")))))
-
-(define/contract (election-set! sym)
- (-> symbol? void?)
- (set! election sym)
- (when (not (hash-has-key? election->candidates
- election))
- (hash-set! election->candidates election
- (list))))
-
-(define transitions
- (hasheq 'committing 'voting
- 'voting 'summing
- 'summing 'done))
-
-(define (transition [trans #f])
- (set! state (if trans trans (hash-ref transitions state))))
-
-(define (server)
- (define (candidates request)
- (if (eq? state 'committing)
- (response/jsexpr (hash-ref election->candidates election))
- (response/jsexpr
- empty
- #:code 403
- #:message #"The election is currently closed")))
-
- (define (auth username password)
- (equal? (hash-ref
- (json-response-body
- (post (update-ssl (update-host json-requester
- "AUTH-HOST-HERE")
- #t)
- "/auth/route/here"
- #:data
- (jsexpr->string (hasheq 'username username
- 'password password))))
- 'result)
- "success"))
-
- (define (register request)
- (if (eq? state 'registering)
- (let* ([params (bytes->jsexpr (request-post-data/raw request))]
- [username (hash-ref params 'username)]
- [password (hash-ref params 'password)]
- [input (hash-ref params 'input)])
- (if (auth username password)
- ; check if username is already present
- (if (for/or ([(_ peer) _peers])
- (equal? username (hash-ref peer 'username)))
- (response/jsexpr
- "That username is already in use"
- #:code 403)
- (let* ([token (crypto-random-bytes 128)]
- [token (bytes->hex-string token)])
- (displayln (format "~a is voting! (~a)" username input))
- (hash-set! _peers (string->symbol token)
- (hasheq 'input input
- 'username username))
- ; send the token that the peer will use for further
- ; authorization
- (response/jsexpr token)))
- (response/jsexpr
- "Bad Login"
- #:code 400)))
- (response/jsexpr
- "Registration is closed"
- #:code 403)))
-
- (define (peer-count request)
- (if (eq? state 'committing)
- (response/jsexpr (hash-count _peers))
- (response/jsexpr
- "Committing has not begun"
- #:code 403)))
-
- (define (commit request)
- (if (eq? state 'committing)
- (let* ([params (bytes->jsexpr (request-post-data/raw request))]
- [peer (hash-ref _peers (string->symbol
- (hash-ref params 'token)))])
- (displayln params)
- (hash-set! _commits (hash-ref peer 'input)
- (hasheq 'p (hash-ref params 'p))
- ; TODO: D polynomial
- ;; (hasheq 'd (hash-ref params 'd))
- )
- ; has everyone committed?
- (when (eqv? (hash-count _commits)
- (hash-count _peers))
- (transition))
- (response/jsexpr empty))
- (response/jsexpr "Not in the committing phase"
- #:code 403)))
-
- (define (peers request)
- (if (eq? state 'voting)
- (response/jsexpr (for/list ([v (hash-values _peers)])
- (hash-ref v 'input)))
- (response/jsexpr
- "Voting has not begun"
- #:code 403)))
-
- (define (outputs request)
- (if (eq? state 'voting)
- (let* ([params (bytes->jsexpr (request-post-data/raw request))]
- ; ensure this is a registered peer
- [peer (hash-ref _peers (string->symbol
- (hash-ref params 'token)))])
- ; TODO: check validity of inputs
- (for ([(p v) (hash-ref params 'outputs)])
- (hash-update! _outputs
- (symbol->string p)
- (λ (l) (cons v l)) empty))
- ; has everyone submitted their outputs?
- (when (for/and ([(p v) _outputs])
- (eqv? (length v)
- (hash-count _peers)))
- (transition))
- (response/jsexpr empty))
- (response/jsexpr
- "This election is not in the voting phase"
- #:code 403)))
-
- (define (_values request)
- (if (eq? state 'summing)
- (let* ([params (bytes->jsexpr (request-post-data/raw request))]
- [peer (hash-ref _peers (string->symbol
- (hash-ref params 'token)))])
- (response/jsexpr
- (hash-ref _outputs (hash-ref peer 'input))))
- (response/jsexpr
- "This election is not in the summing phase"
- #:code 403)))
-
- (define (sum request)
- (if (eq? state 'summing)
- (let* ([params (bytes->jsexpr (request-post-data/raw request))]
- [peer (hash-ref _peers (string->symbol
- (hash-ref params 'token)))]
- [input (string->symbol (hash-ref peer 'input))]
- [sum (hash-ref params 'sum)])
- (hash-set! _sums input sum)
- (response/jsexpr
- empty))
- (response/jsexpr
- "This election is not in the summing phase"
- #:code 403)))
-
- (define (sums request)
- (if (eq? state 'summing)
- (if (eq? (length (hash-keys _sums))
- (hash-count _peers))
- (begin
- (transition)
- (response/jsexpr _sums))
- (response/jsexpr
- "The sums are not yet available"
- #:code 403))
- (if (eq? state 'done)
- (response/jsexpr _sums)
- (response/jsexpr
- "Too early to request sums"
- #:code 403))))
-
- (define (quit request)
- (let* ([token (string->symbol
- (hash-ref
- (bytes->jsexpr (request-post-data/raw request))
- 'token))]
- [username (hash-ref (hash-ref _peers token) 'username)])
- (displayln (format "~a quit!" username))
- (hash-remove! _peers token)))
-
- (define-values (dispatch-route url-generator)
- (dispatch-rules
- [("register") #:method "post" register ]
- [("candidates") #:method "get" candidates]
- [("peer-count") #:method "get" peer-count]
- [("commit") #:method "post" commit ]
- [("peers") #:method "get" peers ]
- [("outputs") #:method "post" outputs ]
- [("values") #:method "post" _values ]
- [("sum") #:method "post" sum ]
- [("sums") #:method "get" sums ]
- [("quit") #:method "post" quit ]))
-
- (define/contract (internal-server-error url ex)
- (url? any/c . -> . can-be-response?)
- (response/jsexpr
- empty
- #:code 400))
-
- (define/contract (dispatcher req)
- (request? . -> . any)
- (if (eq? state 'closed)
- (response/jsexpr
- "Election closed / cancelled"
- #:code 410)
- (dispatch-route req)))
-
- (serve/servlet
- dispatcher
- #:port 1984
- #:servlet-regexp #rx""
- #:command-line? #t
- ; comment out the following to get client-side tracebacks
- #:servlet-responder internal-server-error))
-
-(module+ main
- (void (thread server))
-
- (let loop ()
- (let ([line (readline "> ")])
- (when (not (eq? line eof))
- (when (not (equal? line ""))
- (add-history line))
- (with-handlers ([exn:fail? (λ (ex)
- (displayln (exn-message ex))
- (break-enabled #t)
- (loop))])
- (let ([sp (open-input-string line)])
- (match (read sp)
- ['add (match (read sp)
- ['cand
- (hash-update! election->candidates
- election
- (λ (l)
- (cons (~a (read sp)) l)))]
- [(? eof-object?) (displayln "add what? options are `cand'")]
- [else (displayln "cannot add that")])]
- ['list (match (read sp)
- ['cands
- (println (hash-ref election->candidates election))]
- ['peers
- (println (hash-values _peers))]
- ['elections
- (displayln (format "current: ~s" election))
- (println (hash-keys election->candidates))]
- [(? eof-object?)
- (displayln "list what? options are `cands' `peers' `elections'")]
- [else (displayln "cannot list that")])]
- ['set (match (read sp)
- ['election (election-set!
- (string->symbol (~a (read sp))))]
- [(? eof-object?)
- (displayln "set what? options are `election'")]
- [else (displayln "cannot set that")])]
- ['open
- (if (memq state '(closed registering))
- (transition 'committing)
- (displayln "election is not closed"))]
- ['close
- (transition 'closed)
- (reset)]
- ['register
- (transition 'registering)
- (reset)]
- ['kick (if (eq? state 'closed)
- (let ([username (~a (read sp))])
- ; only need to find the first peer with the username
- (for/first ([(token peer) _peers]
- #:when (equal? (hash-ref peer 'username)
- username))
- (hash-remove! _peers token)))
- (displayln "close the election first"))]
- ['state (displayln (symbol->string state))]
- ['waiting
- (displayln
- (set-map
- (for/set ([p (hash-values _peers)]
- #:when (not (hash-has-key? _commits (hash-ref p 'input))))
- (hash-ref p 'input))
- (λ (input)
- (for/first ([(k v) _peers]
- #:when (equal? (hash-ref v 'input) input))
- (hash-ref v 'username)))))]
- [else (displayln "unknown command")])
- (loop)))))))
D client.rkt => client.rkt +0 -356
@@ 1,356 0,0 @@
-#lang typed/racket
-(require math/array)
-(require math/matrix)
-(require racket/list)
-(require racket/math)
-(require racket/port)
-
-(require (only-in typed/openssl/sha1 bytes->hex-string hex-string->bytes))
-(require/typed get-pass
- [get-pass (->* () (String #:in Input-Port #:out Output-Port) String)])
-(require net/http-client)
-(require net/uri-codec)
-(require typed/json)
-; TODO: all of these type declarations are horrid
-(require/typed binaryio
- [bytes->integer (->* (Bytes Boolean) (Boolean Natural Natural) Integer)]
- [integer->bytes (->* (Integer Positive-Integer Boolean) (Boolean Bytes Natural) Bytes)]
- [integer-bytes-length (-> Integer Boolean Natural)])
-(require/typed readline/readline
- [readline (-> String String)])
-(require/typed simple-http
- [#:struct requester
- ([host : String]
- [headers : Any]
- [port : Integer]
- [ssl : Boolean]
- [type : Symbol])]
- [update-host (-> requester String requester)]
- [update-port (-> requester Integer requester)]
- [update-ssl (-> requester Boolean requester)]
- [json-requester requester]
- [#:struct json-response
- ([status : String]
- [headers : Any]
- [body : JSExpr])]
- [get (->* (requester String) (#:params (Listof Pair)) json-response)]
- [post (->* (requester String) (#:data Any #:params (Listof Pair)) json-response)]
- [#:struct (exn:fail:network:http:error exn:fail:network) ([code : Any] [type : Any])])
-(require/typed crypto
- [crypto-random-bytes (Natural -> Bytes)])
-(require/typed sugar
- [members-unique? (-> (Listof Any) Boolean)])
-
-(require "merkle.rkt")
-(require "poly.rkt")
-(require/typed "ballot-tui.rkt"
- [get-vote (-> (Listof String) (Listof (Setof Natural)))])
-
-(define (integer->hex-string [n : Integer])
- (bytes->hex-string
- (integer->bytes n (assert (integer-bytes-length n #t) positive?) #t)))
-
-(define (hex-string->integer [hs : String])
- (bytes->integer (hex-string->bytes hs) #t))
-
-(define-syntax-rule (retry-request f)
- (let loop ([wait 0])
- (sleep wait)
- (with-handlers ([exn:fail:network:http:error?
- (λ ([ex : exn:fail:network:http:error])
- ; 410 indicates the election is closed/cancalled
- (when (eqv? (exn:fail:network:http:error-code ex)
- 410)
- (newline)
- (raise ex))
- (break-enabled #t)
- (display ".")
- (flush-output)
- (loop 3))])
- f)))
-
-(define (vote-in-election
- [point : Integer]
- [bulletin : requester]
- [token : JSExpr])
- (display "waiting for voting to commence...")
- (define peer-count (cast
- (json-response-body
- (retry-request (get bulletin "/peer-count")))
- Positive-Integer))
- (newline)
-
- (break-enabled #f) ; voting has begun!
-
- (display "retrieving candidates...")
- (define candidates (cast (json-response-body
- (retry-request (get bulletin "/candidates")))
- (Listof String)))
- (define cand-count (cast (length candidates) Positive-Integer))
- (newline)
-
- (define vote
- (let* ([vote (get-vote candidates)]
- [m cand-count]
- [n m]
- [arr (array->mutable-array
- (make-array (vector m n) 0))])
- (let loop ([rank (car vote)]
- [rst (cdr vote)]
- [remaining (set-subtract (list->set (range m)) (car vote))])
- (for ([cand rank])
- (for ([other remaining])
- (array-set! arr (vector cand other) 1)))
- (when (not (empty? rst))
- (loop (car rst) (cdr rst) (set-subtract remaining (car rst)))))
- (bytes->integer
- (for*/fold : Bytes
- ([bstr : Bytes #""])
- ([i : Natural m]
- [j : Natural n])
- (bytes-append bstr
- (integer->bytes
- (array-ref arr (vector i j))
- (cast
- (max (integer-bytes-length peer-count #t) 1)
- Positive-Integer)
- #t)))
- #t)))
-
- (displayln "committing poly...")
- (define poly (random-poly
- (cast (sub1 peer-count) Natural)
- vote))
- (post bulletin "/commit"
- #:data
- (jsexpr->string
- (hasheq
- 'token token
- 'p
- (bytes->hex-string
- (merkle-node-hsh
- (merkle-tree-root (poly-merkle poly)))))))
-
- (display "retrieving peers...")
- (define peer-inputs
- (assert (map hex-string->integer
- (cast (json-response-body
- (retry-request (get bulletin "/peers")))
- (Listof String)))
- (λ ([lst : (Listof Integer)])
- (= (length lst) peer-count))))
- (newline)
-
- (displayln "submitting poly outputs...")
- (post bulletin "/outputs"
- #:data
- (jsexpr->string
- (hasheq
- 'token token
- 'outputs
- (for/hasheq : (Immutable-HashTable Symbol String)
- ([p : Integer (cast peer-inputs (Listof Integer))])
- (values (string->symbol (integer->hex-string p))
- (integer->hex-string (poly p)))))))
-
- (display "summing...")
- (post bulletin "/sum"
- #:data
- (jsexpr->string
- (hasheq
- 'token token
- 'sum
- (integer->hex-string
- (foldl + 0
- (map
- hex-string->integer
- (cast (json-response-body
- (retry-request
- (post bulletin "/values"
- #:data
- (jsexpr->string
- (hasheq 'token token)))))
- (Listof String))))))))
- (newline)
-
- (break-enabled #t) ; it's ok if the client quits at this point
-
- (display "finding constant...")
- (define constant
- (let ([k (length peer-inputs)]
- [sums (for/hash : (Immutable-HashTable Integer Integer)
- ([(k v)
- (in-hash
- (cast
- (json-response-body
- (retry-request (get bulletin "/sums")))
- (Immutable-HashTable Symbol String)))])
- (values (hex-string->integer (symbol->string k))
- (hex-string->integer v)))])
- (cast
- (matrix-ref
- (matrix-solve
- ; M
- (for*/matrix k k ([x peer-inputs]
- [p (range k)]) : Number
- (expt x p))
- ; B
- (for*/matrix k 1 ([x peer-inputs]) : Number
- (hash-ref sums x)))
- 0 0)
- Integer)))
- (newline)
-
- (displayln ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; RESULTS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;")
- (define pairwise-prefs
- (let* ([partial-size (cast (integer-bytes-length peer-count #t)
- Positive-Integer)]
- [bstr (integer->bytes constant
- (* partial-size cand-count cand-count)
- #t)]
- [arr (for/array: #:shape (vector cand-count cand-count)
- ([section : Natural (in-range 0
- (bytes-length bstr)
- partial-size)])
- : Integer
- (bytes->integer bstr #t #t section
- (+ section partial-size)))]
- [candidates (list->vector candidates)])
- (for*/hash : (HashTable (Pairof Natural Natural) Integer)
- ([i cand-count]
- [j cand-count]
- #:when (not (eqv? i j)))
- (values (cons i j)
- (let ([prefer-i-over-j (array-ref arr (vector i j))])
- (displayln (format "~a over ~a: ~a"
- (vector-ref candidates i)
- (vector-ref candidates j)
- prefer-i-over-j))
- prefer-i-over-j)))))
-
- (define strongest-paths
- (let ([p : (HashTable (Pairof Natural Natural) Integer)
- (make-hash)])
- (for* ([i cand-count]
- [j cand-count]
- #:when (not (eqv? i j)))
- (hash-set! p (cons i j)
- (if (> (hash-ref pairwise-prefs (cons i j))
- (hash-ref pairwise-prefs (cons j i)))
- (hash-ref pairwise-prefs (cons i j))
- 0)))
- (for* ([i cand-count]
- [j cand-count]
- #:when (not (eqv? i j))
- [k cand-count]
- #:when (and (not (eqv? i k)) (not (eqv? j k))))
- (hash-update! p (cons j k)
- (λ ([c : Integer])
- (cast
- (max c (min (hash-ref p (cons j i))
- (hash-ref p (cons i k))))
- Integer))))
- p))
-
- (define rankings
- (let loop : (Listof (Setof Natural))
- ([remaining : (Setof Natural)
- (list->set (range cand-count))])
- (if (set-empty? remaining)
- empty
- (let ([winners
- (for/set : (Setof Natural)
- ([cand : Natural remaining]
- #:when
- (for/and : Boolean
- ([other : Natural remaining]
- #:when (not (eqv? cand other)))
- (>= (hash-ref strongest-paths
- (cons cand other))
- (hash-ref strongest-paths
- (cons other cand)))))
- cand)])
- (cons winners (loop (set-subtract remaining winners)))))))
-
- (displayln "Rankings:")
- (for ([i (in-naturals 1)]
- [rank rankings])
- (for ([r rank])
- (displayln (format "~a) ~a" i (list-ref candidates r))))))
-
-(define (wait-for-open-election [bulletin : requester])
- (let retry : Any ([wait 0])
- (sleep wait)
- (with-handlers
- ([exn:fail:network:http:error?
- (λ ([ex : exn:fail:network:http:error])
- (break-enabled #t)
- (when (eqv? 410 (exn:fail:network:http:error-code ex))
- (retry 3)))])
- (get bulletin "/candidates")
- (void))))
-
-(define (can-we-register? [bulletin : requester]) : (Values Boolean (Option String))
- (with-handlers ([exn:fail:network:http:error?
- (λ ([ex : exn:fail:network:http:error])
- (if (eqv? (exn:fail:network:http:error-code ex) 400)
- (values #t #f)
- (values #f (exn-message ex))))])
- (post bulletin "/register" #:data (jsexpr->string empty))
- (values #t #f)))
-
-(module+ main
- (define point (gen))
-
- (define bulletin
- (update-ssl
- (update-port (update-host json-requester
- (readline "Bulletin host: "))
- 1984)
- #t))
-
- ; check if we're allowed to register
- (let-values ([(answer why) (can-we-register? bulletin)])
- (when (not answer)
- (displayln (format "Cannot register: ~a" why))
- (exit)))
-
- (define token
- (let ([username (readline "Username: ")]
- [password (get-pass "Password: ")])
- (with-handlers ([exn:fail:network:http:error?
- (λ ([ex : exn:fail:network:http:error])
- (newline)
- (displayln (format "Login refused: ~a"
- (exn-message ex)))
- (exit))])
- (newline)
- (displayln "retrieving token...")
- (json-response-body
- (post bulletin "/register"
- #:data
- (jsexpr->string (hasheq 'input (integer->hex-string point)
- 'username username
- 'password password)))))))
-
- ; the bulletin can have multiple elections, so loop
- (let loop ()
- (with-handlers
- ([exn:break?
- (λ ([ex : exn:break])
- (post bulletin "/quit"
- #:data
- (jsexpr->string
- (hasheq
- 'token token))))]
- [exn:fail:network:http:error?
- (λ ([ex : exn:fail:network:http:error])
- (break-enabled #t)
- (if (eqv? 410 (exn:fail:network:http:error-code ex))
- (begin
- (displayln
- "Election was closed; awaiting for it to reopen...")
- (wait-for-open-election bulletin))
- (raise ex)))])
- (vote-in-election point bulletin token))
- (loop)))
D info.rkt => info.rkt +0 -12
@@ 1,12 0,0 @@
-#lang info
-(define collection "tallyard")
-(define deps '("base" "charterm" "crypto" "get-pass"
- "sha" "simple-http" "sugar"))
-(define build-deps '("scribble-lib" "racket-doc" "rackunit-lib"))
-(define scribblings '(("scribblings/tallyard.scrbl" ())))
-(define pkg-desc "Description Here")
-(define version "0.0")
-(define pkg-authors '(edwargix))
-
-(define racket-launcher-names '("tallyard"))
-(define racket-launcher-libraries '("client.rkt"))
D main.rkt => main.rkt +0 -1
@@ 1,1 0,0 @@
-#lang racket
D merkle.rkt => merkle.rkt +0 -40
@@ 1,40 0,0 @@
-#lang typed/racket/base
-(require/typed sha [sha256 (-> Bytes Bytes)])
-
-(struct merkle-tree
- ([root : merkle-node]
- [leaves : (Vectorof merkle-node)]
- [content : (Vectorof Bytes)]))
-
-(struct merkle-node
- ([parent : (Option merkle-node)]
- [hsh : Bytes])
- #:mutable
- #:transparent)
-
-(define (merkle [content : (Vectorof Bytes)])
- (let* ([n (vector-length content)]
- [leaves
- (build-vector (+ n (modulo n 2))
- (λ ([i : Natural])
- (let ([bstr (vector-ref content (min i (sub1 n)))])
- (merkle-node #f (sha256 bstr)))))])
- (let build-level : merkle-tree
- ([nodes : (Vectorof merkle-node) leaves])
- (let ([n (vector-length nodes)])
- (if (> n 1)
- (build-level
- (for/vector : (Vectorof merkle-node)
- ([left (in-vector nodes 0 n 2)]
- [right (in-vector nodes 1 n 2)])
- (let ([new-node
- (merkle-node
- #f
- (sha256 (bytes-append (merkle-node-hsh left)
- (merkle-node-hsh right))))])
- (set-merkle-node-parent! left new-node)
- (set-merkle-node-parent! right new-node)
- new-node)))
- (merkle-tree (vector-ref nodes 0) leaves content))))))
-
-(provide (all-defined-out))
D poly.rkt => poly.rkt +0 -35
@@ 1,35 0,0 @@
-#lang typed/racket/base
-(require (only-in racket/math natural?))
-(require (only-in racket/vector vector-map))
-(require/typed binaryio
- [bytes->integer (->* (Bytes Boolean) (Boolean Natural Natural) Integer)]
- [integer->bytes (->* (Integer Positive-Integer Boolean)
- (Boolean Bytes Natural) Bytes)]
- [integer-bytes-length (Integer Boolean -> Positive-Integer)])
-(require/typed crypto
- [crypto-random-bytes (Natural -> Bytes)])
-
-(require "merkle.rkt")
-
-(define-type Poly (Integer -> Integer))
-
-(define (gen)
- (let* ([num-bytes (assert (/ 1024 8) natural?)]
- [bstr (crypto-random-bytes num-bytes)])
- (bytes->integer bstr #t #t 0 num-bytes)))
-
-(define (random-poly [degree : Natural] [constant : Integer]) : Poly
- (let ([coefficients (build-vector degree (λ (_) (gen)))])
- (λ ([x : Integer]) : Integer
- (cast (+ constant
- (for/sum : Integer ([i degree])
- (* (expt x (add1 i)) (vector-ref coefficients i))))
- Integer))))
-
-(define (poly-merkle [p : Poly]) : merkle-tree
- (merkle
- (vector-map
- (λ ([x : Integer]) (integer->bytes x (integer-bytes-length x #t) #t))
- (build-vector 100000 p))))
-
-(provide (all-defined-out))
D scribblings/tallyard.scrbl => scribblings/tallyard.scrbl +0 -10
@@ 1,10 0,0 @@
-#lang scribble/manual
-@require[@for-label[tallyard
- racket/base]]
-
-@title{tallyard}
-@author{edwargix}
-
-@defmodule[tallyard]
-
-Package Description Here