;;; Okay, this is a bit confusing.  Don't try to understand how the code works,
;;; just mess with what it does.  (An explanation of the mechanism is at the
;;; end).
;;;
;;; The procedures in the middle of make-connection are all of the situations
;;; the connection could be in:  just made a connection, just negotiated
;;; protocol version, partway through authentication, etc.
;;;
;;; Each procedure takes (a) the expression sent by the other end and (b) a 
;;; procedure used to go to the next step.  This should be called to switch
;;; between steps.  For clarity, it should only be used at the end of the
;;; procedure, but it would work at any point---the current procedure will
;;; finish after setting the next step.
;;;
;;; Here's an example:
;;;
;;; (define (wait-for-ack-and-write-foo exp goto)
;;;   (case (car exp)
;;;     ((:ack) (write '(:foo) con)
;;;	     (goto get-foo-response))
;;;     ((:nak) (recover exp goto))
;;;     (else (error exp goto))))
;;;
;;; This uses two other steps, recover and error. Note that goto may only be
;;; used if we're expecting to get a response; we have to do our side of the
;;; interaction before we can return.
;;;
;;; As a special case, (goto #f) closes the connection.
;;;
;;; To change the connection:
;;;
;;; a) vector-set! con-rec 1 to a procedure which will close the connection.
;;;    This gets initialized properly for a basic connection.
;;; b) set-car! connection to the port that expressions should be read out of.
;;; c) set! con to the port that expressions should be written to.

;(ssl:initialize!) ; this has to be done somewhere before cert stuffs

(yreq "Utilities/yenta-utils")

;;; Never make this variable a yenta-var.  Doing so would cause its value to be
;;; persistent, which means that a change caused by a new release would have to
;;; be explicitly undone by that release, or it would wind up using the old value.
;;; This isn't supposed to change while Yenta is running anyway, so there's no
;;; need for it to be a yvar.
(define *iy-port* 14990)		; %%% This must be changed to 14989, and decremented until we find a free port, once mux is available.

(define *iy:connection-limit* 10)	; The most connections we'll make.

(defvar *iy:server-ctx* #f)		; Set when the task starts.
(defvar *iy:client-ctx* #f)		; Set when the task starts.

(defvar *to-do-list* 
  '((other give-clusters)))

;;; When we meet a stranger, we get their identity and attestations and 
;;; send them our clusters.
(define iy:initial-meet-to-do '(get-info attestations give-clusters))

;;; When we see someone again 
(define iy:occasional-to-do '(get-info attestations give-clusters))

;;; When we get a connection from someone we know, we don't have any tasks,
;;; because if we did, we'd have contacted them. We do check to see if we are
;;; planning to contact them (they've moved and we didn't find them when we
;;; wanted to talk to them, e.g.)

(define (iy:get-to-do yid)
  ; returns the list of things we wanted to talk to this yenta about.
  ; it takes into account "lost yentas", strangers, and people we haven't
  ; quite gotten around to contacting.
  (let ((found (assoc yid *iy:to-do-lists*)))
    (if found 
	(cdr found) ; we have something in particular to say
	(if (identity:get-key yid)
	    '() ; we don't have anything to say
	    iy:initial-meet-to-do)))) ; we didn't know about this yenta

(define (iy:did-to-do-items yid items)
  ; Removes a list of items from the to-do list for a yenta, and returns the
  ; list of things left to do.
  (let ((found (assoc yid *iy:to-do-lists*)))
    (if found 
	(begin
	  (for-each (lambda (item) (delete! item found))
		    items)
	  (cdr found))
	'())))

(define (iy:contact-host hostname)
  (set! *iy:contact-list* (cons (list hostname #f #f #f)
				*iy:contact-list*)))

(defvar *iy:talking* #f)
(define (iy:check-talking)
  (set! *iy:talking*
	(and ;(not (equal? "" (cadr *local-yenta-addr*)))
	     ;
	 )))

(define (iy:contact-yenta yid . tasks)
  (define (in-progress)
    (let ((tasklist (assoc yid *iy:in-progress*)))
      (cond (tasklist
	     (set-cdr! tasklist (append (cdr tasklist) tasks))
	     #t)
	    (t
	     #f))))
  (define (awaiting)
    (there-exists?
     (lambda (item)
       (equal? yid (list-ref item 2)))
     *iy:contact-list*))
  (when (null? tasks)
    (set! tasks iy:initial-meet-to-do))
  (let ((tasklist (assoc yid *iy:to-do-lists*)))
    (if tasklist 
	(set-cdr! tasklist (union (cdr tasklist) tasks))
	(set! *iy:to-do-lists* (cons (cons yid tasks) *iy:to-do-lists*))))
  (if (not (or (in-progress)
	       (awaiting)))
      (let ((addr (list #f #f yid #f)))
	(identity:fix-addr! addr)
	(if (car addr)
	    (set! *iy:contact-list* (cons addr *iy:contact-list*))
	      
	    ;; %%%
	    ;; otherwise, we've got no clue how to get in touch with this 
	    ;; person, so we won't try. We may eventually set up something
	    ;; to keep track of people we'd like to talk to if we can ever
	    ;; find them.
	))	
      ;; %%% We're already planning to contact this Yenta, or it's us.
      ))

(define (iy:create-outgoing-yenta-task)
  (set! *iy:client-ctx* (ssl:make-ctx (ssl:v23-client-method)))
  (when (not (valid-ssl-ctx? *iy:client-ctx*))
	(set! *iy:client-ctx* #f)
	; %%%
	)
  (when (not (ssl:use-rsa-private-key!
	    *iy:client-ctx* 
	    (ssl:der-string->rsa-private-key *local-yenta-priv-key*)))
      ; %%%
      )
  (when (not (ssl:use-certificate-from-asn1-string! *iy:client-ctx* *local-yenta-cert*))
    (format-debug 7 "ack, bad client ctx~&")) ; %%% Get the right error here.
  (unless (equal? (ssl:get-errors) "")
    (format-debug 7 "SSL errors: ~S~&" (ssl:get-errors)))
  (scheduler:add-task! 
   "Outgoing InterYenta" 1
   (lambda () (and (not (null? *iy:contact-list*))
		   (> *iy:connection-limit* (length *connections*))
		   *iy:talking*))
   (lambda ()
     (let* ((item (car *iy:contact-list*))
	    ; we don't bother if either (a) we're talking to our own YID.
	    ; or (b) we're talking to our machine, and not looking for someone
	    ; else. This means that in the multiuser case, we're going to have
	    ; to talk to the redirector to find out who else is on our machine
	    ; since we can't just contact them.
	    (con (if (not (or (and (equal? (car item) (local-host-ip))
				   (not (caddr item)))
			      (equal? (caddr item) *local-yenta-id*)))
		     (tcp:connect (car item) *iy-port*)
		     #f))
	    (known-yid (caddr item))
	    (con-rec (if con
			 (begin
			   (inc! *ctr:conns-initiated*)
			   (make-connection con #f known-yid 
					    (iy:get-to-do known-yid)))
			 #f)))
       (cond (con-rec
	      (format-debug 8 "~&Contacting ~A...~&" item)
	      (when known-yid
		(set! *iy:in-progress* (cons (list known-yid)
					     *iy:in-progress*)))
	      (set! *iy:contact-list* (cdr *iy:contact-list*))
	      (scheduler:split 
	       (begin
		 (vector-set! (caddr con-rec) 2 (scheduler:current-task))
		 ;; This is where the child agrees to be killed rather than the parent.
		 (run-protocol con-rec #f))))
	     (t
	      (format-debug 8 "~&Connection refused by ~A~&" (car *iy:contact-list*))
	      (set! *iy:contact-list* (cdr *iy:contact-list*))
	      ;; For now, we just try every time we've got
	      ;; something new to say to them. Alternatively,
	      ;; they could contact us, perhaps from another
	      ;; location.
	      ))))))

(defvar last-exp #f)			; Debugging.  Not currently read anywhere, and only set inside make-connection.

(define (close-yenta-server)
  ; This will close all InterYenta connections
  ; The protocol specifies that either end is allowed to simply close the
  ; connection at any time, and the other end should deal. When we're shutting
  ; down, we want to just give up immediately on any connections, since we've
  ; already saved our variables for the last time when the next protocol step
  ; could happen.
  (scheduler:remove-task! "Outgoing InterYenta") ; no new connections
  (scheduler:remove-task! "InterYenta server") ; in either direction
  (when *iy:tcp-listener*
    (tcp:close-listener *iy:tcp-listener*)
    (set! *iy:tcp-listener* #f))
  ; Don't let us try to close it a second time; we'll err.
  (filter (lambda (con-rec)
	    (let ((name (scheduler:task-name (vector-ref con-rec 2))))
	      (cond ((not (vector-ref con-rec 1))
		     #f) ; already closed, but the scavenger hasn't run since
		    ((or (equal? name '("Outgoing InterYenta" child))
			 (equal? name '("InterYenta server" child)))
		     ((vector-ref con-rec 1))
		     (scheduler:kill-task! (vector-ref con-rec 2))
		     #f)
		    (else #t))))
	  *connections*))

;;; The toplevel engine for the protocol.
(define (make-connection con svr yid-sought to-do)
  (define con-rec (vector (current-time) 
			  (lambda () 
			    (close-port con)
			    (if yid-sought
				(set! *iy:in-progress*
				      (filter (lambda (item)
						(not (equal? (car item)
							     yid-sought)))
					      *iy:in-progress*)))
			    (vector-set! con-rec 1 #f))
			  (scheduler:current-task)))
  (define connection #f)		; Filled in at the end...
  (define proto-version #f)
  (define to-do '())
  (define other-yenta-addr (list (tcp:remote-ip con) #f #f #f))
  (define other-yenta-id #f)
  (define proved-id #f)
  (define ask-id-list (identity:wanted-list))
  (define retries 10)			; Errors decrement this, and close if it reaches 0.

  (define seen-last-time 0)

  (define referral-list '())

  (define (output exp)
    (let ((conn (car connection)))
      (format-debug 8 "~&Sending via IY: ~S~&" exp)
      (write exp conn)
      (newline conn)
      (force-output conn)
      (inc! *ctr:opcodes-sent*)))

  (define (got-identity ident)
    (format-debug 8  "~&Got identity ~A ~S~&" proto-version ident)
    (case proto-version
      ((1 2)
       (set-car! (cddr other-yenta-addr) (public-key->yenta-id
					  (ui:hex->bytes ident)))
       (if (null? to-do)
	   (if (not (identity:fix-addr! other-yenta-addr))
	       (set! to-do (union to-do iy:initial-meet-to-do))
	       (set! to-do (union to-do
				  (iy:get-to-do (caddr other-yenta-addr))))))
       (set! other-yenta-id (caddr other-yenta-addr))
       (set! attestations-to-get (identity:attestations-seek-list
				  other-yenta-id))
       (set! messages-to-send (identity:message-list other-yenta-id))
       (set! referral-list (identity:referral-list other-yenta-id))
       (set! seen-last-time (identity:last-seen other-yenta-id))
       (let ((atts (identity:get-attestations other-yenta-id)))
	 (if atts
	     (set! signatures-to-send
		   (filter (lambda (sig-item)
			     (> (cadr (caddr sig-item)) seen-last-time))
			   (flatten
			    (map (lambda (att)
				   (map (lambda (sig)
					  (list other-yenta-id (car att) sig))
					(cadr att)))
				 atts))))
	     (set! signatures-to-send '())))
       ;; %%% make-interest-table should take the attestations
       
       (set! clusters-to-send (if *interests:available*
				  (interests:make-interest-table
				   '() other-yenta-id)
				  '()))
       ;; Note:  we set the "seen" time after figuring out everything we want to
       ;; say.  Anything based on novelty must be above this point.
       (identity:seen-now other-yenta-id))))

  (define opcode-list 
    '(:this-is-a-Yenta :this-is-also-a-Yenta :version :version-ack 
		       :challenge :challenge-ack :who-is :addr-is
		       :ack :nak :bye :reverse :done :interest-interesting
		       :interest-boring :have-an-interest :id-unknown
		       :message-for-you :attestations :atts-unknown :okay
		       :get-attestations :have-a-signature
		       ))

  (define newest-version 2)

  (define (check-versions exp)
    (let ((other-yenta-version (assq 'yenta exp)))
      (cond ((not other-yenta-version) #f)
	    ((version-newer (cdr other-yenta-version) (yenta-version))
	     (set! to-do (cons 'get-contact-attestations to-do))
	     #t)
	    (t #t))))

  (define (select-client-version version-number)
    (set! proto-version (min version-number newest-version))
    (case proto-version
      ((1) client-trade-versions)
      ((2) version-two-client-intro)))

  (define (version-two-client-intro exp goto)
    ;; Synchronize connection so the handshake doesn't get chewed up.
    (display "~" (car connection))
    (scheduler:sequences
     ((scheduler:do-with ((char (sch-read-char (car connection))
				(sch-read-char (car connection))))
			 ((or (eof-object? char)
			      (char=? char #\~)) #f)
	#t))
;     ((newline)
;      (display "$" (car connection))
;      (do ((c (read-char (car connection)) (read-char (car connection))))
;	  ((eof-object? c) #f)
;	(write c))
;      (goto done))))
     ;; Switch to SSL encrypted port.
     ((scheduler:let* ((port (ssl:make-and-accept
			      *iy:server-ctx* (car connection) 60)))
	       (if (ssl? port)
		   (begin
		     (set-car! connection port)
		     (set! proved-id 
			   (ssl:sha1-hash
			    (ssl:rsa-public-key->der-string
			     (ssl:x509->rsa-public-key
			      (ssl:peer-certificate port)))))
		     (vector-set! (caddr connection) 1
				  (let ((plain-close 
					 (vector-ref (caddr connection) 1)))
				    (lambda ()
				      (close-port port)
				      (plain-close))))
		     (client-trade-versions exp goto))
		   (goto #f))))))

  (define (client-get-version-ack exp goto)
    (cond ((not (eq? (car exp) ':version-ack))
	   (error exp goto))
	  ((check-versions (cdr exp)) (client-start-challenge exp goto))
	  (else (malformed exp goto))))

  (define (get-redirect-resp exp goto)
    (cond ((eq? (car exp) ':try-port)
	   ;;; stuff to start a new interaction on the redirected port
	   (output '(:ack))
	   (goto #f)) ; close this one (which is to the port redirector
	  (else
	   (output '(:ack)) ; oops, we've gotten an actual wrong yenta.
	   (goto #f))))

  (define (want-redirect exp goto)
    (output `(:wanted ,(ui:bytes->hex yid-sought)))
    (goto get-redirect-resp))

  (define (client-trade-versions exp goto) ; We speak first.
    (output `(:version ,@*yenta-component-versions*))
    (goto client-get-version-ack))

  (define (client-start-challenge exp goto) ; We speak first.
    (output `(:challenge ,(ui:bytes->hex *local-yenta-pub-key*)))
    (goto client-get-challenge-ack))

  (define (client-get-challenge-ack exp goto)
    (cond ((not (eq? (car exp) ':challenge-ack))
	   (error exp goto))
	  ((and (equal? (ssl:sha1-hash (ui:hex->bytes (cadr exp))) proved-id))
	   (scheduler:sequences
	    ((got-identity (cadr exp)))
	    ((if (or (not yid-sought)
		   (equal? proved-id yid-sought))
	       (client-work exp goto)
	       (want-redirect exp goto)))))
	  (else
	   (inc! *ctr:auth-failures*)
	   (output '(:nak never))
	   (goto #f))))

  (define (reverse-or-quit exp goto)
    (cond ((eq? (car exp) ':bye) (goto #f))
	  ((eq? (car exp) ':reverse)
	   (output '(:ack))
	   (goto server-work))
	  (else (error exp goto))))

  (define clusters-to-send '())

  (define (followup-get-ack exp goto)
    (case (car exp)
      ((:ack) (followup-rumor exp goto))
      (else (error exp goto))))

  ;;; Here's the client-side referral code.

  (define (followup-rumor exp goto)
    (cond ((not (null? referral-list))
	   (output `(:other-interested ,(caar referral-list) 
				       ,(cadar referral-list)))
	   (set! referral-list (cdr referral-list))
	   (goto followup-get-ack))
	  (t
	   (set! to-do (delq 'referrals to-do))
	   (identity:clear-referral-list! other-yenta-id)
	   (client-work exp goto))))

  (define (get-cluster-resp exp goto)
    (case (car exp)
      ((:interest-interesting)
       (if (caar clusters-to-send)
	 (interests:add-to-cluster-cache (caar clusters-to-send)
					 (caddr other-yenta-addr)
					 (if (not (null? (cdr exp)))
					     (cadr exp)
					     #f))
	 (interests:tell-source (cadar clusters-to-send) other-yenta-addr))
       (set! clusters-to-send (cdr clusters-to-send))
       (send-clusters exp goto))
      ((:interest-boring)
       (set! clusters-to-send (cdr clusters-to-send))
       (send-clusters exp goto))
      ((:nak)
       (set! clusters-to-send '())
       (send-clusters exp goto)
       ; don't bother-- this means the other end isn't
       ; up to doing comparisons, so we'll give up on clusters for this
       ; connection. We ought to remember that we didn't really exchange
       ; clusters this time around, though...
       )
      (else (error exp goto))))

  (define (send-clusters exp goto)
    (cond ((null? clusters-to-send)
	   (set! to-do (delq 'give-clusters to-do))
	   (client-work exp goto))
	  (t
	   (let ((description (compare:export-document
			       (caddr (car clusters-to-send))
			       75)))	; %%% This should be a parameter.
	     (if (not (null? description))
		 (begin
		   (output `(:have-an-interest 
			     ,(cadddr (car clusters-to-send))
			     ,description))
		   (goto get-cluster-resp))
		 (begin
		   ;; This isn't really valid.
		   (set! clusters-to-send (cdr clusters-to-send))
		   (send-clusters exp goto)))))))

  (define (receive-message exp goto)
    (messages:add-message (messages:unpack (cadr exp)))
    (set! *ui:messages-new* #t)		; Open the doors.  We don't do this in add-message 'cause we don't want to do it when the user -sends- one.
    (output '(:ack))
    (goto server-work))

  (define messages-to-send '())

  (define (sent-message exp goto)
    (case (car exp)
      ((:ack) (set! messages-to-send (cdr messages-to-send))
	      (send-messages exp goto))
      (else (error exp goto))))

  (define (send-messages exp goto)
    (cond ((null? messages-to-send)
	   (set! to-do (delq 'messages to-do))
	   (identity:clear-message-list! (caddr other-yenta-addr))
	   (client-work exp goto))
	  (t
	   (output `(:message-for-you
		    ,(messages:pack-for-transit (messages:get-message 
						 (car messages-to-send)))))
	   (goto sent-message))))

  (define (get-info-response exp goto)
    (cond ((eq? (car exp) ':id-unknown)
	   (set! to-do (delq 'get-info to-do))
	   ;; Well, we're not going to be happy about this, since the other
	   ;; Yenta ought to recognize their own id, but...
	   (client-work exp goto))
	  ((not (eq? (car exp) ':addr-is))
	   (error exp goto))
	  ((or (not (= (length exp) 3))
	       (not (list? (cadr exp)))
	       (not (= (length (cadr exp)) 5)))
	   (malformed exp goto))
	  (t
	   (cond ((identity:check-signature 
		   (caadr exp) 
		   (identity:addr-hex->bytes (cdadr exp))
		   (ui:hex->bytes (caddr exp)))
		  ;; Check signature stuff.
		  (identity:notice (caadr exp) 
				   (identity:addr-hex->bytes (cdadr exp))
				   (caddr exp))
		  (identity:fix-addr! other-yenta-addr)
		  (set! to-do (delq 'get-info to-do))
		  (client-work exp goto))
		 (t
		  (set! to-do (delq 'get-info to-do))
		  ;; We're not really happy here, either.
		  (client-work exp goto))))))

  (define (get-info exp goto)
    (output `(:who-is ,(ui:bytes->hex (identity:addr->id other-yenta-addr))))
    (goto get-info-response))
  
  (define (get-other-info-response exp goto)
    (cond ((eq? (car exp) ':id-unknown)
	   (set! ask-id-list (cdr ask-id-list))
	   (ask-other-info exp goto))
	  ((not (eq? (car exp) ':addr-is))
	   (error exp goto))
	  ((or (not (= (length exp) 3))
	       (not (list? (cadr exp)))
	       (not (= (length (cadr exp)) 5)))
	   (malformed exp goto))
	  (else
	   (cond ((identity:check-signature 
		   (caadr exp) 
		   (identity:addr-hex->bytes (cdadr exp))
		   (ui:hex->bytes (caddr exp)))
		  ;; Check signature stuff.
		  (identity:notice (caadr exp) 
				   (identity:addr-hex->bytes (cdadr exp))
				   (caddr exp))
		  (set! ask-id-list (cdr ask-id-list))
		  (ask-other-info exp goto))
		 (else
		  ;; We don't say anything---the other end's not likely to
		  ;; give us a better response if we complain, and they must
		  ;; know the signature's bad.  %%% We could LOG this, however.
		  (set! ask-id-list (cdr ask-id-list))
		  (ask-other-info exp goto))))))

  (define (ask-other-info exp goto)
    (cond ((null? ask-id-list)
	   (set! to-do (delq 'identities to-do))
	   (client-work exp goto))
	  (t
	   (output `(:who-is ,(ui:bytes->hex (car ask-id-list))))
	   (goto get-other-info-response))))

  (define signatures-to-send '())

  (define (signature-send exp goto)
    (cond ((null? signatures-to-send)
	   (set! to-do (delq 'signatures to-do))
	   (client-work exp goto))
	  (t
	   (let ((sig-item (car signatures-to-send)))
	     (output `(:have-a-signature 
		       ,(ui:bytes->hex (car sig-item))
		       ,(cadr sig-item)
		       (,(ui:bytes->hex (car (caddr sig-item)))
			,(cadr (caddr sig-item))
			,(ui:bytes->hex (caddr (caddr sig-item)))))))
	   (set! signatures-to-send (cdr signatures-to-send))
	   ;; We'll ignore the response, which we wouldn't change our
	   ;; behavior based on, anyway.
	   (goto signature-send))))

  (define (signature-receive exp goto)
    (cond ((receive-signature! (ui:hex->bytes (cadr exp))
			    (caddr exp) 
			    (list
			     (ui:hex->bytes (car (cadddr exp)))
			     (cadr (cadddr exp))
			     (ui:hex->bytes (caddr (cadddr exp)))))
	   (set! *ui:attestations-new* #t) ; Got a new signature.
	   (output '(:ack)))
	  (t
	   (output '(:nak never))))
    (goto server-work))

  (define attestations-to-get '())

  (define (get-attestation-response exp goto)
    (cond ((eq? (car exp) ':atts-unknown)
	   (set! attestations-to-get (cdr attestations-to-get))
	   (ask-for-attestations exp goto))
	  ((or (not (eq? (car exp) ':attestations))
	       (not (equal? (ui:hex->bytes (caddr exp))
			    (car attestations-to-get))))
	   (error exp goto))
	  (#f				; Check for malformed.
	   (malformed exp goto))
	  (t				; (:attestations-are () id list)
	   ;; [Just because we got somebody attestation is no reason to open the doors;
	   ;;  that means that -every- new contact will do so!  And yet the user won't
	   ;;  see anything new.  So only open them above, when we get a new signature.
	   ;;  We can somehow special-case this if the user asks to refresh the attestations
	   ;;  of some other Yenta, but deal w/that later.  %%% This still might be worth
	   ;;  a counter here, though.]
;	   (set! *ui:attestations-new* #t) ; Got a new attestation.
	   (for-each (lambda (att) (receive-attestation! 
				    (car attestations-to-get) att))
		     (map (lambda (att)
			    (list (car att)
				  (map (lambda (sig)
					 (list
					  (ui:hex->bytes (car sig))
					  (cadr sig)
					  (ui:hex->bytes (caddr sig))))
				       (cadr att))))
			  (cadddr exp)))
	   (set! attestations-to-get (cdr attestations-to-get))
	   (ask-for-attestations exp goto))))

  (define (ask-for-attestations exp goto)
    (cond ((null? attestations-to-get)
	   (set! to-do (delq 'attestations to-do))
	   (client-work exp goto))
	  (t
	   (output `(:get-attestations ,(ui:bytes->hex 
					(car attestations-to-get))))
	   (goto get-attestation-response))))

  (define (client-work exp goto)
    ;; exp has already been handled.
    (cond ((null? to-do)
	   (output '(:done))
	   (goto reverse-or-quit))
	  (t
	   (iy:did-to-do-items (caddr other-yenta-addr) (list (car to-do)))
	   (case (car to-do)
	     ((give-clusters) (send-clusters exp goto))
	     ((get-info) (get-info exp goto))
	     ((messages) (send-messages exp goto))
	     ((referrals) (followup-rumor exp goto))
	     ((identities) (ask-other-info exp goto))
	     ((attestations) (ask-for-attestations exp goto))
	     ((signatures) (signature-send exp goto))
	     (else 
	      ;; Log problem-- we're trying to do something we don't know to do.
	      ;; %%% [Perhaps this should log an event for the stats logger,
	      ;; %%%  or use the debugging logger?]
	      (format-debug 8 "~&Unknown work type: ~A~&" (car to-do))
	      (set! to-do (cdr to-do))	; Skip it.
	      (client-work exp goto))))))

  (define done #f) ; for (goto done)

  (define recover-resp #f) ; for now we don't recover
  (define recover #f)

  (define (malformed exp goto)
    (inc! *ctr:network-errors*)
    (output '(:nak malformed))
    (if (> retries 0)
	(set! retries (- retries 1))
	(goto #f)))

  (define (error exp goto)
    (cond ((memq (car exp) opcode-list)
	   (output '(:nak unexpected-response)))
	  ((eq? (car exp) ':error)
	   (output '(:nak bad-structure)))
	  (else
	   (output '(:nak unknown-opcode))))
    (if (> retries 0)
	(set! retries (- retries 1))
	(goto #f)))

  (define (client-version-sel exp goto)
    (cond ((not (eq? (car exp) ':this-is-also-a-Yenta))
	   (goto #f))			; The server is not a Yenta:  close.
	  ((and (pair? (cdr exp))
		(number? (cadr exp)))
	   ((select-client-version (cadr exp)) exp goto))
	  (else (malformed exp goto))))
  
  (define (info-resp exp goto)
    (cond ((or (not (= (length exp) 2))
	       (not (string? (cadr exp))))
	   (malformed exp goto))
	  (t
	   (output (identity:tell-info (ui:hex->bytes (cadr exp))))
	   (goto server-work))))

  (define (cluster-resp exp goto)
    (cond ((= (length exp) 3)
	   (let ((doc (compare:import-document (caddr exp))))
	     (cond ((not doc) 
		    (malformed exp goto))
		   ((not *interests:available*)
		    (output '(:nak later)) ; we can't actually compare now
		    (goto server-work))
		   (t
		    (let ((result (interests:match-interest-with-database doc)))
		      (cond ((> (car result) *interyenta:accept-interest-threshold*)
			     (output `(:interest-interesting ,(car result)))
			     (inc! *ctr:clusters-joined*)
			     (goto server-work))
			    (t
			     (output '(:interest-boring))
			     (interests:add-rumor doc (cadr exp)
						  other-yenta-addr)
			     (goto server-work))))))))
	   (t
	    (malformed exp goto))))
  
  (define (expect-switch exp goto)
    (case (car exp)
      ((:ack) (client-work exp goto))
      (else (error exp goto))))

  (define (send-attestations exp goto)
    (cond ((or (not (= (length exp) 2))
	       (not (string? (cadr exp))))
	   (malformed exp goto))
	  (t
	   (let* ((att-list (identity:get-attestations
			     (ui:hex->bytes (cadr exp))))
		  (hex-att-list 
		   (map (lambda (att)
			  (list (car att)
				(map (lambda (sig)
				       (list
					(ui:bytes->hex (car sig))
					(cadr sig)
					(ui:bytes->hex (caddr sig))))
				     (cadr att))))
			att-list)))
	     (inc! *ctr:atts-fetched*)
	     (output `(:attestations () ,(cadr exp) ,hex-att-list))
	     (goto server-work)))))

  ;;; Here's the server-side referral work.

  (define (accept-referral exp goto)
    (interests:handle-referral (cadr exp) (caddr exp))
    (output '(:ack))
    (goto server-work))

  (define (wanted-resp exp goto)
    (cond ((= 2 (length exp))
	   (output '(:nak unable)) ; We're not a timesharing server...
	   (goto server-work))
	  (else
	   (malformed exp goto))))

  (define (server-work exp goto)
    (case (car exp)
      ((:wanted) (wanted-resp exp goto))
      ((:who-is) (info-resp exp goto))
      ((:have-an-interest) (cluster-resp exp goto))
      ((:message-for-you) (receive-message exp goto))
      ((:get-attestations) (send-attestations exp goto))
      ((:have-a-signature) (signature-receive exp goto))
      ((:other-interested) (accept-referral exp goto))
      ((:done) (cond ((null? to-do)
		      (output '(:bye))
		      (goto #f))
		     (t
		      (output '(:reverse))
		      (goto expect-switch))))
      (else (error exp goto))))

  (define (challenge-resp exp goto)
    (cond ((not (eq? (car exp) ':challenge))
	   (error exp goto))
	  ((equal? (ssl:sha1-hash (ui:hex->bytes (cadr exp))) proved-id)
	   (output `(:challenge-ack ,(ui:bytes->hex *local-yenta-pub-key*)))
	   (goto server-work) ; goto is only for next protocol step, not flow
	   (got-identity (cadr exp))) ; this may be delayed
	  (else
	   (output '(:nak never))
	   (inc! *ctr:auth-failures*)
	   (goto #f))
	  ))

  (define (version-resp exp goto)
    (cond ((not (eq? (car exp) ':version))
	   (error exp goto))
	  ((check-versions (cdr exp)) (output `(:version-ack 
						,@*yenta-component-versions*))
				      (goto challenge-resp))
	  (else (malformed exp goto))))

  (define (select-server-version version)
    (set! proto-version version)
    (case version
      ((1) nop-then-version-resp)
      ((2) version-two-server-intro)
      (else #f)))

  (define (nop-then-version-resp exp goto)
    (goto version-resp))

  (define (version-two-server-intro exp goto)
    ;; Synchronize connection so the handshake doesn't get chewed up.
    (display "~" (car connection)) ; okay.
    (scheduler:sequences
     ((scheduler:do-with ((char (sch-read-char (car connection))
				(sch-read-char (car connection))))
			 ((or (eof-object? char)
			      (char=? char #\~)) #f)
	#t))
;     ((newline)
;      (display "$" (car connection))
;      (do ((c (read-char (car connection)) (read-char (car connection))))
;	  ((eof-object? c) #f)
;	(write c))
;      (goto done))))
      ; switch to SSL encrypted port
     ((scheduler:let* ((port (ssl:make-and-connect
			      *iy:client-ctx* (car connection) 60)))
	   (if (ssl? port)
	       (begin
		 (set-car! connection port)
		 (set! proved-id 
		       (ssl:sha1-hash
			(ssl:rsa-public-key->der-string
			 (ssl:x509->rsa-public-key
			  (ssl:peer-certificate port)))))
		 (vector-set! (caddr connection) 1
			      (let ((plain-close
				     (vector-ref (caddr connection) 1)))
				(lambda ()
				  (close-port port)
				  (plain-close))))
		 (goto version-resp))
	       (goto #f))))))

  (define (server-init exp goto)
    (cond ((not (eq? (car exp) ':this-is-a-Yenta))
	   (goto #f))			; The client is not a Yenta:  close.
	  ((and (pair? (cdr exp))
		(number? (cadr exp)))
	   (output `(:this-is-also-a-Yenta ,(min newest-version (cadr exp))))
	   ((select-server-version
	     (min newest-version (cadr exp)))
	    exp goto))
	  (t (malformed exp goto))))
	   
  (define (client-init exp goto)
    (output `(:this-is-a-Yenta ,newest-version))
    (goto client-version-sel))

  (set! connection (list con (if svr server-init client-init) con-rec))
  (set! *connections* (cons con-rec *connections*))

  connection)

(define (run-protocol connection svr)
  (let ((tcp-port (car connection)))
    (unless svr
      ((cadr connection) #f (lambda (fn) (set-car! (cdr connection) fn)))
      (newline (car connection)))
    (scheduler:loop (cadr connection)
      (scheduler:let* ((exp (sch-read-exp (car connection))))
	(format-debug 8 "~&Received via IY:~&~S~&" exp)
	(inc! *ctr:opcodes-received*)
	(set! last-exp exp)
	(vector-set! (caddr connection) 0 (current-time))
	(unless (list? exp)
	  (set! exp (list ':error exp)))
	(format-debug 8 "~&Next: ~S~&" (cadr connection))
	((cadr connection) exp (lambda (fn) (set-car! (cdr connection) fn))))
      (begin
	(counter:increment-by-zero-okay! *ctr:bytes-sent*
					 (tcp:meter-port-sent tcp-port))
	(counter:increment-by-zero-okay! *ctr:bytes-received*
			       (tcp:meter-port-read tcp-port))
	((vector-ref (caddr connection) 1))))))

(define *iy:tcp-listener* #f)		; Set by start-yenta-server.

(define (start-yenta-server)
  (set! *iy:server-ctx* (ssl:make-ctx (ssl:v23-server-method)))
  (ssl:set-verification! *iy:server-ctx* #t)
  (unless (valid-ssl-ctx? *iy:server-ctx*)
	(set! *iy:server-ctx* #f)
	;; %%% error-type-stuff: couldn't set up a context
	)
  (unless (ssl:use-rsa-private-key!
	   *iy:server-ctx*
	   (ssl:der-string->rsa-private-key *local-yenta-priv-key*))
	(set! *iy:server-ctx* #f)
	;; %%% error-type-stuff: couldn't set key
	)
  (unless (ssl:use-certificate-from-asn1-string!
	   *iy:server-ctx* *local-yenta-cert*)
	(set! *iy:server-ctx* #f)
	(format-debug 0 "arg. bad server ctx")
	;; %%% error-type-stuff: couldn't set cert
	)
  
  (let ((yenta-lsnr (tcp:listen *iy-port*)))
    (when yenta-lsnr
      (set! *iy:tcp-listener* yenta-lsnr)
      (scheduler:add-task! "InterYenta server" 2 
			   (lambda () (tcp:heard? yenta-lsnr))
			   (lambda ()
			     (let ((con (tcp:accept yenta-lsnr)))
			       (scheduler:split
				(run-protocol
				 (make-connection con #t #f '()) #t))
			       (inc! *ctr:conns-served*)))))))

;;; Okay, here's how it works internally. First, the basic code:
;;;
;;; (define (make-connection con svr)
;;;   (define con-rec (vector (current-time) (lambda () (close-port con))
;;; 			  (scheduler:current-task)))
;;;   (define connection (list con (if svr server-init client-init) con-rec))
;;;   (set! *connections* (cons con-rec *connections*))
;;;
;;;   (define (error exp goto)
;;;     ...)
;;;   (define (recover exp goto)
;;;     ...)
;;;   (define (... exp goto)
;;;     ...)
;;;   (define (server-init exp goto)
;;;     ...)
;;;   (define (client-init exp goto)
;;;     ...)
;;;
;;;   connection)
;;;
;;; (define (run-protocol connection)
;;;   (scheduler:loop (cadr connection)
;;;     (scheduler:let* ((exp (sch-read-exp (car connection))))
;;;       (vector-set! (caddr connection) 0 (current-time))
;;;       ((cadr connection) exp (lambda (fn) (set-car! (cdr connection) fn))))
;;;     ((vector-ref (caddr connection) 1))))
;;
;;; con-rec is a vector: #(time close-proc task)
;;; connection is a list: (con next-step con-rec)
;;; *connections* is a list of con-recs, used to close dead connections.
;;
;;; So run-protocol:
;;; loops as long as the next step is not #f
;;;  when it's not, reads (non-blocking) an expression into exp
;;;                 sets the time in con-rec to now
;;;                 calls next-step with the expression and a procedure
;;;                  which will set next-step to its argument.
;;;  when it is, calls close-proc.
;;;
;;; Don't try to think about the order things get evaluated in. It's just too
;;; complicated at that level. You'll just get lost. :/

;;; End of file.
