protocol.tcl from aMSN at Krugle
Show protocol.tcl syntax highlighted
# Microsoft Messenger Protocol Implementation
#=======================================================================
::Version::setSubversionId {$Id: protocol.tcl 8982 2007-09-01 18:11:03Z kakaroto $}
if { $initialize_amsn == 1 } {
global list_BLP list_cmdhnd sb_list contactlist_loaded
set contactlist_loaded 0
#To be deprecated and replaced with ::abook thing
set list_BLP -1
#Clear all user infomation
::abook::clearData
set list_cmdhnd [list]
set sb_list [list]
package require base64
package require sha1
if { [version_vcompare [info patchlevel] 8.4.13] >= 0} {
package require snit
} else {
source utils/snit/snit.tcl
}
}
namespace eval ::MSNFT {
namespace export inviteFT acceptFT rejectFT
#TODO: Instead of using a list, use many variables: ft_name, ft_sockid...
# If type is = 1 then it's an MSNP2P file send
proc invitationReceived { filename filesize cookie chatid fromlogin {type "0"}} {
variable filedata
if { $type == 0 } {
set filedata($cookie) [list "$filename" $filesize $chatid $fromlogin "receivewait" "ipaddr"]
after 300000 "::MSNFT::DeleteFT $cookie"
SendMessageFIFO [list ::amsn::fileTransferRecv $filename $filesize $cookie $chatid $fromlogin] "::amsn::messages_stack($chatid)" "::amsn::messages_flushing($chatid)"
#set filetoreceive [list "$filename" $filesize]
} elseif { $type == 1 } {
set filedata($cookie) [list "$filename" $filesize $chatid $fromlogin]
}
}
proc acceptReceived {cookie chatid fromlogin message} {
variable filedata
#status_log "DATA: $cookie $chatid $fromlogin $message $body\n"
if {![info exists filedata($cookie)]} {
return
}
#set requestdata [string range $requestdata 0 [expr {[string length requestdata] -2}]]
set requestdata [$message getField Request-Data]
status_log "Ok, so here we have cookie=$cookie, requestdata=$requestdata\n" red
if { $requestdata != "IP-Address:" } {
status_log "Requested data is not IP-Address!!: $requestdata\n" red
return
}
set ipaddr [$message getField $requestdata]
#If IP field is blank, and we are sender, Send the File and requested IP (SendFile)
if { ($ipaddr == "") && ([getTransferType $cookie]=="send") } {
status_log "Invitation to filetransfer $cookie accepted\n" black
SendMessageFIFO [list ::amsn::acceptedFT $chatid $fromlogin [getFilename $cookie]] "::amsn::messages_stack($chatid)" "::amsn::messages_flushing($chatid)"
set newcookie [::md5::md5 "$cookie$fromlogin"]
set filedata($newcookie) $filedata($cookie)
SendFile $newcookie $cookie
#TODO: Show accept or reject messages from other users? (If transferType=="receive")
} elseif {($ipaddr == "") && ([getTransferType $cookie]!="send")} {
SendMessageFIFO [list ::amsn::acceptedFT $chatid $fromlogin [getFilename $cookie]] "::amsn::messages_stack($chatid)" "::amsn::messages_flushing($chatid)"
#If message comes from sender, and we are receiver, connect
} elseif { ($fromlogin == [lindex $filedata($cookie) 3]) && ([getTransferType $cookie]=="receive")} {
after cancel "::MSNFT::timeoutedFT $cookie"
set port [$message getField Port]
set authcookie [$message getField AuthCookie]
#status_log "Body: $body\n"
ConnectMSNFTP $ipaddr $port $authcookie $cookie
}
}
proc getUsername { cookie } {
variable filedata
if {[info exists filedata($cookie)]} {
return [lindex $filedata($cookie) 3]
}
return ""
}
proc getFilename { cookie } {
variable filedata
if {[info exists filedata($cookie)]} {
return [lindex $filedata($cookie) 0]
}
return ""
}
proc getTransferType { cookie } {
variable filedata
if {[info exists filedata($cookie)]} {
return [lindex $filedata($cookie) 4]
}
return ""
}
proc cancelFT { cookie } {
variable filedata
if {[info exists filedata($cookie)]} {
::amsn::FTProgress ca $cookie [lindex $filedata($cookie) 0]
set sockid [lindex $filedata($cookie) 6]
catch {puts $sockid "CCL\n"}
DeleteFT $cookie
status_log "File transfer manually canceled\n"
}
}
proc timeoutedFT { cookie } {
variable filedata
after cancel "::MSNFT::timeoutedFT $cookie"
if {[info exists filedata($cookie)]} {
::amsn::FTProgress e $cookie [lindex $filedata($cookie) 0]
DeleteFT $cookie
status_log "File transfer timeouted\n"
}
}
proc FinishedFT { cookie } {
variable filedata
set filename [file join [::config::getKey receiveddir] [lindex $filedata($cookie) 0] ]
set finishedname [filenoext $filename]
if { [string range $filename [expr [string length $filename] - 11] [string length $filename]] == ".incomplete" } {
if { [catch { file rename $filename $finishedname } ] } {
::amsn::infoMsg [trans couldnotrename $filename] warning
}
}
DeleteFT $cookie
status_log "File transfer finished ok\n"
}
proc DeleteFT { cookie } {
variable filedata
if {[info exists filedata($cookie)] } {
set sockid [lindex $filedata($cookie) 6]
set fileid [lindex $filedata($cookie) 7]
status_log "Closing FT socket $sockid\n"
catch {fileevent $sockid writable ""}
catch {fileevent $sockid readable ""}
catch {close $sockid}
status_log "Closing FT file $fileid\n"
catch {close $fileid}
unset filedata($cookie)
}
}
#################################
#All about receiving files
#################################
proc acceptFT {chatid cookie} {
#Send the acceptation for a file transfer, request IP
variable filedata
if { ![info exists filedata($cookie)]} {
return -1
}
after cancel "::MSNFT::DeleteFT $cookie"
set filedata($cookie) [lreplace $filedata($cookie) 4 4 "receive"]
set msg "MIME-Version: 1.0\r\nContent-Type: text/x-msmsgsinvite; charset=UTF-8\r\n\r\n"
set msg "${msg}Invitation-Command: ACCEPT\r\n"
set msg "${msg}Invitation-Cookie: $cookie\r\n"
set msg "${msg}Launch-Application: FALSE\r\n"
set msg "${msg}Request-Data: IP-Address:\r\n\r\n"
set msg [encoding convertto utf-8 $msg]
set msg_len [string length $msg]
set sbn [::MSN::SBFor $chatid]
if {$sbn == 0 } {
cancelFT $cookie
return 0
}
set sock [$sbn cget -sock]
::MSN::WriteSBNoNL $sbn "MSG" "U $msg_len\r\n$msg"
after 20000 "::MSNFT::timeoutedFT $cookie"
::amsn::FTProgress a $cookie [lindex $filedata($cookie) 0]
return 1
}
proc rejectFT {chatid cookie} {
set sbn [::MSN::SBFor $chatid]
if {$sbn == 0 } {
cancelFT $cookie
return 0
}
#Send the cancellation for a file transfer
set msg "MIME-Version: 1.0\r\nContent-Type: text/x-msmsgsinvite; charset=UTF-8\r\n\r\n"
set msg "${msg}Invitation-Command: CANCEL\r\n"
set msg "${msg}Invitation-Cookie: $cookie\r\n"
set msg "${msg}Cancel-Code: REJECT\r\n\r\n"
set msg [encoding convertto utf-8 $msg]
set msg_len [string length $msg]
::MSN::WriteSBNoNL $sbn "MSG" "U $msg_len\r\n$msg"
status_log "Rejecting filetransfer sent\n" red
cancelFT $cookie
}
proc ConnectMSNFTP {ipaddr port authcookie cookie} {
#I connect to a remote host to retrieve the file
variable filedata
if {![info exists filedata($cookie)]} {
status_log "ConnectMSNFTP: Ignoring file transfer, filedata($cookie) doesn't exists, cancelled\n" red
return
}
status_log "Connecting to $ipaddr port $port\n"
::amsn::FTProgress c $cookie [lindex $filedata($cookie) 0] $ipaddr $port
if { [catch {set sockid [socket -async $ipaddr $port]} res ]} {
set filename [lindex $filedata($cookie) 0]
cancelFT $cookie
::amsn::FTProgress e $cookie $filename
return
}
lappend filedata($cookie) $sockid
#TODO: What are we cancelling here?
after cancel "::MSNFT::cancelFT $cookie"
fconfigure $sockid -blocking 0 -translation {binary binary} -buffering line
fileevent $sockid writable "::MSNFT::ConnectedMSNFTP $sockid $authcookie $cookie"
}
proc ConnectedMSNFTP {sockid authcookie cookie} {
variable filedata
if {![info exists filedata($cookie)]} {
status_log "ConnectedMSNFTP: Ignoring file transfer, filedata($cookie) doesn't exists, cancelled\n" red
return
}
set error_msg [fconfigure $sockid -error]
if {$error_msg != ""} {
status_log "Can't connect to server: $error_msg!!\n" white
set filename [lindex $filedata($cookie) 0]
cancelFT $cookie
::amsn::FTProgress e $cookie $filename
return
}
fileevent $sockid writable ""
fileevent $sockid readable "::MSNFT::FTNegotiation $sockid $cookie 0 $authcookie"
status_log "Connected, going to give my identity\n"
::amsn::FTProgress i $cookie [lindex $filedata($cookie) 0]
status_log "I SEND: VER MSNFTP\r\n"
catch {puts $sockid "VER MSNFTP\r"}
}
proc FTNegotiation { sockid cookie state {authcookie ""}} {
variable filedata
if {![info exists filedata($cookie)]} {
status_log "ConnectedMSNFTP: Ignoring file transfer, filedata($cookie) doesn't exists, cancelled\n" red
return
}
if { [eof $sockid] } {
status_log "FTNegotiation:: EOF\n" white
set filename [lindex $filedata($cookie) 0]
cancelFT $cookie
::amsn::FTProgress l $cookie $filename
return
}
gets $sockid tmpdata
status_log "FTNegotiation: I RECEIVE: $tmpdata\n"
if { $tmpdata == "" } {
update idletasks
return
}
switch $state {
0 {
if {[string range $tmpdata 0 9] == "VER MSNFTP"} {
catch {fileevent $sockid readable "::MSNFT::FTNegotiation $sockid $cookie 1"}
catch {puts $sockid "USR [::config::getKey login] $authcookie\r"}
status_log "FTNegotiation: I SEND: USR [::config::getKey login] $authcookie\r\n"
} else {
status_log "FT failed in state 0\n" red
set filename [lindex $filedata($cookie) 0]
cancelFT $cookie
::amsn::FTProgress l $cookie $filename
}
}
1 {
if {[string range $tmpdata 0 2] == "FIL"} {
set filesize [string range $tmpdata 4 [expr {[string length $tmpdata]-2}]]
if { "$filesize" != "[lindex $filedata($cookie) 1]" } {
status_log "Filesize is now $filesize and was [lindex $filedata($cookie) 1] before!!\n" white
#cancelFT $cookie
#return
}
status_log "FTNegotiation: They send me file with size $filesize\n"
catch {puts $sockid "TFR\r"}
status_log "Receiving file...\n"
set filename [file join [::config::getKey receiveddir] [lindex $filedata($cookie) 0]]
set origfile $filename
set num 1
while { [file exists $filename] } {
set filename "[filenoext $origfile] $num[fileext $origfile]"
incr num
}
if {[catch {open $filename w} fileid]} {
# Cannot create this file. Abort.
status_log "Could not saved the file '$filename' (write-protected target directory?)\n" red
cancelFT $cookie
::amsn::FTProgress l $cookie $filename
::amsn::infoMsg [trans readonlymsgbox] warning
return
}
lappend filedata($cookie) $fileid
fconfigure $fileid -blocking 1 -buffering none -translation {binary binary}
#Receive the file
fconfigure $sockid -blocking 0 -translation {binary binary} -buffering full -buffersize 16384
catch {fileevent $sockid readable "::MSNFT::ReceivePacket $sockid $fileid $filesize $cookie"}
} else {
status_log "FT failed in state 1\n" red
set filename [lindex $filedata($cookie) 0]
cancelFT $cookie
::amsn::FTProgress l $cookie $filename
}
}
default {
status_log "FTNegotiation: Unknown state!!!\n" white
cancelFT $cookie
}
}
}
proc ReceivePacket { sockid fileid filesize cookie} {
#Get a packet from the file transfer
variable filedata
if {![info exists filedata($cookie)]} {
status_log "ConnectedMSNFTP: Ignoring file transfer, filedata($cookie) doesn't exists, cancelled\n" red
return
}
if { [eof $sockid] } {
status_log "ReveivePacket EOF\n" white
set filename [lindex $filedata($cookie) 0]
cancelFT $cookie
::amsn::FTProgress l $cookie $filename
return
}
fileevent $sockid readable ""
set recvbytes [tell $fileid]
set packetrest [expr {2045 - ($recvbytes % 2045)}]
if {$packetrest == 2045} {
#Need a full packet, header included
::amsn::FTProgress r $cookie [lindex $filedata($cookie) 0] $recvbytes $filesize
update idletasks
fconfigure $sockid -blocking 1
set header [read $sockid 3]
set packet1 1
binary scan $header ccc packet1 packet2 packet3
#If packet1 is 1 -- Transfer canceled by the other
if { ($packet1 != 0) } {
status_log "File transfer cancelled by remote with packet1=$packet1\n"
cancelFT $cookie
return
}
#If you want to cancel, send "CCL\n"
set packet2 [expr {($packet2 + 0x100) % 0x100}]
set packet3 [expr {($packet3 + 0x100) % 0x100}]
set packetsize [expr {$packet2 + ($packet3<<8)}]
set firstbyte [read $sockid 1]
catch {puts -nonewline $fileid $firstbyte}
fconfigure $sockid -blocking 0
set recvbytes [tell $fileid]
#::amsn::fileTransferProgress r $cookie $recvbytes $filesize
} else {
#A full packet didn't come the previous reading, read the rest
set thedata [read $sockid $packetrest]
catch {puts -nonewline $fileid $thedata}
set recvbytes [tell $fileid]
}
if { $recvbytes >= $filesize} {
#::amsn::fileTransferProgress r $cookie $recvbytes $filesize
catch {puts $sockid "BYE 16777989\r"}
status_log "File received\n"
::amsn::FTProgress fr $cookie [lindex $filedata($cookie) 0] $recvbytes $filesize
FinishedFT $cookie
} else {
fileevent $sockid readable "::MSNFT::ReceivePacket $sockid $fileid $filesize $cookie"
}
}
###################################
#All about sending files
###################################
proc supportsNewFT { clientid } {
set msnc [expr 0xF0000000]
if { ($clientid & $msnc) != 0 } {
return 1
}
return 0
}
proc sendFTInvitation { chatid filename filesize ipaddr cookie} {
#Invitation to filetransfer, initial message
variable filedata
if {[supportsNewFT [::abook::getContactData $chatid clientid]]} {
set sid [::MSN6FT::SendFT $chatid $filename $filesize]
setObjOption $cookie msn6ftsid $sid
setObjOption $sid theCookie $cookie
return 0
}
set sbn [::MSN::SBFor $chatid]
if {$sbn == 0 } {
return 0
}
status_log "sentFTInvitation: filename (not converted to utf-8) is [file tail $filename]\n" blue
status_log "sentFTInvitation: filename (converted to utf-8) is [encoding convertto utf-8 [file tail $filename]]\n" blue
set msg "MIME-Version: 1.0\r\nContent-Type: text/x-msmsgsinvite; charset=UTF-8\r\n\r\n"
set msg "${msg}Application-Name: File Transfer\r\n"
set msg "${msg}Application-GUID: {5D3E02AB-6190-11d3-BBBB-00C04F795683}\r\n"
set msg "${msg}Invitation-Command: INVITE\r\n"
set msg "${msg}Invitation-Cookie: $cookie\r\n"
set msg "${msg}Application-File: [file tail $filename]\r\n"
set msg "${msg}Application-FileSize: $filesize\r\n\r\n"
set msg [encoding convertto utf-8 $msg]
set msg_len [string length $msg]
::MSN::WriteSBNoNL $sbn "MSG" "U $msg_len\r\n$msg"
status_log "sentFTInvitation: Invitation to $filename sent: $msg\n" red
#Change to allow multiple filetransfer
#set filedata($cookie) [list $sbn "$filename" $filesize $cookie $ipaddr]
set filedata($cookie) [list "$filename" $filesize $chatid [::MSN::usersInChat $chatid] "send" $ipaddr]
after 300000 "::MSNFT::DeleteFT $cookie"
}
proc cancelFTInvitation { chatid cookie } {
set sid [getObjOption $cookie msn6ftsid]
if { $sid != "" } {
::MSN6FT::CancelFT $chatid $sid
DeleteFT $cookie
} else {
rejectFT $chatid $cookie
}
}
proc rejectedFT {chatid who cookie} {
variable filedata
if {![info exists filedata($cookie)]} {
return
}
SendMessageFIFO [list ::amsn::rejectedFT $chatid $who [getFilename $cookie] ] "::amsn::messages_stack($chatid)" "::amsn::messages_flushing($chatid)"
}
proc SendFile { cookie oldcookie} {
#File transfer accepted by remote, send final ACK
variable filedata
status_log "Here in sendfile\n" red
if {![info exists filedata($cookie)]} {
return
}
status_log "File transfer ok, begin\n"
set sbn [::MSN::SBFor [lindex $filedata($cookie) 2]]
if { $sbn == 0 } {
cancelFT $cookie
return
}
#Invitation accepted, send IP and Port to connect to
#option: possibility to enter IP address (firewalled connections)
set ipaddr [lindex $filedata($cookie) 5]
#if error ::AMSN::Error ...
if {![string is digit [::config::getKey initialftport]] || [string length [::config::getKey initialftport]] == 0} {
::config::setKey initialftport 6891
}
set port [::config::getKey initialftport]
#Random authcookie
set authcookie [expr {[clock clicks] % (65536 * 4)}]
while {[catch {set sockid [socket -server "::MSNFT::AcceptConnection $cookie $authcookie" $port]} res]} {
incr port
}
#TODO: More than one transfer? Don't create one listening socket for every person, just one for all,
# but that makes the authcookie thing difficult...
lappend filedata($oldcookie) $sockid
after 300000 "catch {close $sockid}"
set msg "MIME-Version: 1.0\r\nContent-Type: text/x-msmsgsinvite; charset=UTF-8\r\n\r\n"
set msg "${msg}Invitation-Command: ACCEPT\r\n"
set msg "${msg}Invitation-Cookie: $oldcookie\r\n"
set msg "${msg}IP-Address: $ipaddr\r\n"
set msg "${msg}Port: $port\r\n"
set msg "${msg}AuthCookie: $authcookie\r\n"
set msg "${msg}Launch-Application: FALSE\r\n"
set msg "${msg}Request-Data: IP-Address:\r\n\r\n"
set msg [encoding convertto utf-8 $msg]
set msg_len [string length $msg]
::MSN::WriteSBNoNL $sbn "MSG" "U $msg_len\r\n$msg"
::amsn::FTProgress w $cookie [lindex $filedata($cookie) 0] $port
status_log "Listening on port $port for incoming connections...\n" red
}
proc AcceptConnection {cookie authcookie sockid hostaddr hostport} {
variable filedata
if {![info exists filedata($cookie)]} {
status_log "AcceptConnection: Ignoring file transfer, filedata($cookie) doesn't exists, cancelled\n" red
return
}
lappend filedata($cookie) $sockid
status_log "::MSNFT::AcceptConnection have connection from $hostaddr : $hostport\n" white
fconfigure $sockid -blocking 0 -buffering none -translation {binary binary}
fileevent $sockid readable "::MSNFT::FTSendNegotiation $sockid $cookie 0 $authcookie"
::amsn::FTProgress i $cookie [lindex $filedata($cookie) 0]
}
proc FTSendNegotiation { sockid cookie state {authcookie ""}} {
variable filedata
#puts "Here2 state=$state cookie=$cookie sockid=$sockid"
if {![info exists filedata($cookie)]} {
status_log "ConnectedMSNFTP: Ignoring file transfer, filedata($cookie) doesn't exists, cancelled\n" red
return
}
if { [eof $sockid] } {
status_log "FTSendNegotiation:: EOF\n" white
set filename [lindex $filedata($cookie) 0]
cancelFT $cookie
::amsn::FTProgress l $cookie $filename
return
}
gets $sockid tmpdata
status_log "FTNegotiation: I RECEIVE: $tmpdata\n"
if { $tmpdata == "" } {
update idletasks
return
}
switch $state {
0 {
if { [regexp "^VER\ ?\[0-9\]* MSNFTP" $tmpdata] } {
catch {fileevent $sockid readable "::MSNFT::FTSendNegotiation $sockid $cookie 1 $authcookie"}
catch {puts $sockid "VER MSNFTP\r"}
status_log "FTSendNegotiation: I SEND: VER MSNFTP\r\n"
} else {
status_log "FT failed in state 0\n" red
cancelFT $cookie
}
}
1 {
if {[string range $tmpdata 0 2] == "USR"} {
set filename [lindex $filedata($cookie) 0]
set filesize [lindex $filedata($cookie) 1]
#Comprobar authcookie y nombre de usuario
catch {fileevent $sockid readable "::MSNFT::FTSendNegotiation $sockid $cookie 2"}
catch {puts $sockid "FIL $filesize\r"}
status_log "SENT: FIL $filesize\n"
} else {
status_log "FT failed in state 1\n" red
cancelFT $cookie
}
}
2 {
if {[string range $tmpdata 0 2] == "TFR"} {
set filename [lindex $filedata($cookie) 0]
set filesize [lindex $filedata($cookie) 1]
#Send the file
#TODO, what if not exists?
if {[catch {set fileid [open $filename r]} res]} {
return 0;
}
lappend filedata($cookie) $fileid
fconfigure $fileid -translation {binary binary} -blocking 1
status_log "Sending file $filename size $filesize\n"
fconfigure $sockid -blocking 0 -buffering full -buffersize 16384
fileevent $sockid writable "::MSNFT::SendPacket $sockid $fileid $filesize $cookie"
fileevent $sockid readable "::MSNFT::MonitorTransfer $sockid $cookie"
} else {
status_log "FT failed in state 2\n" red
cancelFT $cookie
}
}
default {
status_log "FTNegotiation: Unknown state!!!\n" white
cancelFT $cookie
}
}
}
proc SendPacket { sockid fileid filesize cookie } {
variable filedata
# puts "cookie=$cookie"
if {![info exists filedata($cookie)]} {
status_log "ConnectedMSNFTP: Ignoring file transfer, filedata($cookie) doesn't exists, cancelled\n" red
return
}
#Send a packet for the file transfer
fileevent $sockid writable ""
set sentbytes [tell $fileid]
set packetsize [expr {$filesize-$sentbytes}]
if {$packetsize > 2045} {
set packetsize 2045
}
if {$packetsize>0} {
set data [read $fileid $packetsize]
set byte1 [expr {$packetsize & 0xFF}]
set byte2 [expr {$packetsize >> 8}]
catch {puts -nonewline $sockid "\0[format %c $byte1][format %c $byte2]$data" ; flush $sockid }
set sentbytes [expr {$sentbytes + $packetsize}]
::amsn::FTProgress s $cookie [lindex $filedata($cookie) 0] $sentbytes $filesize
fileevent $sockid writable "::MSNFT::SendPacket $sockid $fileid $filesize $cookie"
}
}
proc MonitorTransfer { sockid cookie} {
#puts "Monitortransfer"
variable filedata
if {![info exists filedata($cookie)]} {
status_log "::MSNFT::MonitorTransfer: Ignoring file transfer, filedata($cookie) doesn't exists, cancelled\n" red
return
}
if { [eof $sockid] } {
status_log "MonitorTransfer EOF\n" white
cancelFT $cookie
return
}
fileevent $sockid readable ""
#Monitor messages from the receiving host in a file transfer
catch {fconfigure $sockid -blocking 1}
if {[catch {gets $sockid datos} res]} {
status_log "::MSNFT::MonitorTransfer: Transfer failed: $res\n"
cancelFT $cookie
return
}
status_log "Got from remote side: $datos\n"
if {[string range $datos 0 2] == "CCL"} {
status_log "::MSNFT::MonitorTransfer: Connection cancelled\n"
cancelFT $cookie
return
}
if {[string range $datos 0 2] == "BYE"} {
status_log "::MSNFT::MonitorTransfer: Connection finished\n"
::amsn::FTProgress fs $cookie [lindex $filedata($cookie) 0]
FinishedFT $cookie
return
}
cancelFT $cookie
}
}
namespace eval ::MSN {
#TODO: Export missing procedures (the one whose starts with lowercase)
namespace export changeName logout changeStatus connect blockUser \
unblockUser addUser removeUserFromGroup deleteUser login myStatusIs \
cancelReceiving cancelSending moveUser
if { $initialize_amsn == 1 } {
#Forward list
variable list_FL [list]
#Reverse List
variable list_RL [list]
#Accept List
variable list_AL [list]
#Block list
variable list_BL [list]
#Pending list (MSNP11)
variable list_PL [list]
variable list_users ""
variable myStatus FLN
#Double array containing:
# CODE NAME COLOR ONLINE/OFFLINE SMALLIMAGE BIGIMAGE
variable list_states {
{NLN online #0000A0 online online bonline}
{IDL noactivity #008000 online away baway}
{BRB rightback #008080 online away baway}
{PHN onphone #008080 online busy bbusy}
{BSY busy #800000 online busy bbusy}
{AWY away #008000 online away baway}
{LUN gonelunch #008000 online away baway}
{HDN appearoff #404040 offline offline boffline}
{FLN offline #404040 offline offline boffline}
}
}
proc reconnect { error_msg } {
cmsn_draw_reconnect $error_msg
after 5000 ::MSN::connect
}
proc saveOldStatus { {status "" } {amessage ""} } {
global oldstatus
global automessage
if {$status != "" } {
set oldstatus $status
} else {
set oldstatus [::MSN::myStatusIs]
}
if { $amessage == "" } {
if { [info exists automessage] } {
set automsg $automessage
} else {
set automsg -1
}
} else {
set automsg $amessage
}
if {$automsg != -1 } {
for {set idx 0} {$idx < [StateList size] } { incr idx } {
if { [StateList get $idx] == $automsg} {
set oldstatus $idx
}
}
}
}
proc cancelReconnect { } {
after cancel ::MSN::connect
catch { unset ::oldstatus }
::MSN::logout
cmsn_draw_offline
}
proc connect { {passwd ""}} {
#Cancel any pending reconnect
after cancel ::MSN::connect
if { [ns cget -stat] != "d" } {
return
}
set username [::config::getKey login]
if { $passwd == "" } {
global password
set passwd [set password]
}
if {$passwd == "" } {
return
}
ns configure -stat "d" -sock "" \
-server [split [::config::getKey start_ns_server] ":"]
#Setup the conection
setup_connection ns
#Call the pre authentication
set proxy [ns cget -proxy]
if { [$proxy authInit] < 0 } {
return -1
}
cmsn_ns_connect $username $passwd
::Event::fireEvent loggingIn protocol
}
proc logout {} {
::abook::lastSeen
::log::eventlogout
::MSN::WriteSBRaw ns "OUT\r\n";
set proxy [ns cget -proxy]
$proxy finish ns
ns configure -stat "d"
CloseSB ns
global automessage
ns configure -server [split [::config::getKey start_ns_server] ":"]
setMyStatus FLN
status_log "Loging out\n"
if {[::config::getKey enablebanner] && [::config::getKey adverts]} {
adv_pause
}
::groups::Disable
StopPolling
::abook::saveToDisk
global list_BLP emailBList
::MSN::clearList AL
::MSN::clearList BL
::MSN::clearList FL
::MSN::clearList RL
set list_BLP -1
if { [info exists emailBList] } {
unset emailBList
}
::abook::unsetConsistent
#Try to update Preferences
catch {InitPref 1}
set automessage "-1"
::plugins::PostEvent OnDisconnect evPar
#an event to let the GUI know we are actually logged out now
::Event::fireEvent loggedOut protocol
#cmsn_draw_offline
#Set all CW users as offline
foreach user_name [::abook::getAllContacts] {
::abook::setVolatileData $user_name state "FLN"
}
foreach chat_id [::ChatWindow::getAllChatIds] {
::ChatWindow::TopUpdate $chat_id
}
#Alert dock of status change
# send_dock "FLN"
send_dock "STATUS" "FLN"
# Remove mail icon once offline.
send_dock "MAIL" 0
}
#TODO: delete when MSNP11 is used, REA is not used anymore
#Callback procedure called when a REA (screen name change) message is received
proc GotREAResponse { recv } {
if { [string tolower [lindex $recv 3]] == [string tolower [::config::getKey login]] } {
#This is our own nick change
::abook::setPersonal MFN [urldecode [lindex $recv 4]]
send_dock STATUS [::MSN::myStatusIs]
cmsn_draw_online 1 1
#an event used by guicontactlist to know when we changed our nick
::Event::fireEvent myNickChange protocol
} else {
#This is another one nick change
::abook::setContactData [lindex $recv 3] nick [urldecode [lindex $recv 4]]
#an event used by guicontactlist to know when a contact changed nick
::Event::fireEvent contactNickChange protocol [lindex $recv 3]
}
}
#Callback procedure called when a UUX (PSM change) message is received
proc GotUUXResponse { recv } {
cmsn_draw_online 1 1
#an event used by guicontactlist to know when we changed our nick
::Event::fireEvent myNickChange protocol
}
#Callback procedure called when a ADC message is received
proc GotADCResponse { recv } {
set username ""
set nickname ""
set contactguid ""
set curr_list ""
set groups "0"
#We skip ADC TrID
foreach information [lrange $recv 2 end] {
set key [string toupper [string range $information 0 1]]
if { $key == "N=" } {
set username [string range $information 2 end]
} elseif { $key == "F=" } {
set nickname [urldecode [string range $information 2 end]]
} elseif { $key == "C=" } {
set contactguid [string range $information 2 end]
} elseif { $curr_list == "" } {
#We didn't get the list names yet
set curr_list $information
} elseif { $groups == "0" } {
#We didn't get the group list yet
set groups $information
}
}
if { $curr_list == "RL" && [lsearch [::abook::getLists $username] "PL"] == -1 && [lsearch [::abook::getLists $username] "AL"] == -1 && [lsearch [::abook::getLists $username] "BL"] == -1 } {
newcontact $username $nickname
} elseif { $curr_list == "RL" && ( [lsearch [::abook::getLists $username] "AL"] != -1 || [lsearch [::abook::getLists $username] "BL"] != -1 ) } {
#Contact already in Allow List or Block List, so the notification window is useless, just silently remove from the PL:
::MSN::WriteSB ns "REM" "PL $username"
}
if { $curr_list == "FL" } {
status_log "Addition to FL"
if { $username == "" } {
#The server doesn't give the username so it gives the GUID
set username [::abook::getContactForGuid $contactguid]
} else {
#It's a new contact so we save its guid and its nick
::abook::setContactData $username contactguid $contactguid
::abook::setContactForGuid $contactguid $username
if {[::abook::getContactData $username nick ""] == ""} {
::abook::setContactData $username nick $nickname
}
}
status_log "$username was in groups [::abook::getGroups $username]"
if {[::abook::getGroups $username] != "" && $groups == 0} {
status_log "do nothing since a contact can't be in no group AND in a group"
} else {
::abook::addContactToGroup $username $groups
}
status_log "$username is in groups [::abook::getGroups $username]"
}
::abook::addContactToList $username $curr_list
::MSN::addToList $curr_list $username
::MSN::contactListChanged
set contactlist_loaded 1
::abook::setConsistent
::abook::saveToDisk
if { $curr_list != "FL" } {
#there isn't any group for other lists than FL
set groups ""
}
if { $curr_list == "FL" || $curr_list == "RL" } {
#Don't send the event for an addition to any other list
::Event::fireEvent contactAdded protocol $username $groups
}
}
proc GotREMResponse { recv } {
set list_sort [string toupper [lindex $recv 2]]
if { [lindex $recv 2] == "FL" } {
set userguid [lindex $recv 3]
set user [::abook::getContactForGuid $userguid]
if { [lindex $recv 4] == "" } {
#Remove from all groups!!
set affected_groups [::abook::getGroups $user]
::abook::emptyUserGroups $user
status_log "cmsn_listdel: Contact $user isn't in any group, removing!!\n" blue
::MSN::deleteFromList FL $user
::abook::removeContactFromList $user FL
#The GUID is invalid if the contact is removed from the FL list
::abook::setContactForGuid $userguid ""
::abook::setContactData $user contactguid ""
::abook::clearVolatileData $user
} else {
#Remove fromonly one group
set affected_groups [list [lindex $recv 4]]
::abook::removeContactFromGroup $user [lindex $recv 4]
}
if { [::abook::getGroups $user] == [list 0] } {
#User is now on nogroup
::Event::fireEvent contactMoved protocol $user [linsert $affected_groups end 0]
::Event::fireEvent contactAdded protocol $user 0
} else {
#an event to let the GUI know a user is removed from a group / the list
::Event::fireEvent contactRemoved protocol $user $affected_groups
}
} else {
set user [lindex $recv 3]
::MSN::deleteFromList $list_sort $user
::abook::removeContactFromList $user $list_sort
#an event to let the GUI know a user is removed from a list
::Event::fireEvent contactListChange protocol $user
}
global contactlist_loaded
set contactlist_loaded 1
}
#Handler when we're setting our nick, so we check if the nick is allowed or not
proc badNickCheck { userlogin newname recv } {
switch [lindex $recv 0] {
PRP {
ns handlePRPResponse $recv
}
REA {
GotREAResponse $recv
}
209 {
#Try again urlencoding any character
status_log "Nick $newname not allowed, try to avoid filtering (badNickCheck)\n" red
set name [urlencode_all $newname]
::MSN::WriteSB ns "REA" "$userlogin $name"
}
default {
}
}
}
#Change a users nickname
proc changeName { userlogin newname { nourlencode 0 } } {
if { $userlogin == "" } {
return
}
if { $nourlencode } {
set name $newname
} else {
set name [urlencode $newname]
}
if { [::config::getKey protocol] == 11 } {
::MSN::WriteSB ns "PRP" "MFN $name" "ns handlePRPResponse $name"
} else {
if { [::config::getKey allowbadwords] == 1 } {
#If we're allowing banned words in nicks, try to set usual nick. It it fails,
#we will try again urlencoding every character, to avoid censure
::MSN::WriteSB ns "REA" "$userlogin $name" \
"::MSN::badNickCheck $userlogin [list $name]"
} else {
::MSN::WriteSB ns "REA" "$userlogin $name"
}
}
}
#Change a users personal message
proc changePSM { newpsm { forcechange 0 } } {
#TODO: encode XML etc
if { [::config::getKey protocol] == 11 } {
if { [::abook::getPersonal PSM] != $newpsm || $forcechange } {
set currentMedia [::abook::getPersonal currentMedia]
set currentMedia [::sxml::xmlreplace $currentMedia]
set currentMedia [encoding convertto utf-8 $currentMedia]
::abook::setPersonal PSM $newpsm
set newpsm [::sxml::xmlreplace $newpsm]
set newpsm [encoding convertto utf-8 $newpsm]
set psm "<Data><PSM>$newpsm</PSM><CurrentMedia>$currentMedia</CurrentMedia></Data>"
::MSN::WriteSBNoNL ns "UUX" "[string length $psm]\r\n$psm"
save_config
::abook::saveToDisk
# ::Event::fireEvent myPSMChange protocol $userlogin
}
} else {
#Do nothing
}
}
#changes the current media in the personal message
#type: can be one of: Music, Games or Office
#enabled: 0 or 1
#format: A formatter string ala .Net; For example: {0} - {1}
#args: list with the other things, first will match {0} in format
proc changeCurrentMedia { type enabled format args } {
set psm [::abook::getPersonal PSM]
set psm [::sxml::xmlreplace $psm]
set psm [encoding convertto utf-8 $psm]
if {$enabled == 1} {
set currentMedia "aMSN\\0$type\\01\\0$format\\0[join $args \\0]\\0"
} else {
set currentMedia ""
}
::abook::setPersonal currentMedia $currentMedia
set currentMedia [::sxml::xmlreplace $currentMedia]
set currentMedia [encoding convertto utf-8 $currentMedia]
set str "<Data><PSM>$psm</PSM><CurrentMedia>$currentMedia</CurrentMedia></Data>"
::MSN::WriteSBNoNL ns "UUX" "[string length $str]\r\n$str"
}
#Procedure called to change our status
proc changeStatus {new_status} {
global autostatuschange
# set clientid 805306412
if {[::config::getKey displaypic] == "" } {
::config::setKey displaypic nopic.gif
}
if { [::config::getKey displaypic] != "nopic.gif" } {
::MSN::WriteSB ns "CHG" "$new_status [::config::getKey clientid] [urlencode [create_msnobj [::config::getKey login] 3 [::skin::GetSkinFile displaypic [::config::getKey displaypic]]]]"
} else {
::MSN::WriteSB ns "CHG" "$new_status [::config::getKey clientid]"
}
#Reset automatic status change to 0
set autostatuschange 0
}
# set a capability of the client
# possiblities for cap are:
# mobile Mobile Device
# inkgif receive Ink as gif
# inkisf receive Ink as ISF
# webcam Webcam
# multip Multi-Packeting
# paging Paging
# drctpg Direct-Paging
# webmsn WebMessenger
# tgw Connected via TGW
# space User has an MSN Spaces
# mce Connected using Win XP Media Center Edition
# direct DirectIM
# winks Winks
# search Client supports Shared search
# bot Is Bot
# voice Client supports Voice Clips
# secure Client supports secure channel chatting
# sip Client supports SIP based communiation
# shared Client supports Shared Folders
# msnc1 This is the value for MSNC1 (MSN Msgr 6.0)
# msnc2 This is the value for MSNC2 (MSN Msgr 6.1)
# msnc3 This is the value for MSNC3 (MSN Msgr 6.2)
# msnc4 This is the value for MSNC4 (MSN Msgr 7.0)
# msnc5 This is the value for MSNC5 (MSN Msgr 7.5)
# msnc6 This is the value for MSNC5 (MSN Msgr 8.0)
# msnc7 This is the value for MSNC5 (MSN Msgr 8.1)
#
#switch==1 means turn on, 0 means turn off
#
# Reference : http://zoronax.spaces.live.com/?_c11_BlogPart_FullView=1&_c11_BlogPart_blogpart=blogview&_c=BlogPart&partqs=amonth%3d6%26ayear%3d2006
#
# From http://forums.fanatic.net.nz/index.php?showtopic=17639 thanks to Ole Andre
#define CapabilityMobileOnline 0x00000001
#define CapabilityMSN8User 0x00000002
#define CapabilityRendersGif 0x00000004
#define CapabilityRendersIsf 0x00000008
#define CapabilityWebCamDetected 0x00000010
#define CapabilitySupportsChunking 0x00000020
#define IsMobileEnabled 0x00000040
#// FIXME: the canonical meaning of 0x00000080 is missing
#define CapabilityWebIMClient 0x00000200
#define CapabiltiyConnectedViaTGW 0x00000800
#// FIXME: the canonical meaning of 0x00001000 is missing
#define CapabilityMCEUser 0x00002000
#define CapabilitySupportsDirectIM 0x00004000
#define CapabilitySupportsWinks 0x00008000
#define CapabilitySupportsSharedSearch 0x00010000
#define CapabilityIsBot 0x00020000
#define CapabilitySupportsVoiceIM 0x00040000
#define CapabilitySupportsSChannel 0x00080000
#define CapabilitySupportsSipInvite 0x00100000
#define CapabilitySupportsSDrive 0x00400000
#define CapabilityHasOnecare 0x01000000
#define CapabilityP2PSupportsTurn 0x02000000
#define CapabilityP2PBootstrapViaUUN 0x04000000
#define CapabilityMsgrVersion 0xf0000000
#define CapabilityP2PAware(id) ((id & CapabilityMsgrVersion) != 0)
proc setClientCap { cap { switch 1 } } {
set clientid [::config::getKey clientid 0]
if $switch {
switch $cap {
mobile { set clientid [expr {$clientid | 0x000001} ] }
inkgif { set clientid [expr {$clientid | 0x000004} ] }
inkisf { set clientid [expr {$clientid | 0x000008} ] }
webcam { set clientid [expr {$clientid | 0x000010} ] }
multip { set clientid [expr {$clientid | 0x000020} ] }
paging { set clientid [expr {$clientid | 0x000040} ] }
drctpg { set clientid [expr {$clientid | 0x000080} ] }
webmsn { set clientid [expr {$clientid | 0x000200} ] }
tgw { set clientid [expr {$clientid | 0x000800} ] }
space { set clientid [expr {$clientid | 0x001000} ] }
mce { set clientid [expr {$clientid | 0x002000} ] }
direct { set clientid [expr {$clientid | 0x004000} ] }
winks { set clientid [expr {$clientid | 0x008000} ] }
search { set clientid [expr {$clientid | 0x010000} ] }
bot { set clientid [expr {$clientid | 0x020000} ] }
voice { set clientid [expr {$clientid | 0x040000} ] }
secure { set clientid [expr {$clientid | 0x080000} ] }
sip { set clientid [expr {$clientid | 0x100000} ] }
shared { set clientid [expr {$clientid | 0x400000} ] }
msnc1 { set clientid [expr {$clientid | 0x10000000} ] }
msnc2 { set clientid [expr {$clientid | 0x20000000} ] }
msnc3 { set clientid [expr {$clientid | 0x30000000} ] }
msnc4 { set clientid [expr {$clientid | 0x40000000} ] }
msnc5 { set clientid [expr {$clientid | 0x50000000} ] }
msnc6 { set clientid [expr {$clientid | 0x60000000} ] }
msnc7 { set clientid [expr {$clientid | 0x70000000} ] }
}
} else {
switch $cap {
mobile { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x000001)} ] }
inkgif { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x000004)} ] }
inkisf { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x000008)} ] }
webcam { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x000010)} ] }
multip { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x000020)} ] }
paging { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x000040)} ] }
drctpg { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x000080)} ] }
webmsn { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x000200)} ] }
tgw { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x000800)} ] }
space { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x001000)} ] }
mce { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x002000)} ] }
direct { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x004000)} ] }
winks { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x008000)} ] }
search { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x010000)} ] }
bot { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x020000)} ] }
voice { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x040000)} ] }
secure { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x080000)} ] }
sip { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x100000)} ] }
shared { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x400000)} ] }
msnc1 { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x10000000)} ] }
msnc2 { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x20000000)} ] }
msnc3 { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x30000000)} ] }
msnc4 { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x40000000)} ] }
msnc5 { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x50000000)} ] }
msnc6 { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x60000000)} ] }
msnc7 { set clientid [expr {$clientid & (0xFFFFFFFF ^ 0x70000000)} ] }
}
}
::config::setKey clientid $clientid
return $clientid
}
proc myStatusIs {} {
variable myStatus
return $myStatus
}
proc setMyStatus { status } {
variable myStatus
set myStatus $status
}
proc userIsBlocked {userlogin} {
set lists [::abook::getLists $userlogin]
if { [lsearch $lists BL] != -1} {
return 1
}
return 0
}
proc blockUser { userlogin username} {
::MSN::WriteSB ns REM "AL $userlogin"
if {[::config::getKey protocol] == 11} {
::MSN::WriteSB ns ADC "BL N=$userlogin"
} else {
::MSN::WriteSB ns ADD "BL $userlogin $username"
}
#an event to let the GUI know a user is blocked
after 500 [list ::Event::fireEvent contactBlocked protocol $userlogin]
}
proc unblockUser { userlogin username} {
::MSN::WriteSB ns REM "BL $userlogin"
if {[::config::getKey protocol] == 11} {
::MSN::WriteSB ns ADC "AL N=$userlogin"
} else {
::MSN::WriteSB ns ADD "AL $userlogin $username"
}
#an event to let the GUI know a user is unblocked
after 500 [list ::Event::fireEvent contactUnblocked protocol $userlogin]
}
# Move user from one group to another group
proc moveUser { passport oldGid newGid {userName ""}} {
if { $userName == "" } {
set userName $passport
}
if { $oldGid == $newGid } {
return
}
if { [::config::getKey protocol ] == 11 } {
set contactguid [::abook::getContactData $passport contactguid]
set atrid [::MSN::WriteSB ns "ADC" "FL C=$contactguid $newGid" "::MSN::MOVHandler $oldGid $contactguid $passport" ]
} else {
set atrid [::MSN::WriteSB ns "ADD" "FL $passport [urlencode $userName] $newGid"]
set rtrid [::MSN::WriteSB ns "REM" "FL $passport $oldGid"]
}
#an event to let the GUI know a user is moved between 2 groups
::Event::fireEvent contactMoved protocol $passport [list $oldGid $newGid]
}
#Copy user from one group to another
proc copyUser { passport newGid {userName ""}} {
if { $userName == "" } {
set userName $passport
}
if { [::config::getKey protocol ] == 11 } {
set contactguid [::abook::getContactData $passport contactguid]
set atrid [::MSN::WriteSB ns "ADC" "FL C=$contactguid $newGid"]
} else {
set atrid [::MSN::WriteSB ns "ADD" "FL $passport [urlencode $userName] $newGid"]
}
}
#Add user to our Forward (contact) list
proc addUser { userlogin {username ""} {gid 0} } {
set userlogin [string map {" " ""} $userlogin]
if {[string match "*@*" $userlogin] < 1 } {
set domain "@hotmail.com"
set userlogin $userlogin$domain
}
set userlogin [string trim $userlogin]
set userlogin [string map { " " "" "\r" "" "\n" "" "\t" "" } $userlogin]
if { $username == "" } {
set username $userlogin
}
if { [::config::getKey protocol] == 11 } {
::MSN::WriteSB ns "ADC" "FL N=$userlogin F=$username" "::MSN::ADCHandler $gid"
} else {
::MSN::WriteSB ns "ADD" "FL $userlogin $username $gid" "::MSN::ADDHandler"
}
}
#Handler for the ADD message, to show the ADD messagebox
proc ADDHandler { item } {
if { [lindex $item 2] == "FL"} {
set contact [urldecode [lindex $item 4]] ;# Email address
#an event to let the GUI know a user is copied/added to a group
set newGid [lindex $item 6]
::Event::fireEvent contactAdded protocol $contact $newGid
msg_box "[trans contactadded]\n$contact"
}
if { [lindex $item 0] == 500 } {
#Instead of disconnection, transform into error 201
cmsn_ns_handler [lreplace $item 0 0 201]
return
}
cmsn_ns_handler $item
}
#Handler for the ADC message, to show the ADD messagebox, and to move a user to a group if gid != 0
proc ADCHandler { gid item } {
if { [lindex $item 2] == "FL"} {
set contact [urldecode [string range [lindex $item 3] 2 end]] ;# Email address
#an event to let the GUI know a user is copied/added to a group
::abook::setContactData $contact contactguid [string range [lindex $item 5] 2 end]
::abook::setContactForGuid [string range [lindex $item 5] 2 end] $contact
::Event::fireEvent contactAdded protocol $contact $gid
if { $gid != 0 } {
moveUser $contact 0 $gid
}
msg_box "[trans contactadded]\n$contact"
}
if { [lindex $item 0] == 500 } {
#Instead of disconnection, transform into error 201
cmsn_ns_handler [lreplace $item 0 0 201]
return
}
cmsn_ns_handler $item
}
proc MOVHandler { oldGid contactguid passport item } {
::MSN::GotADCResponse $item
if { $oldGid != "0" } {
set rtrid [::MSN::WriteSB ns "REM" "FL $contactguid $oldGid"]
} else {
::abook::removeContactFromGroup $passport "0"
}
}
#Remove user from a groups
proc removeUserFromGroup { userlogin grId } {
if {[::abook::getGroups $userlogin] == 0} {
return
}
if { [::config::getKey protocol] == 11 } {
::MSN::WriteSB ns REM "FL [::abook::getContactData $userlogin contactguid] $grId"
} else {
::MSN::WriteSB ns REM "FL $userlogin $grId"
}
}
#Delete user totally
proc deleteUser { userlogin } {
if { [::config::getKey protocol] == 11 } {
#We remove from everywhere
::MSN::WriteSB ns REM "FL [::abook::getContactData $userlogin contactguid]"
foreach groupID [::abook::getGroups $userlogin] {
::MSN::WriteSB ns REM "FL [::abook::getContactData $userlogin contactguid] $groupID"
}
} else {
::MSN::WriteSB ns REM "FL $userlogin"
}
}
##################################################
#Internal procedures
##################################################
#Start the loop that will keep a keepalive (PNG) message every minute
proc StartPolling {} {
if {([::config::getKey keepalive] == 1) && ([::config::getKey connectiontype] == "direct")} {
variable pollstatus 0
after cancel "::MSN::PollConnection"
after 60000 "::MSN::PollConnection"
} else {
after cancel "::MSN::PollConnection"
}
}
#Stop sending the keepalive message
proc StopPolling {} {
after cancel "::MSN::PollConnection"
}
#Send a keepalive message
proc PollConnection {} {
variable pollstatus
#Let's try to keep the connection alive... sometimes it gets closed if we
#don't do send or receive something for a long time
if { [::MSN::myStatusIs] != "FLN" } {
::MSN::WriteSBRaw ns "PNG\r\n"
#Reconnect if necessary
if { $pollstatus > 1 && [::config::getKey reconnect] == 1 } {
::MSN::saveOldStatus
::MSN::logout
::MSN::reconnect "[trans connectionlost]"
} elseif { $pollstatus > 10 } {
::MSN::logout
}
incr pollstatus
}
after 60000 "::MSN::PollConnection"
}
if { $initialize_amsn == 1 } {
variable trid 0
}
#Write a string to the given SB, followed by a NewLine character, adding the transfer ID
proc WriteSB {sbn cmd param {handler ""}} {
WriteSBNoNL $sbn $cmd "$param\r\n" $handler
}
#Write a string to the given SB, with no NewLine, adding the transfer ID
proc WriteSBNoNL {sbn cmd param {handler ""}} {
variable trid
set msgid [incr trid]
set msgtxt "$cmd $msgid $param"
WriteSBRaw $sbn $msgtxt
if {$handler != ""} {
global list_cmdhnd
lappend list_cmdhnd [list $trid $handler]
}
return $msgid
}
proc WriteSBRaw {sbn cmd} {
if { $sbn == 0 } {
return
}
#Finally, to write, use a wrapper, so it's transparent to use
#a direct connection, a proxy, or anything
set proxy [$sbn cget -proxy]
catch {$proxy write $sbn $cmd} res
if { $res == 0 } {
if { $sbn != "ns" } {
catch {$sbn configure -last_activity [clock seconds] }
}
if {$sbn != "ns" } {
degt_protocol "->$sbn-[$sbn cget -sock] $cmd" sbsend
} else {
degt_protocol "->$sbn-[$sbn cget -sock] $cmd" nssend
}
} else {
::MSN::CloseSB $sbn
degt_protocol "->$sbn FAILED: $cmd" error
}
}
proc SendInk { chatid file } {
set maxchars 1202
set sb [::MSN::SBFor $chatid]
if { $sb == 0 } {
return
}
set fd [open $file r]
fconfigure $fd -translation {binary binary}
set data [read $fd]
close $fd
set data [::base64::encode $data]
set data [string map { "\n" ""} $data]
set data "base64:$data"
set chunks [expr {int( [string length $data] / $maxchars) + 1 } ]
status_log "Ink data : $data\nchunks : $chunks\n"
for {set i 0 } { $i < $chunks } { incr i } {
set chunk [string range $data [expr $i * $maxchars] [expr ($i * $maxchars) + $maxchars - 1]]
set msg ""
if { $i == 0 } {
set msg "MIME-Version: 1.0\r\nContent-Type: image/gif\r\n"
if { $chunks == 1 } {
set msg "${msg}\r\n$chunk"
} else {
set msgid "[format %X [myRand 4369 65450]][format %X [myRand 4369 65450]]-[format %X [myRand 4369 65450]]-[format %X [myRand 4369 65450]]-[format %X [expr { int([expr {rand() * 1000000}])%65450 } ] + 4369]-[format %X [myRand 4369 65450]][format %X [myRand 4369 65450]][format %X [myRand 4369 65450]]"
set msg "${msg}Message-ID: \{$msgid\}\r\nChunks: $chunks\r\n\r\n$chunk"
}
} else {
set msg "${msg}Message-ID: \{$msgid\}\r\nChunk: $i\r\n\r\n$chunk"
}
set msglen [string length $msg]
::MSN::WriteSBNoNL $sb "MSG" "N $msglen\r\n$msg"
}
}
# This method sends an Action to MSNP13+ users, datacast id 4 with Data being the action message, the messages look like emotes, in grey with no '$nick says' heading
proc SendAction {chatid action } {
set sbn [::MSN::SBFor $chatid]
set msg "MIME-Version: 1.0\r\nContent-Type: text/x-msnmsgr-datacast\r\n\r\nID: 4\r\nData: $action\r\n\r\n"
set msg_len [string length $msg]
#Send the packet
::MSN::WriteSBNoNL $sbn "MSG" "U $msg_len\r\n$msg"
}
########################################################################
# Check if the old closed preferred SB is still the preferred SB, or
# close it if not.
proc CheckKill { sb } {
#Kill any remaining timers
after cancel "::MSN::CheckKill $sb"
if { [catch {$sb cget -name}] } {
#The SB was destroyed
return
}
if { [$sb cget -stat] != "d" } {
#The SB is connected again, forget about killing
return
} else {
#Get the chatid
set chatid [::MSN::ChatFor $sb]
if { $chatid == 0 } {
#If SB is not in any chat, we can just kill it
status_log "Session $sb killed with no chatid associated\n"
::MSN::KillSB $sb
return 0
}
#If we're the preferred chatid
if { [::MSN::SBFor $chatid] == $sb } {
#It's the preferred SB, so keep it for the moment
set items [expr {[llength [$sb cget -users]] -1}]
status_log "Session $sb closed, there are [expr {$items+1}] users: [$sb cget -users]\n" blue
for {set idx $items} {$idx >= 0} {incr idx -1} {
set user_info [lindex [$sb cget -users] $idx]
$sb delUser $idx
amsn::userLeaves [::MSN::ChatFor $sb] [list $user_info] 0
}
#Try to kill it again in 5 minutes
after 300000 "::MSN::CheckKill $sb"
} else {
#It's not the preferred SB,so we can safely delete it from the
#chat and Kill it
DelSBFor $chatid $sb
::MSN::KillSB $sb
}
}
}
#///////////////////////////////////////////////////////////////////////
# Usually called from anywhere when a problem is found when writing or
# reading a SB. It closes the sock.
# For NS connection, call only when an error happens. To manually log out,
# call ::MSN::logout
proc CloseSB { sb } {
status_log "::MSN::CloseSB $sb Called\n" green
catch {fileevent [$sb cget -sock] readable "" } res
catch {fileevent [$sb cget -sock] writable "" } res
set sock [$sb cget -sock]
# if {$sock != ""} {
# set proxy [$sb cget -proxy]
# $proxy finish $sb
# $proxy destroy
# }
# #Append an empty string to the SB buffer. This will cause the
# #actual SB cleaning, but will allow to process all buffer
# #before doing the cleaning
# $sb addData ""
ClearSB $sb
}
#///////////////////////////////////////////////////////////////////////
########################################################################
#Called when we find a "" (empty string) in the SB buffer. This means
#the SB is closed. Proceed to clear everything related to it
proc ClearSB { sb } {
status_log "::MSN::ClearSB $sb called\n" green
set oldstat [$sb cget -stat]
# $sb configure -data ""
$sb configure -stat "d"
if { [string match -nocase "*ns*" $sb] } {
status_log "clearing sb $sb. oldstat=$oldstat"
catch {close [$sb cget -sock]}
$sb configure -sock ""
set mystatus [::MSN::myStatusIs]
if { [info exists ::automessage] } {
set old_automessage $::automessage
} else {
set old_automessage ""
}
#If we were not disconnected or authenticating, logout
if { ("$oldstat" != "d") && ("$oldstat" != "u") } {
logout
}
#If we're not disconnected, connected, or authenticating, then
#we have a connection error.
if { ("$oldstat"!="d") && ("$oldstat" !="o") && ("$oldstat" !="u") && ("$oldstat" !="closed")} {
::config::setKey start_ns_server [::config::getKey default_ns_server]
set error_msg [ns cget -error_msg]
#Reconnect if necessary
if { [::config::getKey reconnect] == 1 } {
::MSN::saveOldStatus $mystatus $old_automessage
if { $error_msg != "" } {
::MSN::reconnect "[trans connecterror]: [ns cget -error_msg]"
} else {
::MSN::reconnect "[trans connecterror]"
}
return
}
if { $error_msg != "" } {
msg_box "[trans connecterror]: [ns cget -error_msg]"
} else {
msg_box "[trans connecterror]"
}
}
#If we were connected, we have lost the connection
if { ("$oldstat"=="o") } {
::config::setKey start_ns_server [::config::getKey default_ns_server]
set error_msg [ns cget -error_msg]
#Reconnect if necessary
if { [::config::getKey reconnect] == 1 } {
::MSN::saveOldStatus $mystatus $old_automessage
if { $error_msg != "" } {
::MSN::reconnect "[trans connectionlost]: [ns cget -error_msg]"
} else {
::MSN::reconnect "[trans connectionlost]"
}
return
}
if { $error_msg != "" } {
msg_box "[trans connectionlost]: [ns cget -error_msg]"
} else {
msg_box "[trans connectionlost]"
}
status_log "Connection lost\n" red
}
} else {
#Check if we can kill the SB (clear all related info
CheckKill $sb
}
}
#///////////////////////////////////////////////////////////////////////
########################################################################
#Answer the server challenge. This is a handler for CHL message
proc AnswerChallenge { item } {
if { [lindex $item 1] != 0 } {
status_log "Invalid challenge\n" red
} else {
if {[::config::getKey protocol] == 11} {
set prodkey "PROD0090YUAUV\{2B"
set str [CreateQRYHash [lindex $item 2]]
} else {
set prodkey "PROD0061VRRZH@4F"
set str [lindex $item 2]JXQ6J@TUOGYV@N0M
set str [::md5::md5 [lindex $item 2]JXQ6J@TUOGYV@N0M]
}
::MSN::WriteSBNoNL ns "QRY" "$prodkey 32\r\n$str"
}
}
proc CreateQRYHash {chldata {prodid "PROD0090YUAUV\{2B"} {prodkey "YMM8C_H7KCQ2S_KL"}} {
# Create an MD5 hash out of the given data, then form 32 bit integers from it
set md5hash [::md5::md5 $chldata$prodkey]
set md5parts [MD5HashToInt $md5hash]
# Then create a valid productid string, divisable by 8, then form 32 bit integers from it
set nrPadZeros [expr {8 - [string length $chldata$prodid] % 8}]
set padZeros [string repeat 0 $nrPadZeros]
set chlprodid [CHLProdToInt $chldata$prodid$padZeros]
# Create the key we need to XOR
set key [KeyFromInt $md5parts $chlprodid]
set low 0x[string range $md5hash 0 15]
set high 0x[string range $md5hash 16 32]
set low [expr {$low ^ $key}]
set high [expr {$high ^ $key}]
set p1 [format %8.8x [expr {($low / 0x100000000) % 0x100000000}]]
set p2 [format %8.8x [expr {$low % 0x100000000}]]
set p3 [format %8.8x [expr {($high / 0x100000000) % 0x100000000}]]
set p4 [format %8.8x [expr {$high % 0x100000000}]]
return $p1$p2$p3$p4
}
proc KeyFromInt { md5parts chlprod } {
# Create a new series of numbers
set key_temp 0
set key_high 0
set key_low 0
# Then loop on the entries in the second array we got in the parameters
for {set i 0} {$i < [llength $chlprod]} {incr i 2} {
# Make $key_temp zero again and perform calculation as described in the documents
set key_temp [lindex $chlprod $i]
set key_temp [expr {(wide(0x0E79A9C1) * wide($key_temp)) % wide(0x7FFFFFFF)}]
set key_temp [expr {wide($key_temp) + wide($key_high)}]
set key_temp [expr {(wide([lindex $md5parts 0]) * wide($key_temp)) + wide([lindex $md5parts 1])}]
set key_temp [expr {wide($key_temp) % wide(0x7FFFFFFF)}]
set key_high [lindex $chlprod [expr {$i+1}]]
set key_high [expr {(wide($key_high) + wide($key_temp)) % wide(0x7FFFFFFF)}]
set key_high [expr {(wide([lindex $md5parts 2]) * wide($key_high)) + wide([lindex $md5parts 3])}]
set key_high [expr {wide($key_high) % wide(0x7FFFFFFF)}]
set key_low [expr {wide($key_low) + wide($key_temp) + wide($key_high)}]
}
set key_high [expr {(wide($key_high) + wide([lindex $md5parts 1])) % wide(0x7FFFFFFF)}]
set key_low [expr {(wide($key_low) + wide([lindex $md5parts 3])) % wide(0x7FFFFFFF)}]
set key_high 0x[byteInvert [format %8.8X $key_high]]
set key_low 0x[byteInvert [format %8.8X $key_low]]
set long_key [expr {(wide($key_high) << 32) + wide($key_low)}]
return $long_key
}
# Takes an CHLData + ProdID + Padded string and chops it in 4 bytes. Then converts to 32 bit integers
proc CHLProdToInt { CHLProd } {
set hexs {}
set result {}
while {[string length $CHLProd] > 0} {
lappend hexs [string range $CHLProd 0 3]
set CHLProd [string range $CHLProd 4 end]
}
for {set i 0} {$i < [llength $hexs]} {incr i} {
binary scan [lindex $hexs $i] H8 int
lappend result 0x[byteInvert $int]
}
return $result
}
# Takes an MD5 string and chops it in 4. Then "decodes" the HEX and converts to 32 bit integers. After that it ANDs
proc MD5HashToInt { md5hash } {
binary scan $md5hash a8a8a8a8 hash1 hash2 hash3 hash4
set hash1 [expr {"0x[byteInvert $hash1]" & 0x7FFFFFFF}]
set hash2 [expr {"0x[byteInvert $hash2]" & 0x7FFFFFFF}]
set hash3 [expr {"0x[byteInvert $hash3]" & 0x7FFFFFFF}]
set hash4 [expr {"0x[byteInvert $hash4]" & 0x7FFFFFFF}]
return [list $hash1 $hash2 $hash3 $hash4]
}
proc byteInvert { hex } {
set hexs {}
while {[string length $hex] > 0} {
lappend hexs [string range $hex 0 1]
set hex [string range $hex 2 end]
}
set hex ""
for {set i [expr [llength $hexs] -1]} {$i >= 0} {incr i -1} {
append hex [lindex $hexs $i]
}
return $hex
}
proc CALReceived {sb_name user item} {
switch [lindex $item 0] {
215 {
#if you try to begin a chat session with yourself
status_log "trying to chat with yourself"
set chatid [::MSN::ChatFor $sb_name]
::MSN::ClearQueue $chatid
::amsn::chatStatus $chatid "[trans useryourself]\n" miniwarning
}
216 {
# if you try to begin a chat session with someone who blocked you and is online
set chatid [::MSN::ChatFor $sb_name]
::MSN::ClearQueue $chatid
::amsn::chatStatus $chatid "$user: [trans userblocked]\n" miniwarning
return 0
}
217 {
#TODO: Check what we do with sb stat "?", disable chat window?
# this should be related to user state changes
#sb get $sb_name stat
set chatid [::MSN::ChatFor $sb_name]
::MSN::ClearQueue $chatid
# DO NOT cleanchat... it's needed for ::ChatWindow::TopUpdate
# ::MSN::CleanChat $chatid
::amsn::chatStatus $chatid "$user: [trans usernotonline]\n" miniwarning
::abook::setVolatileData $user state "FLN"
::ChatWindow::TopUpdate $chatid
#msg_box "[trans usernotonline]"
return 0
}
713 {
status_log "CALReceived: 713 USER TOO ACTIVE\n" white
return 0
}
}
}
########################################################################
########################################################################
########################################################################
# CHAT RELATED PROCEDURES. SHOULD THEY HAVE THEIR OWN NAMESPACE??
########################################################################
########################################################################
########################################################################
########################################################################
#Send x-clientcaps packet, for third-party MSN client
proc clientCaps {chatid} {
set sbn [SBFor $chatid]
#If not connected to the user OR if user don't want to send clientCaps info, do nothing
if {$sbn == 0 || ![::config::getKey clientcaps]} {
return
}
set msg "MIME-Version: 1.0\r\nContent-Type: text/x-clientcaps\r\n\r\n"
#Add the aMSN version to the message
set msg "${msg}Client-Name: aMSN [set ::version]\r\n"
#Verify if the user keep logs or not
if {[::config::getKey keep_logs]} {
set chatlogging "Y"
} else {
set chatlogging "N"
}
#Add the log information to the $msg
set msg "${msg}Chat-Logging: $chatlogging\r\n"
#Jerome: I disable that feature because I'm not sure users will like to provide theses kinds of
#informations to everybody, but it can be useful later..
#Verify the platform (feel free to improve it if you want better details, like bsd, etc)
#if { [OnDarwin] } {
# set operatingsystem "Mac OS X"
#} elseif { [OnWin] } {
# set operatingsystem "Windows"
#} elseif { [OnLinux] } {
# set operatingsystem "Linux"
#}
#Add the operating system to the msg
#set msg "${msg}Operating-System: $operatingsystem\r\n\r\n"
#Send the packet
#set msg [encoding convertto utf-8 $msg]
set msg_len [string length $msg]
WriteSBNoNL $sbn "MSG" "U $msg_len\r\n$msg"
status_log "Send text/x-clientcaps\n" red
#status_log "$msg" red
}
# Return a list of users in chat, or last user in chat if chat is closed
proc usersInChat { chatid } {
set sb [SBFor $chatid]
if { $sb == 0 || [catch {$sb cget -name}] } {
status_log "usersInChat: no SB for chat $chatid!! (shouldn't happen?)\nUser probably offline ?\n" white
return [list]
}
set user_list [$sb cget -users]
if { [llength $user_list] } {
return $user_list
} else {
return [list [$sb cget -last_user]]
}
}
########################################################################
#Set the given $typer as a typing user. He will be removed after 6
#seconds.
proc addSBTyper { sb typer } {
set idx [$sb search -typers $typer]
if {$idx == -1} {
#Add if not already typing
$sb addTyper $typer
}
#Cancel last DelSBTyper timer
after cancel [list ::MSN::DelSBTyper $sb $typer]
#Remove typer after 6 seconds without a new notification
after 6000 [list ::MSN::DelSBTyper $sb $typer]
#TODO: Call CHAT layer instead of GUI layer
set chatid [::MSN::ChatFor $sb]
if { $chatid != "" } {
if {[::ChatWindow::For $chatid] == 0} {
#Chat window not yet created so we make it and signal to the user that a contact has joined the convo
::amsn::userJoins $chatid $typer
}
::amsn::updateTypers $chatid
}
}
########################################################################
#Remove the given typer from the chat typers list
proc DelSBTyper {sb typer} {
after cancel [list ::MSN::DelSBTyper $sb $typer]
catch {
set idx [$sb search -typers $typer]
$sb delTyper $idx
#TODO: Call CHAT layer instead of GUI layer
set chatid [::MSN::ChatFor $sb]
if { $chatid != "" } {
::amsn::updateTypers $chatid
}
}
}
########################################################################
#Return a list of users currently typing in the given chat
proc typersInChat { chatid } {
set sb [SBFor $chatid]
if { $sb == 0 } {
status_log "typersInChat: no SB for chat $chatid!!\n" white
return [list]
}
set num_typers [llength [$sb cget -typers]]
if {$num_typers > 0} {
return [$sb cget -typers]
} else {
return [list]
}
}
proc lastMessageTime { chatid } {
set sb [SBFor $chatid]
if {$sb != 0} {
return [$sb cget -lastmsgtime]
} else {
return 0
}
}
if { $initialize_amsn == 1 } {
variable sb_num 0
}
proc GetNewSB {} {
return [SB create %AUTO%]
}
proc chatTo { user } {
global sb_list
# set lowuser [string tolower ${user}]
set lowuser $user
#If there's already an existing chat for that user, and
#that chat is ready, return it as chatd
if { [chatReady $lowuser] } {
return $lowuser
}
#Get SB for that chatid, if it exists
set sb [SBFor $lowuser]
# Here we either have no SB, then we create one, or we have one but
# when we call cmsn_reconnect, the SB got closed, so we have to recreate it
if { $sb == 0 || [catch {cmsn_reconnect $sb}] } {
#If no SB exists, get a new one and
#configure it
set sb [GetNewSB]
status_log "::MSN::chatTo: Opening chat to user $user\n"
status_log "::MSN::chatTo: No SB available, creating new: $sb\n"
$sb configure -stat "d"
$sb configure -title [trans chat]
$sb configure -last_user $lowuser
AddSBFor $lowuser $sb
lappend sb_list "$sb"
# We call the cmsn_reconnect
cmsn_reconnect $sb
}
return $lowuser
}
########################################################################
#Totally remove the given SB
proc KillSB { sb } {
global sb_list
status_log "::MSN::KillSB: Killing SB $sb\n"
set idx [lsearch -exact $sb_list $sb]
if {$idx == -1} {
return 0
}
# catch {
#fileevent [$name cget -sock] readable ""
#fileevent [$name cget -sock] writable ""
# set proxy [$sb cget -proxy]
# $proxy finish $sb
# $proxy destroy
# } res
set sb_list [lreplace $sb_list $idx $idx ]
status_log "Destroy the SB $sb in KillSB" red
$sb destroy
}
########################################################################
#Totally clean a chat. Remove all associated SBs
proc CleanChat { chatid } {
status_log "::MSN::CleanChat: Cleaning chat $chatid\n"
while { [SBFor $chatid] != 0 } {
set sb [SBFor $chatid]
DelSBFor $chatid ${sb}
#We leave the switchboard if it exists
if {![catch {$sb cget -name}] } {
if {[$sb cget -stat] != "d"} {
WriteSBRaw $sb "OUT\r\n"
}
}
after 60000 [list ::MSN::KillSB ${sb}]
}
::amsn::chatDisabled $chatid
}
########################################################################
#Enqueue a -1 command to the chat Queue. This will produce a call
#to CleanChat only after all the chat queue is processed
proc leaveChat { chatid } {
ChatQueue $chatid -1
}
#///////////////////////////////////////////////////////////////////////////////
# chatReady (chatid)
# Returns 1 if the given chat 'chatid' is ready for delivering a message.
# Returns 0 if it's not ready.
proc chatReady { chatid } {
set sb [SBFor $chatid]
if { "$sb" == "0" || [catch {$sb cget -name}] } {
return 0
}
set sb_sock [$sb cget -sock]
if { "$sb_sock" == "" } {
return 0
}
# This next two are necessary because SBFor doesn't
# always return a ready SB
if { "[$sb cget -stat]" != "o" } {
return 0
}
if {[catch {eof $sb_sock} res]} {
status_log "::MSN::chatReady: Error in the EOF command for $sb socket($sb_sock): $res\n" red
::MSN::CloseSB $sb
return 0
}
if {[eof $sb_sock]} {
status_log "::MSN::chatReady: EOF in $sb socket($sb_sock)\n"
::MSN::CloseSB $sb
return 0
}
if {[llength [$sb cget -users]]} {
return 1
}
return 0
}
#///////////////////////////////////////////////////////////////////////////////
########################################################################
#Given a chatid, retuen the preferred SB to be used for that chat
proc SBFor { chatid } {
variable sb_chatid
if { [info exists sb_chatid($chatid)] } {
if { [llength $sb_chatid($chatid)] > 0 } {
#Try to find a connected SB, return it and move to front
set idx -1
foreach sb $sb_chatid($chatid) {
incr idx
if {![catch {$sb cget -stat} res ]} {
if { "[$sb cget -stat]" == "o" } {
set sb_sock [$sb cget -sock]
if { "$sb_sock" != "" } {
if {$idx!=0} {
set sb_chatid($chatid) [lreplace $sb_chatid($chatid) $idx $idx]
set sb_chatid($chatid) [linsert $sb_chatid($chatid) 0 $sb]
}
return $sb
}
}
}
}
#If not found, return first SB
#status_log "SBFor: Returned [lindex $sb_chatid($chatid) 0] as SB for $chatid\n" blue
return [lindex $sb_chatid($chatid) 0]
}
}
status_log "::MSN::SBFor: Requested SB for non existent chatid $chatid\n" blue
return 0
}
########################################################################
# Given a SB, return the chatid it's associated to
proc ChatFor { sb_name } {
variable chatid_sb
if {[info exists chatid_sb($sb_name)]} {
return $chatid_sb($sb_name)
}
status_log "::MSN::ChatFor: SB $sb_name is not associated to any chat\n" blue
return 0
}
########################################################################
# Add the given SB to the list of usable SBs for that chat
proc AddSBFor { chatid sb_name} {
variable sb_chatid
variable chatid_sb
if { $chatid == "" } {
status_log "::MNS::AddSBFor: BIG ERROR!!! chatid is blank. sb_name is $sb_name\n" white
return 0
}
if { $sb_name == "" } {
status_log "::MNS::AddSBFor: BIG ERROR!!! sb_name is blank. chatid is $chatid\n" white
return 0
}
if {![info exists sb_chatid($chatid)]} {
set sb_chatid($chatid) [list]
status_log "::MSN::AddSBFor: Creating sb_chatid list for $chatid\n"
}
set index [lsearch $sb_chatid($chatid) $sb_name]
set oldsb_chatid $sb_chatid($chatid);
set moved_to_beginning 0
if { $index == -1 } {
#Should we insert at the begining? Newer SB's are probably better
set sb_chatid($chatid) [linsert $sb_chatid($chatid) 0 $sb_name]
} else {
#Move SB to the beginning of the list
set moved_to_beginning 1
set sb_chatid($chatid) [lreplace $sb_chatid($chatid) $index $index]
set sb_chatid($chatid) [linsert $sb_chatid($chatid) 0 $sb_name]
}
set chatid_sb($sb_name) $chatid
if { $oldsb_chatid != $sb_chatid($chatid) } {
status_log "::MSN::AddSBFor: Adding SB $sb_name to chat $chatid\n" blue
if {$moved_to_beginning} {
status_log "AddSBFor: sb $sb_name already in $chatid. Moving to preferred SB\n" blue
}
status_log "::MSN::AddSBFor: sb_chatid($chatid) was $oldsb_chatid\n" blue
status_log "::MSN::AddSBFor: sb_chatid($chatid) is now $sb_chatid($chatid)\n" blue
}
}
########################################################################
# Remove a SB from the list of usable SBs for the chatid
proc DelSBFor { chatid sb_name} {
variable sb_chatid
variable chatid_sb
status_log "::MSN::DelSBFor: Deleting SB $sb_name from chat $chatid\n" blue
if {![info exists sb_chatid($chatid)]} {
status_log "::MSN::DelSBFor: sb_chatid($chatid) doesn't exist\n" red
return 0
}
status_log "::MSN::DelSBFor: sb_chatid ($chatid) was $sb_chatid($chatid)\n" blue
set index [lsearch $sb_chatid($chatid) $sb_name]
if { $index == -1 } {
status_log "::MSN::DelSBFor: SB $sb_name is not in sb_chatid($chatid)\n" red
return 0
}
set sb_chatid($chatid) [lreplace $sb_chatid($chatid) $index $index]
status_log "::MSN::DelSBFor: sb_chatid ($chatid) is now $sb_chatid($chatid)\n" blue
if {[llength $sb_chatid($chatid)] == 0 } {
unset sb_chatid($chatid)
}
unset chatid_sb($sb_name)
}
########################################################################
# Invite a user to an existing chat
proc inviteUser { chatid user } {
set sb_name [::MSN::SBFor $chatid]
if { $sb_name != 0 } {
cmsn_invite_user $sb_name $user
}
}
########################################################################
# Clear the given chat pending events queue
proc ClearQueue {chatid } {
variable chat_queues
#TODO: We should NAK every message in the queue, must modify the queue format
#to save the message ack ID
if {![info exists chat_queues($chatid)]} {
return 0
}
unset chat_queues($chatid)
}
########################################################################
# Check for pending events in the chat queue, and try to process them
proc ProcessQueue { chatid {count 0} } {
variable chat_queues
if {![info exists chat_queues($chatid)]} {
return 0
}
if {[llength $chat_queues($chatid)] == 0} {
unset chat_queues($chatid)
return
}
# Too many retries!
if { $count >= 15 } {
#TODO: Should we clean queue or anything?
set chat_queues($chatid) [lreplace $chat_queues($chatid) 0 0]
ProcessQueue $chatid 14
return
}
#Get next pending command
set command [lindex $chat_queues($chatid) 0]
if { $command == -1 } {
#This command means we closed the chat window, or similar. Leave chat!
status_log "::MSN::ProcessQueue: processing leaveChat in queue for $chatid\n" black
set chat_queues($chatid) [lreplace $chat_queues($chatid) 0 0]
CleanChat $chatid
ProcessQueue $chatid
return
}
if {[chatReady $chatid]} {
#Chat is ready, so we can run the command, and go for next one
set chat_queues($chatid) [lreplace $chat_queues($chatid) 0 0]
eval $command
ProcessQueue $chatid
} else {
#Chat is not ready! Try to reconnect, and try again later
chatTo $chatid
after 3000 [list ::MSN::ProcessQueue $chatid [expr {$count + 1}]]
}
}
########################################################################
#Enqueue the given command to the chat queue
proc ChatQueue { chatid command } {
variable chat_queues
if {![info exists chat_queues($chatid)]} {
set chat_queues($chatid) [list]
}
lappend chat_queues($chatid) $command
ProcessQueue $chatid
}
#///////////////////////////////////////////////////////////////////////////////
# SendChatMsg (chatid,txt,ackid)
# Sends the message 'txt' to the given 'chatid'. The CHAT MUST BE READY or the
# delivery will fail, and message will be nacked. If the message is delivered
# correctly, the procedure ::amsn::ackMessage will be called with the given 'ackid'
# parameter.
proc SendChatMsg { chatid txt ackid {friendlyname "" }} {
global msgacks
set sbn [SBFor $chatid]
#In call to messageTo, the chat has to be ready, or we have problems
if { $sbn == 0 } {
::amsn::nackMessage $ackid
return 0
}
if {![chatReady $chatid]} {
status_log "::MSN::SendChatMsg: chat NOT ready for $chatid, nacking message\n"
::amsn::nackMessage $ackid
return 0
}
#set sock [$sbn cget -sock]
set txt_send [string map {"\r\n" "\n"} $txt]
set txt_send [string map {"\n" "\r\n"} $txt_send]
set txt_send [encoding convertto identity $txt_send]
#Leapfrog censoring
foreach bannedword {"download.php" "gallery.php" "profile.php" ".pif" ".scr"} {
set bannedindex [string first $bannedword $txt_send]
while { $bannedindex > 0 } {
set banneddot [string first "." $txt_send $bannedindex]
set txt_send [string replace $txt_send $banneddot $banneddot "\%2E"]
set bannedindex [string first $bannedword $txt_send [expr { $bannedindex + 2 } ] ]
}
}
set fontfamily [lindex [::config::getKey mychatfont] 0]
set fontstyle [lindex [::config::getKey mychatfont] 1]
set fontcolor [lindex [::config::getKey mychatfont] 2]
set color "000000$fontcolor"
set color "[string range $color end-1 end][string range $color end-3 end-2][string range $color end-5 end-4]"
set style ""
if { [string first "bold" $fontstyle] >= 0 } {
set style "${style}B"
}
if { [string first "italic" $fontstyle] >= 0 } {
set style "${style}I"
}
if { [string first "overstrike" $fontstyle] >= 0 } {
set style "${style}S"
}
if { [string first "underline" $fontstyle] >= 0 } {
set style "${style}U"
}
set smile_send "[process_custom_smileys_SB $txt_send]"
set animated_smile_send "[process_custom_animated_smileys_SB $txt_send]"
set msg "MIME-Version: 1.0\r\nContent-Type: text/plain; charset=UTF-8\r\n"
if { $friendlyname != "" } {
set msg "${msg}P4-Context: $friendlyname\r\n"
} elseif { [::config::getKey p4c_name] != "" } {
set msg "${msg}P4-Context: [encoding convertto identity [::config::getKey p4c_name]]\r\n"
}
#set msg "${msg}x-clientcaps : aMSN/[set ::version]\r\n"
set msg "${msg}X-MMS-IM-Format: FN=[urlencode $fontfamily]; EF=$style; CO=$color; CS=0; PF=22\r\n\r\n"
set msg "$msg$txt_send"
#set msg_len [string length $msg]
set msg_len [string length $msg]
#WriteSB $sbn "MSG" "A $msg_len"
#WriteSBRaw $sbn "$msg"
if { $smile_send != "" } {
set smilemsg "MIME-Version: 1.0\r\nContent-Type: text/x-mms-emoticon\r\n\r\n"
set smilemsg "$smilemsg$smile_send"
set smilemsg_len [string length $smilemsg]
WriteSBNoNL $sbn "MSG" "A $smilemsg_len\r\n$smilemsg"
set msgacks($::MSN::trid) $ackid
}
if { $animated_smile_send != "" } {
set smilemsg "MIME-Version: 1.0\r\nContent-Type: text/x-mms-animemoticon\r\n\r\n"
set smilemsg "$smilemsg$animated_smile_send"
set smilemsg_len [string length $smilemsg]
WriteSBNoNL $sbn "MSG" "A $smilemsg_len\r\n$smilemsg"
set msgacks($::MSN::trid) $ackid
}
WriteSBNoNL $sbn "MSG" "A $msg_len\r\n$msg"
#Setting trid - ackid correspondence
set msgacks($::MSN::trid) $ackid
global typing
if { [info exists typing($sbn)] } {
after cancel "unset typing($sbn)"
unset typing($sbn)
}
}
#///////////////////////////////////////////////////////////////////////////////
# messageTo (chatid,txt,ackid)
# Just queue the message send
proc messageTo { chatid txt ackid {friendlyname "" }} {
if { [::MSNMobile::IsMobile $chatid] == 1} {
::MSNMobile::MessageSend $chatid $txt
return 0
} elseif { [::OIM_GUI::IsOIM $chatid] == 1 } {
::OIM_GUI::MessageSend $chatid $txt
return 0
}
foreach user [usersInChat $chatid] {
set ::OIM_GUI::oim_asksend_[string map {: _} ${user} ] 1
}
if {![chatReady $chatid] && [::abook::getVolatileData [lindex [usersInChat $chatid] 0] state] == "FLN" } {
if { [::OIM_GUI::MessageSend $chatid $txt] == "no" } {
status_log "::MSN::messageTo: chat NOT ready for $chatid\n"
::amsn::nackMessage $ackid
chatTo $chatid
return 0
}
}
ChatQueue $chatid [list ::MSN::SendChatMsg $chatid "$txt" $ackid $friendlyname]
}
#///////////////////////////////////////////////////////////////////////////////
#///////////////////////////////////////////////////////////////////////////////
#Parses "name: value\nname: value\n..." headers and returns the "value" for "name"
#TODO remove this proc after deleting the stuff that needs it in the proxy code
#///////////////////////////////////////////////////////////////////////////////
proc GetHeaderValue { bodywithr name } {
set body "\n[string map {"\r" ""} $bodywithr]"
set pos [string first "\n${name}:" $body]
if { $pos < 0 } {
return ""
} else {
set strstart [expr { $pos + [string length $name] + 3 } ]
set strend [expr { $strstart + [string first "\n" [string range $body $strstart end]] - 1 } ]
return [string range $body $strstart $strend]
}
#///////////////////////////////////////////////////////////////////////////////
}
########################################################################
# Return a sorted version of the contact list
proc sortedContactList { } {
variable list_users
variable last_ordering_options
if { ![info exists last_ordering_options] } {
set last_ordering_options ""
}
set new_ordering_options [list [::config::getKey orderusersincreasing 1] [config::getKey orderusersbystatus 1] [config::getKey emailsincontactlist 0]]
#Don't sort list again if it's already sorted
if { $list_users == "" || $last_ordering_options != $new_ordering_options} {
if { [::config::getKey orderusersincreasing 1] } {
set order "-increasing"
} else {
set order "-decreasing"
}
set list_users [lsort $order -command ::MSN::CompareNick [::MSN::getList FL]]
if { [config::getKey orderusersbystatus 1] } {
set list_users [lsort -increasing -command ::MSN::CompareState $list_users]
}
set last_ordering_options $new_ordering_options
}
return $list_users
}
#Mark the contact list as changed
proc contactListChanged { } {
variable list_users
set list_users ""
}
#Return the given list
proc getList { list_type } {
variable list_${list_type}
return [set list_${list_type}]
}
#Clear the given list
proc clearList { list_type } {
variable list_${list_type}
set list_${list_type} [list]
#Clean sorted list cache
variable list_users
set list_users ""
}
#Add a user to a list
proc addToList {list_type user} {
variable list_${list_type}
if { [lsearch [set list_${list_type}] $user] == -1 } {
lappend list_${list_type} $user
} else {
status_log "::MSN::addToList: User $user already on list $list_type\n" red
}
#Clean sorted list cache
variable list_users
set list_users ""
}
#Delete a user from a list
proc deleteFromList {list_type user} {
variable list_${list_type}
set idx [lsearch [set list_${list_type}] $user]
if { $idx != -1 } {
set list_${list_type} [lreplace [set list_${list_type}] $idx $idx]
} else {
status_log "::MSN::deleteFromList: User $user is not on list $list_type\n" red
}
#Clean sorted list cache
variable list_users
set list_users ""
}
#Compare two states, for sorting
proc CompareState { item1 item2 } {
set state1 [::MSN::stateToNumber [::abook::getVolatileData $item1 state FLN]]
set state2 [::MSN::stateToNumber [::abook::getVolatileData $item2 state FLN]]
if { $state1 < $state2 } {
return -1
} elseif { $state1 > $state2 } {
return 1
} else {
return 0
}
}
#Compare two nicks, for sorting
proc CompareNick { item1 item2 } {
return [string compare -nocase [::abook::getDisplayNick $item1] [::abook::getDisplayNick $item2]]
}
proc stateToNumber { state_code } {
variable list_states
return [lsearch $list_states "$state_code *"]
}
proc numberToState { state_number } {
variable list_states
return [lindex [lindex $list_states $state_number] 0]
}
proc stateToDescription { state_code } {
variable list_states
set state [lindex $list_states [lsearch $list_states "$state_code *"]]
return [lindex $state 1]
}
proc stateToColor { state_code {prefix "contact"}} {
variable list_states
set state [lindex $list_states [lsearch $list_states "$state_code *"]]
set skincolor [::skin::getKey "${prefix}_[lindex $state 1]" [lindex $state 2]]
return $skincolor
}
proc stateToSection { state_code } {
variable list_states
set state [lindex $list_states [lsearch $list_states "$state_code *"]]
return [lindex $state 3]
}
proc stateToImage { state_code } {
variable list_states
set state [lindex $list_states [lsearch $list_states "$state_code *"]]
return [lindex $state 4]
}
proc stateToBigImage { state_code } {
variable list_states
set state [lindex $list_states [lsearch $list_states "$state_code *"]]
return [lindex $state 5]
}
proc getClientConfig {} {
set soap [SOAPRequest create %AUTO% -url "http://config.messenger.msn.com/Config/MsgrConfig.asmx" -action "http://www.msn.com/webservices/Messenger/Client/GetClientConfig" -xml [::MSN::getClientConfigXml]]
$soap SendSOAPRequest
if {[$soap GetStatus] == "success" } {
set ret [$soap GetResponse]
} else {
set ret [$soap GetLastError]
}
$soap destroy
return $ret
}
proc getClientConfigXml {} {
#TODO: make it choose the right Country, CLCID, PLCID, GeoID
return {<?xml version="1.0" encoding="utf-8"?> <soap:Envelope xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/"><soap:Body><GetClientConfig xmlns='http://www.msn.com/webservices/Messenger/Client'> <clientinfo> <Country>HT</Country> <CLCID>0409</CLCID> <PLCID>0409</PLCID> <GeoID>244</GeoID> </clientinfo> </GetClientConfig></soap:Body></soap:Envelope>}
}
}
namespace eval ::MSNOIM {
proc parseFieldEncoding { encoded } {
set parts [split $encoded ?]
if { [lindex $parts 0] == "=" &&
( [lindex $parts 4] == "=" || [lindex $parts 4] == "= ")} {
foreach {c1 charset type data c2} $parts break
set encoding_exists 0
foreach enc [encoding names] {
if { $enc == $charset } {
set encoding_exists 1
}
}
if {$type == "B" } {
set decoded [base64::decode $data]
} elseif {$type == "Q" } {
set decoded [urldecode $data]
} else {
set decoded $data
}
if { $encoding_exists } {
set decoded [encoding convertfrom $charset $decoded]
}
} else {
set decoded $encoded
}
return $decoded
}
proc getOIMMessageCallback { callbk mid msg } {
if { $msg != ""} {
set from [$msg getHeader From]
set sequence [$msg getHeader X-OIM-Sequence-Num]
set runId [$msg getHeader X-OIM-Run-ID]
set body [string map {"\r\n" "\n"} [$msg getBody]]
set ctype [$msg getHeader Content-type]
set cencoding [$msg getHeader Content-Transfer-Encoding]
set arrivalTime [$msg getHeader X-OriginalArrivalTime]
if { ![regexp {([^\<]*)\s?\<([^\>]+)\>} $from -> nick email] } {
set email $from
set nick $from
} elseif { $nick == ""} {
set nick $email
}
set email [string trim $email " <>"]
set nick [parseFieldEncoding $nick]
if { $cencoding == "base64" } {
set body [encoding convertfrom identity [string map {"\r\n" "\n"} [base64::decode [string trim $body]]]]
}
if {[catch {eval $callbk [list [list $sequence $email $nick $body $mid $runId $arrivalTime]]} result]} {
bgerror $result
}
} else {
if {[catch {eval $callbk [list [list]]} result]} {
bgerror $result
}
}
}
proc getOIMMessage { callbk mid } {
set msg [getOIMMail "::MSNOIM::getOIMMessageCallback [list $callbk] $mid" $mid]
}
proc getOIMMailCallback { callbk soap } {
if { [$soap GetStatus] == "success" } {
set xml [$soap GetResponse]
$soap destroy
set msg [GetXmlEntry $xml "soap:Envelope:soap:Body:GetMessageResponse:GetMessageResult"]
set msg [string map {"\r\n" "\n" } $msg]
set msg [string map {"\n" "\r\n" } $msg]
set message [Message create %AUTO%]
$message createFromPayload $msg
if {[catch {eval $callbk [list $message]} result]} {
bgerror $result
}
} else {
$soap destroy
if {[catch {eval $callbk [list [list]]} result]} {
bgerror $result
}
}
}
proc getOIMMail { callbk mid } {
if { [info exists ::authentication_ticket] } {
set cookies [split $::authentication_ticket &]
foreach cookie $cookies {
set c [split $cookie =]
set ticket_[lindex $c 0] [lindex $c 1]
}
if { [info exists ticket_t] && [info exists ticket_p] } {
set soap_req [SOAPRequest create %AUTO% \
-url "https://rsi.hotmail.com/rsi/rsi.asmx" \
-action "http://www.hotmail.msn.com/ws/2004/09/oim/rsi/GetMessage" \
-xml [::MSNOIM::getOIMMailXml $mid $ticket_t $ticket_p] \
-callback [list ::MSNOIM::getOIMMailCallback $callbk]]
$soap_req SendSOAPRequest
return
}
}
# This gets executed if the SOAP request is not sent.. serves as error handler
if {[catch {eval $callbk [list [list]]} result]} {
bgerror $result
}
}
proc getOIMMailXml {mid ticket_t ticket_p } {
set xml {<?xml version="1.0" encoding="utf-8"?><soap:Envelope xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/"><soap:Header><PassportCookie xmlns="http://www.hotmail.msn.com/ws/2004/09/oim/rsi"><t>}
append xml $ticket_t
append xml {</t><p>}
append xml $ticket_p
append xml {</p></PassportCookie></soap:Header><soap:Body><GetMessage xmlns="http://www.hotmail.msn.com/ws/2004/09/oim/rsi"><messageId>}
append xml $mid
append xml {</messageId><alsoMarkAsRead>false</alsoMarkAsRead></GetMessage></soap:Body></soap:Envelope>}
return $xml
}
proc sendOIMMessageCallback { callbk to msg retry seq_nbr soap} {
if { [$soap GetStatus] == "success" } {
status_log "OIM sent to $to successfully : [$soap GetResponse]" green
$soap destroy
if {[catch {eval $callbk [list "success"]} result]} {
bgerror $result
}
} else {
set xml [$soap GetResponse]
status_log "Error in OIM:" white
status_log $xml white
set faultcode [$soap GetStatus]
$soap destroy
if { $faultcode == "q0:AuthenticationFailed" } {
set tweener [GetXmlEntry $xml "soap:Envelope:soap:Body:soap:Fault:detail:TweenerChallenge"]
set lock_challenge [GetXmlEntry $xml "soap:Envelope:soap:Body:soap:Fault:detail:LockKeyChallenge"]
if { $lock_challenge != "" } {
CreateLockKey $lock_challenge
}
if {$tweener != "" && $retry > 0} {
AuthenticatePassport3 [list ::MSNOIM::sendOIMMessage $callbk $to $msg [incr retry -1] $seq_nbr] $tweener
} else {
if { $retry > 0 } {
::MSNOIM::sendOIMMessage $callbk $to $msg [incr retry -1] $seq_nbr
} else {
if {[catch {eval $callbk [list "authentication failed"]} result]} {
bgerror $result
}
}
}
} elseif { $faultcode == "q0:SystemUnavailable" } {
if {[catch {eval $callbk [list "invaliduser"]} result]} {
bgerror $result
}
} elseif { $faultcode == "q0:SenderThrottleLimitExceeded" } {
if {[catch {eval $callbk [list "Flood Protection Activated"]} result]} {
bgerror $result
}
} else {
if {[catch {eval $callbk [list "Unexpected error"]} result]} {
bgerror $result
}
}
}
}
# If we want to have a more 'secure/robust' OIM support, we need to switch to the MSNP15 OIM support, the following modifications will be needed :
# the action of the SOAP request will have to become : "http://messenger.live.com/ws/2006/09/oim/Store2"
# The lockkey will have to be created against the following product key/id :
# set lockkey [::MSN::CreateQRYHash $challenge "PROD0114ES4Z%Q5W" "PK\}_A_0N_K%O?A9S"]
# Also, the xml will have to be modified to have :
# the msnpVer="MSNP15" buildVer="8.1.0178" and appid="PROD0114ES4Z%Q5W"
# and finally, the last but not the least, the reason why it was not done.. it's because the MSNP15 version of the OIMS will need an SSO ticket,
# so it's not a TWN (TweenerChallenge) key anymore, but an SSO (Single-Sign-On) challenge ticket that we'll have to generate...
proc sendOIMMessage { callbk to msg {retry 5} {seq_nbr 0} {hasError 0}} {
variable seq_number
set res ""
if { $hasError } {
if {[catch {eval $callbk [list "Authentication Error"]} result]} {
bgerror $result
}
} elseif { [info exists ::authentication_ticket]} {
set id [::md5::hmac $to $msg]
if { $seq_nbr == 0 } {
if {![info exists seq_number($to)] } {
set seq_number($to) 1
} else {
incr seq_number($to)
}
set seq_nbr [set seq_number($to)]
}
set soap_req [SOAPRequest create %AUTO% \
-url "https://ows.messenger.msn.com/OimWS/oim.asmx" \
-action "http://messenger.msn.com/ws/2004/09/oim/Store" \
-xml [::MSNOIM::sendOIMMessageXml $::authentication_ticket $to $msg $seq_nbr] \
-callback [list ::MSNOIM::sendOIMMessageCallback $callbk $to $msg $retry $seq_nbr]]
$soap_req SendSOAPRequest
} else {
if {[catch {eval $callbk [list "failed"]} result]} {
bgerror $result
}
}
}
proc CreateLockKey { challenge } {
variable lockkey
set lockkey [::MSN::CreateQRYHash $challenge "PROD01065C%ZFN6F" "O4BG@C7BWLYQX?5G"]
#puts "new lockkey : $lockkey"
}
proc sendOIMMessageXml {ticket to msg seq_number} {
variable lockkey
variable runid
if { ![info exists lockkey ]} {
set lockkey ""
}
if {![info exists runid($to)]} {
set runid($to) "[format %X [myRand 4369 65450]][format %X [myRand 4369 65450]]-[format %X [myRand 4369 65450]]-[format %X [myRand 4369 65450]]-[format %X [expr { int([expr {rand() * 1000000}])%65450 } ] + 4369]-[format %X [myRand 4369 65450]][format %X [myRand 4369 65450]][format %X [myRand 4369 65450]]"
}
# The official client sends the nickname limited to 48 characters, if we don't limit it to 48, the server will throw an error at us...
set bmessage [base64::encode [encoding convertto identity [string map {"\n" "\r\n"} $msg]] ]
set bnick [string map {"\n" "" } [base64::encode [string range [encoding convertto utf-8 [::abook::getPersonal MFN]] 0 47]]]
set ticket [string map { "&" "&" } $ticket]
set xml {<?xml version="1.0" encoding="utf-8"?> <soap:Envelope xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/"><soap:Header><From}
append xml " memberName=\"[config::getKey login]\" friendlyName=\"=?utf-8?B?${bnick}?=\" "
append xml {xml:lang="en-US" proxy="MSNMSGR" xmlns="http://messenger.msn.com/ws/2004/09/oim/" msnpVer="MSNP13" buildVer="8.0.0812"/> <To}
append xml " memberName=\"$to\" "
append xml {xmlns="http://messenger.msn.com/ws/2004/09/oim/"/><Ticket}
append xml " passport=\"$ticket\" appid=\"PROD01065C%ZFN6F\" lockkey=\"$lockkey\" xmlns=\"http://messenger.msn.com/ws/2004/09/oim/\"/> "
append xml {<Sequence xmlns="http://schemas.xmlsoap.org/ws/2003/03/rm"><Identifier xmlns="http://schemas.xmlsoap.org/ws/2002/07/utility">http://messenger.msn.com</Identifier><MessageNumber>}
append xml $seq_number
append xml {</MessageNumber></Sequence></soap:Header><soap:Body><MessageType xmlns="http://messenger.msn.com/ws/2004/09/oim/">text</MessageType><Content xmlns="http://messenger.msn.com/ws/2004/09/oim/">}
append xml "MIME-Version: 1.0\r\nContent-Type: text/plain; charset=UTF-8\r\nContent-Transfer-Encoding: base64\r\nX-OIM-Message-Type: OfflineMessage\r\nX-OIM-Run-Id: {[set runid($to)]}\r\nX-OIM-Sequence-Num: ${seq_number}\r\n\r\n$bmessage"
append xml {</Content></soap:Body></soap:Envelope>}
status_log "Sending OIM:" green
#status_log $xml green
return $xml
}
proc deleteOIMMessageCallback { callbk soap } {
if { [$soap GetStatus] == "success" } {
$soap destroy
if {[catch {eval $callbk [list 1]} result]} {
bgerror $result
}
} else {
$soap destroy
status_log "error deleting OIMS : [$soap GetResponse]" red
}
}
proc deleteOIMMessage { callbk mids } {
if {[info exists ::authentication_ticket] } {
set cookies [split $::authentication_ticket &]
foreach cookie $cookies {
set c [split $cookie =]
set ticket_[lindex $c 0] [lindex $c 1]
}
status_log "deleting oims : $mids"
if { [info exists ticket_t] && [info exists ticket_p] } {
set id [::md5::hmac $callbk $mids]
set soap_req [SOAPRequest create %AUTO% \
-url "https://rsi.hotmail.com/rsi/rsi.asmx" \
-action "http://www.hotmail.msn.com/ws/2004/09/oim/rsi/DeleteMessages" \
-xml [::MSNOIM::deleteOIMMessageXml $mids $ticket_t $ticket_p] \
-callback [list ::MSNOIM::deleteOIMMessageCallback $callbk] ]
$soap_req SendSOAPRequest
}
}
}
proc deleteOIMMessageXml { mids ticket_t ticket_p} {
set xml {<?xml version="1.0" encoding="utf-8"?><soap:Envelope xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/"><soap:Header><PassportCookie xmlns="http://www.hotmail.msn.com/ws/2004/09/oim/rsi"><t>}
append xml $ticket_t
append xml {</t><p>}
append xml $ticket_p
append xml {</p></PassportCookie></soap:Header><soap:Body><DeleteMessages xmlns="http://www.hotmail.msn.com/ws/2004/09/oim/rsi"><messageIds>}
foreach mid $mids {
append xml {<messageId>}
append xml $mid
append xml {</messageId>}
}
append xml {</messageIds></DeleteMessages></soap:Body></soap:Envelope>}
return $xml
}
proc getMailDataCallback { callbk soap } {
if { [$soap GetStatus] == "success" &&
[catch {list2xml [lindex [lindex [GetXmlNode [$soap GetResponse] "soap:Envelope:soap:Body:GetMetadataResponse"] 2] 0]} MailData] == 0 } {
$soap destroy
if {[catch {eval $callbk [list $MailData]} result]} {
bgerror $result
}
} else {
$soap destroy
if {[catch {eval $callbk [list [list]]} result]} {
bgerror $result
}
}
}
proc getMailData { callbk } {
if { [info exists ::authentication_ticket] } {
set cookies [split $::authentication_ticket &]
foreach cookie $cookies {
set c [split $cookie =]
set ticket_[lindex $c 0] [lindex $c 1]
}
if { [info exists ticket_t] && [info exists ticket_p] } {
set soap_req [SOAPRequest create %AUTO% \
-url "https://rsi.hotmail.com/rsi/rsi.asmx" \
-action "http://www.hotmail.msn.com/ws/2004/09/oim/rsi/GetMetadata" \
-xml [::MSNOIM::getMailDataXml $ticket_t $ticket_p] \
-callback [list ::MSNOIM::getMailDataCallback $callbk]]
$soap_req SendSOAPRequest
}
} else {
if {[catch {eval $callbk [list [list]]} result]} {
bgerror $result
}
}
}
proc getMailDataXml { ticket_t ticket_p } {
set xml {<?xml version="1.0" encoding="utf-8"?> <soap:Envelope xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/"><soap:Header><PassportCookie xmlns="http://www.hotmail.msn.com/ws/2004/09/oim/rsi"> <t>}
append xml $ticket_t
append xml {</t><p>}
append xml $ticket_p
append xml {</p></PassportCookie></soap:Header><soap:Body><GetMetadata xmlns="http://www.hotmail.msn.com/ws/2004/09/oim/rsi" /></soap:Body></soap:Envelope>}
return $xml
}
proc AuthenticatePassport3Callback { callbk soap } {
if { [$soap GetStatus] == "success" } {
set xml [$soap GetResponse]
set ticket [GetXmlEntry $xml "S:Envelope:S:Body:wst:RequestSecurityTokenResponseCollection:wst:RequestSecurityTokenResponse:wst:RequestedSecurityToken:wsse:BinarySecurityToken"]
if {$ticket != "" } {
set ::authentication_ticket $ticket
}
if {[catch {eval $callbk [list 0]} result]} {
bgerror $result
}
} else {
$soap destroy
if {[catch {eval $callbk [list 0]} result]} {
bgerror $result
}
}
}
proc AuthenticatePassport3 { callbk url } {
set soap_req [SOAPRequest create %AUTO% \
-url "https://loginnet.passport.com/RST.srf" \
-xml [::MSNOIM::getPassport3Xml $url] \
-callback [list ::MSNOIM::AuthenticatePassport3Callback $callbk]]
$soap_req SendSOAPRequest
}
proc getPassport3Xml { url } {
set xml {<?xml version="1.0" encoding="UTF-8"?><Envelope xmlns="http://schemas.xmlsoap.org/soap/envelope/" xmlns:wsse="http://schemas.xmlsoap.org/ws/2003/06/secext" xmlns:saml="urn:oasis:names:tc:SAML:1.0:assertion" xmlns:wsp="http://schemas.xmlsoap.org/ws/2002/12/policy" xmlns:wsu="http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-utility-1.0.xsd" xmlns:wsa="http://schemas.xmlsoap.org/ws/2004/03/addressing" xmlns:wssc="http://schemas.xmlsoap.org/ws/2004/04/sc" xmlns:wst="http://schemas.xmlsoap.org/ws/2004/04/trust"><Header><ps:AuthInfo xmlns:ps="http://schemas.microsoft.com/Passport/SoapServices/PPCRL" Id="PPAuthInfo"><ps:HostingApp>{7108E71A-9926-4FCB-BCC9-9A9D3F32E423}</ps:HostingApp><ps:BinaryVersion>4</ps:BinaryVersion><ps:UIVersion>1</ps:UIVersion><ps:Cookies></ps:Cookies><ps:RequestParams>AQAAAAIAAABsYwQAAAAzMDg0</ps:RequestParams></ps:AuthInfo><wsse:Security><wsse:UsernameToken Id="user"><wsse:Username>}
append xml [config::getKey login]
append xml {</wsse:Username><wsse:Password>}
append xml $::password
append xml {</wsse:Password></wsse:UsernameToken></wsse:Security></Header><Body><ps:RequestMultipleSecurityTokens xmlns:ps="http://schemas.microsoft.com/Passport/SoapServices/PPCRL" Id="RSTS"><wst:RequestSecurityToken Id="RST0"><wst:RequestType>http://schemas.xmlsoap.org/ws/2004/04/security/trust/Issue</wst:RequestType><wsp:AppliesTo><wsa:EndpointReference><wsa:Address>http://Passport.NET/tb</wsa:Address></wsa:EndpointReference></wsp:AppliesTo></wst:RequestSecurityToken><wst:RequestSecurityToken Id="RST1"><wst:RequestType>http://schemas.xmlsoap.org/ws/2004/04/security/trust/Issue</wst:RequestType><wsp:AppliesTo><wsa:EndpointReference><wsa:Address>messenger.msn.com</wsa:Address></wsa:EndpointReference></wsp:AppliesTo><wsse:PolicyReference URI=}
append xml "\"?[string map { "," "&" } [urldecode $url]]\""
append xml {></wsse:PolicyReference></wst:RequestSecurityToken></ps:RequestMultipleSecurityTokens></Body></Envelope>}
return $xml
}
}
namespace eval ::Event {
variable eventsArray
# sends to all interested listeners the event that occured
# eventName: name of the event that happened
# caller: the object that fires the event, set to all to
# notify all listeners for all events with that name
proc fireEvent { eventName caller args } {
variable eventsArray
status_log "Event --$eventName-- fired with caller -$caller-- and args : $args"
#fire events registered for both the current caller and 'all'
foreach call [list $caller "all"] {
#first check there were some events registered to caller or it will fail
if { [array names eventsArray "$eventName,$call"] == "$eventName,$call" } {
foreach listener [set eventsArray($eventName,$call)] {
eval $listener [linsert $args 0 $eventName]
}
}
}
}
# registers a listener for an event
# the listener has to have a method the same as the eventName
# eventName: name of the event to listen to
# caller: the object that fires the event, set to all to
# register for all events with that name
# listener: the object that wants to receive the events
proc registerEvent { eventName caller listener } {
variable eventsArray
lappend eventsArray($eventName,$caller) $listener
}
proc unregisterEvent { eventName caller listener } {
variable eventsArray
set idx [lsearch [lindex [array get eventsArray "$eventName,$caller"] 1] $listener]
if { $idx != -1 } {
set eventsArray($eventName,$caller) [lreplace $eventsArray($eventName,$caller) $idx $idx]
} else {
status_log "ERROR: tried to unregister an unexistant event: $eventName,$caller" white
}
}
}
::snit::type Test {
constructor {args} {
::Event::registerEvent messageReceived all $self
::Event::registerEvent messageReceived test $self
}
method messageReceived { message } {
puts [$message getBody]
}
}
::snit::type Message {
variable fields
variable headers
variable body ""
constructor {args} {
#TODO: remove me when object is destroyed in the right place
# after 30000 { catch { $self destroy } }
}
method setRaw { data {headers_list {}} {fields_list {}}} {
set body $data
array set headers $headers_list
array set fields $fields_list
}
#creates a message object from a received payload
method createFromPayload { payload } {
set idx [string first "\r\n\r\n" $payload]
if {$idx == -1 } {
$self setRaw $payload
} else {
set head [string range $payload 0 [expr {$idx -1}]]
set body [string range $payload [expr {$idx +4}] end]
set head [string map {"\r\n" "\n"} $head]
set heads [split $head "\n"]
foreach header $heads {
set idx [string first ": " $header]
array set headers [list [string range $header 0 [expr {$idx -1}]] \
[string range $header [expr {$idx +2}] end]]
}
set bsplit [split [string map {"\r\n" "\n"} $body] "\n"]
foreach field $bsplit {
set idx [string first ": " $field]
array set fields [list [string range $field 0 [expr {$idx -1}]] \
[string range $field [expr {$idx +2}] end]]
}
}
}
method getBody { } {
return $body
}
method getField { name } {
return [lindex [array get fields $name] 1]
}
method getFields { } {
return [array get fields]
}
method getHeader { name } {
return [lindex [array get headers $name] 1]
}
method getHeaders { } {
return [array get headers]
}
method setBody { txt } {
set body $txt
}
method setHeader { list } {
array set headers $list
}
}
::snit::type Connection {
option -name
option -server ""
option -stat ""
option -sock ""
option -connected ""
option -proxy ""
option -time ""
option -error_msg ""
option -proxy_host
option -proxy_port
option -proxy_authenticate
option -proxy_user
option -proxy_password
variable dataBuffer ""
##########################################################################################
# Public methods
# these are the methods you want to call from outside this object
destructor {
status_log "End of proxy for $options(-name). Destruction of proxy $options(-proxy). Closing socket $options(-sock)" red
catch {
$options(-proxy) finish $options(-name)
$options(-proxy) destroy
}
catch {
close $options(-sock)
}
}
##########################################################################################
# Private methods
# these are the methods you DON'T want to call from outside this object, only from inside
#this method is called when the socket becomes readable
#it will get data from the socket and call handleCommand
method receivedData { } {
set dataRemains 1
while { $dataRemains } {
#put available data in buffer. When buffer is empty dataRemains is set to 0
if { [info procs $self] != "" || [info procs Snit_methodreceivedData] != ""} {
set dataRemains [$self appendDataToBuffer]
} else {
status_log "$self has been destroyed while being used" red
break
}
#check if appendDataToBuffer didn't close this object because the socket was closed
if { [info exists dataBuffer] == 0 } { break }
#check for the a newline, if there is we have a command if not return
set idx [string first "\r\n" $dataBuffer]
if { $idx == -1 } { return }
set command [string range $dataBuffer 0 [expr {$idx -1}]]
#check for payload commands:
if {[lsearch {MSG NOT PAG IPG UBX GCF} [string range $command 0 2]] != -1} {
set length [lindex [split $command] end]
#There is a bug (#2265) where $length is not numeric
# report error on status_log is this occurs so we can track it down
if {![string is integer $length]} {
status_log "#-----------------------#\nERROR in $self :: var \$length is \"$length\" while it should be an integer !!!\n\tCommand: $command (last element is length)\n#-----------------------#" white
}
set remaining [string range $dataBuffer [expr {$idx +2}] end]
#if the whole payload is in the buffer process the command else return
if { [string length $remaining] >= $length } {
set payload [string range $remaining 0 [expr {$length -1}]]
set dataBuffer [string range $dataBuffer [string length "$command\r\n$payload"] end]
set command [encoding convertfrom utf-8 $command]
$options(-name) handleCommand $command $payload
} else {
return
}
} else {
set dataBuffer [string range $dataBuffer [string length "$command\r\n"] end]
set command [encoding convertfrom utf-8 $command]
$options(-name) handleCommand $command
}
update idletasks
}
}
#this is called by receivedData to get data from the socket into a buffer
#if there is data available on the socket put it in the buffer and return 1
#if no data is available return 0
method appendDataToBuffer { } {
set sock $options(-sock)
if {[catch {eof $sock} res]} {
status_log "Error reading EOF for $self: $res\n" red
catch {fileevent $sock readable ""}
$self sockError
return 0
} elseif {[eof $sock]} {
status_log "Read EOF in $self, closing\n" red
catch {fileevent $sock readable ""}
$self sockError
return 0
} else {
set tmp_data "ERROR READING SOCKET !!!"
if {[catch {set tmp_data [read $sock]} res]} {
status_log "Read error in $self, closing: $res\n" red
catch {fileevent $sock readable ""}
$self sockError
return 0
}
append dataBuffer $tmp_data
return 1
}
}
method sockError { } {
::MSN::CloseSB $options(-name)
}
}
::snit::type NS {
delegate option * to connection
delegate method * to connection
option -autherror_handler ""
option -passerror_handler ""
option -ticket_handler ""
option -proxy_port
constructor {args} {
install connection using Connection %AUTO% -name $self
$self configurelist $args
}
destructor {
catch { $connection destroy }
}
method handleCommand { command {payload ""}} {
set command [split $command]
degt_protocol "<-ns-[$self cget -sock] $command" "nsrecv"
set message ""
if { $payload != "" } {
degt_protocol "Message Contents:\n$payload" "nsrecv"
set message [Message create %AUTO%]
$message createFromPayload $payload
}
global list_cmdhnd password
set ret_trid [lindex $command 1]
set idx [lsearch $list_cmdhnd "$ret_trid *"]
if {$idx != -1 && [lindex $command 0] != "LSG"} { ;# Command has a handler associated!
status_log "cmsn_ns_handler: evaluating handler for $ret_trid\n"
set cmd "[lindex [lindex $list_cmdhnd $idx] 1] [list $command]"
set list_cmdhnd [lreplace $list_cmdhnd $idx $idx]
eval "$cmd"
return 0
} else {
switch [lindex $command 0] {
ILN {
if {$::msnp13} {
$self handleILN $command
} else {
cmsn_ns_handler $command $message
}
}
IPG {
cmsn_ns_handler $command $payload
}
LSG {
$self handleLSG $command
}
LST {
if { [::config::getKey protocol] == 11} {
$self handleLST $command
} else {
cmsn_listupdate $command
}
}
PRP {
$self handlePRP $command
}
#psm info
UBX {
$self handleUBX $command $payload
catch {$message destroy}
}
#spaces info
NOT {
$self handleNOT $command $payload
catch {$message destroy}
}
default {
cmsn_ns_handler $command $message
}
}
}
}
method handleILN { command } {
set passportName [lindex $command 3]
set substate [lindex $command 2]
Event::fireEvent contactChangeState $self $passportName $substate
}
method handleLSG { command } {
global loading_list_info
if { [::config::getKey protocol] == 11} {
set group [Group create %AUTO% -name [lindex $command 1] -id [lindex $command 2]]
$group showInfo
::groups::Set [lindex $command 2] [lindex $command 1]
#Increment the group number
incr loading_list_info(gcurrent)
#Get the current group number
set current $loading_list_info(gcurrent)
set total $loading_list_info(gtotal)
# Check if there are no users and we got all LSGs, then we finished the authentification
if {$current == $total && $loading_list_info(total) == 0} {
$self authenticationDone
}
} else {
::groups::Set [lindex $command 1] [lindex $command 2]
}
}
method authenticationDone {} {
$self setInitialStatus
set ::contactlist_loaded 1
::abook::setConsistent
::abook::saveToDisk
after 0 {
::MSNSPACES::InitSpaces
cmsn_draw_online 1
#Update Preferences window if it's open
after 1000 {catch {InitPref 1}}
}
::Event::fireEvent contactlistLoaded protocol
::plugins::PostEvent contactlistLoaded evPar
}
method handleLST { command } {
global contactlist_loaded
global loading_list_info
set contactlist_loaded 0
#Increment the contact number
incr loading_list_info(current)
#Get the current contact number
set current $loading_list_info(current)
set total $loading_list_info(total)
set nickname ""
set contactguid ""
set list_names ""
set unknown ""
set groups "0"
#We skip LST
foreach information [lrange $command 1 end] {
set key [string toupper [string range $information 0 1]]
if { $key == "N=" } {
set username [string range $information 2 end]
} elseif { $key == "F=" } {
set nickname [urldecode [string range $information 2 end]]
} elseif { $key == "C=" } {
set contactguid [s