<%
'session("CodeAdmin") = 4
'session("accesslevel") = 5
''' initiate global vars and constants
dim action
dim b_error, a_errors, error_list, a_msg, msg_list
dim cmd, rs, rsselect, sql, do_search, a_records
''' instantiate error handling and messaging
set error_list = CreateObject("Scripting.Dictionary")
set msg_list = CreateObject("Scripting.Dictionary")
on error resume next
if err.number <> 0 then response.redirect "error.asp"
on error goto 0
''' command object
set cmd = Server.CreateObject("ADODB.Command")
cmd.ActiveConnection = cn
''' recordset object
set rs = Server.CreateObject("ADODB.Recordset")
''' set locale identifier - default is US English
''' (http://msdn.microsoft.com/library/default.asp?url=/library/en-us/script56/html/vsmsclcid.asp)
session.lcid = 1033
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'' ERROR AND MESSAGE DISPLAY SUBS
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
sub display_errs
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' display content of the error dictionary object
':::::::::::::::::::::::::::::::::::::::::::::::::::::
if error_list.count > 0 then
''' display errors
a_errors = error_list.items
for i = 0 to error_list.count - 1
response.write "" & a_errors(i) & "
"
next
end if
end sub
sub display_msg
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' displays msgs after successful database action
':::::::::::::::::::::::::::::::::::::::::::::::::::::
':: check if a msg was passed to the page
if request("msg") <> "" then
msg = replace(request("msg"),"://","")
msg = replace(msg,"script","")
msg = replace(msg,"%","")
msg = replace(msg,"form","")
msg_list.add "msg",msg
end if
':: display messages
a_msg = msg_list.items
for i = 0 to msg_list.count - 1
response.write "" & a_msg(i) & "
"
next
end sub
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'' USER MANAGMENT FUNCTIONS
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
function check_security(iLevel)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' authenticates user and verifies access level
':::::::::::::::::::::::::::::::::::::::::::::::::::::
if session("CodeAdmin") = "" OR isNull(session("accesslevel")) then
response.redirect("login.asp?ret_page=" & to_url(request.serverVariables("SCRIPT_NAME")&"?"&request.serverVariables("QUERY_STRING")))
elseif session("accesslevel") <> "" then
if cLng(session("accesslevel")) < cLng(iLevel) then response.redirect("login.asp?action=noaccess&ret_page=" & to_url(request.serverVariables("SCRIPT_NAME")&"?"&request.serverVariables("QUERY_STRING")))
else
CodeAdmin = session("CodeAdmin")
accesslevel = session("accesslevel")
end if
end function
sub do_login
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' autheticates user in db and creates session
':::::::::::::::::::::::::::::::::::::::::::::::::::::
sql = "SELECT NomU, password FROM Admin WHERE NomU = " & to_sql(NomU,"text") & " AND password = " & to_sql(password,"text") & ""
set rs = user_cn.Execute(sql)
if rs.EOF then
'login failed
error_list.add "login", "Login or password is incorrect."
b_error = true
else
'login and password passed
sql = "SELECT CodeAdmin, accesslevel FROM Admin WHERE NomU = " & to_sql(NomU,"text") & " AND password = " & to_sql(password,"text") & ""
set rs = user_cn.Execute(sql)
if rs.EOF then
'should never happen
error_list.add "login", "User does not exist."
b_error = true
else
'login user
session("CodeAdmin") = rs(0)
session("accesslevel") = rs(1)
'add Nom Utilisateur to app dict (global.asa)
if isObject(online_Admin) then online_Admin.item(session.sessionid) = session("CodeAdmin") & "," & NomU
'store last visit date in session, set current date in db
on error resume next
set rs = user_cn.Execute("SELECT dtlast FROM Admin WHERE CodeAdmin = " & to_sql(session("CodeAdmin"),"number"))
session("dtlast") = rs(0)
if err.number = 0 then user_cn.Execute = "UPDATE Admin SET last_ip='" & Request.ServerVariables("REMOTE_ADDR") & "', dtlast = " & to_sql(now,"date") & " WHERE CodeAdmin = " & to_sql(session("CodeAdmin"),"number")
on error goto 0
'where to next?
querystring = request("querystring")
ret_page = request("ret_page")
if (ret_page <> request.serverVariables("SCRIPT_NAME")) AND (ret_page <> "") then
'return to page that preceded login
response.redirect(ret_page)
else
'go home
response.redirect("default.asp")
end if
end if
end if
rs.Close
end sub
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'' FORMATTING FUNCTIONS
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
function to_url(strValue)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' make passed paramters url friendly
':::::::::::::::::::::::::::::::::::::::::::::::::::::
if IsNull(strValue) then strValue = ""
to_url = Server.URLEncode(strValue)
end function
function to_html(strValue)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' convert and clean string
':::::::::::::::::::::::::::::::::::::::::::::::::::::
if IsNull(strValue) then strValue = ""
strValue = Replace(strValue,"<%","<"&chr(37))
strValue = Replace(strValue,"%>",chr(37)&">")
strValue = Replace(strValue,"<script","",1)
to_html = Server.HTMLEncode(strValue)
end function
function to_sql(Value,DataType)
dim dteDateTime
dteDateTime = Value
if Value = "" or isNull(Value) then
to_sql = "NULL"
elseif (DataType = "date" OR DataType = "absdate") then
if IsDate(dteDateTime) = True then
if DataType="date" AND Hour(dteDateTime)>0 AND application("server_time_diff")<>0 AND not isNull(application("server_time_diff")) then dteDateTime = DateAdd("H",application("server_time_diff"),dteDateTime)
dim dteDay, dteMonth, dteYear, dteHour, dteMinute, dteSecond
dteDay = Day(dteDateTime)
dteMonth = Month(dteDateTime)
dteYear = Year(dteDateTime)
dteHour = Hour(dteDateTime)
dteMinute = Minute(dteDateTime)
dteSecond = Second(dteDateTime)
dteDateTime = dteYear & _
"-" & Right(Cstr(dteMonth + 100),2) & _
"-" & Right(Cstr(dteDay + 100),2) & _
" " & Right(Cstr(dteHour + 100),2) & _
":" & Right(Cstr(dteMinute + 100),2) & _
":" & Right(Cstr(dteSecond + 100),2)
if instr(lcase(cn.Provider),"jet")>0 then
':access
to_sql = "#" & Replace(dteDateTime, "'", "''") & "#"
else
':sql server
to_sql = "'" & Replace(dteDateTime, "'", "''") & "'"
end if
else
to_sql = "NULL"
end if
elseif DataType <> "number" then
Value = Replace(Value,"<"&chr(37),"<%")
Value = Replace(Value,chr(37)&">","%>")
Value = Replace(Value,"","</script>",1)
to_sql = "'" & Replace(Value, "'", "''") & "'"
elseif inStr(Value,".") then
to_sql = Value
else
to_sql = cLng(Value)
end if
end function
':::::::::::::::::::::::::::::::::::::::::::
function strip_html(str_html)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' removes html tags from str_html
':::::::::::::::::::::::::::::::::::::::::::::::::::::
dim objRegExp, str_output
set objRegExp = new Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<(.|\n)+?>"
str_output = objRegExp.Replace(str_html, "")
str_output = Replace(str_output, "<", "<")
str_output = Replace(str_output, ">", ">")
strip_html = str_output
set objRegExp = Nothing
end function
function get_options(sql,selected_value)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' displays option tags for a select list
':::::::::::::::::::::::::::::::::::::::::::::::::::::
'response.write sql
if isNull(selected_value) then selected_value = ""
set rsSelect = cn.Execute(sql)
do until rsSelect.EOF
if not isNull(rsSelect(0)) then
get_options = get_options + ""
if rsSelect.Fields.Count-1 = 0 then
get_options = get_options + "" & rsSelect(0) & " "
else
for i = 1 to rsSelect.Fields.Count-1
if rsSelect(i) <> "" then
get_options = get_options + "" & rsSelect(i)
if i < rsSelect.Fields.Count-1 then get_options = get_options + ": "
end if
next
end if
get_options = get_options + "" & vbCRLF & chr(9) & chr(9)
end if
rsSelect.MoveNext
loop
rsSelect.Close
end function
function is_reserved(strValue)
':::::::::::::::::::::::::::::::::::::::::::::::::::::
' compare a string with a list of vb and sql reserved words
':::::::::::::::::::::::::::::::::::::::::::::::::::::
reserved_words = "|and||as||boolean||byref||byte||byval||call||case||class||const||currency||date||desc||debug||dim||do||double||each||else||elseif||empty||end||endif||enum||eqv||event||exit||false||for||function||get||goto||if||imp||implements||in||integer||is||let||like||long||loop||lset||me||mod||new||next||not||nothing||null||on||option||optional||or||paramarray||preserve||private||public||raiseevent||redim||rem||resume||rows||rset||select||set||shared||single||size||static||stop||sub||then||to||true||type||typeof||until||variant||wend||while||with||xor|"
if inStr(reserved_words,"|" & lcase(strValue) & "|") > 0 then
is_reserved = true
else
is_reserved = false
end if
end function
':: correct secure urls :::::::::::::::::::::::::::::::::::::::
': this section assures that user does not persist in
': ssl (https://) mode. only pages in the application
': secure_pages variable (global.asa) will stay in https.
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
if request.servervariables("https") = "on" then
': list of pages where https is permitted
secure_list = application("secure_pages")
this_page = request.servervariables("script_name")
a_tmp = split(secure_list, ",")
for ctr = 0 to uBound(a_tmp)
if instr(this_page,trim(a_tmp(ctr))) > 0 then
'' this page should be secure
b_redirect = false
exit for
else
b_redirect = true
end if
next
if b_redirect then response.redirect "http://" & request.servervariables("server_name") & request.servervariables("script_name")
end if
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
%>