;; SUI
;; 6.891 Spring 2006
;;
;; XHTML/AJAX server
;;
;; $Id: suid.scm 71 2006-05-17 19:38:07Z nelhage $

(load "widgets.scm")
(load "layouts.scm")
(load "events.scm")

(define ((wrap-content key) . content)
  (flatten-append "\n"
                  "<" key (if (car content)
                              (map (lambda (x) (list " " (first x)
                                                "=\"" (second x) "\""))
                                   (car content))
                              "") ">"
                  (cdr content)
                  "</" key ">"))


(define (flatten-append . pieces)
  (apply string-append
         (map (lambda (piece)
                (cond ((string? piece) piece)
              ((symbol? piece) (symbol->string piece))
                      ((number? piece) (number->string piece))
                      ((list? piece) (apply flatten-append piece))
                      (else
                       (error "Unknown piece type: flatten-append"
                              piece))))
              pieces)))

(define (css alist)
  (flatten-append
   (map (lambda (x)
          (list (first x) ":"
                (second x) ";"))
        alist)))

(define (dquote thing) (flatten-append "\"" thing "\""))

(define x-html (wrap-content "html"))
(define x-body (wrap-content "body"))
(define x-head (wrap-content "head"))
(define x-title (wrap-content "title"))
(define x-div (wrap-content "div"))
(define x-input (wrap-content "input"))
(define x-form (wrap-content "form"))

(define *root-frame* #f)

(define server-socket #f)

(define (wait-and-accept)
  (if server-socket
      (close-tcp-server-socket server-socket))
  (let ((srvsock (open-tcp-server-socket "rplay")))
    (set! server-socket srvsock)
    (define (loop)
      (let ((ioport (tcp-server-connection-accept srvsock #t #f)))
        (let ((input (read-line ioport)))
          (cond ((equal? input "init") (cmd-init ioport))
                ((equal? input "resp") (cmd-resp ioport))
                ((equal? input "done") (cmd-done ioport))))

        (newline ioport)
        (write-string "END" ioport)
        (newline ioport)
        (flush-output ioport)
        (close-port ioport)
        (loop)))
    (loop)))

(define (cmd-init ioport)
  (write-string (make-html) ioport))

(define (ajax-magic . ids)
  (string-append "ajax_magic(['" (reduce (lambda (lhs rhs)
                                           (string-append lhs "','" rhs))
                                         "" ids)
                 "']" ",['entirebody'], 'POST'); return false"))

(define (schemejax-doc . content)
  (x-html #f (x-head #f
                     (x-title #f (frame-title *root-frame*)))
          (x-div `((id "entirebody")) content)))

(define (make-html)
  (schemejax-doc (make-body)))

(define (make-body)  
  (x-body #f (xhtml-types-hidden)
          (x-form `((action  "#"))
                  (xhtml-draw-widget *root-frame*))))

(define (cmd-resp ioport)
  (let* ((args (collect-args ioport))
         (initiator-id (string->symbol (car args)))
         (event-type (cadr args)))
    (update-gui *root-frame* (cddr args))
    ;; XXX: ignore event type for now and assume only buttons get events
    ((button-onclick (find-widget-named *root-frame* initiator-id))
     (make-mouseclick *root-frame* 'left))
    (write-string (make-body) ioport)))

(define *delim-char* #\:)

(define (collect-args ioport)
  (if (char=? (peek-char ioport) *delim-char*) (read-char ioport))
  (let ((curarg (read-string (char-set *delim-char*) ioport)))
    (if (string=? "END" curarg) '()
        (cons curarg (collect-args ioport)))))

(define (cmd-done ioport)
  (close-tcp-server-socket server-socket)
  (exit))

(define-generic xhtml-draw-widget (widget))

(define-generic xhtml-draw-internal (widget))

(define-method xhtml-draw-widget ((container <container>))
  (flatten-append (map
                   (lambda (widget)
                     (xhtml-draw-widget widget))
                   (container-contents container))))

(define *renderable-widgets* (list <button> <textbox>))

(define (widget-renderable? widget)
  (let ((widget-type (object-class widget)))
    (there-exists? *renderable-widgets*
                   (lambda (type)
                     (eq? widget-type type)))))

(define (all-renderable-widgets)
  (keep-matching-items (all-widgets *root-frame*)
                       widget-renderable?))

(define (allids)
  (map (lambda (widget)
         (symbol->string (widget-name widget)))
       (all-renderable-widgets)))
   
(define (xhtml-types-hidden)
  (let lp ((types (alltypes)))
	(if (null? types)
	    ""
        (string-append (hidden-div (car types))
                       (lp (cdr types))))))

(define (alltypes)
  '("onClick"))

(define (meta id) (flatten-append "meta" id))
(define (hidden-div id) (x-input `((type hidden) (id ,(meta id)) (value ,id)) ""))

(define-method xhtml-draw-widget ((widget <widget>))
  (string-append
   (hidden-div (widget-name widget))
   (x-div `((style
                ,(css `((top ,(widget-absolute-y widget)) (left ,(widget-absolute-x widget))
                        (width ,(widget-width widget)) (height ,(widget-height widget))
                        (position absolute)))))
          (xhtml-draw-internal widget))))

(define-method xhtml-draw-internal ((button <button>))
  (x-input `((type "submit")
			 (name ,(widget-name button))
			 (id ,(widget-name button))
			 (value ,(button-label button))
			 (onClick ,(apply ajax-magic (meta (widget-name button)) (meta "onClick") (allids))))))

(define-method xhtml-draw-internal ((textbox <textbox>))
  (x-input `((type "text")
             (name ,(widget-name textbox))
             (id ,(widget-name textbox))
             (value ,(textbox-text textbox)))))

(define-generic update-widget (widget newval))

(define-method update-widget ((button <button>)
                              newval)
  (set-button-label! button newval))

(define-method update-widget ((textbox <textbox>)
                              newval)
  (set-textbox-text! textbox newval))

(define (update-gui frame newvals)
  (let loop ((widgets (all-renderable-widgets))
             (newvals newvals))
    (if (null? widgets)
        unspecific
        (begin
          (update-widget (car widgets) (car newvals))
          (loop (cdr widgets) (cdr newvals))))))

(define (ajax-draw-gui frame)
  (fluid-let ((*root-frame* frame))
    (wait-and-accept)))