@ -1,5 +1,8 @@
@@ -1,5 +1,8 @@
;; TODO(eta): use something like STRING-CASE in this file
;;; Package definitions
( defpackage :wee-impl
( :use ) )
@ -12,6 +15,8 @@
@@ -12,6 +15,8 @@
( in-package :weexmpp )
;;; Globals
( defvar *jid* nil
"Jabber ID (JID) of active connection. NIL if not connected yet." )
( defvar *iq-hash-table* ( make-hash-table :test #' equal )
@ -22,6 +27,145 @@
@@ -22,6 +27,145 @@
( defparameter +ns-bind+ "urn:ietf:params:xml:ns:xmpp-bind" )
( defparameter +ns-disco-info+ "http://jabber.org/protocol/disco#info" )
;;; Thenables library
( defclass thenable ( )
( ( callbacks
:accessor callbacks
:initform nil )
( state
:initform :pending
:accessor state )
( name
:initarg :name
:reader name )
( errbacks
:accessor errbacks
:initform nil )
( resolved-value
:accessor resolved-value
:initform nil )
( rejected-value
:accessor rejected-value
:initform nil ) ) )
( defmethod print-object ( ( obj thenable ) stream )
( print-unreadable-object ( obj stream :type t )
( with-slots ( state callbacks errbacks name ) obj
( format stream "\"~A\" ~A (~A cb, ~A eb)"
name state ( length callbacks ) ( length errbacks ) ) ) ) )
( defun thenable-resolve ( thenable args-list )
( unless ( eql ( state thenable ) :pending )
( error "Thenable ~A is already ~A (tried to resolve)"
thenable ( state thenable ) ) )
( setf ( state thenable ) :resolved )
( setf ( resolved-value thenable ) args-list )
( dolist ( callback ( callbacks thenable ) )
( apply callback args-list ) ) )
( defun thenable-reject ( thenable args-list )
( unless ( eql ( state thenable ) :pending )
( error "Thenable ~A is already ~A (tried to reject)"
thenable ( state thenable ) ) )
( setf ( state thenable ) :rejected )
( setf ( rejected-value thenable ) args-list )
( dolist ( callback ( errbacks thenable ) )
( apply callback args-list ) ) )
( defmacro with-thenable ( ( &key resolve reject name ) &body body )
( let ( ( thenable-sym ( gensym "thenable" ) )
( args1-sym ( gensym "args" ) )
( args2-sym ( gensym "args" ) )
( resolve-sym ( or resolve ( gensym "resolve" ) ) )
( reject-sym ( or reject ( gensym "reject" ) ) )
( condition-sym ( gensym "condition" ) ) )
` ( let ( ( , thenable-sym
( make-instance 'thenable
:name ( or , name "unnamed thenable" ) ) ) )
( labels
( ( , resolve-sym ( &rest , args1-sym )
( thenable-resolve , thenable-sym , args1-sym ) )
( , reject-sym ( &rest , args2-sym )
( thenable-reject , thenable-sym , args2-sym ) ) )
( handler-case
( progn ,@ body )
( serious-condition ( , condition-sym )
( , reject-sym , condition-sym ) ) ) )
, thenable-sym ) ) )
( defun thenable-immediate ( value )
( with-thenable ( :resolve resolve
:name "immediate thenable" )
( resolve value ) ) )
( defun do-then ( thenable &optional callback errback )
( with-thenable ( :resolve resolve
:reject reject
:name ( format nil "then: ~A"
( name thenable ) ) )
( when callback
( let ( ( next-callback
( lambda ( &rest args )
( handler-case
( let ( ( result ( apply callback args ) ) )
( typecase result
( thenable
( do-then result #' resolve #' reject ) )
( t
( apply #' resolve result ) ) ) )
( serious-condition ( c )
( reject c ) ) ) ) ) )
( if ( eql ( state thenable ) :resolved )
( apply next-callback ( resolved-value thenable ) )
( push next-callback ( callbacks thenable ) ) ) ) )
( let ( ( err-callback
( lambda ( &rest args )
( when errback
( ignore-errors ( apply errback args ) ) )
( apply #' reject args ) ) ) )
( if ( eql ( state thenable ) :rejected )
( apply err-callback ( rejected-value thenable ) )
( push err-callback ( errbacks thenable ) ) ) ) ) )
( defun thenable-join ( &rest thenables )
( with-thenable ( :resolve resolve
:reject reject
:name ( format nil "join of ~A thenables"
( length thenables ) ) )
( let ( ( results ( make-array ( length thenables )
:initial-element nil ) )
( num-resolved 0 )
( num 0 )
( num-needed ( length thenables ) )
( err nil ) )
( labels
( ( each-callback ( nth &rest args )
( unless err
( setf ( aref results nth ) args )
( when ( eql ( incf num-resolved ) num-needed )
( apply #' resolve ( coerce results 'list ) ) ) ) )
( each-errback ( &rest args )
( unless err
( apply #' reject args ) ) ) )
( dolist ( thenable thenables )
( let ( ( i ( 1- ( incf num ) ) ) )
( do-then thenable
( lambda ( &rest args )
( apply #' each-callback i args ) )
#' each-errback ) ) ) ) ) ) )
( defmacro then ( thenable lambda-list &body body )
` ( do-then , thenable
( lambda , lambda-list ,@ body ) ) )
( defmacro then-err ( thenable lambda-list &body body )
` ( do-then , thenable
nil
( lambda , lambda-list ,@ body ) ) )
;;; WeeChat output gray streams
( defclass weechat-output ( gray::fundamental-character-output-stream )
( ( to-err
:initarg :to-err
@ -280,26 +424,24 @@
@@ -280,26 +424,24 @@
( random ( expt 2 32 ) )
( get-universal-time ) ) )
( defvar *current-stanza-id* :sentinel )
( defun do-on-result ( func )
( when ( eql *current-stanza-id* :sentinel )
( error "ON-RESULT may only be used from within an IQ-GET invocation" ) )
( setf ( gethash *current-stanza-id* *iq-hash-table* )
func ) )
( defmacro on-result ( ( stanza ) &body body )
` ( do-on-result ( lambda ( , stanza ) ,@ body ) ) )
( defmacro iq-get ( ( &key to id ) &body body )
` ( let ( ( *current-stanza-id* ( or , id ( generate-id ) ) ) )
( stanzaize ( "iq" )
,@ ( when to
` ( ( stanza-attr "to" , to ) ) )
( stanza-attr "from" *jid* )
( stanza-attr "id" *current-stanza-id* )
( stanza-attr "type" "get" )
,@ body ) ) )
( let ( ( stanza-id-sym ( gensym "stanza-id" ) )
( thenable-sym ( gensym "thenable" ) ) )
` ( let* ( ( , stanza-id-sym ( or , id ( generate-id ) ) )
( , thenable-sym
( make-instance 'thenable
:name ( format nil "IQ ~A" , stanza-id-sym ) ) ) )
( setf ( gethash , stanza-id-sym *iq-hash-table* )
, thenable-sym )
( send
( stanzaize ( "iq" )
,@ ( when to
` ( ( stanza-attr "to" , to ) ) )
( stanza-attr "from" *jid* )
( stanza-attr "id" , stanza-id-sym )
( stanza-attr "type" "get" )
,@ body ) )
, thenable-sym ) ) )
( defun bare-jid ( jid )
"Strips the resource component from JID, if there is one."
@ -316,18 +458,29 @@
@@ -316,18 +458,29 @@
( subseq jid ( 1+ at ) )
jid ) ) )
( defun update-server-features ( entity )
( send
( iq-get ( :to entity )
( stanzaize ( "query" )
( stanza-attr "xmlns" +ns-disco-info+ ) )
( on-result ( stanza )
( let ( ( query-child ( s-child "query" stanza ) ) )
( dolist ( child ( children query-child ) )
( when ( string= ( name child ) "feature" )
( push ( s-attr "var" child ) *server-features* ) ) )
( printf "xmpp: identified ~A disco#info features for ~A"
( length *server-features* ) entity ) ) ) ) ) )
( defun disco-info ( entity )
( then
( iq-get ( :to entity )
( stanzaize ( "query" )
( stanza-attr "xmlns" +ns-disco-info+ ) ) )
( stanza )
( let ( ( query-child ( s-child "query" stanza ) )
( ret nil ) )
( dolist ( child ( children query-child ) )
( when ( string= ( name child ) "feature" )
( push ( s-attr "var" child ) ret ) ) )
ret ) ) )
( defun update-server-features ( )
( then
( thenable-join
( disco-info ( jid-hostname *jid* ) )
( disco-info ( bare-jid *jid* ) ) )
( server self )
( let ( ( both ( append server self ) ) )
( printf "xmpp: identified ~A disco#info features (~A server, ~A self)"
( length both ) ( length server ) ( length self ) )
( setf *server-features* both ) ) ) )
;; Stanza handling
@ -343,8 +496,7 @@
@@ -343,8 +496,7 @@
( progn
( setf *jid* bound-jid )
( update-presence )
( update-server-features ( jid-hostname *jid* ) )
( update-server-features ( bare-jid *jid* ) )
( update-server-features )
( printf "xmpp: bound to JID ~A" bound-jid ) )
( eprintf "xmpp: failed to destructure bind stanza! rendered ~A"
( render-stanza stanza ) ) ) ) )
@ -352,16 +504,9 @@
@@ -352,16 +504,9 @@
( s-name-is "iq" stanza )
( s-attr-is "type" "result" stanza ) )
( let* ( ( id ( s-attr "id" stanza ) )
( func ( gethash id *iq-hash-table* ) ) )
( if func
( progn
( handler-case
( funcall func stanza )
( error ( e )
( eprintf "xmpp: IQ handler for ~A failed: ~A"
id e ) ) )
( remhash id *iq-hash-table* ) )
( eprintf "xmpp: no IQ handler registered: ~A" ( render-stanza stanza ) ) ) ) )
( thenable ( gethash id *iq-hash-table* ) ) )
( thenable-resolve thenable ( list stanza ) )
( remhash id *iq-hash-table* ) ) )
( ( and
( s-name-is "iq" stanza )
( s-attr-is "type" "error" stanza ) )