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

(module smsmatrix
  (smsmatrix-username smsmatrix-password
   get-balance get-sms-rate)

(import chicken scheme)

(use extras 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      "http://www.smsmatrix.com/balance")
(define sms-rate-uri     "https://www.smsmatrix.com/sms_rate")
(define voice-rate-uri   "https://www.smsmatrix.com/voice_rate")
(define tts-rate-uri     "https://www.smsmatrix.com/tts_rate")
(define carrier-uri      "http://www.smsmatrix.com/carrier")
(define csv-report-uri   "http://www.smsmatrix.com/csv_report")
(define status-uri       "http://www.smsmatrix.com/matrix_status")

;; Sending messages
(define sms-uri          "https://www.smsmatrix.com/matrix")
(define fax-uri          "https://www.smsmatrix.com/matrix_fax")
(define tts-uri          "http://www.smsmatrix.com/matrix_tts")
(define voice-upload-uri "http://www.smsmatrix.com/matrix_voice")
(define voice-link-uri   "http://www.smsmatrix.com/matrix_voicew")
(define voice-tts-uri    "http://www.smsmatrix.com/matrix_vtts")

;; 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.
(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 (error-from-code loc code)
  (let ((code (if (number? code) code (string->number code))))
    (unless code
      (error loc "An error without a numeric status code was returned" code))
    (let ((message (alist-ref code http-overloaded-error-codes =
                              "An unknown error occurred")))
      (error loc message code))))

(define-syntax define/api*
  (syntax-rules ()
    ((_ ?username ?password ?request ?base-uri (?procname ?args ...)
        ?body ...)
     (define (?procname ?args ...
                        #!key
                        (?username (smsmatrix-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")))
       (let* ((base-uri (uri-reference ?base-uri))
              (query (uri-query base-uri))
              (uri (update-uri base-uri query: query))
              (?request (make-request method: 'POST uri: uri)))
         ?body ...)))))

;; Stub to inject literal keywords "username", "password" and "request"
(define-syntax define/api
  (er-macro-transformer
   (lambda (e r c)
     `(define/api* username password request . ,(cdr e)))))

(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 balance-uri (get-balance)
  (let* ((res (call-with-input-request request `((username . ,username)
                                                 (password . ,password))
                                       read-fields-as-alist))
         (balance (alist-ref 'balance res)))
    (cond ((not balance) (error 'get-balance "Did not return a balance!"))
          ((irregex-match '(: (w/nocase "ERROR") (+ space) ($ (+ num))) balance)
           => (lambda (m)
                (error-from-code 'get-balance (irregex-match-substring m 1))))
          ((string->number balance))
          (else
           (error 'get-balance "Did not return a numeric balance!" balance)))))

(define (get-sms-rate phone-number)
  (let* ((uri (uri-reference sms-rate-uri))
         (request (make-request method: 'POST uri: uri))
         (res (call-with-input-request request `((phone . ,phone-number))
                                       read-fields-as-alist))
         (sms-rate (alist-ref 'sms-rate res)))
    (cond ((not sms-rate)
           (error 'get-sms-rate "Did not return a rate!"))
          ((string-ci=? sms-rate "NOT SUPPORTED")
           (error 'get-sms-rate
                  "Phone number is not supported or invalid" phone-number))
          ((string->number sms-rate))
          (else
           (error 'get-sms-balance "Did not return a numeric rate!" sms-rate)))))

)