steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Parse buddy list

cvs
Doug Coleman 2005-10-16 23:41:35 +00:00
parent 1ed21403ca
commit d36bb2e58a
1 changed files with 131 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
contrib/aim/aim.factor
View File

@ -12,13 +12,19 @@ SYMBOL: login-key
SYMBOL: aim-chat-ip SYMBOL: aim-chat-ip
SYMBOL: aim-chat-port SYMBOL: aim-chat-port
SYMBOL: auth-code SYMBOL: auth-code
! snac
SYMBOL: family SYMBOL: family
SYMBOL: opcode SYMBOL: opcode
SYMBOL: snac-flags
SYMBOL: snac-request-id
SYMBOL: name SYMBOL: name
SYMBOL: message SYMBOL: message
SYMBOL: encoding SYMBOL: encoding
SYMBOL: warning SYMBOL: warning
SYMBOL: buddy-list SYMBOL: buddy-list
SYMBOL: group-list
SYMBOL: banned-list
SYMBOL: channel SYMBOL: channel
SYMBOL: icbm-cookie SYMBOL: icbm-cookie
SYMBOL: message-type SYMBOL: message-type
@ -28,6 +34,10 @@ SYMBOL: file-transfer-cancelled
SYMBOL: direct-connect-cancelled SYMBOL: direct-connect-cancelled
SYMBOL: remote-internal-ip SYMBOL: remote-internal-ip
SYMBOL: remote-external-ip SYMBOL: remote-external-ip
SYMBOL: ssi-length
TUPLE: group name id ;
TUPLE: buddy name id gid capabilities buddy-icon online ;
: aim-login-server "login.oscar.aol.com" ; inline : aim-login-server "login.oscar.aol.com" ; inline
: icq-login-server "login.icq.com" ; inline : icq-login-server "login.icq.com" ; inline
@ -49,24 +59,20 @@ SYMBOL: remote-external-ip
! 205.188.210.203 ! 205.188.210.203
: aim-file-server-port 5190 ; inline : aim-file-server-port 5190 ; inline
! Family names from ethereal ! Family names from ethereal
: family-names : family-names
{{ {{
[[ 1 "Generic" ]] [[ 1 "Generic" ]] [[ 2 "Location" ]] [[ 3 "Buddylist" ]]
[[ 2 "Location" ]] [[ 4 "Messaging" ]] [[ 6 "Invitation" ]] [[ 8 "Popup" ]]
[[ 3 "Buddylist" ]] [[ 9 "BOS" ]] [[ 10 "User Lookup" ]] [[ 11 "Stats" ]]
[[ 4 "Messaging" ]] [[ 12 "Translate" ]] [[ 19 "SSI" ]] [[ 21 "ICQ" ]]
[[ 6 "Invitation" ]] [[ 34 "Unknown Family" ]] }} ;
[[ 8 "Popup" ]]
[[ 9 "BOS" ]] : hash-swap ( hash -- hash )
[[ 10 "User Lookup" ]] [ [ unswons cons , ] hash-each ] { } make alist>hash ;
[[ 11 "Stats" ]]
[[ 12 "Translate" ]] : 2list>hash ( keys values -- hash )
[[ 19 "SSI" ]] {{ }} clone -rot [ swap pick set-hash ] 2each ;
[[ 21 "ICQ" ]]
[[ 34 "Unknown Family" ]]
}} ;
: capability-names : capability-names
{{ {{
@ -86,27 +92,28 @@ SYMBOL: remote-external-ip
[[ "Add-Ins" HEX: 094613474c7f11d18222444553540000 ]] [[ "Add-Ins" HEX: 094613474c7f11d18222444553540000 ]]
}} ; }} ;
: capability-values : capability-values
capability-names hash-swap ;
: capability-abbrevs
{{ {{
[[ HEX: 094601054c7f11d18222444553540000 "Unknown1" ]] [[ CHAR: A "Voice" ]]
[[ HEX: 0946134a4c7f11d18222444553540000 "Games" ]] [[ CHAR: C "Send File" ]]
[[ HEX: 0946134b4c7f11d18222444553540000 "Send Buddy List" ]] [[ CHAR: E "AIM Direct IM" ]]
[[ HEX: 748f2420628711d18222444553540000 "Chat" ]] [[ CHAR: F "Buddy Icon" ]]
[[ HEX: 0946134d4c7f11d18222444553540000 "AIM/ICQ Interoperability" ]] [[ CHAR: G "Add-Ins" ]]
[[ HEX: 094613414c7f11d18222444553540000 "Voice Chat" ]] [[ CHAR: H "Get File" ]]
[[ HEX: 094600004c7f11d18222444553540000 "iChat" ]] [[ CHAR: K "Send Buddy List" ]]
[[ HEX: 094613434c7f11d18222444553540000 "Send File" ]]
[[ HEX: 094601ff4c7f11d18222444553540000 "Unknown2" ]]
[[ HEX: 094601014c7f11d18222444553540000 "Live Video" ]]
[[ HEX: 094613454c7f11d18222444553540000 "Direct Instant Messaging" ]]
[[ HEX: 094601034c7f11d18222444553540000 "Unknown3" ]]
[[ HEX: 094613464c7f11d18222444553540000 "Buddy Icon" ]]
[[ HEX: 094613474c7f11d18222444553540000 "Add-Ins" ]]
}} ; }} ;
: initialize-aim ( username password -- ) : initialize-aim ( username password -- )
password set username set password set username set
{{ }} clone buddy-list set ! {{ }} clone buddy-list set
{ } clone buddy-list set
{ } clone group-list set
{ } clone banned-list set
! 65535 random-int seq-num set ! 65535 random-int seq-num set
0 seq-num set 0 seq-num set
1 stage-num set ; 1 stage-num set ;
@ -146,8 +153,8 @@ SYMBOL: remote-external-ip
: parse-snac ( stream -- ) : parse-snac ( stream -- )
head-short family set head-short family set
head-short opcode set head-short opcode set
head-short drop head-short snac-flags set
head-int drop ; head-int snac-request-id set ;
: (unhandled-opcode) ( str -- ) : (unhandled-opcode) ( str -- )
"Family: " write family get unparse write "Family: " write family get unparse write
@ -164,18 +171,20 @@ SYMBOL: remote-external-ip
"Unhandled family: " write family get unparse writeln "Unhandled family: " write family get unparse writeln
unhandled-opcode ; unhandled-opcode ;
! Events ! Events
: buddy-signon ( name -- ) : buddy-signon ( name -- )
0 swap buddy-list get set-hash ; drop ; ! 0 swap buddy-list get set-hash ;
: buddy-signoff ( name -- ) : buddy-signoff ( name -- )
buddy-list get remove-hash ; drop ; ! buddy-list get remove-hash ;
: get-gid-by-name ( name -- gid )
: print-buddy-list : print-buddy-list
[ buddy-list get hash-keys string-sort [ , ] each ] { } make [ drop ] simple-outliner ; group-list get [ [ buddy-name , ] each ] { } make
;
! [ buddy-list get hash-keys string-sort [ , ] each ] { } make [ drop ] simple-outliner ;
: family-table ( -- hash ) : family-table ( -- hash )
@ -192,9 +201,6 @@ SYMBOL: remote-external-ip
car family-table hash word scan 10 base> rot set-hash f ; parsing car family-table hash word scan 10 base> rot set-hash f ; parsing
! Generic, Capabilities ! Generic, Capabilities
: send-generic-capabilities : send-generic-capabilities
[ [
@ -331,6 +337,12 @@ SYMBOL: remote-external-ip
head-byte head-string drop head-byte head-string drop
unscoped-stream get empty? [ handle-29 ] unless ; unscoped-stream get empty? [ handle-29 ] unless ;
: handle-abbrev-capabilities
unscoped-stream get empty? [
head-short .h
handle-abbrev-capabilities
] unless ;
: handle-buddy-status : handle-buddy-status
head-byte head-string name set head-byte head-string name set
head-short drop head-short drop
@ -344,11 +356,10 @@ SYMBOL: remote-external-ip
{ [ dup 3 = ] [ drop name get write " went online at " write head-int unparse writeln name get buddy-signon ] } { [ dup 3 = ] [ drop name get write " went online at " write head-int unparse writeln name get buddy-signon ] }
{ [ dup 4 = ] [ drop name get write " has been idle for " write head-short unparse write " minutes." writeln ] } { [ dup 4 = ] [ drop name get write " has been idle for " write head-short unparse write " minutes." writeln ] }
{ [ dup 6 = ] [ drop name get write ": (6): " write head-short unparse write " " write head-short unparse writeln ] } { [ dup 6 = ] [ drop name get write ": (6): " write head-short unparse write " " write head-short unparse writeln ] }
! { [ dup 10 = ] [ drop ] } ! external ip { [ dup 13 = ] [ drop "Capabilities3:" print handle-capabilities ] }
! { [ dup 12 = ] [ drop ] } ! same as CLI_SETSTATUS { [ dup 14 = ] [ drop "Capabilities4:" print handle-capabilities ] }
{ [ dup 13 = ] [ drop "Capabilities:" print handle-capabilities ] }
{ [ dup 14 = ] [ drop "Capabilities:" print handle-capabilities ] }
{ [ dup 15 = ] [ drop name get write " has been online for " write head-int unparse write " seconds." writeln ] } { [ dup 15 = ] [ drop name get write " has been online for " write head-int unparse write " seconds." writeln ] }
{ [ dup 25 = ] [ drop "Abbreviated capabilities: " write handle-abbrev-capabilities ] }
{ [ dup 27 = ] [ drop "(27): " write 4 [ head-int unparse write " " write ] repeat terpri ] } { [ dup 27 = ] [ drop "(27): " write 4 [ head-int unparse write " " write ] repeat terpri ] }
{ [ dup 29 = ] [ drop handle-29 ] } { [ dup 29 = ] [ drop handle-29 ] }
{ [ t ] [ " Unhandled tlv 3h-bh: " write unparse writeln head-contents hexdump ] } { [ t ] [ " Unhandled tlv 3h-bh: " write unparse writeln head-contents hexdump ] }
@ -508,7 +519,7 @@ SYMBOL: remote-external-ip
] } ] }
{ [ dup "Chat" = ] [ . handle-chat-start-tlvs { [ dup "Chat" = ] [ . handle-chat-start-tlvs
"Chat join message: " write message get writeln ] } "Chat join message: " write message get writeln ] }
{ [ dup "Direct Instant Messaging" = ] [ . handle-direct-start-tlvs { [ dup "AIM Direct IM" = ] [ . handle-direct-start-tlvs
direct-connect-cancelled get [ send-direct-connect-start ] unless direct-connect-cancelled get [ send-direct-connect-start ] unless
] } ] }
{ [ t ] [ "Unsupported capability in channel 2: " write writeln head-contents hexdump ] } { [ t ] [ "Unsupported capability in channel 2: " write writeln head-contents hexdump ] }
@ -578,13 +589,46 @@ SYMBOL: remote-external-ip
: handle-19-3 : handle-19-3
; FAMILY: 19 OPCODE: 3
! : handle-19-6-tlv ( str-reader -- )
! empty? [ (handle-19-6-tlv) handle-19-6-tlv ] unless ;
SYMBOL: g-id ! group id
SYMBOL: b-id ! buddy id
SYMBOL: type
: handle-19-6
head-byte drop ! ssi version, probably 0
head-short [
head-short head-string name set name get .
head-short g-id set g-id get .
head-short b-id set b-id get .
head-short type set type get . ! type 0 is a buddy, 1 is a group
"TLV CHAIN DATA: " print
head-short head-string hexdump ! short short data
type get
{
{ [ dup 0 = ] [ drop name get b-id get g-id get { } clone f f <buddy> buddy-list get push ] }
{ [ dup 1 = ] [ drop name get dup length 0 = [ drop ] [ g-id get <group> group-list get push ] if ] }
{ [ dup 3 = ] [ drop name get b-id get g-id get { } clone f f <buddy> banned-list get push ] }
{ [ t ] [ drop "Unknown 19-6 type" print ] }
} cond
] repeat
head-short drop ! timestamp
snac-flags get 1 = [
! SSI, Activate ! SSI, Activate
[ HEX: 13 7 0 7 make-snac ] send-aim [ HEX: 13 7 0 7 make-snac ] send-aim
! Set User Info. Capabilities! ! Set User Info. Capabilities!
! if you send this packet correctly you get capabilities
! and others' capabilities turn into letters instead of u128s
[ [
2 4 0 4 make-snac 2 4 0 4 make-snac
5 >short 5 >short
HEX: e0 >short capability-values hash-keys length 16 * >short ! size
capability-values hash-keys [ >u128 ] each capability-values hash-keys [ >u128 ] each
6 >short 6 >short 4 >short 2 >short 2 >short 6 >short 6 >short 4 >short 2 >short 2 >short
] send-aim ] send-aim
@ -616,14 +660,13 @@ SYMBOL: remote-external-ip
HEX: b HEX: 1 HEX: 110 HEX: 8f1 HEX: b HEX: 1 HEX: 110 HEX: 8f1
] [ >short ] each ] [ >short ] each
] send-aim ] send-aim
; FAMILY: 19 OPCODE: 3
: handle-19-6 ! Process
] when
; FAMILY: 19 OPCODE: 6 ; FAMILY: 19 OPCODE: 6
: print-op ( op -- )
"Op: " write . ;
: parse-server ( ip:port -- ) : parse-server ( ip:port -- )
":" split [ first ] keep second string>number aim-chat-port set aim-chat-ip set ; ":" split [ first ] keep second string>number aim-chat-port set aim-chat-ip set ;
@ -633,11 +676,8 @@ SYMBOL: remote-external-ip
head-short head-short
swap swap
{ {
! { [ dup 1 = ] [ print-op head-string . ] }
{ [ dup 5 = ] [ drop head-string parse-server ] } { [ dup 5 = ] [ drop head-string parse-server ] }
{ [ dup 6 = ] [ drop head-string auth-code set ] } { [ dup 6 = ] [ drop head-string auth-code set ] }
! { [ dup 8 = ] [ print-op head-string . ] }
! { [ t ] [ print-op head-string . ] }
{ [ t ] [ drop head-string drop ] } { [ t ] [ drop head-string drop ] }
} cond } cond
process-login-chunks process-login-chunks