1083 lines
33 KiB
Factor
1083 lines
33 KiB
Factor
! All Talk
|
|
|
|
IN: aim-internals
|
|
USING: kernel sequences lists prettyprint strings namespaces math threads vectors errors parser interpreter test io crypto words hashtables inspector aim-internals generic queues arrays ;
|
|
|
|
SYMBOL: username
|
|
SYMBOL: password
|
|
SYMBOL: conn
|
|
SYMBOL: seq-num
|
|
SYMBOL: stage-num
|
|
SYMBOL: login-key
|
|
SYMBOL: aim-chat-ip
|
|
SYMBOL: aim-chat-port
|
|
SYMBOL: auth-code
|
|
! snac
|
|
SYMBOL: family
|
|
SYMBOL: opcode
|
|
SYMBOL: snac-flags
|
|
SYMBOL: snac-request-id
|
|
SYMBOL: extra-data
|
|
|
|
SYMBOL: name
|
|
SYMBOL: message
|
|
SYMBOL: encoding
|
|
SYMBOL: warning
|
|
SYMBOL: buddy-hash-name
|
|
SYMBOL: buddy-hash-id
|
|
SYMBOL: group-hash-name
|
|
SYMBOL: group-hash-id
|
|
SYMBOL: banned-hash-name
|
|
SYMBOL: banned-hash-id
|
|
SYMBOL: channel
|
|
SYMBOL: icbm-cookie
|
|
SYMBOL: message-type
|
|
SYMBOL: my-ip
|
|
SYMBOL: blue-ip
|
|
SYMBOL: file-transfer-cancelled
|
|
SYMBOL: direct-connect-cancelled
|
|
SYMBOL: remote-internal-ip
|
|
SYMBOL: remote-external-ip
|
|
SYMBOL: ssi-length
|
|
SYMBOL: modify-queue
|
|
|
|
TUPLE: group name id ;
|
|
TUPLE: buddy name id gid capabilities buddy-icon online ;
|
|
|
|
: aim-login-server "login.oscar.aol.com" ; inline
|
|
: icq-login-server "login.icq.com" ; inline
|
|
: login-port 5190 ; inline
|
|
: client-md5-string "AOL Instant Messenger (SM)" ; inline
|
|
: client-id-string "AOL Instant Messenger, version 5.5 3595/WIN32" ; inline
|
|
: client-id-num HEX: 109 ; inline
|
|
: client-major-ver 5 ; inline
|
|
: client-minor-ver 5 ; inline
|
|
: client-lesser-ver 0 ; inline
|
|
: client-build-num 3595 ; inline
|
|
: client-distro-num 260 ; inline
|
|
: client-language "en" ; inline
|
|
: client-country "us" ; inline
|
|
: client-ssi-flag 1 ; inline
|
|
: client-charset "text/aolrtf; charset=\"us-ascii\"" ; inline
|
|
: file-transfer-url "http://dynamic.aol.com/cgi/redir?http://www.aol.com/aim/filetransfer/antivirus.html" ; inline
|
|
: aim-file-server-port 5190 ; inline
|
|
|
|
! Family names from ethereal
|
|
: family-names
|
|
H{
|
|
{ 1 "Generic" } { 2 "Location" } { 3 "Buddylist" }
|
|
{ 4 "Messaging" } { 6 "Invitation" } { 8 "Popup" }
|
|
{ 9 "BOS" } { 10 "User Lookup" } { 11 "Stats" }
|
|
{ 12 "Translate" } { 19 "SSI" } { 21 "ICQ" }
|
|
{ 34 "Unknown Family" } } ;
|
|
|
|
: sanitize-name ( name -- name ) HEX: 20 swap remove >lower ;
|
|
|
|
: hash-swap ( hash -- hash )
|
|
hash>alist [ first2 swap 2array ] map alist>hash ;
|
|
|
|
: 2list>hash ( keys values -- hash )
|
|
H{ } clone -rot [ swap pick set-hash ] 2each ;
|
|
|
|
: capability-names
|
|
H{
|
|
{ "Unknown1" HEX: 094601054c7f11d18222444553540000 }
|
|
{ "Games" HEX: 0946134a4c7f11d18222444553540000 }
|
|
{ "Send Buddy List" HEX: 0946134b4c7f11d18222444553540000 }
|
|
{ "Chat" HEX: 748f2420628711d18222444553540000 }
|
|
{ "AIM/ICQ Interoperability" HEX: 0946134d4c7f11d18222444553540000 }
|
|
{ "Voice Chat" HEX: 094613414c7f11d18222444553540000 }
|
|
{ "iChat" HEX: 094600004c7f11d18222444553540000 }
|
|
{ "Send File" HEX: 094613434c7f11d18222444553540000 }
|
|
{ "Unknown2" HEX: 094601ff4c7f11d18222444553540000 }
|
|
{ "Live Video" HEX: 094601014c7f11d18222444553540000 }
|
|
{ "Direct Instant Messaging" HEX: 094613454c7f11d18222444553540000 }
|
|
{ "Unknown3" HEX: 094601034c7f11d18222444553540000 }
|
|
{ "Buddy Icon" HEX: 094613464c7f11d18222444553540000 }
|
|
{ "Add-Ins" HEX: 094613474c7f11d18222444553540000 }
|
|
} ;
|
|
|
|
SYMBOL: capability-names-hash-swapped
|
|
: capability-values capability-names-hash-swapped get ;
|
|
|
|
: capability-abbrevs
|
|
H{
|
|
{ CHAR: A "Voice" }
|
|
{ CHAR: C "Send File" }
|
|
{ CHAR: E "AIM Direct IM" }
|
|
{ CHAR: F "Buddy Icon" }
|
|
{ CHAR: G "Add-Ins" }
|
|
{ CHAR: H "Get File" }
|
|
{ CHAR: K "Send Buddy List" }
|
|
} ;
|
|
|
|
: aim-errors
|
|
H{
|
|
{ 1 "Invalid SNAC header." }
|
|
{ 2 "Server rate limit exceeded." }
|
|
{ 3 "Client rate limit exceeded." }
|
|
{ 4 "Recipient is not logged in." }
|
|
{ 5 "Requested service unavailable." }
|
|
{ 6 "Requested service not defined." }
|
|
{ 7 "You sent obsolete SNAC." }
|
|
{ 8 "Not supported by server." }
|
|
{ 9 "Not supported by client." }
|
|
{ 10 "Refused by client." }
|
|
{ 11 "Reply too big." }
|
|
{ 12 "Responses lost." }
|
|
{ 13 "Request denied." }
|
|
{ 14 "Incorrect SNAC format." }
|
|
{ 15 "Insufficient rights." }
|
|
{ 16 "In local permit/deny. (recipient blocked)" }
|
|
{ 17 "Sender too evil." }
|
|
{ 18 "Receiver too evil." }
|
|
{ 19 "User temporarily unavailable." }
|
|
{ 20 "No match." }
|
|
{ 22 "List overflow." }
|
|
{ 23 "Request ambiguous." }
|
|
{ 24 "Server queue full." }
|
|
{ 25 "Not while on AOL." }
|
|
} ;
|
|
|
|
|
|
: initialize-aim ( username password -- )
|
|
password set username set
|
|
H{ } clone buddy-hash-name set
|
|
H{ } clone buddy-hash-id set
|
|
H{ } clone group-hash-name set
|
|
H{ } clone group-hash-id set
|
|
H{ } clone banned-hash-name set
|
|
H{ } clone banned-hash-id set
|
|
<queue> modify-queue set
|
|
HEX: 7fff random-int seq-num set
|
|
capability-names hash-swap capability-names-hash-swapped set
|
|
1 stage-num set ;
|
|
|
|
: prepend-aim-protocol ( data -- )
|
|
[
|
|
HEX: 2a >byte
|
|
stage-num get >byte
|
|
seq-num get >short
|
|
] "" make
|
|
seq-num get dup HEX: 7fff >= [ 0 ] [ 1+ ] if seq-num set
|
|
swap dup >r length (>short) r> append append ;
|
|
|
|
: (send-aim) ( str -- )
|
|
"Sending: " print
|
|
dup hexdump
|
|
conn get [ stream-write ] keep stream-flush ;
|
|
|
|
: send-aim ( data -- )
|
|
make-packet prepend-aim-protocol (send-aim) terpri ;
|
|
|
|
: with-aim ( quot -- )
|
|
conn get swap with-unscoped-stream ;
|
|
|
|
: read-aim ( -- bc )
|
|
[
|
|
[
|
|
head-byte drop
|
|
head-byte drop
|
|
head-short drop
|
|
head-short head-string
|
|
] with-aim
|
|
] catch [ "Socket error" print throw ] when
|
|
"Received: " write dup hexdump ;
|
|
|
|
: make-snac ( fam subtype flags req-id -- )
|
|
4vector { (>short) (>short) (>short) (>int) } papply % ;
|
|
|
|
: parse-snac ( stream -- )
|
|
head-short family set
|
|
head-short opcode set
|
|
head-short snac-flags set
|
|
head-int snac-request-id set
|
|
snac-flags get HEX: 8000 bitand 0 > [
|
|
head-short head-string extra-data set
|
|
extra-data get "Extra data: " writeln hexdump
|
|
] when ;
|
|
|
|
: (unhandled-opcode) ( str -- )
|
|
! "Family: " write family get >hex write
|
|
! ", opcode: " write opcode get >hex writeln
|
|
head-contents hexdump ;
|
|
|
|
: unhandled-opcode ( -- )
|
|
"Unhandled opcode!" writeln (unhandled-opcode) ;
|
|
|
|
: incomplete-opcode ( -- )
|
|
"Incomplete handling: " write (unhandled-opcode) ;
|
|
|
|
: unhandled-family-opcode ( -- )
|
|
"Unhandled family: " write family get unparse writeln
|
|
unhandled-opcode ;
|
|
|
|
GENERIC: get-buddy
|
|
M: integer get-buddy ( bid -- <buddy> )
|
|
buddy-hash-id get hash ;
|
|
M: object get-buddy ( name -- <buddy> )
|
|
sanitize-name buddy-hash-name get hash ;
|
|
|
|
GENERIC: get-group
|
|
M: integer get-group ( bid -- <group> )
|
|
group-hash-id get hash ;
|
|
M: object get-group ( name -- <group> )
|
|
sanitize-name group-hash-name get hash ;
|
|
|
|
GENERIC: get-banned
|
|
M: integer get-banned ( bid -- <buddy> )
|
|
banned-hash-id get hash ;
|
|
M: object get-banned ( name -- <buddy> )
|
|
sanitize-name banned-hash-name get hash ;
|
|
|
|
: buddy-name? ( name -- bool )
|
|
get-buddy >boolean ;
|
|
|
|
: group-name? ( name -- bool )
|
|
get-group >boolean ;
|
|
|
|
: banned-name? ( name -- bool )
|
|
get-banned >boolean ;
|
|
|
|
: random-buddy-id ( -- id )
|
|
HEX: fff0 random-int 1+ dup get-buddy [ drop random-buddy-id ] when ;
|
|
|
|
: random-group-id ( -- id )
|
|
HEX: fff0 random-int 1+ dup get-group [ drop random-group-id ] when ;
|
|
|
|
|
|
! Events
|
|
: buddy-signon ( name -- )
|
|
get-buddy dup [ t swap set-buddy-online ] [ drop "Can't find buddy in buddylist: " write name get writeln ] if ;
|
|
|
|
: buddy-signoff ( name -- )
|
|
get-buddy dup [ f swap set-buddy-online ] [ drop "Can't find buddy in buddylist: " write name get writeln ] if ;
|
|
|
|
: print-buddylist
|
|
! group-list get [ [ buddy-name , ] each ] { } make
|
|
! [ buddylist get hash-keys string-sort [ , ] each ] { } make [ drop ] simple-outliner ;
|
|
;
|
|
|
|
: family-table ( -- hash ) H{ } ;
|
|
|
|
: FAMILY: ( -- fam# )
|
|
scan hex> swons dup car family-table hash dup [
|
|
drop
|
|
] [
|
|
drop H{ } clone over car family-table set-hash
|
|
] if ; parsing
|
|
|
|
: OPCODE: ( fam# -- )
|
|
car family-table hash word scan hex> rot set-hash f ; parsing
|
|
|
|
|
|
! Generic, Capabilities
|
|
: send-generic-capabilities
|
|
[
|
|
1 HEX: 17 0 HEX: 17 make-snac
|
|
[ 1 4 HEX: 13 3 2 1 3 1 4 1 6 1 8 1 9 1 HEX: a 1 HEX: b 1 ]
|
|
[ >short ] each
|
|
] send-aim ;
|
|
|
|
: (handle-supported-families)
|
|
unscoped-stream get empty? [
|
|
head-short family-names hash .
|
|
(handle-supported-families)
|
|
] unless ;
|
|
|
|
! : unscoped-stream get empty? [
|
|
! head-short
|
|
! [
|
|
! head-short
|
|
! head-short head-string <string-reader> [
|
|
! cond
|
|
! ] with-unscoped-stream
|
|
! ] repeat
|
|
! ] unless ;
|
|
|
|
: handle-supported-families
|
|
"Families: " print
|
|
(handle-supported-families)
|
|
send-generic-capabilities
|
|
; FAMILY: 1 OPCODE: 3
|
|
|
|
: send-requests ( -- )
|
|
! Self Info Request
|
|
[ 1 HEX: e 0 HEX: e make-snac ] send-aim
|
|
|
|
! Request Rights
|
|
[ HEX: 13 2 0 2 make-snac ] send-aim
|
|
|
|
! Request List
|
|
[ HEX: 13 4 0 HEX: 3efb0004 make-snac ] send-aim
|
|
|
|
! Location, Request Rights
|
|
[ 2 2 0 2 make-snac ] send-aim
|
|
|
|
! Buddylist Service, Rights Request
|
|
[ 3 2 0 2 make-snac ] send-aim
|
|
|
|
! Messaging, Request Parameter Info
|
|
[ 4 4 0 4 make-snac ] send-aim
|
|
|
|
! Privacy Management Service, Rights Query
|
|
[ 9 2 0 2 make-snac ] send-aim ;
|
|
|
|
: handle-1-7
|
|
[
|
|
1 8 0 8 make-snac
|
|
head-short dup [
|
|
! "Rate Classes: " write
|
|
head-short >short ! rate class id
|
|
head-int drop ! window size
|
|
head-int drop ! clear level
|
|
head-int drop ! alert level
|
|
head-int drop ! limit level
|
|
head-int drop ! disconnect level
|
|
head-int drop ! current level
|
|
head-int drop ! max level
|
|
head-int drop ! last time
|
|
head-byte drop ! current state
|
|
] repeat
|
|
[
|
|
head-short drop ( rate class id again )
|
|
! Pairs
|
|
head-short [ head-int drop ] repeat
|
|
] repeat
|
|
] send-aim ( BOS, Rights Query )
|
|
send-requests ; FAMILY: 1 OPCODE: 7
|
|
|
|
: handle-capabilities
|
|
unscoped-stream get empty? [
|
|
head-u128 capability-values hash dup [ "Unknown Capability" nip ] unless
|
|
writeln handle-capabilities
|
|
] unless ;
|
|
|
|
|
|
|
|
SYMBOL: saved-cond
|
|
: (process-tlv) ( -- )
|
|
head-short dup warning set
|
|
head-short head-string <string-reader> [
|
|
saved-cond get cond
|
|
] with-unscoped-stream ;
|
|
|
|
: process-tlv ( cond -- )
|
|
saved-cond set
|
|
unscoped-stream get empty? [
|
|
drop
|
|
] [
|
|
head-short drop
|
|
head-short [ (process-tlv) ] repeat
|
|
] if ;
|
|
|
|
: process-tlv-loop ( cond -- )
|
|
saved-cond set
|
|
unscoped-stream get empty? [
|
|
(process-tlv)
|
|
saved-cond get process-tlv-loop
|
|
] unless ;
|
|
|
|
|
|
! for inside a loop
|
|
: (process-tlv-loop2) ( cond -- )
|
|
head-byte
|
|
head-byte drop
|
|
head-short head-string <string-reader> [
|
|
saved-cond get cond
|
|
] with-unscoped-stream ;
|
|
|
|
! useful inside a tlv handler
|
|
: process-tlv-loop2 ( cond -- )
|
|
saved-cond set
|
|
unscoped-stream get empty? [
|
|
(process-tlv-loop2)
|
|
saved-cond get process-tlv-loop2
|
|
] unless ;
|
|
|
|
: (handle-online-info)
|
|
unscoped-stream get empty? [
|
|
head-byte head-string name set
|
|
head-short drop
|
|
head-short
|
|
[
|
|
head-short
|
|
head-short head-string <string-reader> [
|
|
{
|
|
{ [ dup 1 = ] [ drop head-short "Class: " write unparse writeln ] }
|
|
{ [ dup 3 = ] [ drop head-int "Time went online: " write unparse writeln ] }
|
|
{ [ dup 4 = ] [ drop head-short "Unknown4: " write unparse writeln ] }
|
|
{ [ dup 5 = ] [ drop head-int "Time registered: " write unparse writeln ] }
|
|
{ [ dup 10 = ] [ drop head-int int>ip "IP: " write writeln ] }
|
|
{ [ dup 13 = ] [ drop handle-capabilities ] }
|
|
{ [ dup 15 = ] [ drop head-int "Idle: " write unparse writeln ] }
|
|
{ [ dup 20 = ] [ drop head-byte "Unknown20: " write unparse writeln ] }
|
|
! { [ dup 29 = ] [ drop ] }
|
|
{ [ dup 30 = ] [ drop head-int "Unknown30: " write unparse writeln ] }
|
|
{ [ dup 34 = ] [ drop head-short "Unknown32: " write unparse writeln ] }
|
|
{ [ t ] [ " Unhandled tlv 1h-fh: " write unparse writeln head-contents hexdump ] }
|
|
} cond
|
|
] with-unscoped-stream
|
|
] repeat (handle-online-info)
|
|
] unless ;
|
|
|
|
: handle-online-info
|
|
(handle-online-info)
|
|
; FAMILY: 1 OPCODE: f
|
|
|
|
! message of the day
|
|
: handle-1-13
|
|
7 [ head-short drop ] repeat
|
|
! Generic, Rate Info Request
|
|
[ 1 6 0 6 make-snac ] send-aim ; FAMILY: 1 OPCODE: 13
|
|
|
|
! capabilities ack
|
|
: handle-1-18
|
|
"Unhandled ack: " write head-contents writeln ; FAMILY: 1 OPCODE: 18
|
|
|
|
: handle-1-21
|
|
! AIM Email
|
|
! [ 1 4 HEX: 02cc 4 make-snac HEX: 18 >short ] send-aim
|
|
|
|
! AIM Location
|
|
! [ 2 HEX: b HEX: 446d HEX: b make-snac username get length >byte username get % ] send-aim
|
|
|
|
! head-short
|
|
! [
|
|
! head-short
|
|
! head-short head-string <string-reader> [
|
|
! {
|
|
! ! { [ ] [ ] }
|
|
! { [ t ] [ " Unhandled tlv 1h-21h: " write unparse writeln head-contents hexdump ] }
|
|
! } cond
|
|
! ] with-unscoped-stream
|
|
! ] repeat
|
|
; FAMILY: 1 OPCODE: 21
|
|
|
|
|
|
: handle-2-1
|
|
head-short aim-errors hash "Error: " write writeln
|
|
; FAMILY: 2 OPCODE: 1
|
|
|
|
|
|
: handle-29
|
|
unscoped-stream get empty? [
|
|
"(29)" print
|
|
head-short drop
|
|
head-byte drop
|
|
head-byte head-string drop
|
|
handle-29
|
|
] unless ;
|
|
|
|
: handle-abbrev-capabilities
|
|
unscoped-stream get empty? [
|
|
head-short .h
|
|
handle-abbrev-capabilities
|
|
] unless ;
|
|
|
|
: handle-buddy-status
|
|
head-byte head-string name set
|
|
{
|
|
{ [ dup 1 = ] [ drop name get write head-short HEX: 20 bitand 1 > [ " is away." ] [ " is online." ] if writeln ] }
|
|
{ [ dup 2 = ] [ drop "Member since: " write head-short unparse writeln ] }
|
|
{ [ 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 6 = ] [ drop name get write ": (6): " write head-short unparse write " " write head-short unparse writeln ] }
|
|
{ [ dup 13 = ] [ drop "Capabilities3:" print handle-capabilities ] }
|
|
{ [ dup 14 = ] [ drop "Capabilities4:" print handle-capabilities ] }
|
|
{ [ 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 29 = ] [ drop handle-29 ] }
|
|
{ [ t ] [ " Unhandled tlv 3h-bh: " write unparse writeln head-contents hexdump ] }
|
|
} process-tlv ; FAMILY: 3 OPCODE: b
|
|
|
|
! : handle-4-5
|
|
! ; FAMILY: 4 OPCODE: 5
|
|
|
|
: handle-buddy-signoff ( -- )
|
|
head-byte head-string name set
|
|
{
|
|
{ [ dup 1 = ] [ drop name get write " signed off." writeln name get buddy-signoff ] }
|
|
{ [ dup HEX: 1d = ] [ drop ] }
|
|
{ [ t ] [ "Unhandled tlv 3h-ch: " write unparse writeln head-contents hexdump ] }
|
|
} process-tlv ; FAMILY: 3 OPCODE: c
|
|
|
|
: parse-family-4h-header
|
|
extra-data get <string-reader> [
|
|
head-short drop
|
|
head-short drop
|
|
head-short drop
|
|
] with-unscoped-stream ;
|
|
|
|
|
|
|
|
: handle-file-transfer-start-tlvs
|
|
unscoped-stream get empty? [
|
|
head-short
|
|
head-short head-string <string-reader> [
|
|
dup unparse write ": " write
|
|
{
|
|
{ [ dup 2 = ] [ drop head-int int>ip dup my-ip set "my ip: " write write ] }
|
|
{ [ dup 3 = ] [ drop head-int int>ip dup blue-ip set "blue.aol ip: " write write ] }
|
|
{ [ dup 4 = ] [ drop head-int unparse write ] }
|
|
{ [ dup 5 = ] [ drop head-short unparse write ] }
|
|
{ [ dup 10 = ] [ drop head-short unparse write ] }
|
|
{ [ dup 11 = ] [ drop head-short unparse . "Transfer cancelled" print file-transfer-cancelled on ] }
|
|
{ [ dup 12 = ] [ drop head-contents message set "Message: " write message get writeln ] }
|
|
{ [ dup 13 = ] [ drop head-contents encoding set ] }
|
|
{ [ dup 14 = ] [ drop head-short unparse write ] }
|
|
{ [ dup 15 = ] [ drop ( do nothing ) ] }
|
|
{ [ dup 22 = ] [ drop head-int unparse write ] }
|
|
{ [ dup 23 = ] [ drop head-short unparse write ] }
|
|
{ [ dup 10001 = ] [ drop head-contents write ] }
|
|
{ [ dup 10002 = ] [ drop head-contents write ] }
|
|
{ [ t ] [ "Unhandled file transfer tlv: " write unparse writeln head-contents hexdump ] }
|
|
} cond terpri
|
|
] with-unscoped-stream
|
|
handle-file-transfer-start-tlvs
|
|
] unless ;
|
|
|
|
: send-file-transfer-start
|
|
"STARTING FILE TRANSFER" print
|
|
[
|
|
4 6 0 HEX: 778f0006 make-snac
|
|
icbm-cookie get >longlong
|
|
2 >short
|
|
name get length >byte
|
|
name get %
|
|
5 >short
|
|
56 >short
|
|
0 >short
|
|
icbm-cookie get >longlong
|
|
"Send File" capability-names hash >u128
|
|
10 >short 2 >short 2 >short
|
|
2 >short 4 >short 0 >int
|
|
22 >short 4 >short HEX: ffffffff >int ! gateway?
|
|
3 >short 4 >short 0 >int
|
|
] send-aim ;
|
|
|
|
: handle-chat-start-tlvs
|
|
unscoped-stream get empty? [
|
|
head-short
|
|
head-short head-string <string-reader> [
|
|
dup unparse write ": " write
|
|
{
|
|
{ [ dup 10 = ] [ drop head-short unparse write ] }
|
|
{ [ dup 12 = ] [ drop head-contents message set ] }
|
|
{ [ dup 13 = ] [ drop head-contents encoding set ] }
|
|
{ [ dup 14 = ] [ drop head-byte unparse write ] }
|
|
{ [ dup 15 = ] [ drop ( do nothing ) ] }
|
|
{ [ dup 10001 = ] [ drop head-contents hexdump ] }
|
|
{ [ t ] [ "Unhandled chat transfer tlv: " write unparse writeln head-contents hexdump ] }
|
|
} cond terpri
|
|
] with-unscoped-stream
|
|
handle-chat-start-tlvs
|
|
] unless ;
|
|
|
|
: handle-direct-start-tlvs
|
|
unscoped-stream get empty? [
|
|
head-short
|
|
head-short head-string <string-reader> [
|
|
dup unparse write ": " write
|
|
{
|
|
{ [ dup 2 = ] [ drop head-int int>ip dup remote-internal-ip set "remote internal ip: " write write ] }
|
|
{ [ dup 3 = ] [ drop head-int int>ip dup remote-external-ip set "remote external? ip: " write write ] }
|
|
{ [ dup 4 = ] [ drop head-int int>ip dup my-ip set "my? ip: " write write ] }
|
|
{ [ dup 5 = ] [ drop head-short unparse "port?" write write ] }
|
|
{ [ dup 10 = ] [ drop head-short unparse write ] }
|
|
{ [ dup 11 = ] [ drop head-short unparse write direct-connect-cancelled set ] }
|
|
{ [ dup 15 = ] [ drop ( do nothing ) ] }
|
|
{ [ dup 22 = ] [ drop head-int unparse write ] }
|
|
{ [ dup 23 = ] [ drop head-short unparse "port?" write write ] }
|
|
{ [ t ] [ "Unhandled direct transfer tlv: " write unparse writeln head-contents hexdump ] }
|
|
} cond terpri
|
|
] with-unscoped-stream
|
|
handle-direct-start-tlvs
|
|
] unless ;
|
|
|
|
: send-direct-connect-start
|
|
;
|
|
|
|
: send-auth-file-transfer
|
|
[
|
|
0 >short
|
|
1 >short
|
|
"Send File" capability-names hash >u128
|
|
0 >short
|
|
] send-aim ;
|
|
|
|
: connect-aim-file-transfer-server
|
|
"205.188.210.203" aim-file-server-port <client> ;
|
|
|
|
|
|
: handle-file-transfer-start
|
|
head-short message-type set
|
|
head-longlong icbm-cookie set
|
|
head-u128 capability-values hash
|
|
{
|
|
{ [ dup "Send File" = ]
|
|
[ . file-transfer-cancelled off
|
|
handle-file-transfer-start-tlvs
|
|
file-transfer-cancelled get [ send-file-transfer-start ] unless
|
|
] }
|
|
{ [ dup "Chat" = ] [ . handle-chat-start-tlvs
|
|
"Chat join message: " write message get writeln ] }
|
|
{ [ dup "AIM Direct IM" = ] [ . handle-direct-start-tlvs
|
|
direct-connect-cancelled get [ send-direct-connect-start ] unless
|
|
] }
|
|
{ [ t ] [ "Unsupported capability in channel 2: " write writeln head-contents hexdump ] }
|
|
} cond ;
|
|
|
|
: parse-message-text ( -- str )
|
|
head-short drop head-short drop head-contents ;
|
|
|
|
: handle-incoming-message ( -- )
|
|
parse-family-4h-header
|
|
head-longlong drop
|
|
head-short channel set
|
|
head-byte head-string name set
|
|
{
|
|
{ [ dup 1 = ] [ drop head-short drop ] }
|
|
{ [ dup 2 = ] [ drop 15 head-string drop ] }
|
|
{ [ dup 3 = ] [ drop ] }
|
|
{ [ dup 15 = ] [ drop ] }
|
|
{ [ dup 29 = ] [ drop ] }
|
|
{ [ t ] [ "Unknown tlv: " write unparse writeln head-contents hexdump ] }
|
|
} process-tlv
|
|
{
|
|
{ [ dup 2 = ] [ drop
|
|
{
|
|
{ [ dup 1 = ] [ drop parse-message-text message set ] }
|
|
{ [ dup 5 = ] [ drop ] }
|
|
{ [ t ] [ "Unknown frag: " write unparse writeln unscoped-stream get contents hexdump ] }
|
|
} process-tlv-loop2 ] }
|
|
{ [ dup 5 = ] [ drop handle-file-transfer-start ] }
|
|
{ [ dup 11 = ] [ drop ] }
|
|
{ [ t ] [ "Unhandled chunk: " write unparse writeln head-contents hexdump ] }
|
|
} process-tlv-loop
|
|
|
|
channel get 1 = [
|
|
"Incoming msg from " write name get write ": " write
|
|
"Warning: " write warning get 10 /f unparse write "%" writeln
|
|
"Message: " write message get writeln
|
|
] when ; FAMILY: 4 OPCODE: 7
|
|
|
|
! : handle-4-12
|
|
! head-short 2 / [ head-short drop ] repeat
|
|
! head-cstring drop
|
|
! head-short drop
|
|
! head-byte head-string
|
|
! ; FAMILY: 4 OPCODE: 12
|
|
|
|
: handle-typing-message ( -- )
|
|
parse-family-4h-header
|
|
head-longlong drop
|
|
head-short channel set
|
|
head-byte head-string write
|
|
head-short
|
|
{
|
|
{ [ dup 0 = ] [ drop " has an empty textbox." writeln ] }
|
|
{ [ dup 1 = ] [ drop " has entered text." writeln ] }
|
|
{ [ dup 2 = ] [ drop " is typing..." writeln ] }
|
|
{ [ t ] [ " does 4h.14h unknown: " write unparse writeln ] }
|
|
} cond ; FAMILY: 4 OPCODE: 14
|
|
|
|
! : handle-9-3
|
|
! ; FAMILY: 9 OPCODE: 3
|
|
|
|
: handle-b-2
|
|
head-short "Send status report every: " write unparse write " hours" writeln
|
|
head-short "Unknown: " write unparse writeln
|
|
; FAMILY: b OPCODE: 2
|
|
|
|
! : handle-19-3
|
|
! ; FAMILY: 13 OPCODE: 3
|
|
|
|
SYMBOL: gid ! group id
|
|
SYMBOL: bid ! 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 gid set gid get .
|
|
head-short bid set bid 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 bid get gid get V{ } clone f f <buddy>
|
|
dup name get sanitize-name buddy-hash-name get set-hash bid get buddy-hash-id get set-hash ] }
|
|
{ [ dup 1 = ] [ drop name get dup length 0 = [ drop ] [ gid get <group>
|
|
dup name get sanitize-name group-hash-name get set-hash gid get group-hash-id get set-hash ] if ] }
|
|
{ [ dup 3 = ] [ drop name get bid get gid get V{ } clone f f <buddy>
|
|
dup name get sanitize-name banned-hash-name get set-hash bid get banned-hash-id get set-hash ] }
|
|
{ [ t ] [ drop "Unknown 19-6 type" print ] }
|
|
} cond
|
|
] repeat
|
|
head-short drop ! unknown or timestamp
|
|
head-short drop ! unknown or timestamp
|
|
|
|
snac-flags get 0 = [
|
|
! SSI, Activate
|
|
[ HEX: 13 7 0 7 make-snac ] send-aim
|
|
! 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
|
|
5 >short
|
|
capability-values hash-keys length 16 * >short ! size
|
|
capability-values hash-keys [ >u128 ] each
|
|
6 >short 6 >short 4 >short 2 >short 2 >short
|
|
] send-aim
|
|
|
|
! Set ICBM Parameter
|
|
[
|
|
4 2 0 2 make-snac
|
|
0 >int
|
|
HEX: b >short
|
|
HEX: 1f40 >short
|
|
HEX: 03e7 >short
|
|
HEX: 03e7 >short
|
|
0 >int
|
|
] send-aim
|
|
|
|
! Client Ready
|
|
[
|
|
1 2 0 2 make-snac
|
|
[
|
|
HEX: 1 HEX: 4 HEX: 110 HEX: 8f1
|
|
HEX: 13 HEX: 3 HEX: 110 HEX: 8f1
|
|
HEX: 2 HEX: 1 HEX: 110 HEX: 8f1
|
|
HEX: 3 HEX: 1 HEX: 110 HEX: 8f1
|
|
HEX: 4 HEX: 4 HEX: 110 HEX: 8f1
|
|
HEX: 6 HEX: 1 HEX: 110 HEX: 8f1
|
|
HEX: 8 HEX: 1 HEX: 104 HEX: 8f1
|
|
HEX: 9 HEX: 1 HEX: 110 HEX: 8f1
|
|
HEX: a HEX: 1 HEX: 110 HEX: 8f1
|
|
HEX: b HEX: 1 HEX: 110 HEX: 8f1
|
|
] [ >short ] each
|
|
] send-aim
|
|
|
|
! Process
|
|
] when ; FAMILY: 13 OPCODE: 6
|
|
|
|
|
|
: parse-server ( ip:port -- )
|
|
":" split [ first ] keep second string>number aim-chat-port set aim-chat-ip set ;
|
|
|
|
: handle-login-packet ( -- )
|
|
unscoped-stream get empty? [
|
|
head-short head-short swap
|
|
{
|
|
{ [ dup 5 = ] [ drop head-string parse-server ] }
|
|
{ [ dup 6 = ] [ drop head-string auth-code set ] }
|
|
{ [ t ] [ drop head-string drop ] }
|
|
} cond
|
|
handle-login-packet
|
|
] unless ; FAMILY: 17 OPCODE: 3
|
|
|
|
: password-md5 ( password -- md5 )
|
|
login-key get
|
|
password get string>md5 append
|
|
client-md5-string append
|
|
string>md5 >string ;
|
|
|
|
: respond-login-key-packet ( -- )
|
|
[
|
|
HEX: 17 HEX: 2 0 0 make-snac
|
|
1 >short
|
|
username get length >short
|
|
username get %
|
|
|
|
! password hash chunk
|
|
HEX: 25 >short
|
|
HEX: 10 >short
|
|
password-md5 %
|
|
|
|
HEX: 4c >short
|
|
HEX: 00 >short
|
|
HEX: 03 >short client-id-string length >short client-id-string %
|
|
HEX: 16 >short HEX: 02 >short client-id-num >short
|
|
HEX: 17 >short HEX: 02 >short client-major-ver >short
|
|
HEX: 18 >short HEX: 02 >short client-minor-ver >short
|
|
HEX: 19 >short HEX: 02 >short client-lesser-ver >short
|
|
HEX: 1a >short HEX: 02 >short client-build-num >short
|
|
HEX: 14 >short HEX: 04 >short client-distro-num >int
|
|
HEX: 0f >short client-language length >short client-language %
|
|
HEX: 0e >short client-country length >short client-country %
|
|
HEX: 4a >short HEX: 01 >short client-ssi-flag >byte
|
|
] send-aim ;
|
|
|
|
: handle-login-key-packet ( -- )
|
|
head-short head-string login-key set
|
|
respond-login-key-packet ; FAMILY: 17 OPCODE: 7
|
|
|
|
: handle-packet ( packet -- )
|
|
<string-reader>
|
|
[
|
|
parse-snac
|
|
"Family: " write family get >hex write
|
|
", Opcode: " write opcode get >hex writeln
|
|
family get family-table hash dup [
|
|
opcode get swap hash dup [
|
|
execute
|
|
] [
|
|
unhandled-opcode drop
|
|
] if
|
|
] [
|
|
unhandled-family-opcode
|
|
drop
|
|
] if
|
|
unscoped-stream get empty? [ incomplete-opcode ] unless
|
|
] with-unscoped-stream ;
|
|
|
|
! Login
|
|
: send-first-login ( -- )
|
|
[ 1 >int ] send-aim ;
|
|
|
|
: send-first-request-auth ( -- )
|
|
2 stage-num set
|
|
[
|
|
HEX: 17 HEX: 6 0 0 make-snac
|
|
1 >short
|
|
username get length >short
|
|
username get %
|
|
HEX: 4b >short
|
|
HEX: 00 >short
|
|
HEX: 5a >short
|
|
HEX: 00 >short
|
|
] send-aim ;
|
|
|
|
! AIM Chat Server
|
|
: send-second-login
|
|
[
|
|
1 >int
|
|
6 >short
|
|
auth-code get length >short
|
|
auth-code get %
|
|
] send-aim ;
|
|
|
|
: first-server
|
|
! first server
|
|
1 stage-num set
|
|
aim-login-server login-port <client> conn set
|
|
|
|
send-first-login read-aim drop
|
|
|
|
! normal transmission stage
|
|
send-first-request-auth read-aim handle-packet
|
|
read-aim handle-packet
|
|
read-aim drop ! handle-packet
|
|
conn get stream-close ;
|
|
|
|
: second-server
|
|
aim-chat-ip get aim-chat-port get <client> conn set
|
|
1 stage-num set
|
|
HEX: 7fff random-int seq-num set
|
|
send-second-login read-aim drop
|
|
2 stage-num set ;
|
|
|
|
: handle-loop ( -- )
|
|
read-aim handle-packet terpri handle-loop ;
|
|
|
|
: connect-aim ( -- )
|
|
first-server
|
|
aim-chat-ip get
|
|
[ "No aim server received (too many logins, try again later)" throw ] unless
|
|
second-server [ handle-loop ] in-thread ;
|
|
|
|
IN: aim
|
|
|
|
! Commands
|
|
: send-im ( name message -- )
|
|
message set
|
|
name set
|
|
[
|
|
4 6 0 HEX: 7c3a0006 make-snac
|
|
"1973973" >cstring
|
|
1 >short
|
|
name get length >byte
|
|
name get %
|
|
2 >short
|
|
|
|
[
|
|
5 >byte 1 >byte 3 >short 1 >byte 1 >byte 2 >byte
|
|
HEX: 101 >short
|
|
message get length 4 + >short
|
|
0 >short
|
|
HEX: ffff >short
|
|
message get %
|
|
] make-packet
|
|
dup length >short %
|
|
3 >short 0 >short 6 >short 0 >short
|
|
] send-aim ;
|
|
|
|
: query-info ( name -- )
|
|
name set
|
|
[
|
|
2 HEX: 15 0 HEX: 29cb0015 make-snac
|
|
1 >int
|
|
name get length >byte
|
|
name get %
|
|
] send-aim ;
|
|
|
|
: query-away ( name -- )
|
|
name set
|
|
[
|
|
2 HEX: 15 0 HEX: 29cb0015 make-snac
|
|
2 >int
|
|
name get length >byte
|
|
name get %
|
|
] send-aim ;
|
|
|
|
: set-away ( message -- )
|
|
message set
|
|
[
|
|
2 4 0 4 make-snac
|
|
3 >short
|
|
client-charset length >short
|
|
client-charset %
|
|
4 >short
|
|
message get length >short
|
|
message get %
|
|
] send-aim ;
|
|
|
|
: return-from-away ( -- )
|
|
[
|
|
2 4 0 4 make-snac
|
|
4 >short
|
|
0 >short
|
|
] send-aim ;
|
|
|
|
: set-info ( message -- )
|
|
message set
|
|
! [ 2 9 0 HEX: 63e40000 ] send-aim
|
|
[
|
|
2 4 0 4 make-snac
|
|
1 >short
|
|
client-charset length >short
|
|
client-charset %
|
|
2 >short
|
|
message get length >short
|
|
message get %
|
|
] send-aim ;
|
|
|
|
: buddylist-edit-start
|
|
[ HEX: 13 HEX: 11 0 HEX: 11 make-snac ] send-aim ;
|
|
|
|
: buddylist-edit-stop
|
|
[ HEX: 13 HEX: 12 0 HEX: 12 make-snac ] send-aim ;
|
|
|
|
|
|
! add, delete groups, move buddies from group to group
|
|
! parse buddy list
|
|
|
|
: add-group ( name -- )
|
|
dup name set modify-queue get enque
|
|
buddylist-edit-start
|
|
[
|
|
HEX: 13 8 0 HEX: 4fb20008 make-snac
|
|
name get length >short
|
|
name get %
|
|
random-group-id >short
|
|
0 >short ! buddy id
|
|
1 >short ! buddy type
|
|
0 >short ! tlv len
|
|
] send-aim ;
|
|
|
|
: delete-group ( name -- )
|
|
dup name set modify-queue get enque
|
|
buddylist-edit-start
|
|
[
|
|
HEX: 13 HEX: a 0 HEX: 5086000a make-snac
|
|
name get length >short
|
|
name get %
|
|
name get get-group group-id >short
|
|
0 >short
|
|
1 >short
|
|
0 >short
|
|
] send-aim ;
|
|
|
|
! TODO: make sure buddy doesnt already exist, makd sure group exists
|
|
: add-buddy ( name group -- )
|
|
group set
|
|
dup name set modify-queue get enque
|
|
buddylist-edit-start
|
|
[
|
|
HEX: 13 9 0 HEX: 72470009 make-snac
|
|
0 >short
|
|
0 >short
|
|
0 >short
|
|
1 >short
|
|
6 >short
|
|
HEX: c8 >short
|
|
2 >short
|
|
HEX: 6dc5 >short
|
|
] send-aim
|
|
|
|
[
|
|
HEX: 13 8 0 HEX: 5b2f0008 make-snac
|
|
name get length >short
|
|
name get %
|
|
group get get-group group-id >short
|
|
random-buddy-id >short
|
|
0 >short ! buddy type
|
|
0 >short ! tlv len
|
|
] send-aim ;
|
|
|
|
: delete-buddy ( name -- )
|
|
dup name set modify-queue get enque
|
|
buddylist-edit-start
|
|
[
|
|
HEX: 13 HEX: a 0 HEX: 5086000a make-snac
|
|
name get length >short
|
|
name get %
|
|
name get get-buddy dup buddy-gid >short
|
|
buddy-id >short
|
|
0 >short
|
|
0 >short
|
|
] send-aim ;
|
|
|
|
: modify-buddylist ( name -- )
|
|
! dup buddy-name? [ dup name set dup buddy-id bid set buddy-gid gid set ] when
|
|
! dup group-name? [ dup name set dup group-id gid set 0 bid set ] when
|
|
! dup banned-name? [ dup name set dup buddy-id bid set buddy-gid gid set ] when
|
|
! [
|
|
! HEX: 13 9 0 HEX: 6e190009 make-snac
|
|
! name get dup length >short %
|
|
! gid get >short
|
|
! 0 >short
|
|
! 1 >short ! group type = 1
|
|
|
|
! "members of this group" tlv
|
|
! 8 >short
|
|
! HEX: c8 >short
|
|
! 4 >short
|
|
! HEX: 4e833ea8 >int
|
|
! ] send-aim ;
|
|
drop ;
|
|
|
|
IN: aim-internals
|
|
: buddylist-error
|
|
; FAMILY: 13 OPCODE: b
|
|
|
|
: buddylist-ack
|
|
! modify-queue get deque modify-buddylist
|
|
buddylist-edit-stop ; FAMILY: 13 OPCODE: d
|
|
|
|
IN: aim
|
|
|
|
: run ( username password -- )
|
|
initialize-aim connect-aim ;
|
|
! [ initialize-aim connect-aim ] with-scope ;
|
|
|
|
! my aim test account. you can use it.
|
|
: run-test-account
|
|
"FactorTest" "factoraim" run ;
|
|
|