(use iup)
(use srfi-18)
(use tcp)
(use irregex)

(define xoid
  (let ((l '(("dienste" . A53ef7bc7b867017a9b97f36ad7020240)))
	(c 'A00000000000000000000000000000001))
    (lambda x
      (if (pair? x)
	  (let ((h (assoc (car x) l)))
	    (if (pair? h) (set! c (cdr h)))))
      c)))

(module
 iubserver
 (iubserver-verbose
  make-observable connect! disconnect! value value-set! iup-connected)
 (import scheme chicken iup-base srfi-1 (only extras format) (only data-structures identity))
 ;; The first part is rather questionable if not outright stupid.
 (define-values (next-iubserver-handle new-iubserver-handle)
   (let ((n 0))
     (values
      (lambda () n)
      (lambda (proc) (let ((r (proc n))) (set! n (add1 n)) r)))))
 (define *observers* '())
 (define (*observer-add! k v) (set! *observers* (alist-cons k v *observers*)))
 (define (*observer-delete! k)
   (and-let*
    ((e (assoc k *observers*)))
    (set! *observers* (delete! e *observers*))
    (cdr e)))
 
 (define-record <iobserver> receiver)

 (define (finalize-observer x)
   (and-let* ((f (*observer-delete! (<iobserver>-receiver x)))) (f x)))
 
 (define (make-observer receiver . key+finalizer)
   (let ((x (make-<iobserver> receiver))
	 (key (if (pair? key+finalizer) (car key+finalizer) receiver))
	 (final (cond ((and-let* (((pair? key+finalizer))
				  (finalizer? (car key+finalizer))
				  ((pair? finalizer?)))
				 finalizer?)
		       => car)
		      (else identity))))
     (*observer-add! key final)
     (set-finalizer! x finalize-observer)
     x))
 
 (define-record <iobservable> name value converter receivers)
 (define-record-printer (<iobservable> x out)
   (format out "<iobservable ~a ~a>" (<iobservable>-name x) (<iobservable>-receivers x)))

 (define (make-observable name initial . proc)
   (make-<iobservable> name initial (and (pair? proc) (car proc)) '()))
 
 (define (connect! source receiver)
   (let ((receiver (if (<iobserver>? receiver) (<iobserver>-receiver receiver) receiver)))
     (<iobservable>-receivers-set! source (cons receiver (<iobservable>-receivers source)))
     (receiver receiver (<iobservable>-value source)))
   source)

 (define (disconnect! source receiver)
   (let ((receiver (if (<iobserver>? receiver) (<iobserver>-receiver receiver) receiver)))
     (<iobservable>-receivers-set! source (delete receiver (<iobservable>-receivers source))))
   source)

 (define (value record) (<iobservable>-value record))

 (define iubserver-verbose #f)
 
 (define (value-set! record new)
   (let* ((old (<iobservable>-value record))
	  (new (if (<iobservable>-converter record) ((<iobservable>-converter record) old new)
		   (if (equal? old new) old new))))
     (if (eq? old new)
	 (begin
	   (if iubserver-verbose (format (current-error-port) "Warning: ignored update on ~a\n" record))
	   #f)
	 (let ((new (force new)))
	   (<iobservable>-value-set! record new)
	   (for-each
	    (lambda (receiver) (receiver receiver new))
	    (<iobservable>-receivers record))
	   old))))

(define (finalize-iobserver handle)
  (and-let* ((nm (handle-name handle))
	     (f (*observer-delete! nm)))
	    (f handle)))

(define (cons-iobserver-receiver nm receiver)
  (lambda (self v)
    (let ((handle (handle-ref nm)))
      (receiver self handle v)
      (refresh handle))))

(define (cons-iobserver-finalizer nm source receiver)
  (lambda (x) (disconnect! source receiver) (destroy! x)))

 (define (iup-connected source receiver constructor . args)
   (let ((nm (new-iubserver-handle (lambda (x) (format "~a#42.iobserver" x))))
	 (handle (apply constructor args)))
     (handle-name-set! handle nm)
     (connect! source (cons-iobserver-receiver nm receiver))
     (*observer-add! nm (cons-iobserver-finalizer nm source receiver))
     (set-finalizer! handle finalize-iobserver)
     handle))

 
 ) (import iubserver)

(begin
  ;; Set timer to 25Hz for smoot updates.  Beware: I have not yet
  ;; found a way do unblock iup by i/o.  Don't run time critical code
  ;; in the same pthread as iup.  Since iup is currently fixed to the
  ;; chicken thread, this means time critical code should go into it's
  ;; own executable.
  (attribute-set! thread-watchdog 'run #f)
  (attribute-set! thread-watchdog 'time 50)
  (attribute-set! thread-watchdog 'run #t))

(module
 dbg *
 (import scheme chicken extras iup)
 (import (only ports call-with-output-string))
 (import (only srfi-18 current-thread))
 (define (debug l v) (format (current-error-port) "D ~a: ~s\n" l v) v)
 (define (message title value)
   (show (message-dialog title: title value: value) #:modal? #t))
 (define (error-message title value . text)
   (show (dialog
	  (let ((ok (button title: '&OK action: (lambda (h) 'close))))
	    (if (pair? text)
		(apply
		 vbox
		 `(,(label title: value)
		   ,@(map (lambda (text) (textbox expand: #t multiline: #t readonly: #t value: text)) text)
		   ,ok))
		(vbox value ok)))
	  size: 'HALFxQUARTER
	  title: title)
	 #:modal? #t))
 (define (gandle-exceptions-dialog title source ex)
   (error-message title (call-with-output-string (lambda (to) (print-error-message ex to title))) (force source)) '())
 (define (gandle*-exceptions-dialog title source ex)
   (error-message
    title
    (call-with-output-string (lambda (to) (print-error-message ex to title) (print-call-chain to 0 (current-thread)))) (force source))
   '())
 (define-syntax gandle-exceptions
   (syntax-rules ()
     ((_ title source body ...)
      (handle-exceptions ex (gandle-exceptions-dialog title source ex) body ...))))
  (define-syntax gandle*-exceptions
   (syntax-rules ()
     ((_ title source body ...)
      (handle-exceptions ex (gandle*-exceptions-dialog title source ex) body ...))))
 )

(import dbg)


;; As this is only the GUI, we need a connection to the actual process.

(module
 ask-client
 (&begin order&!
  ask-global-server
  ask-connect-global
  )
 (import dbg scheme chicken srfi-18 irregex tcp extras)

 (define (order&! thunk name) (thread-start! (make-thread thunk name)))
 (define-syntax &begin (syntax-rules () ((_ body ...) (order&! (lambda () body ...) "&begin"))))


 (define-record ask-conn mux to from)
 (define ask-g-conn (make-ask-conn (make-mutex 'ask) #f #f))
 (define (ask-connected? conn) (ask-conn-to conn))
(define ask-port 7172)
(define gui-reply-re (irregex "[+*] (?:(?:TAGNYI)|(?:HELLO)) ([[:digit:]]+)"))

(define-syntax with-mutex
  (syntax-rules ()
    ((_ mux body ...)
     (dynamic-wind
	 (lambda () (mutex-lock! mux))
	 (lambda () body ...)
	 (lambda () (mutex-unlock! mux))))))

(define (%ask-close conn)
  (handle-exceptions ex #f (close-input-port (ask-conn-from conn)))
  (ask-conn-from-set! conn #t)
  (handle-exceptions ex #f (close-output-port (ask-conn-to conn)))
  (ask-conn-to-set! conn #t))

(define (ask-read conn)
  (let ((line (read-line (ask-conn-from conn))))
    (if (eof-object? line)
	(begin (%ask-close conn) line)
	(let* ((m (irregex-match gui-reply-re line))
	       (l (string->number (irregex-match-substring m 1)))
	       (s (read-string l (ask-conn-from conn))))
	  (if (> (string-length s) 0) (read-line (ask-conn-from conn)))
	  s))))

(define (ask-global-server s)
  (if (ask-connected? ask-g-conn)
      (with-mutex
       (ask-conn-mux ask-g-conn)
	;;handle-exceptions
       #;ex #;(let ((to (current-error-port)))
	    (print-error-message ex to "Running Exception")
	    (format to "In: ~a" s)
	    (print-call-chain to 0 (current-thread))
	    (raise ex))
	#;(debug 'writing s)
	(define ask-to (ask-conn-to ask-g-conn))
       (display s ask-to)
       (newline ask-to) (newline ask-to)
       (newline ask-to)
       (flush-output ask-to)
       (ask-read ask-g-conn))
      "not connected"))

(define (ask-connect-global)
  (with-mutex
   (ask-conn-mux ask-g-conn)
   (%ask-close ask-g-conn)
   (receive
    (in out) (tcp-connect "127.0.0.1" ask-port)
    (ask-conn-to-set! ask-g-conn out)
    (ask-conn-from-set! ask-g-conn in)
    (if (not (equal? (ask-read ask-g-conn) ""))
	(%ask-close ask-g-conn)))))

(&begin (handle-exceptions ex #f (ask-connect-global)))

) (import ask-client)

;; The GUI.

(module
 ask-state&control
 *
 (import dbg scheme chicken ask-client ports iup)
 (import (only srfi-18 current-thread) extras)
 (import iubserver)
 
;; actions (to be used in callbacks)

(define (eval-input-text input-text result status)
  (value-set! status "Running in GUI...")
  (let* ((s (attribute input-text value:))
	 (r (call-with-output-string
	     (lambda (to)
	       (handle-exceptions
		ex
		(begin
		  (print-error-message ex to "Exception")
		  (print-call-chain to 0 (current-thread)))
		(write (eval (call-with-input-string s read)) to) )))))
    (value-set! result r)
    (value-set! status "GUI result")
    'default))

(define (ask-input-text input-string result status)
  (value-set! status "Running...")
  (&begin
   (value-set! result (ask-global-server input-string))
   (value-set! status "Target result"))
  'default)

(define (apply-ask-converter c r)
  (call-with-output-string
   (lambda (to)
     (handle-exceptions
      ex (format to "Exception ~a in ~a" ex r)
      (case c
	((1) (display r to))
	(else ((case c
		 ((2) display)
		 ((3) write)
		 (else display))
	       (call-with-input-string r read)
	       to)))))))

) (import ask-state&control)

(module
 ask-hosts
 (current-host
  set-host-by-number! set-host-by-name! host-list set-known-hosts!
  current-hostname current-hostnick current-hostfull
  host->nick)
 (import dbg scheme chicken iup iubserver extras ask-client)
 (import srfi-1)

(define known-hosts
  (make-observable
   'known-hosts
   '(
     (A9f7ce54ad83cb8ca6bd8e6e1381a3acc "jfw" "localhost")
     (A00000000000000000000000000000001 "login" "login.softeyes.net")
     (A1fd7da541edc7639a5a895fd412af911 "A1fd" "unknown.softeyes.net")
     (A676f87bc71d5ba036887a23c8d3e039e "peanut" "peanut.softeyes.net")
     (A6b8811b7316d3478c1cf31fdf6729f3e "sth" "sth.softeyes.net")
     (A6b4d4edd80044de521eaeeb3893bc663 "isstvan" "isstvan.softeyes.net")
     (A842a2ba0b1ed2ecae19114170c0e0b31 "bublu" "butteblume.softeyes.net")
     (Aef0d978f436fb1ff96bdf0b273e983af "zt300" "ZT300.softeyes.net")
     (Af051fe01ba259f25aae185d500b3d6a2 "anle" "cl.softeyes.net")
     (Af4aad764b0fb48d49089dbe7880b1a03 "pea" "pea.softeyes.net")
     ("askemos2.tc-mw.de" "unil" "askemos2.softeyes.net")
     )))

(define (host->index x)
  (let loop ((i 1) (hs (value known-hosts)))
    (cond
     ((null? hs) #f)
     ((equal? x (caar hs)) i)
     (else (loop (add1 i) (cdr hs))))))

(define (host->nick x)
  (or (and-let* ((e (assoc x (value known-hosts)))) (cadr e))
      (and-let* ((e (assoc (string->symbol x) (value known-hosts)))) (cadr e))))

(define current-host
  (make-observable
   'current-host
   '(none "none" "none")
   (lambda (old-host current-host)
     (if (equal? old-host current-host)
	 old-host
	 (begin
	   (ask-global-server (if (string? (car current-host))
				  (format "q \"~a\""  (car current-host))
				  (format "q '~a"  (car current-host))))
	   current-host)))))

(define (set-host-by-number! n)
  (value-set! current-host (list-ref (value known-hosts) n)))

(define (set-host-by-name! x)
  (let ((n (host->index x)))
    (and n (set-host-by-number! n))))

(set-host-by-number! 0)

(define (host-list)
  (apply
   iup-connected
   current-host
   (lambda (_ handle x)
     (let ((hn (host->index (car x))))
       (attribute-set! handle value: hn)))
   listbox
   action: (lambda (self text item state) (if (= state 1) (set-host-by-number! (- item 1))) 'default)
   value: 1 dropdown: 'Yes
   (let loop ((i 1) (hs (value known-hosts)))
     (if (null? hs) '()
	 `(,(string->keyword (number->string i)) ,(cadr (car hs)) . ,(loop (+ i 1) (cdr hs)))))
   ))

(define (set-known-hosts! l) (value-set! known-hosts l))
(define (current-hostname) (car (value current-host)))
(define (current-hostnick) (cadr (value current-host)))
(define (current-hostfull) (caddr (value current-host)))

) (import ask-hosts)

(module
 gontrols
 (make-status-line
  gonsole console-name console-input console-status console-result console-hi console-hs console-hr
  send-console-input! console-input-value
  iob:handle-set-value! ;; TODO: move elsewhere
  )
 (import scheme chicken iup iubserver)
 (import (only extras format))
 (define (make-status-line observe)
   (iup-connected
    observe
    (lambda (_ handle str) (attribute-set! handle title: str))
    label expand: 'horizontal title: (value observe)))

 (define (iob:handle-set-value! _ handle v) (attribute-set! handle value: v))
 
 (define-record console name input hi status hs result hr)
 (define (gonsole name)
   (let* ((hi0 #f)			; a hack on scope
	  (infilter
	   (lambda (o n)
	     (cond
	      ((not hi0) n)
	      ((eq? n #t) (let ((i (attribute hi0 value:)))
			    (if (equal? i o) o i)))
	      ((eq? n #f) (delay o))
	      (else (delay n)))))
	  (input (make-observable (format "input ~a" name) "" infilter))
	  (result (make-observable (format "result ~a" name) ""))
	  (status (make-observable (format "status ~a" name) ""))
	  (hi (iup-connected
	       input iob:handle-set-value!
	       textbox
	       expand: #t multiline: 'Yes size: "x10"
	       action: (lambda (s x v) (value-set! status "No tried. (Press M-e)") 'default)))
	  (hr (iup-connected
	       result (lambda (_ h v) #;(value-set! status name) (iob:handle-set-value! _ h v) 'default)
	       textbox expand: 'Yes multiline: 'Yes readonly: 'Yes)))
     (set! hi0 hi)
     (value-set! status "Initial Status")
     (make-console name input hi status (make-status-line status) result hr)))

 (define (send-console-input! console v)
   (value-set!
    (console-input console)
    (case v
      ((clear) "")
      ((save) #t)
      ((restore #f))
      (else v))))
 
 (define (console-input-value console)
   (let ((io (console-input console)))
     (value-set! io #t)
     (value io)))

 ) (import gontrols)

(module
 ask-repl
 *
 (import scheme chicken dbg extras ports iup iubserver gontrols ask-client ask-state&control ask-hosts)
 (import (only data-structures ->string))
 
 ;; other widgets

 (define gui-console (gonsole "GUI result"))

 (define (gui-clear-input-text) (send-console-input! gui-console 'clear))
 
 (define result-converter (make-observable 'result-converter 1))
 
 (define (refresh-result self text item state)
   (if (= state 1) (value-set! result-converter item))
   'default)
 
 (define result-display
   (listbox
    1: 'literal 2: 'display 3: 'write value: (value result-converter) dropdown: 'Yes
    action: refresh-result))

 (connect! result-converter (lambda (_ x) (attribute-set! result-display value: x)))

 (define ask-console (gonsole "Target result"))
 (define ask-result (make-observable 'ask-result ""))

 (define (update-ask-result)
  (value-set! (console-result ask-console) (apply-ask-converter (value result-converter) (value ask-result))))

 (define (%update-ask-result _ x) (update-ask-result))

 (connect! ask-result %update-ask-result)

 (connect! result-converter %update-ask-result)

 (define status-area (make-observable 'status-area '()))

 (define status-area-display
   (begin
     (define (status-area-update! _ handle x)
       (for-each (lambda (x) (and (ihandle? x) (begin (child-remove! x) (unmap-peer! x)))) (children handle))
       (for-each (lambda (x) (and (ihandle? x) (begin (child-add! x handle) (map-peer! x)))) x))
     (iup-connected status-area status-area-update! vbox)))

(define (status-area-set! . x)
  (value-set! status-area x))

(define btn-execute
  (button
   title: '&Eval action:
   (lambda (self) (eval-input-text (console-hi gui-console) (console-result gui-console) (console-status gui-console)))))
(define btn-ask
  (button
   title: '&Eval action:
   (lambda (self) (ask-input-text (console-input-value ask-console) ask-result (console-status ask-console)))))

(define ask-for-hosts
  '(node-list-map (lambda (n) (node-list-map (lambda (n) (data n)) (children n))) (children (http-display-hosts))))
(define ask-for-channels '(display-http-channels))
(define ask-for-netstat ``(netstat (hosts . ,,ask-for-hosts) (channels ,,ask-for-channels))  )
(define ask-for-threads "(thread-list 'dummy)")
(define ask-for-certs "display $ x509-text $ car $ map data $ ball-info '(#f \"cert\")")

(define-syntax define-simple-ask-action
  (syntax-rules ()
    ((_ name msg cmd)
     (define (name self)
       (status-area-set! (label title: msg))
       (&begin (status-area-set! (textbox expand: #t multiline: #t readonly: #t value: (ask-global-server (->string cmd)))))
       'default))))

(define-syntax simple-ask-button-action
  (syntax-rules ()
    ((_ msg cmd)
     (lambda (self)
       (status-area-set! (label title: msg))
       (&begin (gandle-exceptions
		msg cmd (status-area-set! (textbox expand: #t multiline: #t readonly: #t value: (ask-global-server (->string cmd))))))
    'default))))

(define (make-channels-display x)
  (define (cs s n) (substring s 0 (min (string-length s) n)))
  (define (csa s) (cs (->string s) 8))
  (gandle-exceptions
   "make-channels-display" x
   (let* ((ns (cdr (call-with-input-string x read)))
	  (ht (map (lambda (r) (receive (i a c) (apply values r) (list a i c))) (cdar ns))))
     (let* ((t (cdddar (cdadr ns)))
	    (tbl (gridbox numdiv: 11 expand: #f expandchildren: 'horizontal
			  sizecol: 1 gapcol: 1))
	    (adl! (lambda (x) (child-add! (label title: x) tbl)))
	    ;;(adm! (lambda (x) (child-add! (textbox value: x font: "Monospace, 10" readonly: #t canfocus: #f border: #f) tbl)))
	    (adm! (lambda (x) (child-add! (label title: x font: "Monospace, 10") tbl)))
	    (addh! (lambda (x) (child-add! (label title: (car x) size: (cadr x) tip: (caddr x) alignment: 'acenter
						  fontstyle: "Bold") tbl))))
       (for-each addh! '(("host" "30x" "Nickname (if available)") ("OID" "126x" "Object IDentifier") ("ip" "80x" "IP address:port")
			 ("cnt" "8x" "connection left until limit is reached/collect call connections")
			 ("act" "8x" "active connections")
			 ("s" "2x" "Status: '>': established; '<': collect (reverse); '#': in setup; '-': none")
			 ("age" "20x" "seconds since last contact")
			 ("avg" "28x" "average delay until transactions are confirmed")
			 ("avgl" "28x" "sliding average (recent timings have more weight)")
			 ("min" "28x" "minimum") ("max" "28x" "maximum")
			 ))
       (for-each
	(lambda (row)
	  (receive
	   (h l a s1 s2 s3 s4 d r) (apply values (map cadr (cdr row)))
	   (let ((he (assoc h ht)))
	     (adl! (or (and he (host->nick (cadr he))) "-")) (adm! (or (and he (cadr he)) "n/a"))
	     (adm! h) (adl! (or (and he (not (equal? (caddr he) "")) (format "~a/~a" l (caddr he))) l)) (adl! a)
	     (adl! d) (adl! r)
	     (adl! (csa s1)) (adl! (csa s2)) (adl! (csa s3)) (adl! (csa s4))
	     )))
	t)
       tbl))))

(define (ask-channels)
  (status-area-set! (label title: "Asking for network status."))
  (&begin (status-area-set! (make-channels-display (ask-global-server ask-for-netstat)))))

(define btn-ask-for-netstat
  (button title: '&Network action: (lambda (_) (ask-channels) 'default)))

(define btn-ask-for-threads
  (button title: 'Threads
	  action: (simple-ask-button-action "Asking for thread list." ask-for-threads)))

(define (ask-update-certs)
  (status-area-set! (label title: "Asking for certificates."))
  (&begin
   (status-area-set!
    (vbox
     (textbox expand: 'horizontal value: (current-hostname))
     (textbox expand: 'horizontal value: (current-hostnick))
     (textbox expand: 'horizontal value: (current-hostfull))
     (textbox expand: #t multiline: #t readonly: #t value: (ask-global-server ask-for-certs))))))

(define btn-ask-for-certs (button title: 'Cert&ificates action: (lambda (_) (ask-update-certs) 'default)))

;; name those other widgets, so that they can be referenced by name
(set! (handle-name result-display) "result-display")
;(set! (handle-name input-text) "input-text")
;(set! (handle-name result-text) "result-text")

;; the dialog
(define dlg-size
  'HALFxFULL
  ;;'HALFxQUARTER
  )

(define host-lists (vector (host-list) (host-list)))

(define dlg
  (dialog
   (vbox
    (tabs
     (split
      (vbox
       (hbox
	btn-execute
	(button title: '&Clear action: (lambda (self) (gui-clear-input-text) 'default))
	expand: 'horizontal
	)
       (console-hi gui-console))
      (vbox (console-hs gui-console) (console-hr gui-console))
      orientation: 'horizontal value: 250)
     (split
      (vbox
       (hbox
	result-display (vector-ref host-lists 0) btn-ask
	(button title: '&Clear action: (lambda (self) (send-console-input! ask-console 'clear) 'default))
	expand: 'horizontal
	)
       (console-hi ask-console))
      (vbox (console-hs ask-console) (console-hr ask-console))
      orientation: 'horizontal value: 250)
     (vbox
      (hbox
       (button title: '&Reconnect action: (lambda (self) (set-host-by-number! 0) (gandle-exceptions "Reconnect" "localhost" (ask-connect-global))))
       (vector-ref host-lists 1) btn-ask-for-netstat btn-ask-for-threads btn-ask-for-certs
       )
      status-area-display
      )
     tabtitle0: "Gonsole"
     tabtitle1: "Console"
     tabtitle2: "Status"))
   title: "ASK REPL"
   size: dlg-size
   ))

) (import ask-repl)

(show dlg x: 'center y: 'center)

(define gicks (&begin (main-loop)))
(thread-join! gicks)
;;(main-loop)
;(repl)
(display "Done\n" (current-error-port))
(destroy! dlg)
(exit 0)