Tweet
Here goes, right out the oven. 
' Compiler: PB 8.04 (Can be tweaked to work also with PBCC)
' Compiler: PB 8.04 (Can be tweaked to work also with PBCC)
Code:
#COMPILE EXE
#DIM ALL
#INCLUDE "WIN32API.INC"
' This took me lots and lots of time, not because it was hard,
' But because of my lack of knowledge about COM.
'
' Thanx goes to, Paul Franks and David Roberts,
MACRO CreateObject(id) = NEW DISPATCH IN id
' ==== Ask the nexus server to wich server should i connect===============
FUNCTION WriteNEXUS() AS STRING
LOCAL v1 AS VARIANT, v2 AS VARIANT
DIM objXMLHTTP AS DISPATCH
'SET objXMLHTTP = CreateObject("WinHttp.WinHttpRequest.5.1") '<--- This one is better supported in TrustedWebHost
SET objXMLHTTP = CreateObject("Msxml2.xmlhttp.4.0")
v1 ="GET "
v2 = "https://nexus.passport.com:443/rdr/pprdr.asp"
OBJECT CALL objXMLHTTP.open(v1, v2)
v1 = ""
OBJECT CALL objXMLHTTP.send(v1)
OBJECT GET objXMLHTTP.getAllResponseHeaders TO v1
FUNCTION = VARIANT$(v1)
SET objXMLHTTP = NOTHING
END FUNCTION
'============================================================================
'==Send The Autentication Code to the server=================================
FUNCTION WriteLOGIN1(LoginURL AS STRING, AuthPolicy AS STRING, EmailAddress AS STRING, Password AS STRING) AS STRING
LOCAL v1 AS VARIANT, v2 AS VARIANT
DIM objXMLHTTP AS DISPATCH
'SET objXMLHTTP = CreateObject("WinHttp.WinHttpRequest.5.1") '<--- This one is better supported in TrustedWebHost
SET objXMLHTTP = CreateObject("Msxml2.xmlhttp.4.0")
v1 ="GET"
LoginURL = LCASE$(LoginURL)
REPLACE ".com/" WITH ".com:443/" IN LoginURL
REPLACE ".net/" WITH ".net:443/" IN LoginURL
v2 = "https://" & LoginURL
OBJECT CALL objXMLHTTP.open(v1, v2)
v1 = "Authorization"
v2 = "Passport1.4 OrgVerb=GET,OrgURL=http%3A%2F%2Fmessenger%2Emsn%2Ecom,sign-in=" & EmailAddress & ",pwd=" & Password & "," & _
AuthPolicy
OBJECT CALL objXMLHTTP.setRequestHeader(v1, v2)
v1 = "User-Agent"
v2 = "MSMSGS"
OBJECT CALL objXMLHTTP.setRequestHeader(v1, v2)
v1 = "Host"
v2 = PARSE$(LoginUrl, ANY ":/", 1)
OBJECT CALL objXMLHTTP.setRequestHeader(v1, v2)
v1 = "Connection"
v2 = "Keep-Alive"
OBJECT CALL objXMLHTTP.setRequestHeader(v1, v2)
v1 = "Cache-Control"
v2 = "no-cache"
OBJECT CALL objXMLHTTP.setRequestHeader(v1, v2)
v1 = ""
OBJECT CALL objXMLHTTP.send(v1)
OBJECT GET objXMLHTTP.getAllResponseHeaders TO v1
FUNCTION = VARIANT$(v1)
SET objXMLHTTP = NOTHING
END FUNCTION
'=====================================================================================
'==Send a message to the MSN server and wait for an answer============================
FUNCTION WriteMsnPort(FF AS LONG, TCPLine AS STRING, AsIs AS LONG, SleepTime AS LONG) AS STRING
STATIC CurTran AS LONG
LOCAL Index AS LONG
LOCAL Buffer AS STRING
LOCAL Answer AS STRING
ERRCLEAR
IF INSTR(TCPLine, "%TRN") THEN
INCR CurTran
REPLACE "%TRN" WITH FORMAT$(CurTran) IN TCPLine
END IF
IF INSTR(TCPLine, "%TR2") THEN
INCR CurTran
REPLACE "%TR2" WITH FORMAT$(CurTran) IN TCPLine
END IF
IF ISTRUE(VARPTR(AsIs)) THEN
IF AsIs THEN
TCP SEND #FF, TCPLine & $CRLF
ELSE
GOTO ByParts
END IF
ELSE
ByParts:
TcpLine = TcpLine & $CRLF
FOR Index = 1 TO PARSECOUNT(Tcpline, $CRLF)
IF ISTRUE(LEN(PARSE$(TCPLine, $CRLF, Index))) THEN
TCP PRINT #FF, (TRIM$(PARSE$(TCPLine, $CRLF, Index)) & " ")
END IF
NEXT Index
END IF
KeepReading:
Buffer = SPACE$(2048)
TCP RECV #FF, 2048, Buffer
Answer = (Answer & Buffer)
IF ISFALSE(EOF(FF)) THEN
SLEEP SleepTime
GOTO KeepReading
END IF
ReceiveDone:
FUNCTION = Answer
END FUNCTION
'=====================================================================================
FUNCTION GetMoreText(FF AS LONG) AS STRING
LOCAL Buffer AS STRING
LOCAL Answer AS STRING
KeepReading:
TCP LINE #FF, Buffer
Answer = Answer & Buffer & $CRLF
IF ISFALSE(EOF(FF)) THEN GOTO KeepReading
FUNCTION = TRIM$(Answer, ANY $CRLF)
END FUNCTION
'=====================================================================================
'==Replace character codes with apropriate character (Needs to be added more chars)===
FUNCTION FixFormatting(MyString AS STRING) AS STRING
LOCAL targetstring AS STRING
TargetString = MyString
REPLACE "%20" WITH " " IN TargetString
FUNCTION = TargetString
END FUNCTION
'=====================================================================================
'==Easy-To-Call Function to retrieve the contact list=================================
FUNCTION RetrieveContactList(EmailAddress AS STRING, Password AS STRING, List() AS STRING) AS LONG
LOCAL Hserver1 AS LONG
LOCAL HServer2 AS LONG
LOCAL FF1 AS LONG
LOCAL FF2 AS LONG
LOCAL NextServer AS STRING
LOCAL Result AS STRING
LOCAL XML AS STRING
LOCAL AuthPolicy AS STRING
LOCAL Policy AS STRING
LOCAL Pos1 AS LONG
LOCAL Pos2 AS LONG
LOCAL Index AS LONG
LOCAL Index1 AS LONG
LOCAL Index2 AS LONG
LOCAL Index3 AS LONG
IF ISFALSE(LEN(Password)) THEN
MSGBOX "Please edit the code to include your account and password.",,"Please enter required data."
EXIT FUNCTION
END IF
CLOSE
FF1 = FREEFILE
ERRCLEAR
TCP OPEN PORT 1863 AT "207.46.96.153" AS #FF1
' First Part, ask the main server wich server should we connect to.
Result = WriteMsnPort(FF1, "VER %TRN MSNP8 CVR0", 0, 100)
Result = WriteMsnPort(FF1, "CVR %TRN 0x0409 win 4.10 i386 MSNMSGR 6.2.0137 MSMSGS " & EmailAddress, 0, 100)
NextServer = WriteMsnPort(FF1, "USR %TRN TWN I " & EmailAddress, 0, 100)
TCP CLOSE #FF1
NextServer = PARSE$(NextServer, " ", 4)
' Part 2, Ask the second server wich server has our information, and as for an autentication code.
ERRCLEAR
FF1 = FREEFILE
TCP OPEN PORT VAL(PARSE$(NextServer, ":", 2)) AT PARSE$(NextServer, ":", 1) AS #FF1
Result = WriteMsnPort(FF1, "VER %TRN MSNP8 CVR0", 0, 100)
Result = WriteMsnPort(FF1, "CVR %TRN 0x0409 win 4.10 i386 MSNMSGR 6.2.0137 MSMSGS " & EmailAddress, 0, 100)
AuthPolicy = WriteMsnPort(FF1, "USR %TRN TWN I " & EmailAddress, 0, 100)
AuthPolicy = PARSE$(AuthPolicy, " ", 5)
' Now that we have the autentication code, lets atenticate our log in.
Result = WriteNEXUS()
LOCAL TextLine AS STRING
LOCAL TextMember AS STRING
FOR Index1 = 1 TO PARSECOUNT(Result, $CRLF)
TextLine = PARSE$(Result, $CRLF, Index1)
IF UCASE$(TRIM$(PARSE$(TextLine, ":", 1))) = UCASE$("PassportURLs") THEN
TextLine = TRIM$(PARSE$(TextLine, " ", 2))
FOR Index2 = 1 TO PARSECOUNT(Result, ",")
TextMember = TRIM$(PARSE$(TextLine, ",", Index2))
IF UCASE$(TRIM$(PARSE$(TextMember, "=", 1))) = UCASE$("DALogin") THEN
TextMember = TRIM$(PARSE$(TextMember, "=", 2))
GOTO GotServer
END IF
NEXT Index2
END IF
NEXT Index1
GotServer:
' The Nexus server replies with another autentication code, wich we now send to the first server.
Result = WriteLOGIN1(TextMember, AuthPolicy, EmailAddress, Password)
' We check if we succeeded or failed.
IF INSTR(UCASE$(Result), UCASE$("status=failed")) THEN FUNCTION = 0 : TCP CLOSE #FF1 : EXIT FUNCTION
IF ISFALSE(INSTR(UCASE$(Result), UCASE$("='t="))) THEN FUNCTION = 0 : TCP CLOSE #FF1 : EXIT FUNCTION
' We succeded, now the last part is to send the last autentication code to the first server.
FOR Index1 = 1 TO PARSECOUNT(Result, $CRLF)
TextLine = PARSE$(Result, $CRLF, Index1)
IF UCASE$(TRIM$(PARSE$(TextLine, ":", 1))) = UCASE$("Authentication-Info") THEN
Pos1 = (INSTR(TextLine, "='t=") + 1)
TextLine = RIGHT$(TextLine, LEN(TextLine)-Pos1)
TextLine = TRIM$(PARSE$(TextLine, "'", 1))
GOTO GotAuth
END IF
NEXT Index1
GotAuth:
'We send the autentication code!!
Result = WriteMsnPort(FF1, "USR %TRN TWN S " & TextLine, 0, 200)
' We ask for the contact list...
Result = WriteMsnPort(FF1, "SYN %TRN 0", 0, 200)
' We wait a bit so more info comes.
SLEEP 2000
' And we pick our list of contacts!
Result = GetMoreText(FF1)
' Finally we parse it into a tidy array
LOCAL Contact AS LONG
LOCAL ThisContact AS STRING
Contact = 1
FOR Index = 1 TO PARSECOUNT(Result, $CRLF)
ThisContact = TRIM$(PARSE$(Result, $CRLF, Index))
IF UCASE$(PARSE$(ThisContact, " ", 1)) = "LST" THEN
List(Contact) = PARSE$(ThisContact, " ", 2) '& FixFormatting(TRIM$(PARSE$(ThisContact, " ", 3))) ' Un REM This if you also want the nicknames.
INCR Contact
REDIM PRESERVE List(1 TO Contact)
END IF
NEXT Index
IF Contact > 1 THEN REDIM PRESERVE List(1 TO (Contact-1))
FUNCTION = 1
TCP CLOSE #FF1
TCP CLOSE #FF2
END FUNCTION
'=================================================================
FUNCTION PBMAIN () AS LONG
LOCAL Result AS LONG
LOCAL EmailAddress AS STRING
LOCAL Password AS STRING
DIM List(1 TO 1) AS LOCAL STRING
EmailAddress = "[email protected]"
Password = "" '<- Your Password Here.
Result = RetrieveContactList(EmailAddress, Password, List())
IF Result THEN
LOCAL Index AS LONG
LOCAL COntacts AS STRING
FOR Index = LBOUND(List()) TO UBOUND(List())
Contacts = Contacts & List(Index) & $CRLF
NEXT Index
MSGBOX Contacts,,"SUCCESS!!"
ELSE
MSGBOX "The function failed due to unknown error." & $CRLF & _
"Verify the address and Password, also remember" & $CRLF & _
"that server some times rejects requests.",,"FAILURE!!"
END IF
END FUNCTION