Asterisk Manager Interface for Racket

ami.rkt

#lang racket/base

(require racket/tcp racket/async-channel racket/match racket/function)

(define-struct ami [input-port
                    output-port thread
                    request-channel
                    response-channel
                    event-channel
                    [dead? #:mutable]]
  #:property prop:evt (struct-field-index event-channel))

(define-struct ami-message [name fields])
(define-struct (ami-response ami-message) [] #:transparent)
(define-struct (ami-event ami-message) [] #:transparent)

(define (read-message port)
  (define pat #px"([^:]+):\\s*(.*)$")
  (match-define
    (regexp pat (list _ type name))
    (read-line port 'any))
  (define fields (make-hash))
  (for ([l (in-port (lambda (p) (read-line p 'any)) port)]
        #:break (= 0 (string-length l)))
    (match l
      [(regexp pat (list _ key value))
       (hash-set! fields key value)]))
  ((if (equal? type "Event")
       make-ami-event
       make-ami-response)
   (string->symbol name) fields))
      
(define (ami-connect host port username password)
  (define-values
    (in out)
    (tcp-connect host port))
  (define banner (read-line in))
  (when (not (regexp-match #px"Asterisk Call Manager/\\d.\\d" banner))
    (error "Server banner mismatch"))
  (display
   (format "Action: Login\nUsername: ~a\nSecret: ~a\n\n" username password)
   out)
  (flush-output out)
  (read-message in)
  (define request-channel (make-channel))
  (define response-channel (make-channel))
  (define event-channel (make-async-channel))
  (define holder (box #f))
  (define t
    (thread
     (thunk
      (with-handlers ([exn:fail:network?
                       (λ (e)
                         (define conn (unbox holder))
                         (set-ami-dead?! conn #t)
                         (async-channel-put (ami-event-channel conn) eof)
                         (channel-put (ami-response-channel conn) eof))])
        (for ([_ (in-cycle '(#t))])
          (define evt (sync request-channel in))
          (cond
            [(input-port? evt)
             (let ([m (read-message evt)])
               (if (ami-response? m)
                   (channel-put response-channel m)
                   (async-channel-put event-channel m)))]
            [(string? evt)
             (write-string evt out)
             (flush-output out)]
            [else
             (error "wtf?")]))))))

  (define conn (make-ami in out t request-channel response-channel event-channel #f))
  (set-box! holder conn)
  conn)

(define ami-action
  (make-keyword-procedure
   (lambda (keywords values conn action)
     (when (ami-dead? conn)
       (error "network error"))
     (define outstr (open-output-string))
     (parameterize ([current-output-port outstr])
       (write-string (format "Action: ~a~n" action))
       (for ([k keywords]
             [v values])
         (write-string (format "~a: ~a~n" (keyword->string k) v)))
       (write-string "\n"))
     (channel-put (ami-request-channel conn) (get-output-string outstr))
     (let ([v (channel-get (ami-response-channel conn))])
       (if (eof-object? v)
           (error "network error")
           v)))))

(define conn (ami-connect "host" 5038 "user" "secret"))
(sync conn)
(define r (ami-action conn 'ParkedCalls #:ActionID "smoo"))
(printf "~a~n~a~n" (ami-message-name r) (ami-message-fields r))