;;
;; validate.scm -- A demo to show the security in the media bank
;;
;; Created by:	Derek Atkins <warlord@MIT.EDU>
;;
;; $Source$
;; $Author$
;;

(require 'scheme 'map 'dsys 'crypto 'unix)

(define crypto-fcn 'idea)
(define server-map (map-create))
(define current-ticket #f)
(define current-object #f)

(define make-server-vector
  (lambda (name host port)
    (map-insert! server-map 
		 name 
		 (vector
		  (cons 'host host)
		  (cons 'port port)
		  (cons 'conn #f)
		  (cons 'key #f)
		  (cons 'pubkey #f)
		  (cons 'crypto #f)))))

(make-server-vector 'mts "btc.mit.edu" 41923)
(make-server-vector 'mts2 "btc.mit.edu" 41923)
(make-server-vector 'transport "alphaville.media.mit.edu" 20445)

(define make-rpc
  (lambda (type request)
    (let* ((server (map-value server-map type))
	   (conn (vector-lookup server 'conn)))
      (if conn
	  (let ((resp (exception-handler (do-rpc type request))))
	    (if (error? resp)
		(attempt-connect type request)
		resp))
	  (attempt-connect type request)))))

(define do-rpc
  (lambda (type request)
    (let* ((server (map-value server-map type))
	   (conn (vector-lookup server 'conn))
	   (crypto (vector-lookup server 'crypto)))
      (exception-handler 
       (packet->dtype
	(unseal-packet
	 (dsys-connection-rpc conn (seal-packet 
				    (dtype->packet request)
				    crypto))
	 crypto))))))

(define attempt-connect
  (lambda (type request)
    (if (connect type)
	(do-rpc type request)
	(exception "Cannot connect to server"))))

(define set-crypto
  (lambda (type)
    (let* ((server (map-value server-map type))
	   (pubkey (vector-lookup server 'pubkey))
	   (crypto (vector-lookup server 'crypto)))
    (if crypto
	#f
	(let ((key (make-random-key crypto-fcn)))
	  (set-cdr! (vector-lookup-binding server 'crypto)
		    (vector
		     (cons 'pubkey pubkey)
		     (cons 'block (block-create crypto-fcn key))))
	  (set-cdr! (vector-lookup-binding server 'key) key)
	  #t)))))

(define connect
  (lambda (type)
    (let* ((server (map-value server-map type))
	   (host (vector-lookup server 'host))
	   (port (vector-lookup server 'port)))
		   
      (define conn (exception-handler (dsys-connection-create host port)))
      (cond ((error? conn)
	   (set-cdr! (vector-lookup-binding server 'conn) #f)
	   #f)
	  (#t
	   (set-cdr! (vector-lookup-binding server 'conn) conn)
	   (define serv-pubkey (dsys-connection-rpc conn '(server-public-key)))
	   (define pubkey (pubkey-create 'rsa (car serv-pubkey) 
					 (cdr serv-pubkey)))
	   (set-cdr! (vector-lookup-binding server 'pubkey) pubkey)
	   (set-crypto type)
	   (printing-exception-handler
	    (dsys-connection-rpc conn 
				 (list 'set-security 
				       (list 'quote 
					     (setup-key-exchange
					      pubkey
					      crypto-fcn
					      (vector-lookup server 'key))))))
	   #t)))))

(define attempt-close
  (lambda (type)
    (let* ((server (map-value server-map type))
	   (conn (vector-lookup server 'conn)))
      (if conn
	  (begin
	    (dsys-connection-close conn)
	    (set-cdr! (vector-lookup-binding server 'conn) #f))))))

(define get-ticket
  (lambda (for-what)
    (make-rpc 'mts (list 'buy-ticket for-what #t))))

(define open-obj
  (lambda (obj ticket)
    (make-rpc 'transport (list 'mbank-open obj (list 'quote ticket)))))

(define read-obj
  (lambda (obj length)
    (make-rpc 'transport (list 'mbank-bytes-read obj length))))

(define seek-obj
  (lambda (obj pos)
    (make-rpc 'transport (list 'mbank-bytes-seek obj pos))))

(define close-obj
  (lambda (obj)
    (make-rpc 'transport (list 'mbank-close obj))))

(define print-vector
  (lambda (vec)
    (let ((len (vector-length vec))
	  (i 0)
	  (output "#("))
      (while (< i len)
	     (let ()
	       (set! output 
		     (string-append 
		      output 
		      (stringout (vector-ref vec i) "\n")))
	       (set! i (+ i 1))))
      (set! output (string-append output ")"))
      output)))

(define print-ticket
  (lambda (ticket)
    (stringout "(" (print-vector (car ticket)) " . " (cdr ticket))))