<% 'This ASP script originally lived at http://evolvedcode.net/ for the 'original version of this script and a wide variety of other 'scripts, please visit the site. 'Having problems? Have you read the big red text on the page below? ' http://dev.evolvedcode.net/content/code_authenticate/ 'MIME and Base64 encode/decode function concepts are from http://www.zarr.net/vb/ ' these are not the original functions as they have been upgraded quite heavily ' since then by myself to increase performance and decrease code size 'Constant used by the base64 encode/decode functions Const csBase64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" Function Base64_Encode( ByVal sInput ) 'Code to perform a base 64 encode Dim c(3) Dim w(4) Dim iPos Dim sOutput sInput = CStr( sInput ) For iPos = 1 To Len(sInput) Step 3 c(1) = Asc(Mid(sInput, iPos, 1)) c(2) = Asc(Mid(sInput, iPos + 1, 1) + Chr(0)) c(3) = Asc(Mid(sInput, iPos + 2, 1) + Chr(0)) w(1) = Int(c(1) / 4) w(2) = (c(1) And 3) * 16 + Int(c(2) / 16) If Len(sInput) >= iPos + 1 Then w(3) = (c(2) And 15) * 4 + Int(c(3) / 64) Else w(3) = -1 End If If Len(sInput) >= iPos + 2 Then w(4) = c(3) And 63 Else w(4) = -1 End If sOutput = sOutput + MimeEncode(w(1)) + MimeEncode(w(2)) + MimeEncode(w(3)) + MimeEncode(w(4)) Next Base64_Encode = sOutput End Function Function Base64_Decode( ByVal sInput ) 'Code to perform a base 64 decode Dim w(4) Dim iPos Dim sOutput sInput = CStr( sInput ) For iPos = 1 To Len(sInput) Step 4 w(1) = MimeDecode(Mid(sInput, iPos, 1)) w(2) = MimeDecode(Mid(sInput, iPos + 1, 1)) w(3) = MimeDecode(Mid(sInput, iPos + 2, 1)) w(4) = MimeDecode(Mid(sInput, iPos + 3, 1)) If w(2) >= 0 Then sOutput = sOutput + Chr(((w(1) * 4 + Int(w(2) / 16)) And 255)) End If If w(3) >= 0 Then sOutput = sOutput + Chr(((w(2) * 16 + Int(w(3) / 4)) And 255)) End If If w(4) >= 0 Then sOutput = sOutput + Chr(((w(3) * 64 + w(4)) And 255)) End If Next Base64_Decode = sOutput End Function Function MimeEncode( ByVal iInput ) 'Code to perform a MIME encode iInput = CInt( iInput ) If iInput >= 0 Then MimeEncode = Mid( csBase64, iInput + 1, 1 ) Else MimeEncode = "" End If End Function Function MimeDecode( ByVal sInput ) 'Code to perform a MIME decode sInput = CStr( sInput ) If Len(sInput) = 0 Then MimeDecode = -1 Else MimeDecode = InStr( csBase64, sInput ) - 1 End If End Function Function SelfTest() 'Code to execute a self test on the encode / decode function, ' simply we encode some data, then we decode it and check if ' the output matched the input. If it does then that passes. SelfTest = ( StrComp( Base64_Decode( Base64_Encode( csBase64 ) ), csBase64 ) = 0 ) End Function Sub SecurePage( ByVal iUserType ) 'Code which is called from another page when you wish to include authentication ' within that page. As close to the start of the page as possible, it must be used ' before any data has been issued to the client. Dim bAccepted Dim sRawAuthData 'Create the header which forces the browser to show the popup ' for username and password authentication. The text following ' "Basic realm=" is the text which will appear on the pop-up. Response.AddHeader "WWW-Authenticate", "Basic realm=""User Login""" 'Default the pass state to fail closed bAccepted = False 'Prepare the usertype variable (this holds the minimum ' type of user which can access this page) iUserType = CByte( iUserType ) 'Perform a self test If SelfTest() Then 'Self-test passed 'Get the encoded password from the correct server variable sRawAuthData = Request.ServerVariables("HTTP_AUTHORIZATION") 'Check the raw authentication data conforms to our rules If Len( sRawAuthData ) = 0 Or Len( sRawAuthData ) > 1024 Then 'Length is outside the allowed range sRawAuthData = vbNullString ElseIf StrComp( Left( sRawAuthData, 6 ), "Basic ", vbTextCompare ) <> 0 Then 'Does not starts with "basic " sRawAuthData = vbNullString End If 'If we have not rejected the raw authentication data so far ' test if it will actually authenticate the user If sRawAuthData <> vbNullString Then 'Separate the authentication details from the surrounding data, ' then check if the authentication details are valid by passing ' them through the CheckAuth function sRawAuthData = Right( sRawAuthData, Len( sRawAuthData ) - 6 ) If CheckAuth( sRawAuthData, iUserType, False ) Then 'Since the routine fails closed we only ' need to set the result if it all works bAccepted = True End If End If 'Check if we were able to correctly authenticate ' with the details supplied to us If Not bAccepted Then 'Unable to authenticate with these details, since we ' have not committed data at this point execute the ' IIS5 server.transfer method so that what follows for ' the user appears to come from the address of this page, ' but is infact my custom unauthorised page which will ' then set the http status code to the correct value for ' an unauthenticate request. Server.Transfer "custom401.asp" End If Else 'Self-test failed - unable to continue execution since ' we cannot confirm that the endcode/decode process is working ' correctly Response.Write "Diagnostic failure - security module failing closed..." Response.End End If End Sub Function CheckAuth( ByVal sAuthEncoded, ByVal iType, ByVal bCheckOnly ) 'Code to confirm that authentication is actually valid Dim sAuthDecoded, sFileSpec, sData, sTmp Dim objFSO, objData 'Fail closed CheckAuth = False 'Prepare the variables bCheckOnly = CBool( bCheckOnly ) sAuthEncoded = CStr( sAuthEncoded ) 'Decode the user's authentication sAuthDecoded = Base64_Decode( sAuthEncoded ) 'Convert the location of the user data file from ' relative web-path into absolute file-path ' this file should located outside the webroot if ' possible. ' 'The file itself contains entries like these: ' 0:User1:Password ' 2:User2:Password ' 1:User3:Password ' 'Field 1 is the access level which will be used to limit page access, and will be stored in a ' session variable for later re-use. 0 is the lowest practical level as -1 is used for not ' authenticated 'Field 2 is the case-sensitive username 'Field 3 is the case-sensitive password sFileSpec = Server.MapPath("users.txt") 'Create the File System Object Set objFSO = Server.CreateObject("Scripting.FileSystemObject") 'Check that the file we are trying to access realy ' does exist on the system If objFSO.FileExists( sFileSpec ) Then 'Cycle through each line in our file Set objData = objFSO.OpenTextFile( sFileSpec, 1, False ) Do Until objData.AtEndOfStream 'Get raw data from the file, remove any extra spaces ' and then check it is not blank sTmp = Trim( objData.ReadLine() ) If sTmp <> vbNullString Then 'Since it is not blank, split up the incoming data ' at the separation character sData = Split( sTmp, ":" ) 'Check the data has the right number of components once it ' has been split at its separating character If UBound( sData ) + (1-LBound( sData )) = 3 Then 'Compare the stored authentication data to data supplied to ' us by the current user, as well as the access level of that user If StrComp( sAuthDecoded, sData(1) & ":" & sData(2) ) = 0 _ And iType <= CByte( sData(0) ) Then 'Details match exactly, since we fail closed we ' need to set the return value to true as well as ' check if this was a real login or simply a test CheckAuth = True If Not bCheckOnly Then 'Store the encoded authentication given to us, ' as well as the access level of this user into ' the session object Session("EncodeAuth") = sAuthEncoded Session("UserType") = CByte( sData(0) ) Exit Do End If End If End If End If Loop 'Tidy up the text stream object objData.Close Set objData = Nothing Else 'File we use to authenticate against was not found, ' alert the user then stop the process. Response.Write "Diagnostic failure - security module failing closed..." Response.End End If 'Tidy up the file system object Set objFSO = Nothing 'Clean up the results if we could not authenticate ' and this was not a test If ( Not CheckAuth ) And bCheckOnly Then Session("EncodeAuth") = vbNullString Session("UserType") = -1 End If End Function %>