Welcome to the CHICKEN Scheme pasting service

#!/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)))))

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

(module snom-phone
	(snom-phone snom-phone-settings set-snom-phone-settings!)
	(import scheme chicken data-structures utils extras
		srfi-1 srfi-18
		uri-common http-client regex
		snom-event-server)

(define (snom-phone ip-address)
  (let* ((snom-phone '((ip-address . ,ip-address)
		       (current-settings . ())
		       (original-settings . ())))
	 (settings (snom-phone-settings snom-phone)))
    (set! (alist-ref 'current-settings snom-phone) settings)
    (set! (alist-ref 'original-settings snom-phone) settings)
    
    snom-phone))

(define (snom-phone-settings snom-phone)
  (with-input-from-request (format "http://~A/settings.cfg" (alist-ref 'ip-address snom-phone)) #f
			   (lambda ()
			     (let settings-loop ((current-setting (read-line)))
			       (if (eof-object? current-setting)
				   '()
				   (let ((current-setting (string-split-fields "!:\\s" current-setting #:infix)))
				     (alist-cons (string->symbol (car current-setting)) (cdr current-setting) 
						 (settings-loop (read-line)))))))))

(define (set-snom-phone-setting! snom-phone setting)
  (with-input-from-request (format "http://~A/dummy.htm?settings=save~A"
				   (alist-ref 'ip-address snom-phone)
				   (string-append "&" (symbol->string (car setting)) "=" (uri-encode-string (cdr setting)))))
  (set! (alist-ref 'current-settings snom-phone) (snom-phone-settings snom-phone))

  (if (equal? (alist-ref (car setting) (alist-ref 'current-settings snom-phone))
	      (cdr setting))
      #t #f))

(define (set-snom-phone-settings! snom-phone settings)
  (for-each (lambda (setting)
	      (let set-setting-bug-loop ((current-setting (set-snom-phone-setting! snom-phone setting)))
		(unless current-setting
			(thread-sleep! 1)
			(set-setting-bug-loop (set-snom-phone-setting! snom-phone setting)))))
	    settings))


(define (set-identity-settings! snom-phone identity-index identity-settings)
  (void))

(define (set-active-identity! snom-phone identity-index)
  (void))

(define (active-identity snom-phone)
  (void))

(define (active-identity-settings snom-phone)
  (void))

(define (active-identity-call-id snom-phone identity-index)
  (void))

(define (dial from to)
  (receive-results (lambda ()
		     (with-input-from-request (format "http://~A/command.htm?number=~A"
						      (alist-ref 'ip-address from)
						      (active-identity-call-id to (active-identity to))) #f read-all))
		   '(((type . outgoing)
		      (ip . ,(alist-ref 'ip-address from)))
		     ((type . incomming)
		      (ip . ,(alist-ref 'ip-address to))))))
)