<![CDATA[
'****************************** 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>"
%>
'*********************************************************************************
]]>