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

Uses nested unscoped streams 

Handles incoming messages
Various refactoring
cvs
Doug Coleman 2005-09-20 02:58:20 +00:00
parent a8e80915ce
commit 49bc74e044
1 changed files with 90 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

124
contrib/aim/aim.factor
View File

@ -75,12 +75,8 @@ SYMBOL: opcode
"Sending: " write dup hexdump "Sending: " write dup hexdump
(send-aim) ; (send-aim) ;
: drop-header ( str -- )
6 swap tail ;
: with-aim ( quot -- ) : with-aim ( quot -- )
conn get swap with-default-stream ; conn get swap with-unscoped-stream ;
: read-aim ( -- bc ) : read-aim ( -- bc )
[ [
@ -91,7 +87,6 @@ SYMBOL: opcode
] with-aim ; ] with-aim ;
! "Received: " write dup hexdump ; ! "Received: " write dup hexdump ;
: make-snac ( fam subtype flags req-id -- ) : make-snac ( fam subtype flags req-id -- )
4 >nvector { >short >short >short >int } papply ; 4 >nvector { >short >short >short >int } papply ;
@ -103,8 +98,8 @@ SYMBOL: opcode
: (unhandled-opcode) ( -- ) : (unhandled-opcode) ( -- )
"Family: " write family get >hex "h" append write "Family: " write family get >hex "h" append write
", opcode: " write opcode get >hex "h" append write terpri ", opcode: " write opcode get >hex "h" append writeln
default-stream get contents hexdump ; unscoped-stream get contents hexdump ;
: unhandled-opcode ( -- ) : unhandled-opcode ( -- )
"Unhandled opcode: " write (unhandled-opcode) ; "Unhandled opcode: " write (unhandled-opcode) ;
@ -113,9 +108,10 @@ SYMBOL: opcode
"Incomplete handling: " write (unhandled-opcode) ; "Incomplete handling: " write (unhandled-opcode) ;
: unhandled-family-opcode ( -- ) : unhandled-family-opcode ( -- )
"Unhandled family: " write family get >hex "h" append write terpri "Unhandled family: " write family get >hex "h" append writeln
unhandled-opcode ; unhandled-opcode ;
! FAMILY/OPCODE TABLES
! returns handler table for a family ! returns handler table for a family
: FAMILY-TABLE : FAMILY-TABLE
{{ {{
@ -124,20 +120,23 @@ SYMBOL: opcode
: add-family ( -- ) : add-family ( -- )
word dup unparse "-" split second dup length 1- swap head hex> FAMILY-TABLE set-hash ; parsing word dup unparse "-" split second dup length 1- swap head hex> FAMILY-TABLE set-hash ; parsing
! : FAMILY-1h : FAMILY-1h
! {{ {{
! }} ; add-family }} ; add-family
: handle-3h-bh ( -- ) : handle-3h-bh ( -- )
; ;
: FAMILY-3h ( -- hash) : FAMILY-3h ( -- hash)
{{ {{
[[ HEX: b handle-3h-bh ]] [[ HEX: b handle-3h-bh ]]
}} ; add-family }} ; add-family
: drop-family-4h-header
: (drop-family-4h-header)
head-short drop head-short drop
head-short drop head-short drop
head-short drop head-short drop
@ -145,23 +144,75 @@ SYMBOL: opcode
8 head-string drop ! message-id 8 head-string drop ! message-id
; ;
: (parse-incoming-message-text) ( -- str )
head-short drop head-short unscoped-stream get contents ;
: (parse-incoming-message-tlv2)
unscoped-stream get empty? [
head-byte
head-byte drop ! fragVer
head-short head-string <string-reader>
[
{
{ [ dup 1 = ] [ drop (parse-incoming-message-text) writeln ] }
{ [ dup 5 = ] [ drop ] }
{ [ t ] [ "Unknown frag: " write unparse writeln ] }
} cond
] with-unscoped-stream
(parse-incoming-message-tlv2)
] unless ;
: (parse-incoming-message-chunks)
unscoped-stream get empty? [
head-short
head-short head-string <string-reader> [
{
{ [ dup 2 = ] [ drop (parse-incoming-message-tlv2) ] }
{ [ dup 11 = ] [ 2drop ] }
{ [ dup 13 = ] [ drop ] }
{ [ t ] [ "Unhandled chunk: " write unparse writeln ] }
} cond
] with-unscoped-stream
(parse-incoming-message-chunks)
] unless ;
: (parse-incoming-message-tlv) ( n -- )
[
head-short
head-short head-string <string-reader>
[
{
{ [ 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 ] }
} cond
] with-unscoped-stream
] repeat ;
: handle-incoming-message ( -- ) : handle-incoming-message ( -- )
drop-family-4h-header (drop-family-4h-header)
head-short drop ! channel head-short drop ! channel
head-byte head-string "Incoming msg from: " write write terpri ! from name head-byte head-string "Incoming msg from " write write ": " write ! from name
head-short drop ! warning-level head-short drop ! warning-level
head-short (parse-incoming-message-tlv)
(parse-incoming-message-chunks)
; ;
: handle-typing-message ( -- ) : handle-typing-message ( -- )
drop-family-4h-header (drop-family-4h-header)
head-short drop head-short drop
head-byte head-string write head-byte head-string write
head-short head-short
{ {
{ [ dup 0 = ] [ drop " has an empty textbox." write terpri ] } { [ dup 0 = ] [ drop " has an empty textbox." writeln ] }
{ [ dup 1 = ] [ drop " has entered text." write terpri ] } { [ dup 1 = ] [ drop " has entered text." writeln ] }
{ [ dup 2 = ] [ drop " is typing..." write terpri ] } { [ dup 2 = ] [ drop " is typing..." writeln ] }
{ [ t ] [ " does 4h.14h unknown: " write unparse write terpri ] } { [ t ] [ " does 4h.14h unknown: " write unparse writeln ] }
} cond ; } cond ;
: FAMILY-4h ( -- hash) : FAMILY-4h ( -- hash)
@ -170,34 +221,37 @@ SYMBOL: opcode
[[ HEX: 14 handle-typing-message ]] [[ HEX: 14 handle-typing-message ]]
}} ; add-family }} ; add-family
: FAMILY-13h ( -- hash) : FAMILY-13h ( -- hash)
{{ {{
}} ; add-family }} ; add-family
: print-op ( op -- ) : (print-op) ( op -- )
"Op: " write . ; "Op: " write . ;
: parse-server ( ip:port -- ) : (parse-server) ( ip:port -- )
":" split [ first ] keep second string>number aim-chat-port set aim-chat-ip set ; ":" split [ first ] keep second string>number aim-chat-port set aim-chat-ip set ;
: process-login-chunks ( stream -- ) : (process-login-chunks) ( stream -- )
default-stream get empty? [ unscoped-stream get empty? [
head-short head-short
head-short head-short
swap swap
{ {
{ [ dup 1 = ] [ print-op head-string . ] } { [ dup 1 = ] [ (print-op) head-string . ] }
{ [ dup 5 = ] [ print-op head-string dup . parse-server ] } { [ dup 5 = ] [ (print-op) head-string dup . (parse-server) ] }
{ [ dup 6 = ] [ print-op head-string dup . auth-code set ] } { [ dup 6 = ] [ (print-op) head-string dup . auth-code set ] }
{ [ dup 8 = ] [ print-op head-string . ] } { [ dup 8 = ] [ (print-op) head-string . ] }
{ [ t ] [ print-op head-string . ] } { [ t ] [ (print-op) head-string . ] }
} cond } cond
process-login-chunks (process-login-chunks)
] unless ; ] unless ;
: handle-login-packet ( -- ) : handle-login-packet ( -- )
process-login-chunks ; (process-login-chunks) ;
: password-md5 ( password -- md5 ) : password-md5 ( password -- md5 )
login-key get login-key get
@ -242,6 +296,8 @@ SYMBOL: opcode
}} ; add-family }} ; add-family
: handle-packet ( packet -- ) : handle-packet ( packet -- )
<string-reader> <string-reader>
[ [
@ -255,8 +311,8 @@ SYMBOL: opcode
unhandled-family-opcode unhandled-family-opcode
drop drop
] ifte ] ifte
default-stream get empty? [ incomplete-opcode ] unless unscoped-stream get empty? [ incomplete-opcode ] unless
] with-default-stream ; ] with-unscoped-stream ;
: send-first-login ( -- ) : send-first-login ( -- )
[ 1 >int ] send-aim ; [ 1 >int ] send-aim ;