(yreq "Utilities/yenta-utils")
(yreq "UI/preloading-pages")		; Just in case.

;;; This gets set to #f once we've told the user for the first time to aim
;;; their browser at the HTTP server, and -never reset-.  Not even the next
;;; time we come up!  After all, except for the very first time, we shouldn't
;;; be asking the user for anything via an insecure channel, and we should be
;;; running in the background.  This exists mostly to catch coding errors---
;;; if some piece of code is running when it -thinks- it should have the
;;; keyboard, but it doesn't, we should probably know about it, and we
;;; -certainly- shouldn't hang.
(def-yenta-var *ui:keyboard-available* #t)

;;; 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 ui:base-http-port 15000)

(define (permit ip port) #t)
;(string=? ip "127.0.0.1"))

(define (check-cert cert) #t)

(defvar ui:data #f)

(defvar ui:headers #f)

(defvar ui:index #f)

(define (ui:header-datum name)
  (if ui:headers
      (let ((match (assoc name ui:headers)))
	(if match (cdr match) #f))
      #f))

(define (ui:from-form?)
  (if ui:data
      #t
      #f))

(define (ui:form-items)			; This doesn't seem to get called anywhere.
  (if ui:data
      (map car ui:data)
      '()))

(define (ui:form-datum name)
  (if ui:data
      (let ((match (assoc name ui:data)))
	(if match (cdr match)
	    #f)) ; no match
      #f)) ; no form data

(define ui:name-procs
  (begin
    (define (filename data con close-proc)
      data)
    (define (proc-name data con close-proc)
      (data con close-proc))
    (define (proc data con close-proc)
      (car data))
;      (data con close-proc)
;      #f)
    (define (form-response data con close-proc)
      (cond ((and ui:data
		  (for-all? (lambda (name)
			      (if (pair? name)
				  (let ((val (assoc (car name) ui:data)))
				    (and val
					 ((cadr name) (cdr val))))
				  (assoc name ui:data)))
			    (cddr data)))
	     (car data))
	    (t
	     (set! ui:index (cadr data))
	     "inv-form-resp.html")))
    (define (index-req data con close-proc)
      (cond ((and ui:index
		  (or (null? (cddr data))
		      ((caddr data) ui:index)))
	     (car data))
	    (t
	     (set! ui:index (cadr data))
	     "inv-form-resp.html")))
    `((filename . ,filename) (proc-name . ,proc-name) (proc . ,proc)
			     (form-response . ,form-response)
			     (index-req . ,index-req))))

(define ui:serve-procs
  (begin
    (define (as-is data)
      (list data))
    (define text as-is)
    (define (scheme data)
      (data))
    (define (scheme-source data)
      (let ((res (map eval data)))
;	(write data)
;	(newline)
;	(write res)
;	(newline)
	res))
    `((scheme-source . ,scheme-source) (as-is . ,as-is) (text . ,text)
				       (scheme . ,scheme))))

#|
(define ui:filter-procs
  (begin
    (define (pretty-list lst start-tag end-tag)
      (flatten
       (cons start-tag
	    (append
	     (map (lambda (elt) (list "<li>" elt "</li>"))
		  lst)
	     (list end-tag)))))
    (define (pretty-lists lst)
      (flatten (map (lambda (elt) 
		      (if (list? elt) 
			  (pretty-list elt "<ul>" "</ul>")
			  elt))
		    lst)))      
    (define (pretty-ordered-lists lst)
      (flatten (map (lambda (elt) 
		      (if (list? elt) 
			  (pretty-list elt "<ol>" "</ol>")
			  elt))
		    lst)))
    `((flatten . ,flatten) (pretty-lists . ,pretty-lists) 
			 (pretty-ordered-lists . ,pretty-ordered-lists))))
|#

(define ui:output-procs
  (begin
    (define (as-is lst con)
      (let* ((data-list
	      (map (lambda (obj)
		     (call-with-output-string
		       (lambda (port)
			 (display obj port))))
		   lst))
	     (data-string (join-strings data-list "")) ; Pity we can't use the length result from join-strings, ...
	     (data-length (string-length data-string))) ; ... but it's not worth making a special-purpose version just for here.
	(display "Content-Length: " con)
	(display data-length con)
	(display "\r\n\r\n" con)
	(display data-string con)))
    (define (text lst con)
      (as-is (map (lambda (elt)
		    (if (string? elt)
			(string-edit "\n" "\r\n" elt #t)
			elt))
		  (leaves lst)) con))
    (define scheme-source text)
    (define scheme text)
    `((as-is . ,as-is) (text . ,text) (scheme-source . ,scheme-source)
		       (scheme . ,scheme))))

(define (send-headers mime-type con)
  (display "HTTP/1.0 200 OK\r\nContent-Type: " con)
  (display mime-type con)
  (display "\r\n" con))

;;; Some belated documentation for this, derived from reading the code.
;;; The old behavior was that a proc-name method MUST return #f (only!
;;; -not- #<unspecified>!) if it was handling the request itself, and
;;; didn't want to try to serve a page.  The new behavior explicitly
;;; disallows anything but a string as being a "page", e.g., it assumes
;;; that *ui-file-list* is keyed by strings only, and that any non-string
;;; means to punt the lookup.  Also, this version ERRS you if you screw
;;; up and specify some name that doesn't exist, instead of just falling
;;; off the end and therefore acting mysteriously.
(define (use-methods pagespec con close-proc)
  (let ((name ((seaq (cadr pagespec) ui:name-procs)
	       (caddr pagespec) con close-proc)))
    ;; Name (e.g., returned value from the proc-name we just ran) MUST BE A STRING if you expect any further processing to happen.
    (when (string? name)
      (let ((filespec (assoc name *ui-file-list*)))
	(cond (filespec
	       (let ((methodspec (cadr filespec)))
		 ;; Special-case kluge to enable deactivation of the links in the quit page.
		 ;; Must happen here so we generate the right on-the-fly HTML when making up the page.
		 (when (eq? (cdr methodspec) 'final)
		   (set! *sk:wrap-href-disable* t))
		 ;; Okay, now it's safe to generate the page.
		 (let ((pagedata ((seaq (caadr filespec) ui:serve-procs)
				  (cadddr filespec))))
		   (when (string? (caddr filespec))
		     (send-headers (caddr filespec) con))
		   ((seaq (car methodspec) ui:output-procs)
		    pagedata con)
		   (close-proc)
		   (when (eq? (cdr methodspec) 'final)
		     (yenta-exit)))))
	      (t
	       (error "Couldn't find ~S in *ui-file-list*" name)))))))
    
(define (reject-page name con close-proc)
  (format con "HTTP/1.0 404 Not Found~&~
               Content-Type: text/html~2&~
               <title>Page not found</title>~2&~
               <b><i>The page ~A does not exist.</i><p>~2&~
               If you typed in a URL by hand and came here, please check the URL and try again.<p>~2&~
               If you got here by clicking on some link in Yenta, then you have encountered a bug.<br>~&~
               Please <a href=\"bug-reports.html\">report it</a>, including as much detail as you can.  Thanks.<b><p>~&"
	  name)
  (close-proc))

(define (search a alist)
  (let ((val (assoc a alist)))
    (if val
	(cdr val)
	#f)))

(define (assoc2 item lstlst)
  (cond ((null? lstlst) #f)
	((member item (caar lstlst)) (car lstlst))
	(else (assoc2 item (cdr lstlst)))))

;;;; Authentication issues.

(defvar *current-authenticated-session* #f) ; This is either #f or the actual session that we have authenticated.
(defvar *authentic-sessions* '())

;;; Yuck, but I'm not sure there's a better way...  Set in check-authentication & used in ui:front-page-contents.
;;; Other approaches require a complicated state machine...
(defvar *last-ssl* #f)

;;; This checks to see if SSL is from the session that most recently
;;; authenticated.  There is also a special case check for returning the
;;; authentication form, so you can authenticate yourself without
;;; having been authenticated.  In addition, the startup page is
;;; available without authentication when you're first starting up---we
;;; need to figure out how to make sure the person who gets to set the
;;; passphrase at the beginning is actually the user who's running the
;;; Yenta.  Finally, to be able to serve any icons, we also consult
;;; ui:safe-url?
(define (check-authentication request ssl)
; (format-debug 8 "~%check-authentication: ~S" (cadr request))
; (format-debug 8 "~%check-authentication: ~S" (ssl:session ssl))
  (set! *last-ssl* ssl)
  (cond ((equal? (cadr request) "/authenticate-response.html")
	 ;; There's a race condition on this that I want to crush:
	 ;; If the page for checking the authentication is being served
	 ;; so the authentication is being checked, someone else ought not
	 ;; to be able to change which session is being checked.
	 ;; The down side is that if you submit an authenticate page at the
	 ;; same time that someone else does, you have to retype your
	 ;; passphrase.  This is a bit annoying, but won't happen unless you're
	 ;; being attacked, almost certainly.  It also doesn't open a security
	 ;; hole.
	 (cond (*current-authenticated-session*
		#f)
	       (t
		(set! *current-authenticated-session* (ssl:session ssl))
		#t)))
	(t
	 (cond ((or (member (ssl:session->der-string (ssl:session ssl))	; %%% if (ssl:session ssl) isn't valid, s->d-s can bus error.  should catch.
			    *authentic-sessions*)
		    (ui:safe-url? (cadr request)))
		#t)
	       (t
		#f)))))

;;; Called from index.scm and authenticate-response.scm.
(define (ui:note-session-authenticity judgement)
  (when judgement
    (push! (ssl:session->der-string *current-authenticated-session*) *authentic-sessions*))
  (set! *current-authenticated-session* #f)
  "")					; Don't actually emit anything to the page.

;;; Takes a request for a page, returns a request for the authentication page,
;;; with the original request as the place to go afterwards.  This turns:
;;;
;;; {method} {url} {version}
;;; headers...
;;;
;;; {form data}
;;;
;;; into the request that would come from:
;;;
;;; <form method = GET action = "authenticate.html">
;;; <input type = hidden name = "original URL" value = {url}>
;;; <input type = hidden name = "original method" value = {method}>
;;; <input type = hidden name = "original values" value = {form data}>
;;; </form>
;;;
;;; ...except that the "original values" stuff is in a list structure,
;;; rather than a string.
(define (authenticate-first request)
  (format-debug 8 "~%authenticate-first: ~S~&" request)
  (list "GET"				; method
	"/authenticate.html"		; URL
	(caddr request)			; version
	(list				; headers
	 "HTTPD Values"
	 (cons "original URL" (cadr request))
	 (cons "original method" (car request))
	 (cons "original values" (assoc "HTTPD Values" (cdddr request))))))

;;; This is #f until the user has seen enough pages of the pitch that we think
;;; he's likely to be able to understand Yenta well enough to use it.  It's then
;;; set to #t by ui:pitch-has-been-seen, which is included on later pages, and
;;; informs "respond" whether to give the user the intro to the form, or more pitch pages.
(defvar *ui:pitch-seen?* #f)

;;; The URL we should fetch to get the pitch rolling.
(define *ui:pitch-initial-url* "/help-pitch0.html")

(define (ui:pitch-has-been-seen more-pages?)
  (cond ((eq? *ui:startup-state* 'brand-new-yenta) ; If we're a brand-new Yenta, then stuff stuff applies.
	 (set! *ui:pitch-seen?* #t)	; Allow the user to fetch the form.
	 (format nil			; Stolen from alerts:box, with a different color.
		 "<div align=\"center\"><table align=\"center\" bgcolor=\"lightgreen\" border=\"0\" cellspacing=\"5\" width=\"100%\">~
		  <tr><td><b>~A</b></td></tr></table></div><p>"
		 (format nil 
			 "You've now read enough that you can start to use Yenta.~&~
			  Feel free to <a href=\"/\">start it up</a>~:[~;, or keep reading~&~
			  another handful of pages for more background~].  (You can also~&~
			  go backwards and revisit some of the pages you've already seen~&~
                          if you like.  Once Yenta has started, all of these pages are~&~
                          available from Yenta's help system whenever you want.)"
			 more-pages?)))
	(t
	 "")))				; Not a brand-new Yenta, so don't say anything.

;;; Allow skipping the pitch if this is a devo world.  Note that the setting of *ui:pitch-seen?* below means
;;; that a devo world is more flexible about what page fetches are allow, even if the link is -not- followed...
(define (ui:skip-pitch-if-devo)
  (cond (*wb:developer-world*
	 (set! *ui:pitch-seen?* #t)
	 "<div align=\"center\"><h1>[<a href=\"/\">Devo Yenta:  Skip directly to the initial form</a>]</h1></div>")
	(t "")))

(define (respond request con close-proc)
  (let ((authorized? (check-authentication request con))
	(url (cadr request)))
;   (format-debug 0 "~&Original request was ~S~&" url)
    (cond ((ui:safe-url? url)		; Allow serving images, etc.
	   nil)
	  (authorized?
	   (cond ((eq? *ui:startup-state* 'scanning) ; We're starting up and scanning files.  [Scanning at other times still leaves normal Yenta UI.]
		  (set-car! (cdr request) "/"))	; While scanning, all unsafe URL's serve /.
		 (t			; This is the normal case when the UI is up and scanning is done.
		  nil)))
	  (t				; Not yet authorized.  Could be a brand-new Yenta, or new session.
	   (cond ((eq? *ui:startup-state* 'brand-new-yenta) ; Brand new.  Force all unauthorized URL's to be "/", unless we're pitching.
		  (cond ((ui:safe-in-brand-new-url? url) ; If this is a pitch page, just serve it.
			 nil)
			(t
			 (cond (*ui:pitch-seen?* ; If the pitch has been seen, and the user requested something random (not a pitch), serve /.
				(set-car! (cdr request) "/")) ; [This will also force "/" to "/" again, but that's okay---we'll serve it now.]
			       (t	; If the pitch hasn't been seen, start at the beginning.  It will offer "/" to escape on some later page.
				(set-car! (cdr request) *ui:pitch-initial-url*))))))
		 (t			; Unauthorized, but not a brand-new Yenta:  force the user to supply a passphrase, and read persistent state.
		  (set! request (authenticate-first request))))))
;   (format-debug 0 "~&Responding with ~S~&" (cadr request))
    (do-respond request con close-proc)))

(define (do-respond request con close-proc)
  (let ((page (assoc2 (cadr request) *ui-pages*))
	(data (assoc "HTTPD Values" (cdddr request)))
	(index (assoc "HTTPD Index" (cdddr request))))
    (set! ui:headers (cdddr request))
    (if data 
	(set! ui:data (cdr data))
	(set! ui:data #f))
    (if index
	(set! ui:index (cadr index)) ; There is always no more than one index.
	(set! ui:index #f))
    (if page
	(use-methods page con close-proc)
	(reject-page (cadr request) con close-proc))))

;;;; Finding an available HTTP port, and telling the user about it.

;;; We need these because the URL must be repeated, for visibility,
;;; as the last thing the user sees before the shell prompt.  (User
;;; testing as revealed that some users can fail to actually -notice-
;;; a big box of asterisks.)  But we don't have the data from the call
;;; to ui:compute-available-httpd-port at that point.  This is a gross
;;; but quick way to fix this.
(defvar *ui:cached-host* #f)
(defvar *ui:cached-port* #f)
(define (ui:cache-url-info host port)
  (set! *ui:cached-host* host)
  (set! *ui:cached-port* port))

(define (ui:url-only-string)		; You must have called ui:cache-url-info first!
  (format nil "http~:[~;s~]://~A:~A/"
	  *httpd:use-ssl* *ui:cached-host* *ui:cached-port*))

(define (ui:display-url-banner)		; You must have called ui:cache-url-info first!
  (let* ((instructions (format nil "Please aim your browser at ~A" (ui:url-only-string)))
	 (padding 2)
	 (minwidth (+ (string-length instructions) (* 2 (1+ padding))))
	 (callout #\*)
	 (banner (make-string minwidth callout))
	 (whitespace (make-string padding #\Space))
	 (end-to-end (make-string (- minwidth 2) #\Space)))
    (format t "~&~A~&~A~A~A~&~A~A~A~A~A~&~A~A~A~&~A~&"
	    banner
	    callout end-to-end callout
	    callout whitespace instructions whitespace callout
	    callout end-to-end callout
	    banner)))

(define (ui:compute-available-httpd-port)
  (do ((portnum ui:base-http-port (+ portnum 1)))
      ((httpd:httpd portnum permit check-cert respond)
       (ui:cache-url-info (local-host) portnum)
       (ui:display-url-banner)
       (set! *ui:keyboard-available* #f)))) ; We don't have a keyboard ever again...

(define (ui:warn-about-certs)
  (format t "~2&Your browser will probably complain that it doesn't recognize either the~&~
                certificate Yenta presents or the certificate authority that generated it.~&~
                This behavior is normal; Yenta is using a certificate it just generated~&~
                with no help from any known certificate authority.  You can safely tell~&~
                your browser to trust the certificate.  If you'd like to check this, its~&~
                MD5 fingerprint is ~A.~2&"
	    (ssl:x509-md5-fingerprint (ssl:der-string->x509 *httpd:cert*))))

;;;; Dead code.

;(def-yenta-var *yenta:output-file* (yenta-name "yenta.out"))
;(def-yenta-var *yenta:error-file* (yenta-name "yenta.err"))
;(def-yenta-var *yenta:input-file* "/dev/null")
;
;(let ((old-input-port (current-input-port))
;      (old-output-port (current-output-port))
;      (old-error-port (current-error-port))
;      ;; Using "a" is an abstraction violation, but I don't see a good
;      ;; alternative.
;      (new-input-port (open-input-file *yenta:input-file*))
;      (new-output-port (open-file *yenta:output-file* "a"))
;      (new-error-port (open-file *yenta:error-file* "a")))
;  (set-current-input-port new-input-port)
;  (set-current-output-port new-output-port)
;  (set-current-error-port new-error-port)
;  (close-port old-input-port)
;  (close-port old-output-port)
;  (close-port old-error-port))
;(setsid)

; (define (authenticate-first request)	; %%%% What a nutty way to build this list...
;   (format-debug 8 "~%~S~&" request)
;   (cons "GET" ; method
; 	(cons "/authenticate.html" ; URL
; 	      (cons (caddr request) ; version
; 		    (list ; headers
; 		     (cons "HTTPD Values"
; 			   (list
; 			    (cons "original URL" (cadr request))
; 			    (cons "original method" (car request))
; 			    (cons "original values" (assoc "HTTPD Values"
; 							   (cdddr request))))))))))

;;; End of file.
