#lang racket/base

#|

   SOAP Library for Racket
   soap.rkt

   This file is part of rkt-upnp.
   This file is subject to the terms of a MIT-style license, please
   refer to LICENSE.txt for details.


   Currently this is mainly used with UPnP, but it can be
   used for web services as well.

|#

(require racket/match
         racket/list
         xml
         racket/contract)

(provide soap-encode
         soap-decode )

#|
   SOAP Envelope Encoder
   Takes a Xexpr and outputs a string containing a SOAP envelope.
|#
(define (soap-encode body0 [head0 #f] [ns #f] [enc #f])
  (unless (or (string? body0) (pair? body0))
    (raise-argument-error 'soap-encode "xexpr? or string?" body0 body0 head0 ns enc))
  (unless (or (eq? #f head0) (string? head0))
    (raise-argument-error 'soap-encode "string?" head0 body0 head0 ns enc))
  (unless (or (eq? #f ns) (string? ns))
    (raise-argument-error 'soap-encode "string?" ns body0 head0 ns enc))
  (unless (or (eq? #f enc) (string? enc))
    (raise-argument-error 'soap-encode "string?" enc body0 head0 ns enc))
  (let* ( [n  (if (eq? ns #f) "http://www.w3.org/2001/12/soap-envelope" ns)]
          [e  (if (eq? enc #f) '() `((s:encodingStyle ,enc)))]
          [head (if (or (eq? #f head0) (pair? head0)) head0 (list head0))]
          [body (if (pair? body0) body0 (list body0) )]
          [h  (if (eq? head #f) '() `((s:Header () ,@head)))]
          [x `(s:Envelope ((xmlns:s ,n) ,@e) ,@h (s:Body () ,@body)) ] )
    (string->bytes/utf-8
     (format "<?xml version=\"1.0\" encoding=\"utf-8\"?>~a" (xexpr->string x)))
    )
  )

#|
   SOAP Envelope Decoder
   Takes a string containing a SOAP envelope and returns a Xexpr.
|#
(define (soap-decode m [proc-hdlf #f])
  (unless (string? m)
    (raise-argument-error 'soap-decode "string?" m m proc-hdlf))
  (unless (or (eq? #f proc-hdlf) (procedure? proc-hdlf))
    (raise-argument-error 'soap-decode "procedure?" proc-hdlf m proc-hdlf))
  (let*([x (xml->xexpr (document-element (read-xml (open-input-string m))))]
        [ns (match (symbol->string (first x))
              [[regexp "^(.+):Envelope$" (list _ a)] a]
              )]
        [symns (string->symbol (format "xmlns:~a" ns))]
        [symen (string->symbol (format "~a:encodingStyle" ns))]
        [symhd (string->symbol (format "~a:Header" ns))]
        [symbd (string->symbol (format "~a:Body" ns))]
        [symfl (string->symbol (format "~a:Fault" ns))]
        [enc   #f] ; TODO
        [nsurl (second (first (filter (λ (a) (equal? symns (car a)))
                                      (second x))))
             ]
        [cntal (rest (rest x))]
        [cnthd (filter (λ (a) (equal? symhd (car a))) cntal) ]
        [cntbd (filter (λ (a) (equal? symbd (car a))) cntal) ]
        )
    (cond
      [((length cnthd) . > . 1) (raise "More than one SOAP Header")]
      [((length cntbd) . > . 1) (raise "More than one SOAP Body")]
      [else
       
       (let* ( [cnthdc (if ((length cnthd) . eq? . 1) (cddr (first cnthd)) '())]
               [cntbdc (if ((length cntbd) . eq? . 1) (cddr (first cntbd)) '())]
               [cntflt (filter (λ (a) (equal? symfl (car a))) cntbdc)] )
         (if ((length cntflt) . > . 0)
             (if (equal? proc-hdlf #f)
                 (raise "SOAP fault message not handled")
                 (let ([flbdc (first cntflt)]
                       [fcode  #f]
                       [fstr   #f]
                       [factor #f]
                       [fdetl  #f])
                   (for ([z flbdc])
                     (match z
                       [`[faultcode ()   ,y] (set! fcode y)]
                       [`[faultstring () ,y] (set! fstr  y)]
                       [`[faultactor ()  ,y] (set! factor  y)]
                       [`[detail () ,y ...]  (set! fdetl y)]
                       [_ (void)] ))
                   (proc-hdlf fcode fstr factor fdetl) ))
             (values cntbdc cnthdc ns enc) ))]))
  )