#lang scheme/base
;;; @Package     randtok
;;; @Subtitle    Random Token String Generation in Scheme
;;; @HomePage    http://www.neilvandyke.org/randtok-scheme/
;;; @Author      Neil Van Dyke
;;; @Version     0.1
;;; @Date        2009-06-07
;;; @PLaneT      neil/randtok:1:0

;; $Id: randtok.ss,v 1.17 2009/06/07 18:45:15 neilpair Exp $

;;; @legal
;;; Copyright @copyright{} 2009 Neil Van Dyke.  This program is Free Software;
;;; you can redistribute it and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software Foundation; either
;;; version 3 of the License (LGPL 3), or (at your option) any later version.
;;; This program is distributed in the hope that it will be useful, but without
;;; any warranty; without even the implied warranty of merchantability or
;;; fitness for a particular purpose.  See
;;; @indicateurl{http://www.gnu.org/licenses/} for details.  For other licenses
;;; and consulting, please contact the author.
;;; @end legal

;;; @section Introduction

;;; The @b{randtok} library is intended for generating random strings such as
;;; for secure authentication tokens for Web site session cookies.
;;;
;;; @b{randtok} makes fairly efficient use of bits in a scarce random byte
;;; source like @code{/dev/random}.  For example, an 8-character token
;;; consisting of only the lower-case Latin letters consumes only 5 random
;;; bytes, rather than 8.  In a security sensitive application, efficient use
;;; of the source might be important when using effectively random data rather
;;; than a possibly predictable pseudorandom number generator (PRNG).
;;;
;;; Note that this code has not been tested heavily.

(define (%make-variable-bit-reader in (max-bits 8))
  ;; Note: max-bits is currently ignored.
  (or (and (integer? max-bits)
           (<= 1 max-bits 8))
      (raise-type-error 'make-variable-bit-reader
                        "integer 1..8"
                        1
                        max-bits))
  (let ((sema        (make-semaphore 1))
        (last-byte   #f)
        (unused-bits 0))
    (let ((<bit-reader>
           (lambda (num-bits)
             (dynamic-wind
               (lambda ()
                 (semaphore-wait sema))
               (lambda ()
                 (cond
                  ((not (integer? num-bits))
                   (raise-type-error '<bit-reader>
                                     "integer 0..8"
                                     0
                                     num-bits))
                  ((zero? num-bits) 0)
                  (else
                   (let ((diff (- unused-bits num-bits)))
                     (cond
                      ((>= diff 0)
                       (begin0 (bitwise-bit-field last-byte diff unused-bits)
                         (set! unused-bits diff)))
                      ((> num-bits 8)
                       (raise-type-error '<bit-reader>
                                         "integer 0..8"
                                         0
                                         num-bits))
                      (else
                       (let-values
                           (((num1 num-bits)
                             (if (zero? unused-bits)
                                 (values 0 num-bits)
                                 (let ((abs-diff (abs diff)))
                                   (values (arithmetic-shift (bitwise-bit-field
                                                              last-byte
                                                              0
                                                              unused-bits)
                                                             abs-diff)
                                           abs-diff)))))
                         (+ num1
                            (if (= num-bits 8)
                                (read-byte in)
                                (begin
                                  (set! last-byte (read-byte in))
                                  (set! unused-bits (- 8 num-bits))
                                  (bitwise-bit-field last-byte
                                                     unused-bits
                                                     8)))))))))))
               (lambda () (semaphore-post sema))))))
      <bit-reader>)))

(define (%make-fixed-bit-reader in num-bits)
  ;; TODO: We could special-case this for when num-bits is 8.
  (if (and (integer? num-bits)
           (<= 1 num-bits 8))
      (let* ((variable-bit-reader (%make-variable-bit-reader in num-bits))
             (<fixed-bit-reader>  (lambda ()
                                    (variable-bit-reader num-bits))))
        <fixed-bit-reader>)
      (raise-type-error 'make-fixed-bit-reader
                        "integer 1..8"
                        1
                        in
                        num-bits)))

(define %log2
  (let ((log-of-2 (log 2)))
    (lambda (x)
      (/ (log x) log-of-2))))

;;; @defproc make-random-token-string-maker port str len
;;;
;;; Returns a procedure that generats random token strings of length @var{len},
;;; using characters from string @var{str}, with random numbers drawn from
;;; input port @var{port}.
;;;
;;; @lisp
;;; (define random-in (open-input-file "/dev/random"))
;;;
;;; (define f (make-random-token-string-maker
;;;            random-in "0123456789abcdef" 10))
;;;
;;; f   @result{} <procedure:<random-token-string-maker>>
;;; (f) @result{} "7dd73b9ec0"
;;; (f) @result{} "1f7bc42210"
;;;
;;; (close-input-port random-in)
;;; @end lisp
;;;
;;; This is useful for using a single open file of @code{/dev/random} to
;;; generate multiple random token strings throughout the execution of a
;;; program.  For example:
;;;
;;; @lisp
;;; (call-with-input-file "/dev/random"
;;;   (lambda (random-in)
;;;     (file-stream-buffer-mode random-in 'none)
;;;     (let ((randtok (make-random-token-string-maker
;;;                     random-in "ABCD" 10)))
;;;       ...
;;;       (printf "Here is a random token: ~S\n" (randtok))
;;;       ...
;;;       (printf "Here is another random token: ~S\n" (randtok))
;;;       ...)))
;;; @end lisp
;;;
;;; Note that you may wish to disable buffering of the input port, as is done
;;; above.

(define (make-random-token-string-maker port str len)
  (or (and (integer? len)
           (> len 0))
      (raise-type-error 'make-random-token-string-maker
                        "positive integer"
                        2
                        port
                        str
                        len))
  (let* ((str-len   (string-length str))
         (num-bits  (inexact->exact (ceiling (%log2 str-len))))
         (read-bits (%make-fixed-bit-reader port num-bits)))
    (let ((<random-token-string-maker>
           (lambda ()
             (let loop ((i      len)
                        (result '()))
               (if (zero? i)
                   (apply string result)
                   (let ((bits (read-bits)))
                     (if (< bits str-len)
                         (loop (- i 1)
                               (cons (string-ref str bits) result))
                         (loop i result))))))))
      <random-token-string-maker>)))

;;; @defparam current-random-byte-file
;;;
;;; This parameter is a filename for a source of random bytes.  It is used by
;;; procedure @code{random-token-string}.  The default value is
;;; @code{"/dev/random"}.

(define current-random-byte-file (make-parameter "/dev/random"))

;;; @defproc random-token-string [ len ]
;;;
;;; This is a convenient procedure for generating alphanumeric random token
;;; strings, using upper-case and lower-case Latin letters and Arabic digits.
;;; The length defaults to 8.  For example:
;;;
;;; @lisp
;;; (random-token-string)    @result{} "SW6gu2gw"
;;; (random-token-string)    @result{} "9RjdZxyj"
;;; (random-token-string 20) @result{} "thCOmSte6OXWByxtn0G5"
;;; @end lisp
;;;
;;; Note that reusing the output of @code{make-random-token-string-maker}
;;; will be more efficient in some cases.

(define (random-token-string (len 8))
  (call-with-input-file (current-random-byte-file)
    (lambda (in)
      (file-stream-buffer-mode in 'none)
      ((make-random-token-string-maker
        in
        "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
        len)))))

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.1 -- 2009-06-07 -- PLaneT @code{(1 0)}
;;; First release.
;;;
;;; @end table

(provide
 current-random-byte-file
 make-random-token-string-maker
 random-token-string)