diff --git a/contrib/aim/aim.factor b/contrib/aim/aim.factor deleted file mode 100644 index 841f909c83..0000000000 --- a/contrib/aim/aim.factor +++ /dev/null @@ -1,1079 +0,0 @@ -! All Talk - -IN: aim-internals -USING: kernel sequences 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 - 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-hash-id get hash ; -M: object get-buddy ( name -- ) - sanitize-name buddy-hash-name get hash ; - -GENERIC: get-group -M: integer get-group ( bid -- ) - group-hash-id get hash ; -M: object get-group ( name -- ) - sanitize-name group-hash-name get hash ; - -GENERIC: get-banned -M: integer get-banned ( bid -- ) - banned-hash-id get hash ; -M: object get-banned ( name -- ) - 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> dup family-table hash [ - H{ } clone over family-table set-hash - ] unless ; parsing - -: OPCODE: ( fam# -- ) - family-table hash word scan hex> rot set-hash ; 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 [ - ! 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 [ - 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 [ - 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 [ - { - { [ 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 [ - ! { - ! ! { [ ] [ ] } - ! { [ 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 [ - 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 [ - 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 [ - 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 [ - 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 ; - - -: 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 - 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 - 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 - 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 -- ) - - [ - 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 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 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 ; - diff --git a/contrib/aim/load.factor b/contrib/aim/load.factor deleted file mode 100644 index 8636beba4c..0000000000 --- a/contrib/aim/load.factor +++ /dev/null @@ -1,3 +0,0 @@ -REQUIRES: crypto ; - -PROVIDE: aim { "net-bytes.factor" "aim.factor" } ; diff --git a/contrib/aim/net-bytes.factor b/contrib/aim/net-bytes.factor deleted file mode 100644 index 5e79570e8a..0000000000 --- a/contrib/aim/net-bytes.factor +++ /dev/null @@ -1,189 +0,0 @@ -IN: aim-internals -USING: kernel sequences prettyprint strings namespaces math threads vectors errors parser interpreter test io crypto arrays ; - -SYMBOL: big-endian t big-endian set -SYMBOL: unscoped-stream -SYMBOL: unscoped-stack - -! Examples: -! 1 2 3 4 4 >nvector . -! { 1 2 3 4 } - -! { 1 2 3 4 } { >byte >short >int >long } papply . -! "\u0001\0\u0002\0\0\0\u0003\0\0\0\0\0\0\0\u0004" - -! [ 1 >short 6 >long ] make-packet . -! "\0\u0001\0\0\0\0\0\0\0\u0006" - -: int>ip ( n -- str ) - [ HEX: ff000000 over bitand -24 shift unparse % CHAR: . , - HEX: 00ff0000 over bitand -16 shift unparse % CHAR: . , - HEX: 0000ff00 over bitand -8 shift unparse % CHAR: . , - HEX: 000000ff bitand unparse % ] "" make ; - - -! doesn't compile -! : >nvector ( elems n -- ) - ! { } clone swap [ drop swap add ] each reverse ; - -: 4vector ( elems -- ) - V{ } clone 4 [ drop swap add ] each reverse ; - -! TODO: make this work for types other than "" -: papply ( seq seq -- seq ) - [ [ 2array >quotation call % ] 2each ] "" make ; - -: writeln ( string -- ) - write terpri ; - -! NEEDS REFACTORING, GOSH! -! Hexdump -: (print-offset) ( lineno -- ) - 16 * >hex 8 CHAR: 0 pad-left write "h: " write ; - -: (print-hex-digit) ( digit -- ) - >hex 2 CHAR: 0 pad-left write ; - -: (print-hex-line) ( lineno string -- ) - over (print-offset) - dup length dup 16 = - [ [ 2dup swap nth (print-hex-digit) " " write ] repeat ] ! full line - [ ! partial line - [ 2dup swap nth (print-hex-digit) " " write ] repeat - dup length 16 swap - [ " " write ] repeat - ] if - dup length - [ 2dup swap nth dup printable? [ write1 ] [ "." write drop ] if ] repeat - terpri drop ; - -: (num-full-lines) ( bytes -- ) - length 16 / floor ; - -: (get-slice) ( lineno bytes -- ) - >r dup 16 * dup 16 + r> ; - -: (get-last-slice) ( bytes -- ) - dup length dup 16 mod - over length rot ; - -: (print-bytes) ( bytes -- ) - dup (num-full-lines) [ over (get-slice) (print-hex-line) ] repeat - dup (num-full-lines) over (get-last-slice) dup empty? [ 3drop ] [ (print-hex-line) 2drop ] if ; - -: (print-length) ( len -- ) - [ - "Length: " % - dup unparse % - ", " % - >hex % - "h\n" % - ] "" make write ; - -: hexdump ( str -- ) - dup length (print-length) (print-bytes) ; - - - -: save-current-scope - unscoped-stack get [ V{ } clone unscoped-stack set ] unless - swap dup unscoped-stream set unscoped-stack get push ; - -: set-previous-scope - unscoped-stack get dup length 1 > [ - [ pop ] keep nip peek unscoped-stream set ] [ - pop drop - ] if ; - -: with-unscoped-stream ( stream quot -- ) - save-current-scope catch set-previous-scope - [ dup [ unscoped-stream get stream-close ] when rethrow ] when ; - -: close-unscoped-stream ( -- ) - unscoped-stream get stream-close ; - -: >endian ( obj n -- str ) - big-endian get [ >be ] [ >le ] if ; - -: endian> ( obj n -- str ) - big-endian get [ be> ] [ le> ] if ; - -: (>byte) ( byte -- str ) - unit >string ; - -: (>short) ( short -- str ) - 2 >endian ; - -: (>int) ( int -- str ) - 4 >endian ; - -: (>longlong) ( longlong -- str ) - 8 >endian ; - -: (>u128) ( u128 -- str ) - 16 >endian ; - -: (>cstring) ( str -- str ) - "\0" append ; - -: >byte ( byte -- ) - (>byte) % ; - -: >short ( short -- ) - (>short) % ; - -: >int ( int -- ) - (>int) % ; - -: >longlong ( longlong -- ) - (>longlong) % ; - -: >u128 ( u128 -- ) - (>u128) % ; - -: >cstring ( str -- ) - (>cstring) % ; - - -! doesn't compile -! : make-packet ( quot -- ) - ! depth >r call depth r> - [ drop append ] each ; -: make-packet - "" make ; - -: (head-short) ( str -- short ) - 2 swap head endian> ; -: (head-int) ( str -- int ) - 4 swap head endian> ; -: (head-longlong) ( str -- longlong ) - 8 swap head endian> ; -: (head-u128) ( str -- u128 ) - 16 swap head endian> ; - -! 8 bits -: head-byte ( -- byte ) - 1 unscoped-stream get stream-read first ; - -! 16 bits -: head-short ( -- short ) - 2 unscoped-stream get stream-read (head-short) ; - -! 32 bits -: head-int ( -- int ) - 4 unscoped-stream get stream-read (head-int) ; - -! 64 bits -: head-longlong ( -- longlong ) - 8 unscoped-stream get stream-read (head-longlong) ; - -! 128 bits -: head-u128 ( -- u128 ) - 16 unscoped-stream get stream-read (head-u128) ; - -: head-string ( n -- str ) - unscoped-stream get stream-read >string ; - -! : head-cstring ( -- str ) - ! head-byte ] - -: head-contents ( -- str ) - unscoped-stream get contents ; -