;;
;; SMSMatrix library
;;
;; Copyright 2011 Response Genetics, Inc.
;;
;; All rights reserved.
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; 
;; Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; 
;; Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;; 
;; Neither the name of the author nor the names of its contributors may
;; be used to endorse or promote products derived from this software
;; without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
;; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
;; OF THE POSSIBILITY OF SUCH DAMAGE.
;;

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

(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      "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.
;; 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 split-at)
  ;; 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 ((entry '())
             (alist '())
             (line (next-line)))
      (cond ((eof-object? line)
             (if (null? entry)
                 (reverse! alist)
                 (reverse! (cons entry alist))))
            ((string=? "" line) (lp entry alist (next-line)))
            (else (receive (key value)
                    (string-split-char line #\=)
                    (let ((keysym (schemify-string key)))
                      (cond
                       ((not split-at)
                        (lp '() (cons (cons keysym value) alist) (next-line)))
                       ((eq? keysym split-at)
                        (lp (cons (cons keysym value) '())
                            (if (null? entry) alist (cons entry alist))
                            (next-line)))
                       (else ;; split-at, but split point not reached
                        (lp (cons (cons keysym value) entry)
                            alist (next-line)))))))))))

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

(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))
                             #f '(balance)))
           (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))
                                 #f `(,rate-type)))
               (rate (alist-ref rate-type res)))
          (cond ((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 (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))
                             #f '(carrier)))
           (carrier (alist-ref 'carrier res)))
      (maybe-extract-error-code 'carrier-name carrier)
      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))
                             #f '(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 eq? "")) ; May be omitted
              (string->number (alist-ref 'timestamp res))
              (alist-ref 'timezone res)
              (string->number 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))))

(define (send-sms recipients message #!key
                  username password group tts-fallback (error-on-failure #t))
  (let-auth 'send-sms username password
    (let* ((recipient-type (if group 'group 'phone))
           (recipients (if (string? recipients)
                           recipients
                           (string-intersperse recipients ",")))
           (res (api-request 'send-sms sms-uri `((username . ,username)
                                                 (password . ,password)
                                                 (,recipient-type . ,recipients)
                                                 (txt . ,message)
                                                 (tts . ,(if tts-fallback 1 0)))
                             'pin '())))
      ;; Check for errors in phone number recipients if it was asked for
      (when error-on-failure
        (for-each (lambda (entry)
                    (let ((status (alist-ref 'statuscode entry))
                          (status-text (alist-ref 'statustxt entry))
                          (pin (alist-ref 'pin entry)))
                      (error-on-bad-result-code
                       'send-sms status status-text pin)))
                  res))
      (map (lambda (entry)
             (map (lambda (key/value)
                    (let ((key (car key/value))
                          (value (cdr key/value)))
                     (case key
                       ((statuscode timestamp) (cons key (string->number value)))
                       (else key/value))))
                  entry))
           res))))

)