;;; rsa.ss
;;; Bruce T. Smith, University of North Carolina at Chapel Hill
;;; This is a toy example of an RSA public-key encryption system. It
;;; is possible to create users who register their public keys with a
;;; center and hide their private keys. Then, it is possible to have
;;; the users exchange messages. To a limited extent one can look at
;;; the intermediate steps of the process by using encrypt and decrypt.
;;; The encrypted messages are represented by lists of numbers.
;;; Example session:
;;; .(make-user bonzo)
;;;
;;; Registered with Center
;;; User: bonzo
;;; Base: 95401374942573199780646505337133934797
;;; Encryption exponent: 7
;;; ()
;;; .(make-user bobo)
;;;
;;; Registered with Center
;;; User: bobo
;;; Base: 278996768217267905580604935065693354087
;;; Encryption exponent: 11
;;; ()
;;; .(make-user tiger)
;;;
;;; Registered with Center
;;; User: tiger
;;; Base: 120041986623405125830416983664872558039
;;; Encryption exponent: 13
;;; ()
;;; .(show-center)
;;;
;;;
;;; User: tiger
;;; Base: 120041986623405125830416983664872558039
;;; Encryption exponent: 13
;;;
;;; User: bobo
;;; Base: 278996768217267905580604935065693354087
;;; Encryption exponent: 11
;;;
;;; User: bonzo
;;; Base: 95401374942573199780646505337133934797
;;; Encryption exponent: 7
;;; ()
;;; .(send "hi there" bonzo bobo)
;;;
;;; "hi there"
;;; .(send "hi there to you" bobo bonzo)
;;;
;;; "hi there to you"
;;; .(decrypt (encrypt "hi there" bonzo bobo) tiger)
;;;
;;; " $ C F Sx1LH7 t "
;;; Implementation:
;;; (make-user name) creates a user with the chosen name. When it
;;; creates the user, it tells him what his name is. He will use
;;; this when registering with the center.
(define-macro! make-user (uid)
`(begin
(set! ,uid (user ',uid))
(,uid 'register)))
;;; (encrypt mesg u1 u2) causes user 1 to encrypt mesg using the public
;;; keys for user 2.
(define-macro! encrypt (mesg u1 u2)
`((,u1 'send) ,mesg ',u2))
;;; (decrypt number-list u) causes the user to decrypt the list of
;;; numbers using his private key.
(define-macro! decrypt (numbers u)
`((,u 'receive) ,numbers))
;;; (send mesg u1 u2) this combines the functions 'encrypt' and 'decrypt',
;;; calling on user 1 to encrypt the message for user 2 and calling on
;;; user 2 to decrypt the message.
(define-macro! send (mesg u1 u2)
`(decrypt (encrypt ,mesg ,u1 ,u2) ,u2))
;;; A user is capable of the following:
;;; - choosing public and private keys and registering with the center
;;; - revealing his public and private keys
;;; - retrieving user's private keys from the center and encrypting a
;;; message for that user
;;; - decrypting a message with his private key
(define! user
(lambda (name)
(let*
;; low, high = bounds on p and q
;; p,q = two large, probable primes
;; n = p * q, base for modulo arithmetic
;; phi = lcm(p-1,q-1), not quite the Euler phi function,
;; but it will serve for our purposes
;; e = exponent for encryption
;; d = exponent for decryption
((low (expt 2 63))
(high (* 2 low))
(p 0) (q 0) (n 0) (phi 0) (e 0) (d 0))
(lambda (request)
(case request
;; choose keys and register with the center
(register
(set! p (find-prime low high))
(set! q
(recur loop ((q1 (find-prime low high)))
(if (= 1 (gcd p q1))
q1
(loop (find-prime low high)))))
(set! n (* p q))
(set! phi
(/ (* (1- p) (1- q))
(gcd (1- p) (1- q))))
(set! e
(do ((i 3 (+ 2 i)))
((= 1 (gcd i phi)) i)))
(set! d (mod-inverse e phi))
(register-center (cons name (list n e)))
(printf "Registered with Center~n")
(printf "User: ~s~n" name)
(printf "Base: ~d~n" n)
(printf "Encryption exponent: ~d~n" e)
)
;; divulge your keys-- you should resist doing this...
(show-all
(printf "p = ~d ; q = ~d~n" p q)
(printf "n = ~d~n" n)
(printf "phi = ~d~n" (* (1- p) (1- q)))
(printf "e = ~d ; d = ~d~n" e d))
;; get u's public key from the center and encode
;; a message for him
(send
(lambda (mesg u)
(let*
((public (request-center u))
(base (car public))
(exponent (cadr public))
(mesg-list (string->numbers mesg base)))
(mapcar
(lambda (x)
(expt-mod x exponent base))
mesg-list))))
;; decrypt a message with your private key
(receive
(lambda (crypt-mesg)
(let
((mesg-list
(mapcar
(lambda (x) (expt-mod x d n))
crypt-mesg)))
(numbers->string mesg-list)))))))))
;;; The center maintains the list of public keys. It can register
;;; new users, provide the public keys for any particular user, or
;;; display the whole public file.
(let ((public-keys '()))
(define! register-center
(lambda (entry)
(set! public-keys
(cons entry
(rem
(lambda (x) (eq? (car x) (car entry)))
public-keys)))))
(define! request-center
(lambda (u)
(let ((a (assoc u public-keys)))
(when (null? a)
(error 'request-center
"User ~s not registered in center"
u))
(cdr a))))
(define! show-center
(lambda ()
(mapc
(lambda (entry)
(printf "~nUser: ~s~n" (car entry))
(printf "Base: ~s~n" (cadr entry))
(printf "Encryption exponent: ~s~n" (caddr entry)))
public-keys))))
;;; string->numbers encodes a string as a list of numbers
;;; numbers->string decodes a string from a list of numbers
;;; string->numbers and numbers->string are defined with respect to
;;; an alphabet. Any characters in the alphabet are translated into
;;; integers---their regular ascii codes. Any characters outside
;;; the alphabet cause an error during encoding. An invalid code
;;; during decoding is translated to a space.
(let*
((first-code 32)
(last-code 126)
(alphabet
; printed form of the characters, indexed by their ascii codes
(let ((alpha (make-string 128 #\ )))
(do ((i first-code (1+ i)))
((= i last-code) alpha)
(string-set! alpha i (integer->char i)))))
(string->integer
(lambda (str)
(let ((ln (string-length str)))
(recur loop ((i 0) (m 0))
(if (= i ln)
m
(let* ((c (string-ref str i)) (code (char->integer c)))
(when
(or (< code first-code) (>= code last-code))
(error 'rsa "Illegal character ~s" c))
(loop (1+ i) (+ code (* m 128)))))))))
(integer->string
(lambda (n)
(list->string
(mapcar
(lambda (n) (string-ref alphabet n))
(recur loop ((m n) (lst '()))
(if (zero? m)
lst
(loop
(quotient m 128)
(cons (remainder m 128) lst)))))))))
(define! string->numbers
; turn a string into a list of numbers, each no larger than base
(lambda (str base)
(letrec
((block-size
(do ((i -1 (1+ i)) (m 1 (* m 128)))
((>= m base) i)))
(substring-list
(lambda (str)
(let ((ln (string-length str)))
(if (>= block-size ln)
(list str)
(cons
(substring str 0 block-size)
(substring-list
(substring str block-size ln))))))))
(mapcar
string->integer
(substring-list str)))))
(define! numbers->string
; turn a list of numbers into a string
(lambda (lst)
(letrec
((reduce
(lambda (f l)
(if (null? (cdr l))
(car l)
(f (car l) (reduce f (cdr l)))))))
(reduce
string-append
(mapcar
(lambda (x) (integer->string x))
lst))))))
;;; find-prime finds a probable prime between two given arguments.
;;; find-prime uses a cheap but fairly dependable test for primality
;;; for large numbers, by first weeding out multiples of first 200
;;; primes, then applies Fermat's theorem with base 2.
(let*
((product-of-primes
; compute product of first n primes, n > 0
(lambda (n)
(recur loop ((n (1- n)) (p 2) (i 3))
(cond
((zero? n) p)
((= 1 (gcd i p)) (loop (1- n) (* p i) (+ i 2)))
(else (loop n p (+ i 2)))))))
(prod-first-200-primes
(product-of-primes 200))
(probable-prime
; first check is quick, and weeds out most non-primes
; second check is slower, but weeds out almost all non-primes
(lambda (p)
(and (= 1 (gcd p prod-first-200-primes))
(= 1 (expt-mod 2 (1- p) p))))))
(defrec! find-prime
; find probable prime in range low to high (inclusive)
(lambda (low high)
(let ((guess
(lambda (low high)
(let ((g (+ low (random (1+ (- high low))))))
(if (odd? g) g (1+ g))))))
(recur loop ((g (guess low high)))
(cond
; start over if already too high
((> g high) (loop (guess low high)))
; if guess is probably prime, return
((probable-prime g) g)
; don't bother with even guesses
(else (loop (+ 2 g)))))))))
;;; mod-inverse finds the multiplicative inverse of x mod b, if it exists
(letrec
((gcdx
; extended Euclid's gcd algorithm, x <= y
(lambda (x y)
(recur loop ((x x) (y y) (u1 1) (u2 0) (v1 0) (v2 1))
(if (zero? y)
(list x u1 v1)
(let ((q (quotient x y)) (r (remainder x y)))
(loop y r u2 (- u1 (* q u2)) v2 (- v1 (* q v2)))))))))
(define! mod-inverse
(lambda (x b)
(let* ((x1 (mod x b)) (g (gcdx x1 b)))
(unless (= (car g) 1)
(error 'mod-inverse "~d and ~d not relatively prime" x b))
(mod (cadr g) b)))))