;; Media Bank Movie Ticket Server
;;
;; Created by:	Derek Atkins <warlord@MIT.EDU>
;;
;; $Source: /u3/warlord/src/media-bank/scm/RCS/mts.scm,v $
;; $Author: warlord $
;;

(require 'scheme 'unix 'gdbm 'file 'dsys 'set 'crypto 'secure-eval)
(load "/mit/warlord/C/dtcore/secure-eval.scm")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Global Server Definitions

(define senv (environment-create))      ; restricted server environment
(define server-port 41923)              ; the port on which this server listens
(define expire-time (* 60 60 24))	; give a token 24 hours

;; setup the ticket history database
(define server-hostname (vector-ref (string-split (unix-hostname) ".") 0))
(define data-directory "/usr/tmp")
(define gdbm-filename (string-append data-directory "/mts-"
                                     server-hostname ".gdbm"))
(define gdbm-file (gdbm-open gdbm-filename 'wrcreate))

;; read in the server's private key
(define keyfile
  "/mit/warlord/C/crypto/src/test/rsakey.dat")
(define keystr (iostream-open keyfile "r"))
(define private-key (privkey-create-from-iostream 'rsa keystr))
(iostream-close keystr)

(define rng (rng-create 'lc (rng-noise-source)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Raw Database Operations

(define item-store
  (lambda (key item)
    (gdbm-store gdbm-file key item)))

(define item-fetch
  (lambda (key)
    (gdbm-fetch gdbm-file key)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Raw ticket operations and supporting routines

(define update-ticket
  (lambda (ticket object)
    (let* ((tokenid (vector-lookup ticket 'tokenid))
	   (state (exception-handler (item-fetch tokenid))))
      (if (error? state)
	  (set! state (set-create))
	  (if (null? state)
	      (exception "Ticket is invalid")))
      (set-insert! state object)
      (item-store tokenid state))))

(define finish-ticket
  (lambda (ticket)
    (let ((tokenid (vector-lookup ticket 'tokenid)))
      (item-store tokenid '()))))

(define check-ticket
  (lambda (ticket object)
    (let* ((tokenid (vector-lookup ticket 'tokenid))
	   (state (exception-handler (item-fetch tokenid))))
      (cond ((error? state)
	     #t)
	    ((null? state)
	     #f)
	    ((> (unix-time) (vector-lookup ticket 'expires))
	     #f)
	    ((< (unix-time) (vector-lookup ticket 'now))
	     #f)
	    (#t
	     (not (set-contains? state object)))))))	  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Movie Ticket Functions and support

(define check-payment
  (lambda (payment ticket)
    #t)) ; ignore payment for now.

(define find-objects
  (lambda (program)
    (define objs (set-create))
    (set-insert! objs program)
    objs))

(define buy-ticket
  (lambda (program payment)
    (define ticket (vector
		    (cons 'tokenid (rng-get-block rng 16))
		    (cons 'now (unix-time))
		    (cons 'expires (+ (unix-time) expire-time))
		    (cons 'pag (find-objects program))))
    (if (check-payment payment ticket)
	(cons ticket (make-signature private-key (dtype->packet ticket)))
	(exception "Payment is invalid"))))

(define validate-ticket
  (lambda (ticket object)
    (define sig-ok? (printing-exception-handler 
		     (verify-signature private-key (dtype->packet 
						    (car ticket)) 
				       (cdr ticket))))
    (if (error? sig-ok?)
	#f
	(check-ticket (car ticket) object))))

(define turnin-ticket
  (lambda (ticket object)
    (if (verify-signature private-key 
			  (dtype->packet (car ticket)) (cdr ticket))
	(update-ticket (car ticket) object)
	(exception "Ticket did not validate"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Set Security Operations for this connection -- choose confidentiality
;;  and integrity methods for this connection

(define set-security
  (lambda (token)
    (secure-eval-set-client-security token private-key)))

(define server-public-key
  (lambda ()
    (pubkey-extract private-key)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Setup the environment

(define add-symbols
  (lambda (env symbols)
    (for-each (lambda (s) (apply environment-define (list env s s))) symbols)))

(add-symbols senv
             '(buy-ticket validate-ticket turnin-ticket set-security
                          server-public-key quote cons vector list
                          printout stringout current-environment and
                          or not))

;;(secure-eval-loop server-port (current-environment))
(printout "Server starting...\n")
(secure-eval-loop server-port senv)