Further simplification of auth macro, add call-with-csv-report procedure

1 files changed, 69 insertions, 71 deletions

diff --git a/smsmatrix.scm b/smsmatrix.scm
index 1dc9ca1..4047b4a 100644
--- a/smsmatrix.scm
+++ b/smsmatrix.scm
@@ -6,11 +6,12 @@
 
 (module smsmatrix
   (smsmatrix-username smsmatrix-password
-   get-credits get-rate carrier-name message-status)
+   get-credits get-rate carrier-name message-status call-with-csv-report)
 
 (import chicken scheme)
 
-(use extras data-structures irregex srfi-1 srfi-13 intarweb http-client uri-common)
+(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))
@@ -56,31 +57,18 @@
     (514 . "No voice file provided")
     (520 . "Error parsing xml")))
 
-(define-syntax define/auth*
+(define-syntax let-auth
   (syntax-rules ()
-    ((_ ?username ?password ?request ?base-uri (?procname ?args ...)
-        ?body ...)
-     (define (?procname ?args ...
-                        #!key
-                        (?username (smsmatrix-username))
-                        (?password (smsmatrix-password)))
+    ((_ ?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")))
-       (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)))))
+       ?body ...))))
 
 (define (string-split-char s c)
   (let ((idx (string-index s c)))
@@ -103,6 +91,16 @@
                     (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)))
+    (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")))
@@ -129,67 +127,67 @@
                    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-credits #!key username password)
+  (let-auth 'get-credits username password
+    (let* ((res (api-request 'get-credits balance-uri `((username . ,username)
+                                                        (password . ,password))
+                             '(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* ((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")
+        (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"
                         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)))
+(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)))
+           (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))
+                             '(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))))
+
+(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))))
 
 )
\ No newline at end of file