;; The Secure Evaluator
;;
;; Created by:	Derek Atkins <warlord@MIT.EDU>
;;
;; $Source: /u3/warlord/src/media-bank/scm/RCS/secure-eval.scm,v $
;; $Author: warlord $
;;
;; Exported Function List:
;;
;; (secure-eval-add-connect-hook f)
;; (secure-eval-add-disconnect-hook f)
;; (secure-eval-add-init-hook f)
;;
;; (secure-eval-current-client)
;; (secure-eval-set-client-security token private-key)
;;
;; (secure-eval-loop port environment)
;;

(require 'dsys 'file 'crypto)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Global Secure-eval Definitions

(define secure-eval--connect-hooks '())
(define secure-eval--disconnect-hooks '())
(define secure-eval--init-hooks '())
(define secure-eval--pollblock (dsys-pollblock-create))
(define secure-eval--this-client '())
(define secure-eval--client-map (map-create))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Set function hooks

(define secure-eval-add-connect-hook
  (lambda (f)
    (set! secure-eval--connect-hooks 
	  (reverse (cons f (reverse secure-eval--connect-hooks))))))

(define secure-eval-add-disconnect-hook
  (lambda (f)
    (set! secure-eval--disconnect-hooks 
	  (reverse (cons f (reverse secure-eval--disconnect-hooks))))))

(define secure-eval-add-init-hook
  (lambda (f)
    (set! secure-eval--init-hooks 
	  (reverse (cons f (reverse secure-eval--init-hooks))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Obtain information about data structures

(define secure-eval-current-client
  (lambda ()
    secure-eval--this-client))

(define secure-eval-client-info
  (lambda ()
    (map-value secure-eval--client-map (stringout secure-eval--this-client))))

(define secure-eval-client-security
  (lambda ()
    (vector-lookup (secure-eval-client-info) 'security)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Security Parameters and Functions

(define secure-eval-set-client-security
  (lambda (token private-key)
    (let ((client (secure-eval-client-info)))
      (set-cdr! (vector-lookup-binding client 'security) 
		(cond ((null? token)
		       '())
		      (#t
		       (let* ((info (read-key-exchange private-key token))
			      (block (block-create (car info) (cdr info))))
			 (vector
			  (cons 'pubkey private-key)
			  (cons 'privkey private-key)
			  (cons 'block block)))))))))

;; open and verify the request, returning the value or an error
(define read-request
  (lambda (request)
    (let ((crypto (secure-eval-client-security)))
      (packet->dtype (unseal-packet request crypto)))))

;; seal a reply to the client
(define seal-reply
  (lambda (reply)
    (let ((crypto (secure-eval-client-security)))
      (seal-packet (dtype->packet reply) crypto))))

;; perform a secure request, replying securely (exported function)
(define secure-eval
  (lambda (request environment)
    (let* ((req (exception-handler (read-request request)))
	   (response (exception-handler (eval req environment))))
      (seal-reply response))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Client Data

(define server-login-client
  (lambda (server client)
    (printout "Client " client " logged in\n")
    (map-insert! secure-eval--client-map (stringout client)
		 (vector (cons 'security '())))
    (for-each (lambda (f) (f server client)) secure-eval--connect-hooks)))

(define server-logout-client 
  (lambda (server client)
    (printout "Client " client " logged out\n")
    (map-delete! secure-eval--client-map (stringout client))		 
    (for-each (lambda (f) (f server client)) secure-eval--disconnect-hooks)))

(define server-process-packet 
  (lambda (client packet env)
    (printout "Client " client " sent packet to process\n")
    (let ((security (secure-eval-client-security)))
      (if (null? security)
	  (exception-handler (eval packet env))
	  (secure-eval packet env)))))

(define server-process-clients
  (lambda (server env)

    (dsys-pollblock-clear! secure-eval--pollblock)
    (dsys-station-add-read! server secure-eval--pollblock)
    (dsys-pollblock-block secure-eval--pollblock)

    (define r (dsys-server-poll server))

    (printout "Data input: " r "\n")

    (define client (car r))
;;    (printout "About to set current clint\n")
    (set! secure-eval--this-client client)
;;    (printout "Set current client\n")

    (cond ((equal? (cdr r) 'login)
	   (server-login-client server client))
	  ((equal? (cdr r) 'pending)
	   (define packet (exception-handler 
			   (dsys-connection-read 
			    (dsys-server-client server client))))
	   (define ret (exception-handler 
			(server-process-packet client packet env)))
	   (dsys-connection-write (dsys-server-client server client) ret))
	  ((equal? (cdr r) 'logout)
	   (server-logout-client server client))
	  (exception (cons "unknown response from server" r)))))

(define my-printing-exception-handler
  (lambda-macro (x)
    (let ((r (exception-handler (eval x))))
      (if (error? r)
	  (printout "error-handler: " r "\n")
	  r))))

(define secure-eval-loop
  (lambda (port env)
    (define server (dsys-server-create port))
    (for-each (lambda (f) (f server)) secure-eval--init-hooks)
    (while #t (my-printing-exception-handler 
	       (server-process-clients server env)))))