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

(module smsmatrix
  (smsmatrix-username smsmatrix-password
   get-credits get-rate carrier-name message-status)

(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 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")
(define rate-uris
  '((sms . "https://www.smsmatrix.com/sms_rate")
    (voice . "https://www.smsmatrix.com/voice_rate")
    (tts . "https://www.smsmatrix.com/tts_rate")))

;; 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-syntax define/auth*
  (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/auth
  (er-macro-transformer
   (lambda (e r c)
     `(define/auth* 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 (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/auth balance-uri (get-credits)
  (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-credits "Did not return a balance!"))
          ((maybe-extract-error-code 'get-credits balance))
          ((string->number balance))
          (else
           (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* ((uri (uri-reference rate-uri))
               (request (make-request method: 'POST uri: uri))
               (res (call-with-input-request request `((phone . ,phone-number))
                                             read-fields-as-alist))
               (rate (alist-ref (string->symbol (conc type "-rate")) res)))
          (cond ((not rate)
                 (error 'get-rate "Did not return a rate!"))
                ((string-ci=? rate "NOT SUPPORTED")
                 (error 'get-rate "Phone number is not supported or invalid"
                        phone-number))
                ((string->number rate))
                (else
                 (error 'get-rate "Did not return a numeric rate!" rate)))))))

(define/auth carrier-uri (carrier-name phone-number)
  (let* ((res (call-with-input-request request `((username . ,username)
                                                 (password . ,password)
                                                 (phone . ,phone-number))
                                       read-fields-as-alist))
         (carrier (alist-ref 'carrier res)))
    (cond ((not carrier)
           (error 'carrier-name "Did not return a carrier!"))
          ((maybe-extract-error-code 'carrier-name carrier))
          (else carrier))))

(define/auth status-uri (message-status message-id)
  (let* ((res (call-with-input-request request `((username . ,username)
                                                 (password . ,password)
                                                 (id . ,message-id))
                                       read-fields-as-alist))
         (status (alist-ref 'status res))
         (status-text (alist-ref 'statustxt res)))
    (error-on-bad-result-code 'message-status status status-text message-id res)
    (for-each (lambda (element)
                (unless (alist-ref element res)
                  (error 'message-status
                         (conc "Did not return a " element "!")
                         message-id)))
              '(id status timezone response statustxt timestamp))
    (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))
            (alist-ref 'timestamp res)
            (alist-ref 'timezone res)
            status status-text)))

)