smsmatrix / smsmatrix.scm

;; SMSMatrix library
;; Copyright 2011 Response Genetics, Inc.

(module smsmatrix
  (smsmatrix-username smsmatrix-password
   get-credits get-rate carrier-name message-status call-with-csv-report)

(import chicken scheme)

(use extras utils data-structures irregex
     srfi-1 srfi-13 intarweb http-client uri-common)

(define smsmatrix-username (make-parameter #f))
(define smsmatrix-password (make-parameter #f))

;; TODO: Should these be configurable?  Doesn't make much sense
;; (if the URIs change the API probably changes too), but still...

;; Informational
(define balance-uri      "")
(define carrier-uri      "")
(define csv-report-uri   "")
(define status-uri       "")
(define rate-uris
  '((sms . "")
    (voice . "")
    (tts . "")))

;; Sending messages
(define sms-uri          "")
(define fax-uri          "")
(define tts-uri          "")
(define voice-upload-uri "")
(define voice-link-uri   "")
(define voice-tts-uri    "")

;; All values from 0 - 399 (inclusive) mean success, other values mean failure.
;; Yes, this means this list is incomplete. Let's just hope they're not going
;; to return any other status codes.
;; Of course they do! I've at least seen code 620 "ERROR DATABASE SENTMESSAGES"
;; which is returned when you put in an invalid message ID.  It's not documented
;; so we're not including it here since this could mean it's subject to change
(define http-overloaded-error-codes
  `((404 . "Account or user does not exist")
    (500 . "Error")
    (502 . "PIN in do not call database")
    (503 . "Insufficient balance")
    (504 . "Database error")
    (505 . "User not found or wrong password")
    (506 . "Account not active")
    (507 . "Database error")
    (508 . "Database error")
    (510 . "Invalid username")
    (511 . "Invalid txt")
    (512 . "Invalid password")
    (513 . "Invalid PIN")
    (514 . "No voice file provided")
    (520 . "Error parsing xml")))

(define-syntax let-auth
  (syntax-rules ()
    ((_ ?procname ?username ?password ?body ...)
     (let ((?username (or (and ?password ?username) (smsmatrix-username)))
           (?password (or (and ?username ?password) (smsmatrix-password))))
       (unless (and ?username ?password)
         (error '?procname
                (conc "You must provide an SMSMatrix username and password, "
                      "either via the smsmatrix-username and "
                      "smsmatrix-password global parameters or via the "
                      "username and password keys for this procedure")))
       ?body ...))))

(define (string-split-char s c)
  (let ((idx (string-index s c)))
    (values (string-take s idx) (string-drop s (add1 idx)))))

(define (schemify-string str)
  (string->symbol (string-translate (string-downcase str) "_" "-")))

(define (read-fields-as-alist port)
  ;; next-line contains a workaround for #568
  (let ((next-line (lambda ()
                     (let ((l (read-line port)))
                       (if (string? l) (string-chomp l "\r") l)))))
    (let lp ((alist '())
             (line (next-line)))
      (cond ((eof-object? line) (reverse! alist))
            ((string=? "" line) (lp alist (next-line)))
            (else (receive (key value)
                    (string-split-char line #\=)
                    (let ((keysym (schemify-string key)))
                      (lp (cons (cons keysym value) alist) (next-line)))))))))

(define (api-request loc uri params required-result-values)
  (let* ((request (make-request method: 'POST uri: (uri-reference uri)))
         (res (call-with-input-request request params read-fields-as-alist)))
     (lambda (element)
       (unless (alist-ref element res)
         (error loc (conc "Did not return a value for \"" element "\"!"))))

(define (error-from-code loc code . args)
  (let ((message (alist-ref code http-overloaded-error-codes =
                            "An unknown error occurred")))
    (apply error loc message code args)))

(define (error-on-bad-result-code loc code message . args)
  (if (not code)
      (apply error loc "Did not return a status code!" code message args)
      (let ((numeric-code (string->number code)))
        (if numeric-code
            (and (> numeric-code 399)   ; 0 - 399 means success, so return #f
                 (apply error-from-code loc numeric-code message args))
            (apply error loc "Did not return a numeric status code!"
                   code message args)))))

(define maybe-extract-error-code
  (let ((error-irregex (irregex '(: (w/nocase "ERROR") (+ space) ($ (+ num))))))
    (lambda (loc string . args)
      (and-let* ((m (irregex-match error-irregex string)))
        (let* ((code (irregex-match-substring m 1))
               (numeric-code (string->number code)))
          (unless numeric-code
            (apply error loc "An error without a numeric status code was returned"
                   code args))
          (apply error-from-code loc numeric-code args))))))

(define (get-credits #!key username password)
  (let-auth 'get-credits username password
    (let* ((res (api-request 'get-credits balance-uri `((username . ,username)
                                                        (password . ,password))
           (balance (alist-ref 'balance res)))
      (maybe-extract-error-code 'get-credits balance)
      (or (string->number balance)
          (error 'get-credits "Did not return a numeric balance!" balance)))))

(define (get-rate type phone-number)
  (let ((rate-uri (alist-ref type rate-uris)))
    (if (not rate-uri)
        (error 'get-rate "Unknown rate type" type)
        (let* ((rate-type (string->symbol (conc type "-rate")))
               (res (api-request 'get-rate rate-uri
                                 `((phone . ,phone-number)) `(,rate-type)))
               (rate (alist-ref rate-type res)))
          (cond ((string-ci=? rate "NOT SUPPORTED")
                 (error 'get-rate "Phone number is not supported or invalid"
                ((string->number rate))
                 (error 'get-rate "Did not return a numeric rate!" rate)))))))

(define (carrier-name phone-number #!key username password)
  (let-auth 'carrier-name username password
    (let* ((res (api-request 'carrier-name carrier-uri `((username . ,username)
                                                         (password . ,password)
                                                         (phone . ,phone-number))
           (carrier (alist-ref 'carrier res)))
      (maybe-extract-error-code 'carrier-name carrier)

(define (message-status message-id #!key username password)
  (let-auth 'message-status username password
    (let* ((res (api-request 'message-status status-uri `((username . ,username)
                                                          (password . ,password)
                                                          (id . ,message-id))
                             '(id status timezone statustxt timestamp)))
           (status (alist-ref 'status res))
           (status-text (alist-ref 'statustxt res)))
      (error-on-bad-result-code 'message-status status status-text message-id res)
      (unless (string-ci=? (alist-ref 'id res) message-id)
        (error 'message-status
               "Sanity check failed: message ID differs from the one requested!"
               (alist-ref 'id res) message-id))
      (values (string->number (alist-ref 'response res)) ; May be omitted
              (alist-ref 'timestamp res)
              (alist-ref 'timezone res)
              status status-text))))

;; Not really part of the "API" as such since it returns something completely
;; different than =-separated lists of key/value pairs and "email" vs "username"
(define (call-with-csv-report proc #!key username password limit incoming-only?)
  (let-auth 'csv-report username password
    (let* ((request (make-request method: 'POST
                                  uri: (uri-reference csv-report-uri)))
           (params `((email . ,username)
                     (password . ,password)
                     (limit . ,limit)
                     (in . ,(if incoming-only? 1 0)))))
      (call-with-input-request request params proc))))