Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
102 lines (90 sloc) 3.85 KB
#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) ))]))
)