;;;; Interfacing with SSL's random pool, and accepting incoming SSL connections.

(yreq "Utilities/yenta-utils")

;;;; Initializing the pool.

;;; +++ 
;;; These get set for the first time by ssl:generate-random-state.  However, the C
;;; side where this data -really- lives is constantly getting updated when we use
;;; random bits.  The save-procs below arrange to save that state whenever vars:save-vars
;;; happens to get called, by stuffing the value of the C-side data into SCM variables
;;; just before the save happens.  ssl:generate-random-state, if it sees a value in
;;; *ssl:random-state*, will then arrange to stuff the data from the SCM variables
;;; back into the C side.  Note the use of backquote and comma---we need to make sure
;;; that the calls to ssl:random-data and ssl:randbits-in-pool happen -when the vars:save-vars
;;; happens-, -not- when we're calling vars:load-vars!  [By then, it's a new image, the C
;;; side has no state, and we've lost the values we wanted to save!].
(def-yenta-var *ssl:random-state* #f
  (lambda (ignored) `(set! *ssl:random-state* ,(ssl:random-data *ssl:random-STATE_SIZE*))))
(def-yenta-var *ssl:randbits* #f
  (lambda (ignored) `(set! *ssl:randbits* ,(ssl:randbits-in-pool))))
;;; ---

(define *ssl:random-STATE_SIZE* 1023)	; Defined in App/C/SSLeay/crypto/rand/rand_int.h
(define *ssl:initial-key-randbits*	; How many bits of randomness we'll need at key-generation time of the very first run.
  (+ 1024				; Main RSA identity key.  [%%% Or is this 2048, 'cause we've got -two- keys?]
     1024				; Cert for browser.       [%%% Or is this 2048, 'cause we've got -two- keys?]
     128				; Statistics-logging random identity.
     ))
(define *ssl:initial-randbits-required*	; We'll need this bits "soon", but not in the first few seconds of a brand-new Yenta.
  (+ *ssl:initial-key-randbits*
;    1024				; Cert for InterYenta.    [%%% Or is this 2048, 'cause we've got -two- keys?]  [Does this even use any bits?]
;    128				; Statistics-logging network connection SSL key.  [We're not using SSL for stat-logging...]
     128				; At least the very first SSL connection to the browser.
     (* (+ 128 64 64) 6)		; IDEA-CBC key for ePTOB to save vars.scm, plus IDEA-CBC IV, plus verifier; several quick saves on startup.
     256				; Two random extra key's worth of bits, just in case.
     ))

(define (ssl:generate-random-state)
  (cond (*ssl:random-state*		; We've started up before.
	 (ssl:add-random-data! *ssl:random-state*) ; Stuff our saved randomness back into the real random pool.
	 (ssl:set-randbits-in-pool! *ssl:randbits*)) ; Tell the pool it's there.
	(t
	 ;; The keyboard will be available now, because we're just starting up for the very first time.
	 (cond ((getenv (format nil "~A-yenta-magic-no-entropy" (getenv "USER")))
		;; Allow developer worlds (only!) a magical way to avoid mashing the keyboard a lot when debugging brand-new-yenta startup.
		(cond (*wb:developer-world*
		       (format-debug 0 "~%**************** FORCING RANDBITS-IN-POOL ****************~&")
		       (ssl:set-randbits-in-pool! *ssl:initial-randbits-required*))
		      (t		; Customer worlds are forbidden from doing this, since it would compromise security.
		       (error "This is a customer world; real entropy is required."))))
	       (t			; Normal (non-debugging) case.
		(ssl:force-entropy! *ssl:initial-randbits-required* t)
		(format-debug 10 "~%Now have ~S randbits.~&" (ssl:randbits-in-pool)) ; DEBUG.
		(set! *ssl:random-state* (ssl:random-data *ssl:random-STATE_SIZE*))
		(set! *ssl:randbits* (ssl:randbits-in-pool)))))))

;;;; Keeping track of how much we've got in the pool.

;;; "Eats" some random bits from the random pool.  What this really means is that
;;; we're simply declaring that we've removed some random bits to, e.g., generate
;;; a key, and we're doing accounting so we can tell if we're about to exhaust the pool.
;;; It's safest to call this -before- the bits are eaten; use ssl:randbits-available?
;;; to determine before calling this whether they are there to be eaten.  We'll blow
;;; out in some way if you screw this up and try to drive this negative anyway.
;;; We're basically depending on never getting preempted between the calls to
;;; randbits-available? and eat-randbits, since we really can't interlock here;
;;; I hope that's okay, even in the face of, e.g., accepting network connections.
;;;
;;; THIS SHOULD BE THE -ONLY- routine that eats bits!  Why?  Because the C randBits
;;; is an unsigned number, and we want to make sure that we never send it negative...
(define (ssl:eat-randbits! n)
; (format-debug 30 "~&Eating ~S randbits from ~S.~&" n (ssl:randbits-in-pool))
  (cond ((negative? n)			; Just (error ...) instead?  Too drastic.
	 (if *wb:developer-world*
	     (logger:log-and-display 1 "Trying to eat ~S, a negative number of bits!" n)
	     (logger:log             1 "Trying to eat ~S, a negative number of bits!" n)))
	((negative? (- (ssl:randbits-in-pool) n)) ; Just (error ...) instead?  Too drastic.
	 (if *wb:developer-world*
	     (logger:log-and-display 1 "Eating ~S bits from ~S, which would leave it negative!" n (ssl:randbits-in-pool))
	     (logger:log             1 "Eating ~S bits from ~S, which would leave it negative!" n (ssl:randbits-in-pool))))
	(t
	 (ssl:eat-randbits-in-pool! n))))

;;; Returns #t if it's okay to eat n bits from the random pool.
(define (ssl:randbits-available? n)
  (not (negative? (- (ssl:randbits-in-pool) n))))

;;; A centralized way to bitch about unavailable randbits.  However we finally
;;; decide to report these errors, ssl:eat-randbits should probably do likewise.
(define (ssl:err-if-randbits-unavailable n format-string . format-args)
  (cond ((not (ssl:randbits-available? n))
	 (apply #'logger:log-and-display 1 format-string format-args))))

;;; [I don't think this is ever called.  --- Foner]
(define (ssl:random modulus)
  (do ((result #f))
      (result result)
    (do ((m 1 (* m 256))
	 (n 0 (+ (* n 256)
		 (char->integer (string-ref (ssl:random-data 1) 0)))))
	((>= m modulus)
	 (when (< n (- m (modulo m modulus)))
	   (set! result (modulo n modulus)))))))

;;;; Maintaining homoestasis of the pool's available bits.

;;; It's assumed that this stuff starts running -after- key generation
;;; has consumed a bunch of bits, but that things were done correctly,
;;; such that keygen had the bits to consume, and left us at least a few.
;;;
;;; We have a set of tasks, each with a different threshold and a different
;;; basic period.  When a task runs, if it finds that the number of bits in
;;; the pool is below its threshold, it calls force-entropy! to attempt to
;;; increase it.  Tasks that run the most frequently have the lowest threshold;
;;; thus if we have very few bits, we'll run tasks frequently until we get a bunch
;;; of bits back.  But if we have plenty of bits in the pool, we'll only run
;;; tasks at infrequent intervals.  We do this for two reasons:  (a) force-entropy!,
;;; if it fails to get enough bits from fast sources (including /dev/urandom if
;;; the OS has it), must call slow-poll!, which forks many commands and thus
;;; takes 1-2 seconds to run---freezing the rest of Yenta while it does so
;;; (it runs in a single scheduler task), and (b) we don't want to try to sample
;;; these so-called random sources too frequently, or we won't wind up getting
;;; very much entropy out of them (since repeated frequent calls will tend to
;;; return the very same output).

;;; Note that we call force-entropy! without letting it touch the keyboard
;;; (since we don't have it any more), which means it is not guaranteed to
;;; return us as much entropy as we wanted; that's why we wind up calling it
;;; repeatedly.  On the other hand, it's possible we've got /dev/urandom,
;;; and thus can get a large number of bits in one shot, so we ask it for
;;; (- *ssl:greedy-pool-randbits* (ssl:randbits-in-pool)) bits, anyway,
;;; since we might get lucky and finesse having to ask for small amounts
;;; frequently.  If it turns out that we're not so lucky, the pool won't
;;; increase by as much as we asked for, and we'll wind up running repeatedly.
;;;
;;; We don't run tasks at exactly regular intervals, to try to avoid somehow
;;; getting sync'ed up with some external source that might make us think
;;; we're getting bits that are more random than they are.  Instead, for any
;;; given period p, we wait the half-open, evenly-distributed interval [p..2p).
;;; This means that a task with a nominal period of p -really- runs every 1.5p
;;; on average.  [Yes, this means that two tasks that were supposedly at very
;;; different periods have a chance of running very close together in time;
;;; this is fine in the larger scheme of things.]  The "randomness" we use to
;;; get random interarrival times is just SCM's random function; that's random
;;; enough, and doesn't use up any real cryptographic random bits.

(define *ssl:pool-task-basename* "Random pool homeostasis")
(define *ssl:pool-task-priority* 3)

;;; How many bit we'd like (total), if we're lucky.
;;; This should be greater than any of the thresholds in
;;; *ssl:pool-task-thresholds-and-periods*, but we cope if it's not.
(define *ssl:greedy-pool-randbits* (* *ssl:random-STATE_SIZE* 8)) ; Useless if more than this anyway.

(define *ssl:pool-task-thresholds-and-periods* ; Tuples of (minutes bits).
  `((1 2048)
   (20 4096)
   (60 ,(1- (* *ssl:random-STATE_SIZE* 8)))))

;;; Adapted from scheduler:add-periodic-task!.
(define (ssl:add-pool-task! timeout task)
  (let ((.start. (+ (random timeout) (current-time)))) ; %%% This should be a gensym or something.
    (scheduler:add-task!
      (format nil "~A ~A" *ssl:pool-task-basename* timeout)
      *ssl:pool-task-priority*
      (lambda ()
	(> (- (current-time) .start.) timeout))
      (lambda ()
	(task)
	(set! .start. (+ (random timeout) (current-time)))))))

(defvar *ssl:homeostatic-refreshes* 0)	; Debugging.  %%% Maybe make a real stat counter?

(define (ssl:make-pool-task entry)
  (let ((ssl:bit-threshold (cadr entry))) ; Captured & used by the task.
    (ssl:add-pool-task! 
     (* (car entry) 60)	; Convert to seconds.
     ;; The task that runs might as well have the check in it, rather than
     ;; trying to complicate the wait-fn with it; -somebody's- gotta run
     ;; the test, and it takes the same (tiny) amount of time no matter who.
     (lambda ()
;      (format-debug 10 "~&Maybe making randbits.  (ssl:randbits-in-pool) = ~S, ssl:bit-threshold = ~S~&" (ssl:randbits-in-pool) ssl:bit-threshold)
       (unless (> (ssl:randbits-in-pool) ssl:bit-threshold)
	 ;; If we have to ask for any, might as well ask for lots & see what we get...
	 (let ((request (- *ssl:greedy-pool-randbits* (ssl:randbits-in-pool))))
;	   (format-debug 10 "~&Request = ~S~&" request)
	   (when (positive? request)	; Must be, unless a theshold is > the greedy limit, which is an error.
	     (inc! *ssl:homeostatic-refreshes*)
	     (ssl:force-entropy! request nil) ; Not allowed to use the keyboard.
;	     (format-debug 10 "~&(ssl:randbits-in-pool) now ~S~&" (ssl:randbits-in-pool))
	     )))))))

(define (ssl:initialize-pool-tasks!)
  (for-each ssl:make-pool-task *ssl:pool-task-thresholds-and-periods*))

;;;; Accepting incoming SSL connections, or making outgoing ones.

;;; Utility used in either direction.
(define (ssl:make-and-accept-or-connect ctx tcp timeout func use)
  (ssl:err-if-randbits-unavailable
   128
   "Danger accepting connection (~S ~S ~S ~S)~&~
    because we didn't have 128 bits available to generate a session key."
   ctx tcp timeout func)
  (let ((ssl (ssl:make ctx tcp)))
    (define (fail)
      (set! ssl #f)
      (format-debug 10 "failed!~&"))
    (define (done?)
      (when (not (tcp:connected? tcp))
	(fail))
      ;;(if (output-port? ssl)
      ;;(force-output ssl))
      (or (not (ssl? ssl))
	  (ssl:established? ssl)))
    (cond ((and (ssl? ssl)
		(valid-ssl-cipher? (ssl:current-cipher ssl)))
	   ;; This suffers from a potential attack on our pool of random bits,
	   ;; and can get us to inadvertently run down our pool without realizing
	   ;; it, namely to keep connecting and then aborting---since we don't
	   ;; actually subtract the bits for a failed connection.  The only real
	   ;; fix for this is to have the internals of ssl:make do the subtraction
	   ;; instead, at the instant it generates a session key.  But since that
	   ;; seems an unlikely attack, we'll instead do the efficient thing and
	   ;; subtract the bits once we know how many we used (after all, if we're
	   ;; only using 40 bits at a time, no reason to subtract 128).  Another way
	   ;; to do this would be to just always subtract 128 and the hell with it.
	   (ssl:eat-randbits! (ssl:cipher-bits (ssl:current-cipher ssl)))))
    (when (not (valid-ssl? ssl))
	  (debug-format 10 "~A~&" (ssl:get-errors))
	  (fail))
    (when (and ssl
	       (not (func ssl timeout)))
	  (format-debug 10 "handshake failed:~&~S~&~S ~S"
			(ssl:get-errors)
			(ssl:state ssl #t)
			(ssl:read-state ssl #t))
	  (set! ssl (cons 'handshake-failed ssl)))
    (use ssl)))

;;; Accepting incoming connections.
(define (ssl:make-and-accept ctx tcp timeout use)
  (ssl:make-and-accept-or-connect ctx tcp timeout ssl:accept use))

;;; Establishing outgoing connections.
(define (ssl:make-and-connect ctx tcp timeout use)
  (ssl:make-and-accept-or-connect ctx tcp timeout ssl:connect use))

;;; End of file.
