zzkt/gibberish
1
0
Fork 0
Code Issues 1 Pull requests Projects Releases Packages Wiki Activity

defmacro -> define-syntax

Browse source
This commit is contained in:
nik gaffney 2009-04-17 17:30:25 +02:00
parent 9f1434a8da
commit db9fdaabe8
1 changed files with 30 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

59
xmpp.ss
View file

@ -67,15 +67,15 @@
(module xmpp scheme (module xmpp scheme
(provide (all-defined-out) (provide (all-defined-out)
;open-connection ;; with-xmpp-session
;open-ssl-connection ;; xmpp-stream xmpp-session xmpp-auth
;with-xmpp-session ;; send message presence iq
;; jid-user jid-host jid-resource
) )
(require (planet lizorkin/sxml:2:1/sxml)) ;; encoding xml (require (planet lizorkin/sxml:2:1/sxml)) ;; encoding xml
(require (planet lizorkin/ssax:2:0/ssax)) ;; decoding xml (require (planet lizorkin/ssax:2:0/ssax)) ;; decoding xml
(require mzlib/os) ;; hostname (require mzlib/os) ;; hostname
(require mzlib/defmacro) ;; with-xmpp-session macro
(require scheme/tcp) ;; networking (require scheme/tcp) ;; networking
(require openssl) ;; ssl/tls (require openssl) ;; ssl/tls
(require srfi/13) ;; jid decoding (require srfi/13) ;; jid decoding
@ -191,11 +191,11 @@
;; - http://xmpp.org/rfcs/rfc3920.html#sasl ;; - http://xmpp.org/rfcs/rfc3920.html#sasl
;; ;;
;;;; ;; ;;;; ;;
(define session->tls? #f) ;; changes state when a tls proceed is recived (define session->tls? #f) ;; changes state when a tls proceed is recived
;; moved to xmpp-sasl until it 'works' ;; moved to xmpp-sasl until it 'works'
;;;;;;;;; ; ;; ; ; ;; ;; ; ; ;;;;;;;;; ; ;; ; ; ;; ;; ; ;
;; ;;
@ -300,28 +300,29 @@
(define (send str) (define (send str)
(printf "sending iO: ~a ~%~%" str) (printf "sending iO: ~a ~%~%" str)
(fprintf (xmpp-out-port) "~A~%" str) (flush-output (xmpp-out-port))) (fprintf (xmpp-out-port) "~A~%" str) (flush-output (xmpp-out-port)))
(defmacro with-xmpp-session (jid pass . body) (define-syntax with-xmpp-session
`(let ((host (jid-host ,jid)) (syntax-rules ()
(user (jid-user ,jid)) ((_ jid pass . body)
(resource (jid-resource ,jid))) (let ((host (jid-host jid))
(let-values (((in out) (user (jid-user jid))
(ssl-connect host ssl-port 'tls))) (resource (jid-resource jid)))
;;(tcp-connect host port))) (let-values (((in out)
(parameterize ((xmpp-in-port in) (ssl-connect host ssl-port 'tls)))
(xmpp-out-port out)) ;;(tcp-connect host port)))
(file-stream-buffer-mode out 'line) (parameterize ((xmpp-in-port in)
(xmpp-response-handler in) (xmpp-out-port out))
(send (xmpp-stream host)) (file-stream-buffer-mode out 'line)
(send (xmpp-session host)) (xmpp-response-handler in)
;(starttls in out) (send (xmpp-stream host))
(send (xmpp-session host))
(send (xmpp-auth user ,pass resource)) ;(starttls in out)
(send (presence))
(send (presence #:status "Available")) (send (xmpp-auth user pass resource))
,@body (send (presence))
(close-output-port out) (send (presence #:status "Available"))
(close-input-port in))))) body
(close-output-port out)
(close-input-port in)))))))
) ;; end module ) ;; end module