factor/contrib/aim/aim.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 ;