'****************************** ENCRYPTION.ASP ********************************** <% Dim Encryption_Key, DECRYPTED_CYPHERTEXT, g_CryptThis 'CHANGE THIS LINE TO POINT TO WHERE YOU STORE YOUR KEYS.MDB DATABASE DATA_PATH = "c:\emmanoble\redirection\encryption\keys.mdb" ConnPasswords_RuntimeUserName = "" ConnPasswords_RuntimePassword = "" Dim k, iCount, strMyKey DIM KEY_ID, KEYSTREAM On Error Resume Next SUB GENERATE_KEYSTREAM Const g_KeyLen = 512 KEYSTREAM = RNG(g_KeyLen) CALL ADD_KEYSTREAM(KEYSTREAM) if Err <> 0 Then Response.Write "<BR>THERE WAS A PROBLEM GENERATING THE KEYSTREAM" & "<BR>" Response.Write Err.Number & "<BR>" & Err.Description & "<BR>" End If Encryption_Key = KeyStream END SUB SUB DeCrypt_QueryString g_CryptThis = request.querystring("crypt") If Len(g_CryptThis) > 1 then KEY_ID = request.querystring("KEYID") Set RNG_Passwords = Server.CreateObject("ADODB.Connection") Set RNG_GetKEYIDRecord = Server.CreateObject("ADODB.Recordset") RNG_Passwords.Open "DBQ=" & DATA_PATH & ";Driver={Microsoft Access Driver (*.mdb)};UID=" & ConnPasswords_RuntimeUserName & ";PASSWORD=" & ConnPasswords_RuntimePassword mySQL = "SELECT * FROM ONETIMEPAD where (KEY_ID = " & KEY_ID & ")" RNG_GetKEYIDRecord.Open mySQL, RNG_Passwords, 1, 3 If RNG_GetKEYIDRecord.EOF and RNG_GetKEYIDRecord.BOF then Response.write "YOUR KEY:" & KEY_ID & " DOES NOT EXIST ANY MORE!<BR>" Response.write "I CAN NOT DECIPHER THAT QUERYSTRING!<BR><BR>" Else KeyStream = RNG_GetKEYIDRecord("KeyStream") End If RNG_GetKEYIDRecord.Close Set RNG_GetKEYIDRecord = Nothing RNG_Passwords.Close Set RNG_Passwords = Nothing Encryption_Key = KeyStream DECRYPTED_CYPHERTEXT = DeCrypt(g_CryptThis) DELETE_KEYSTREAM(KEY_ID) End If END SUB Function Request_Decrypted(GetQueryString) Dim i,Found_It,Chop_DECRYPTED_CYPHERTEXT,Found_It_Here, TrimExcess Found_It_Here = 0 TrimExcess = 0 Chop_DECRYPTED_CYPHERTEXT = "" for i = 0 to Len(GetQueryString) Found_It = InStr(1, DECRYPTED_CYPHERTEXT, "&" & GetQueryString & "=", 1) If CInt(Found_It) > 0 then Found_It_Here = Found_It TrimExcess = 1 End If If Found_It_Here < 1 then Found_It = InStr(1, DECRYPTED_CYPHERTEXT, "?" & GetQueryString & "=", 1) If (CInt(Found_It) > 0) then Found_It_Here = Found_It TrimExcess = 2 End If End If if Found_It_Here > 0 then Chop_DECRYPTED_CYPHERTEXT = Right(DECRYPTED_CYPHERTEXT,(Len(DECRYPTED_CYPHERTEXT))-Found_It-Len(GetQueryString)-TrimExcess) Found_It = InStr(1, Chop_DECRYPTED_CYPHERTEXT, "&", 1) if CInt(Found_It) > 0 then Chop_DECRYPTED_CYPHERTEXT = Left(Chop_DECRYPTED_CYPHERTEXT,Found_It-1) End If End If Next Request_Decrypted = Chop_DECRYPTED_CYPHERTEXT End Function Function EnCrypt(strCryptThis) strCryptThis = ChkString(strCryptThis) Dim strChar, iKeyChar, iStringChar, i for i = 1 to Len(strCryptThis) iKeyChar = Asc(mid(Encryption_Key,i,1)) iStringChar = Asc(mid(strCryptThis,i,1)) iCryptChar = iStringChar + iKeyChar If iCryptChar > 255 then iCryptChar = iCryptChar - 256 End If 'iCryptChar = iKeyChar Xor iStringChar strEncrypted = strEncrypted & Chr(iCryptChar) next EnCrypt = Server.URLEncode(strEncrypted) End Function Function DeCrypt(strEncrypted) Dim strChar, iKeyChar, iStringChar, i, iDeCryptChar for i = 1 to Len(strEncrypted) iKeyChar = (Asc(mid(Encryption_Key,i,1))) iStringChar = Asc(mid(strEncrypted,i,1)) iDeCryptChar = iStringChar - iKeyChar 'iDeCryptChar = iKeyChar Xor iStringChar If iDeCryptChar < 0 then iDeCryptChar = iDeCryptChar + 256 End If If (iDeCryptChar = 34) or (iDeCryptChar = 39) then Response.write "The FreeURL Robot has detected a possible encryption ERROR<br>" Response.write "please contact webmaster@LasVeg.as?subject=Encryption Error:" & g_CryptThis & "<br>" Response.end Else strDecrypted = strDecrypted & Chr(iDeCryptChar) End If next DeCrypt = strDecrypted End Function Function ChkString(string) If string = "" then string = " " End If ChkString = Replace(string, """", "") ChkString = Replace(ChkString, "'", "") End Function SUB DELETE_KEYSTREAM(KEY_ID) Set RNG_Passwords = Server.CreateObject("ADODB.Connection") Set RNG_DeleteRecord = Server.CreateObject("ADODB.Recordset") myDBQ = "DBQ=" & DATA_PATH & ";Driver={Microsoft Access Driver (*.mdb)};UID=" & ConnPasswords_RuntimeUserName & ";PASSWORD=" & ConnPasswords_RuntimePassword RNG_Passwords.Open myDBQ strSQL = "DELETE * FROM ONETIMEPAD where (KEY_ID=" & KEY_ID & ");" RNG_DeleteRecord.Open strSQL, RNG_Passwords, 0, 1 Response.write "YOUR UNIQUE KEY " & KEY_ID & " WAS DELETED FROM THE ""ONE TIME PAD"" DATABASE!<BR><BR>" RNG_Passwords.Close Set RNG_Passwords = Nothing 'WE SHOULD EXPIRE KEYS VIA THE GLOBAL.ASA OT ANOTHER FILE TO KEEP THE DATABASE NICE AND TIDY. 'WHEN SOMEONE USES THIS SCRIPT - IT CLEANS UP REDUNDANT KEYS OF OVER 6 HOURS OLD. 'SET-UP OUR EXIRY VARIABLES DIM DATE_TYPE, DATE_EXPIRES DATE_TYPE = "H" 'd=days, h=hour, n=minutes, s=seconds DATE_EXPIRES = 6 'THE TIME THAT THE KEY IS VALID REPRESENTED IN DATA_TYPE UNITS TIMESTAMP_EXPIRY = DateAdd(DATE_TYPE, -(DATE_EXPIRES), NOW()) RESPONSE.WRITE "TIME NOW =" & NOW() & ", TIMESTAMP_EXPIRY=" & TIMESTAMP_EXPIRY & "<BR>" Set RNG_Passwords = Server.CreateObject("ADODB.Connection") Set RNG_DeleteRecord = Server.CreateObject("ADODB.Recordset") myDBQ = "DBQ=" & DATA_PATH & ";Driver={Microsoft Access Driver (*.mdb)};UID=" & ConnPasswords_RuntimeUserName & ";PASSWORD=" & ConnPasswords_RuntimePassword RNG_Passwords.Open myDBQ StrSql = "DELETE * FROM ONETIMEPAD where (TIMESTAMP < (#" & TIMESTAMP_EXPIRY & "#));" RNG_DeleteRecord.Open strSQL, RNG_Passwords, 0, 1 RNG_Passwords.Close Set RNG_Passwords = Nothing END SUB Function RNG(iKeyLength) lowerbound = 35 upperbound = 96 Randomize for i = 1 to iKeyLength s = 255 k = Int(((upperbound - lowerbound) + 1) * Rnd + lowerbound) strMyKey = strMyKey & Chr(k) & "" next RNG = strMyKey End Function SUB ADD_KEYSTREAM(KEYSTREAM) Set RNG_Passwords = Server.CreateObject("ADODB.Connection") Set RNG_AddNewRecord = Server.CreateObject("ADODB.Recordset") myDBQ = "DBQ=" & DATA_PATH & ";Driver={Microsoft Access Driver (*.mdb)};UID=" & ConnPasswords_RuntimeUserName & ";PASSWORD=" & ConnPasswords_RuntimePassword RNG_Passwords.Open myDBQ strSQL = "SELECT * FROM ONETIMEPAD" RNG_AddNewRecord.Open strSQL, RNG_Passwords, 1, 3 RNG_AddNewRecord.AddNew RNG_AddNewRecord("KEYSTREAM") = KEYSTREAM RNG_AddNewRecord("TIMESTAMP") = NOW() RNG_AddNewRecord.Update KEY_ID = RNG_AddNewRecord("KEY_ID") RNG_AddNewRecord.Close Set RNG_AddNewRecord = Nothing RNG_Passwords.Close Set RNG_Passwords = Nothing END SUB %> '*************************************************************************** '*********************************** START.ASP ******************************** <%@ Language=VBScript %> <% Response.Buffer = "True" %> <!--#INCLUDE VIRTUAL="/Redirection/Encryption/Encryption.asp"--> <% CALL GENERATE_KEYSTREAM 'set up your request variables Script_Winner = "Active Server Pages" Nomination1 = "4GuysFromRolla.com" Nomination2 = "FreeURL.com" 'set up the request string Encryption_String = "?SW=" & Script_Winner & "&N1=" & Nomination1 & "&N2=" & Nomination2 'encrypt the request string with unique KEY ENCRYPTED_CYPHERTEXT = EnCrypt(Encryption_String) 'set up a hyperlink 'format: nextfile.asp?keyid=" & KEY_ID & "&crypt=" & ENCRYPTED_CYPHERTEXT Response.Write "The following variables are encrypted and sent to the next page via the QUERYSTRING<BR><BR>" Response.Write "Script_Winner = Active Server Pages<BR>" Response.Write "Nomination1 = 4GuysFromRolla.com<BR>" Response.Write "Nomination2 = FreeURL.com<BR><BR>" Response.Write "Click on the following string to test it out!<BR><BR>" Response.Write "<a href='end.asp?keyid=" & KEY_ID & "&crypt=" & ENCRYPTED_CYPHERTEXT & "'>" & "end.asp?keyid=" & KEY_ID & "&crypt=" & ENCRYPTED_CYPHERTEXT & "</a><BR>" %> '*************************************************************************** '**************************** END.ASP ************************************** <% Language=VBScript %> <% Response.Buffer = "True" %> <!--#INCLUDE VIRTUAL="/Redirection/Encryption/Encryption.asp"--> <% 'decrypt the encrypted QUERYSTRING CALL DeCrypt_QueryString 'retrieve our QUERYSTRING variables SW = Request_Decrypted("SW") N1 = Request_Decrypted("N1") N2 = Request_Decrypted("N2") Response.Write "<hr width=""100%"" noshade>" Response.Write "The prize for BEST scripting language goes to:- <font color=""#f00000"">" & SW & "</font><br><br>" Response.Write "The Nominations for cool sites are:-<br>" Response.Write "<a href=""http://www." & N1 & """><font color=""#f00000"">" & N1 & "</font></a> & <a href=""http://www." & N1 & """><font color=""#f00000"">" & N2 & "</font></a><br><br>" Response.Write "<hr width=""100%"" noshade>" Response.Write "If you want to pass info from this screen - repeat the cycle!<br>" Response.Write "Try the REFRESH button or modify the KEY_ID in the querystring to test the unique request.<br>" Response.Write "Do you notice how the QUERYSTRING changes each time, but still has the same real content?<br><br>" 'generate a fresh new key CALL GENERATE_KEYSTREAM 'set up your request variables Script_Winner = "Active Server Pages" Nomination1 = "4GuysFromRolla.com" Nomination2 = "FreeURL.com" 'set up the request string Encryption_String = "?SW=" & Script_Winner & "&N1=" & Nomination1 & "&N2=" & Nomination2 'encrypt the request string with unique KEY ENCRYPTED_CYPHERTEXT = EnCrypt(Encryption_String) 'set up a hyperlink 'format: nextfile.asp?keyid=" & KEY_ID & "&crypt=" & ENCRYPTED_CYPHERTEXT Response.Write "<a href='end.asp?keyid=" & KEY_ID & "&crypt=" & ENCRYPTED_CYPHERTEXT & "'>" & ENCRYPTED_CYPHERTEXT & "</a><p>" %> '*********************************************************************************