protocol.tcl

Linux下的MSN聊天程序源码

						::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} {
                set prodid "PROD0090YUAUV\{2B"
                set 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 {![catch {tk windowingsystem} wsystem] && $wsystem == "aqua"} {
      #	set operatingsystem "Mac OS X"
      #} elseif {$tcl_platform(platform) == "windows"} {
      #	set operatingsystem "Windows"
      #} elseif {$tcl_platform(platform) == "unix"} {
      #	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 is 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?)\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\