#!/usr/local/bin/csi -s

(module snom-event-server
	(start-snom-event-server receive-results)
	(import scheme chicken data-structures extras
		srfi-1 srfi-13 srfi-18
		spiffy mailbox intarweb uri-common irregex
		snom-phone)

(require-library spiffy mailbox)

(define event-server-host "10.10.10.40")
(define event-server-port 8080)

(access-log (open-output-file "snom-event-server.access.log"))
(error-log (open-output-file "snom-event-server.error.log"))

(default-mime-type 'text/plain')
(vhost-map `((".*" . 
	      ,(lambda (continue)
		 (let ((uri (request-uri (current-request))))
		   (if (= (length (uri-path uri)) 2)
		       (if (equal? (list-ref (uri-path uri) 1) "trigger.scm")
			   (begin
			     (event-dispatch (uri-query uri))
			     (send-response code: 'ok
					    body: "200 - OK"))
			   (send-response status: 'forbidden
					  body: "404 - FORBIDDEN"))
		       (send-response status: 'forbidden
				      body: "404 - FORBIDDEN")))))))

(define server-mutex (make-mutex 'server))
(define (start-snom-event-server)
  (thread-start!
   (make-thread (lambda ()
		  (start-server bind-address: event-server-host
				port: event-server-port)) 'event-server-thread)))

(define events (make-mailbox 'events))
(define event-filters '())

(define (event-dispatch event-vars)
  (mutex-lock! server-mutex)

  (print "received-event: ")
  (pp event-vars)

  (unless (null? event-filters)
	  (let event-filter-loop ((event-filter (car event-filters))
				  (remaining-event-filters (cdr event-filters)))
	    (let filter-var-loop ((filter-var (car event-filter))
				  (remaining-filter-vars (cdr event-filter)))
	      (if (equal? (cdr filter-var)
			  (alist-ref (car filter-var) event-vars))
		  (if (null? remaining-filter-vars)
		      (begin
			(set! event-filters (delete event-filter event-filters))
			(mailbox-send! events event-vars))
		      (filter-var-loop (car remaining-filter-vars)
				       (cdr remaining-filter-vars)))
		  (unless (null? remaining-event-filters)
			  (event-filter-loop (car remaining-event-filters)
					     (cdr remaining-event-filters)))))))
  (mutex-unlock! server-mutex))

(define (receive-results action new-event-filters . timeout)
  (mutex-lock! server-mutex)
  (set! event-filters new-event-filters)
  (action)
  (mutex-unlock! server-mutex)
  
  (condition-case 
   (let events-loop ((event (mailbox-receive! events (optional timeout 5))))
     (print "processing...")
     (if (null? event-filters)
	 (list event)
	 (cons event (events-loop (mailbox-receive! events (optional timeout 5)))) ))
   [(exn mailbox timeout) #f]))


(define uri-parameter-string 
  (string-concatenate/shared
   (map (lambda (attribute-mapping)
	  (format "&~A=$~A") (car attribute-mapping) (cadr attribute-mapping))
	'((ip . "phone_ip")
	  (callee . "local")
	  (caller . "remote")
	  (id . "active_url")
	  (user . "active_user")
	  (host . "active_host")
	  (call-id . "call-id")
	  (callee-name . "display_local")
	  (caller-name . "display_remote")))))


(define (available-action-urls snom-phone)
  (filter-map (lambda (setting)
		(if (irregex-search "action_.*_url" (car setting))
		    (string->symbol (car setting))
		    #f))
	      (snom-phone-settings snom-phone)))

(define (make-action-url type)
  (format "http://~A/trigger.scm?type=~A~A"
	  event-server-host
	  (irregex-replace/all "_" (irregex-match-substring (irregex-search '(: "action_" (submatch (* any)) "_url") type) 1) "-")
	  uri-parameter-string))

(define (add-snom-phone snom-phone)
  (set-snom-phone-settings! snom-phone
			    (map (lambda (action-url)
				   '(,action-url . ,(make-action-url action-url)))
				 (available-action-urls snom-phone)))))