(module efax
  (efax-password efax-username efax-account efax-send efax-status)

(import chicken scheme)

(use srfi-1 srfi-13 data-structures
     http-client base64 sxml-serializer ssax sxpath)

(define efax-service-uri "https://secure.efaxdeveloper.com/EFax_WebFax.serv")

(define efax-account  (make-parameter #f))
(define efax-username (make-parameter #f))
(define efax-password (make-parameter #f))

(define-syntax let-auth
  (syntax-rules ()
    ((_ ?procname ?account ?username ?password ?body ...)
     (let ((?username (or (and ?password ?username) (efax-username)))
           (?password (or (and ?username ?password) (efax-password)))
           ;; Account can be provided separately via the global param,
           ;; but username and password must be provided at the same place.
           (?account  (or ?account (efax-account))))
       (unless (and ?username ?password ?account)
         (error '?procname
                (conc "You must provide an eFax account, username & password, "
                      "either via the efax-account, efax-username and "
                      "efax-password global parameters or via the account, "
                      "username and password keys for this procedure")))
       ?body ...))))

(define (read-document-or-raise-error port location)
  (let* ((result (ssax:xml->sxml port '()))
         (tid ((if-car-sxpath
                '(// TransmissionControl TransmissionID *text*)) result))
         (did ((if-car-sxpath
                '(// TransmissionControl DOCID *text*)) result))
         (code ((if-car-sxpath '(// Response StatusCode *text*)) result)))
    (if (or (not code) (string=? code "1"))
        result
        (signal (make-composite-condition
                 (make-property-condition
                  'exn
                  'location location
                  'message
                  ((if-car-sxpath '(// Response ErrorMessage *text*))
                   result))
                 (make-property-condition
                  'efax
                  'error-code code
                  'error-description
                  ((if-car-sxpath '(// Response StatusDescription *text*)) result)
                  'error-level
                  (string->symbol
                   (string-downcase
                    ((if-car-sxpath '(// Response ErrorLevel *text*)) result)))
                  'document-id did 'transmission-id tid))))))

;; TODO: This should probably allow files to be ports so that we can
;; stream large amounts of data. That would mean we can't use SXML anymore,
;; though!  Instead, we would need some kind of chunked layer-upon-layer
;; procedure that encodes base64 inside XML inside uri-encoded POST data.
;; It's probably not worth it since it isn't likely people are going to
;; send gigabytes worth of data; it has to come out a fax machine, which
;; would translate to many pages of dead tree!
(define (efax-send recipients files
                   #!key account username password transmission-id
                   unique-id customer-id high-resolution high-priority)
  (let-auth efax-send account username password
    (call-with-input-request
     efax-service-uri
     `((id . ,account)
       (respond . "XML")
       (xml . ,(serialize-sxml
                `(*TOP*
                  (*PI* xml "version=\"1.0\"")
                  (OutboundRequest
                   (AccessControl (UserName ,username) (Password ,password))
                   (Transmission
                    (TransmissionControl
                     ;; TODO: SelfBusy, FaxHeader
                     ,@(if transmission-id `((TransmissionID ,transmission-id)) '())
                     (NoDuplicates ,(if unique-id "ENABLE" "DISABLE"))
                     ,@(if customer-id `((CustomerID ,customer-id)) '())
                     (Resolution ,(if high-resolution "FINE" "STANDARD"))
                     (Priority ,(if high-priority "HIGH" "NORMAL")))
                    (DispositionControl
                     ;; TODO: DispositionURL, DispositionLevel, DispositionMethod, DispositionEmail(s)?
                     (DispositionLevel "NONE"))
                    (Recipients
                     . ,(if (string? recipients)
                            `((Recipient (RecipientFax ,recipients)))
                            (map
                             (lambda (recipient)
                               `(if (string? recipient)
                                    `(Recipient (RecipientFax ,recipient))
                                    `(Recipient
                                      ,@(map
                                         (lambda (entry)
                                           (let ((key (car entry))
                                                 (value (cdr entry)))
                                             (case key
                                               ((name) `(RecipientName ,value))
                                               ((company) `(RecipientName ,value))
                                               ((fax) `(RecipientFax ,value))
                                               (else (error "Unknown recipient key" key)))))
                                         recipient))))
                             recipients)))
                    (Files . ,(map (lambda (file)
                                     `(File (FileContents ,(base64-encode (cdr file)))
                                            (FileType ,(->string (car file)))))
                                   files))))))))
     (lambda (port)
       (let* ((doc (read-document-or-raise-error port 'efax-send))
              (tid ((if-car-sxpath
                     '(// TransmissionControl TransmissionID *text*)) doc))
              (did ((if-car-sxpath
                     '(// TransmissionControl DOCID *text*)) doc)))
         `((doc-id . ,did) (transmission-id . ,tid)))))))

(define (efax-status #!key account username password doc-id transmission-id)
  (let-auth efax-status account username password
    (call-with-input-request
     efax-service-uri
     `((id . ,account)
       (respond . "XML")
       (xml . ,(serialize-sxml
                `(*TOP*
                  (*PI* xml "version=\"1.0\"")
                  (OutboundStatus
                   (AccessControl (UserName ,username) (Password ,password))
                   (Transmission
                    (TransmissionControl
                     ,@(if transmission-id `((TransmissionID ,transmission-id)) '())
                     ,@(if doc-id `((DOCID ,doc-id)) '()))))))))
     (lambda (port)
       (let* ((doc (read-document-or-raise-error port 'efax-status))
              (tid ((if-car-sxpath
                     '(// TransmissionControl TransmissionID *text*)) doc)))
         `((transmission-id . ,tid)
           (recipients . ,(map (lambda (r)
                                 (cons
                                  ((if-car-sxpath '(Fax *text*)) r)
                                  (fold-right
                                   (lambda (name expr result)
                                     (let ((value ((if-car-sxpath expr) r)))
                                       (if value
                                           (cons (cons name value) result)
                                           result)))
                                   ;; TODO: Convert a few of these to
                                   ;; Scheme-native types?
                                   ;; pages-*, duration, retries can be numbers
                                   '()
                                   '(name company fax status-message
                                     status-classification status-outcome
                                     last-attempt-date last-attempt-time
                                     next-attempt-date next-attempt-time
                                     pages-scheduled pages-sent
                                     baud-rate retries remote-csid)
                                   '((Name *text*) (Company *text*) (Fax *text*)
                                     (Status Message *text*)
                                     (Status Outcome *text*)
                                     (Status Classification *text*)
                                     (LastAttempt LastDate *text*)
                                     (LastAttempt LastTime *text*)
                                     (NextAttempt NextDate *text*)
                                     (NextAttempt NextTime *text*)
                                     (Pages Scheduled *text*)
                                     (Pages Sent *text*)
                                     (BaudRate *text*)
                                     (Retries *text*)
                                     (RemoteCSID *text*)))))
                           ((sxpath '(// Recipient)) doc)))))))))

)