One-time pad/Racket
This is a Racket implementation of the One-time pad task.
We have encryption decryption and pad file management all bundled together here.
#lang racket
(require srfi/14) ; character sets
;; Pseudo-Vigenere implementation
(define (vigenere-en/decrypt-from-alphabet ab... default-char)
(define ab...-cs (string->char-set ab...))
(define m (char-set-size ab...-cs))
(unless (char-set-contains? ab...-cs default-char)
(error 'en/decrypt-from-alphabet
"default-char:~s must be member of alphabet:~s" default-char ab...))
(define chr# (for/hash ((i (in-naturals)) (c ab...)) (values i c)))
(define ord# (for/hash ((i (in-naturals)) (c ab...)) (values c i)))
(define (normalise-char c)
(cond [(char-set-contains? ab...-cs c) c]
[(let ((C (char-upcase c))) (and (char-set-contains? ab...-cs C) C)) => values]
[else default-char]))
(define (encrypt k c)
(hash-ref chr# (modulo (+ (hash-ref ord# k) (hash-ref ord# (normalise-char c))) m)))
(define (decrypt k c)
(hash-ref chr# (modulo (- (hash-ref ord# c) (hash-ref ord# k)) m)))
(values ab... encrypt decrypt))
(define-values (AB... ENCRYPT DECRYPT)
;; I'm no cryptanalyst, but if (length of the alhabet mod 256 != 0), I'm concerned that there
;; *might* be some weakening of the pad (and it gives an excuse for a slightly larger character set)
(vigenere-en/decrypt-from-alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZ_.,!/?" #\_))
;; /dev/random is good but slow. /dev/urandom is a bit faster... the racket PRNG could be too
;; predictable. (But there ain't no /dev/u?random on Windows (AFAIK)
(define (default-random-number-generator rfn)
(define prng (λ () (random #x10000)))
(define frng (λ () (with-input-from-file rfn (λ () (integer-bytes->integer (read-bytes 4) #f)))))
(cond
[(not rfn) (eprintf "WARNING: using build in PRNG~%") prng]
[(not (file-exists? rfn)) (eprintf "WARNING: file:~s does not exist. Using build in PRNG~%" rfn)
prng]
[else frng]))
;; Writes the pad to (current-output-port). If dots? is enabled, then progress is reflected on
;; (current-error-port) -- /dev/random can be very slow!
(define (generate-otp
n-lines #:chars/line (c/l 48) #:chars/block (c/b 6) #:alphabet (ab... AB...)
#:meta-data (meta-data #f) #:dots? (dots? #t) #:random-file-name (rfn #f)
#:rng (rng (default-random-number-generator rfn)))
(define ab...-len (string-length ab...))
(display "# One-time-pad")
(when meta-data (printf "~%# ~s" meta-data))
(for* ((line n-lines)
#:when (begin (newline) (when dots? (newline (current-error-port))))
(chr c/l))
(define rnd-int (rng))
(when (zero? (modulo chr c/b)) (write-char #\space)
(when dots? (write-char #\space (current-error-port))))
(write-char (string-ref ab... (modulo rnd-int ab...-len)))
(when dots? (write-char #\. (current-error-port))))
(newline)
(when dots? (newline (current-error-port)))
(displayln "# End one-time-pad"))
;; Wraps the above to write to the given otp-file-name
(define (generate-pad-file
otp-file-name n-lines #:chars/line (c/l 48) #:chars/block (c/b 6) #:alphabet (ab... AB...)
#:meta-data (mta #f) #:dots? (dots? #t) #:exists (exists 'error) #:random-file-name (rfn #f)
#:rng (rng (default-random-number-generator rfn)))
(with-handlers ([exn:fail:filesystem?
(λ (x) (eprintf "error generating file: ~s~%" (exn-message x)) #f)])
(with-output-to-file otp-file-name #:exists exists
(λ () (generate-otp n-lines #:chars/line c/l #:chars/block c/b #:alphabet ab...
#:meta-data mta #:dots? dots? #:random-file-name rfn #:rng rng)))))
;; OTP FILE "Management" -- scratches lines for you
(define (otp-scratch-lines f-name lines-used)
(define-values (in out) (open-input-output-file f-name #:exists 'update))
(let loop
((fp (file-position in)) (line (read-line in)) (lines-used lines-used))
(cond [(zero? lines-used) (void)]
[(eof-object? line) (error "otp-scratch-lines: ran out of pad!")]
[(regexp-match #px"^[#\\-]" line) (loop (file-position in) (read-line in) lines-used)]
[else
(define old-fp (file-position in))
(file-position out fp)
(write-char #\- out)
(flush-output out)
(file-position in old-fp)
(loop old-fp (read-line in) (sub1 lines-used))]))
(close-input-port in)
(close-output-port out))
;; Produce two functions that taks a pad-file and a string
(define (make-pad-functions encrypt-fn decrypt-fn)
(define ((en/decrypt-from-pad crypto-fn) pad-file str)
(define (use-otp-line line-chars s e lines-used)
(cond [(null? s) (values (list->string (reverse e)) (add1 lines-used))]
[(null? line-chars) (sub-d/e-f-p (read-line) s e (add1 lines-used))]
[(char=? (car line-chars) #\space) (use-otp-line (cdr line-chars) s e lines-used)]
[else (use-otp-line
(cdr line-chars)
(cdr s)
(cons (crypto-fn (car line-chars) (car s)) e)
lines-used)]))
(define (sub-d/e-f-p line s e lines-used)
(cond [(null? s) (values (list->string (reverse e)) lines-used)]
[(eof-object? line) (error 'de/encrypt-from-pad "ran out of pad!")]
[(regexp-match #px"^[#\\-]" line) (sub-d/e-f-p (read-line) s e lines-used)]
[else (use-otp-line (string->list line) s e lines-used)]))
(with-input-from-file pad-file (λ () (sub-d/e-f-p (read-line) (string->list str) null 0))))
(values (en/decrypt-from-pad encrypt-fn) (en/decrypt-from-pad encrypt-fn)))
(define-values (encrypt-from-pad decrypt-from-pad)
(make-pad-functions ENCRYPT DECRYPT))
;; Testing
(module+ test
(generate-pad-file
"test.otp" 4
#:random-file-name "/dev/urandom" ; is faster
#:exists 'replace)
;; pad-file as generated
(printf "Pad file as generated:~%~a~%" (file->string "test.otp"))
(define-values (enc enc-lines-used)
(encrypt-from-pad "test.otp" #<<EOS
Mary had a little lamb! We've heard it all before. Mary had a little lamb, and then she had some more.
EOS
))
(printf "Cyphertext: ~s~%" enc)
(define-values (dec dec-lines-used) (decrypt-from-pad "test.otp" enc))
(printf "Plaintext: ~s~%" dec)
(printf "Scratch: ~s lines from your pad file~%" enc-lines-used)
(otp-scratch-lines "test.otp" enc-lines-used)
(printf "Pad file after scratching:~%~a~%" (file->string "test.otp"))
)