<%
Sub ssAdminMain()
On Error Resume Next
Response.Write ""
Application("LoginField") = "UserName"
Application("PassField") = "Password"
Application("MailField") = "Email"
Application("AdminField") = "AdminStatus"
Application("ValidField") = "ValidationFlag"
Application("PageSize") = "10"
Dim suiteTags
set suiteTags = Server.CreateObject("scripting.dictionary")
suiteTags.Add "dbpath", "dbPath"
suiteTags.Add "uploaddir", "dbFileUploadDir"
suiteTags.Add "sendemail", "sendEmail"
suiteTags.Add "smtpip", "emailServer"
suiteTags.Add "smtpport", "emailServerPort"
suiteTags.Add "emailto", "emailToAddress"
suiteTags.Add "emailfrom", "emailFromAddress"
suiteTags.Add "debug", "publishInDebugMode"
suiteTags.Add "dbcolumns", "dbColumns"
suiteTags.Add "language", "language"
Dim compGeneralTags
set compGeneralTags = Server.CreateObject("scripting.dictionary")
compGeneralTags.Add "currentpage", "currentPage"
compGeneralTags.Add "nextpage", "nextPage"
compGeneralTags.Add "errormark", "errorMark"
compGeneralTags.Add "accessdeniedpage", "accessDeniedPage"
Dim XMLDoc
Set XMLDoc = ssOpenXMLFile(nof_sitePath & nof_scriptDir & "\" & nof_scriptInterfaceFile) 'Returns only documented exceptions on failure
If Err.number <> 0 Then
Call ssRaiseFatalError(Err, "div", nof_debug)
exit sub
End If
Dim componentNode
Set componentNode = ssGetNode(XMLDoc,,"Component", Array("name","id"), Array(nof_componentName, nof_componentId), -1)
If componentNode Is Nothing Then
Err.Raise 400, "ss_admin.main.20", ssGetLocaleString("Error.400", Null)
Call ssRaiseFatalError(err, "div", nof_debug)
Exit Sub
End If
Dim dbPath
dbPath = ssGetProperty(componentNode, suiteTags.Item("dbpath"))
if dbPath = "" then
Err.Raise 526, "ss_admin.main.30", ssGetLocaleString("Error.526", Null)
Call ssRaiseFatalError(err, "div", nof_debug)
Exit Sub
end if
Dim signupNode
set signupNode = ssGetByDBpath(XMLDoc, "signup", suiteTags.Item("dbpath"), dbPath)
if signupNode is Nothing then
Err.Raise 670, "ss_admin.main.35", ssGetLocaleString("Error.670", Null)
Call ssRaiseFatalError(err, "div", nof_debug)
Exit Sub
end if
Dim dbFields
dbFields = ssGetDBFields(ComponentNode, suiteTags.Item("dbcolumns"))
If dbFields = "" Then
dbFields = ssGetDBFields(signupNode, suiteTags.Item("dbcolumns"))
End If
Dim absPath, relPath
If Not inStr(1, dbPath, "\", 1) > 0 then
set relPath = nothing
set relPath = ssReFind(dbPath, "\.\./")
absPath = nof_SitePath & nof_scriptDir
If Not relPath Is Nothing Then
If relPath.count > 0 Then
for i=1 to relPath.count
absPath = Left(absPath, inStrRev(absPath,"\") - 1)
dbPath = Replace(dbPath, "../", "", 1, 1)
next
Else
If inStr(1, dbPath, "./") > 0 Then
dbPath = Replace(dbPath, "./", "", 1, 1)
End If
End If
set relPath = Nothing
end if
dbPath = absPath & "\" & Replace(dbPath, "/", "\")
End If
if ssFileExists(dbPath) then
'check if the fields are the same
tableHead = ssGetLine(dbPath)
if LCase(dbFields) <> LCase(tableHead) then
'create the database
Call ssCreateDB (dbPath, dbFields)
if (Err.Number <> 0) Then
Err.Raise 500, "ss_admin.main.90", ssGetLocaleString("Error.500", Array(dbPath))
Call ssRaiseFatalError(err, "div", nof_debug)
Exit Sub
end if
tableHead = ssGetLine(dbPath)
end if
else
'create the database
Call ssCreateDB (dbPath, dbFields)
if (Err.Number <> 0) Then
Err.Raise 500, "ss_admin.main.100", ssGetLocaleString("Error.500", Array(dbPath))
Call ssRaiseFatalError(err, "div", nof_debug)
Exit Sub
end if
tableHead = ssGetLine(dbPath)
end if
errLocal = ""
msg = ""
if Len(Request.Form("page")) > 0 then
page = Request.Form("page")
else
page = 1
end if
Response.Write " " & vbCrLf
if Request.Form("act") = "add" OR Request.Form("act") = "viewadd" OR _
(Request.Form("act") = "edit" AND Len(Request.Form("SelectedItem")) > 0 ) OR _
(Request.Form("act") = "view" AND Len(Request.Form("SelectedItem")) > 0 ) OR _
Request.Form("act") = "viewedit" then
if Request.Form("act") = "viewadd" OR Request.Form("act") = "viewedit" then
userId = Request.Form("origId")
elseif Request.Form("act") = "view" OR Request.Form("act") = "edit" then
userId = Request.Form("SelectedItem")
end if
Response.Write " " & vbCrLf
if Request.Form("act") = "viewadd" OR Request.Form("act") = "viewedit" then
if Len(errLocal) > 0 then
Response.Write " " & vbCrLf
Response.Write "
" & errLocal & "
" & vbCrLf
else
errLocal = save(XMLDoc, dbPath)
if err.number then
Call ssRaiseFatalError(err, "div", nof_debug)
exit sub
end if
if LCase(errLocal) = "true" then
Response.Write "
"
If Request.Form("act") = "viewadd" Then
Response.Write ssGetLocaleString("SS.Admin.Text.AddSuccess", Null)
Else
Response.Write ssGetLocaleString("SS.Admin.Text.EditSuccess", Null)
End If
Response.Write "
" & vbCrLf
Response.Write " " & vbCrLf
end if
else
'show users list'
dim saveStatus
if ( Request.Form("act") = "edit" OR Request.Form("act") = "view" OR _
Request.Form("act") = "delete" ) AND Len(Request.Form("SelectedItem")) = 0 then
Response.Write "
" & vbCrLf
elseif Request.Form("act") = "showusers" then
Session("ShowUsers") = Request.Form("userType")
elseif Request.Form("act") = "delete" then
dim userExistence
userExistence = UserExist(XMLDoc, Trim(Request.Form("SelectedItem")), dbPath)
if ( err.number ) then
Call ssRaiseFatalError(err, "div", nof_debug)
exit sub
end if
if userExistence then
set rs = RSFileContent(dbPath, "all")
tableHead = ssgetLine(dbPath)
allTHeads = split(tableHead,",")
with rs
.MoveFirst
do while not .EOF
i = 0
if Trim(.Fields(Application("LoginField"))) = _
Trim(Request.Form("SelectedItem")) then
.Delete
.Update
exit do
end if
.MoveNext
loop
end with
saveStatus = Update(dbPath, rs)
If Err.number <> 0 Then
Call ssRaiseFatalError(Err, "div", nof_debug)
exit sub
End If
if saveStatus then
else
errLocal = ssGetLocaleString("DatabaseError", Null)
end if
rs.close
end if
elseif Request.Form("act") = "save" then
if Len(Request.Form("beginUsrList")) > 0 then
set rs = RSFileContent(dbPath, "all")
rs.PageSize = Application("PageSize")
with rs
.MoveFirst
i = 1
start = false
do while not .EOF
changed = false
if Trim(.Fields(Application("LoginField"))) = Trim(Request.Form("beginUsrList")) then
start = true
end if
if start AND i <= CLng(Application("PageSize")) then
if Session("ShowUsers") = "valid" then
if Trim(.Fields(Application("ValidField")).value) = "true" then
if Len(Request.Form("valid" & Trim(.Fields(Application("LoginField"))))) > 0 then
.Fields(Application("ValidField")).value = "true"
else
.Fields(Application("ValidField")).value = "false"
changed = true
end if
.Update
end if
elseif Session("ShowUsers") = "invalid" then
if Trim(.Fields(Application("ValidField")).value) = "false" then
if Len(Request.Form("valid" & Trim(.Fields(Application("LoginField"))))) > 0 then
.Fields(Application("ValidField")).value = "true"
changed = true
else
.Fields(Application("ValidField")).value = "false"
end if
.Update
end if
else
if Trim(.Fields(Application("ValidField")).value) = "false" AND _
Len(Request.Form("valid" & Trim(.Fields(Application("LoginField"))))) > 0 then
changed = true
elseif Trim(.Fields(Application("ValidField")).value) = "true" AND _
Len(Request.Form("valid" & Trim(.Fields(Application("LoginField"))))) = 0 then
changed = true
end if
if Len(Request.Form("valid" & Trim(.Fields(Application("LoginField"))))) > 0 then
.Fields(Application("ValidField")).value = "true"
else
.Fields(Application("ValidField")).value = "false"
end if
.Update
end if
'send the confirmation email'
dim emailTemplate, sendEmail
dim enabled, disabled
enabled = "enabled"
disabled = "disabled"
if ssGetProperty(componentNode, suiteTags.Item("language")) = "de" then
enabled = "aktiviert"
disabled = "deaktiviert"
end if
emailTemplate = nof_SitePath & "scripts\ss_AdminTemplate_" & ssGetProperty(componentNode, suiteTags.Item("language")) & ".properties"
if changed AND ssFileExists(emailTemplate) then
sendEmail = ssGetTemplateValue(emailTemplate, "sendEmail")
if err.number <> 0 then
Call ssRaiseFatalError(err, "div", nof_debug)
Exit Sub
end if
if sendEmail = "true" then
Dim emailFileContent, fromEmail, subject, body, objCfg
body = ssGetTemplateValue(emailTemplate, "Body")
if trim(.Fields(Application("ValidField"))) = "true" then
body = Replace(body, "{2}", enabled, 1, -1, 1)
else
body = Replace(body, "{2}", disabled, 1, -1, 1)
end if
body = Replace(body, "{0}", .Fields(Application("LoginField")), 1, -1, 1)
body = Replace(body, "{1}", .Fields(Application("PassField")), 1, -1, 1)
body = Replace(body, "\n", " ", 1, -1, 1)
Set objMail = Server.CreateObject("CDO.Message")
Set objCfg = Server.CreateObject("CDO.Configuration")
'Out going SMTP server
if ssGetProperty(ComponentNode, suiteTags.Item("smtpip")) <> "" then
objCfg.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = ssGetProperty(ComponentNode, suiteTags.Item("smtpip"))
end if
if ssGetProperty(ComponentNode, suiteTags.Item("smtpport")) <> "" then
objCfg.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = ssGetProperty(ComponentNode, suiteTags.Item("smtpport"))
end if
objCfg.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objCfg.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
objCfg.Fields.Update
'Update the CDOSYS configuration
Set objMail.configuration = objCfg
objMail.From = ssGetTemplateValue(emailTemplate, "From")
objMail.TO = Trim(.Fields(Application("MailField")).value)
objMail.Subject = ssGetTemplateValue(emailTemplate, "Subject")
objMail.HTMLBody = body
Err.Clear
objMail.Send
if err.number <> 0 then
Err.Raise 201, "ss_admin.main.430", ssGetLocaleString("Error.201", Array(objMail.To, objMail.From, objCfg.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver")))
Call ssRaiseFatalError(err, "div", nof_debug)
Exit Sub
end if
Set objMail = Nothing
Set objCfg = Nothing
end if
end if
i = i + 1
elseif i > CLng(Application("PageSize")) then
exit do
end if
.MoveNext
loop
end with
saveStatus = Update(dbPath, rs)
If Err.number <> 0 Then
Call ssRaiseFatalError(Err, "div", nof_debug)
exit sub
End If
if saveStatus then
else
errLocal = "An Error occured while attempting to write in database!!"
end if
rs.close
end if
end if
Response.Write " " & vbCrLf
Response.Write " " & vbCrLf
End If
End Sub
Function checkField(ByVal compNode, ByVal fieldName, ByVal errTagName, ByVal nof_rootDir)
dim errFlag, porpValue, errLocal
errFlag = false
errLocal = ""
fieldValue = EncodeValue(request.form(fieldName))
set errEvent = getErrorEvent(compNode, fieldName, "required")
propValue = ""
if not errEvent is nothing then
propValue = ssGetProperty(errEvent, "message")
end if
if not errFlag AND Len(propValue) > 0 then
if not Len(fieldValue) > 0 then
errFlag = true
errLocal = errLocal & propValue
end if
end if
if not errFlag AND inStr(1, fieldName, "retype" & _
Application("PassField"), 1) > 0 then
if fieldValue <> request.form(Application("PassField")) then
errFlag = true
set errEvent = getErrorEvent(compNode, fieldName, "passwordsnotmatch")
propValue = ""
if not errEvent is nothing then
propValue = ssGetProperty(errEvent, "message")
end if
errLocal = errLocal & propValue
end if
end if
if not errFlag AND inStr(1, fieldName, "email", 1) > 0 then
if not checkEmail(fieldValue) then
errFlag = true
set errEvent = getErrorEvent(compNode, fieldName, "invalidemail")
propValue = ""
if not errEvent is nothing then
propValue = ssGetProperty(errEvent, "message")
end if
errLocal = errLocal & propValue
end if
end if
if not errFlag then
set errEvent = getErrorEvent(compNode, fieldName, "short")
propValue = "0"
if not errEvent is nothing then
propValue = ssGetProperty(errEvent, "minimumlength")
end if
if CLng(propValue) > 0 then
if Len(fieldValue) < CLng(propValue) then
errFlag = true
errLocal = errLocal & ssGetProperty(errEvent, "message")
end if
end if
end if
if not errFlag then
set errEvent = getErrorEvent(compNode, fieldName, "long")
propValue = "0"
if not errEvent is nothing then
propValue = ssGetProperty(errEvent, "maximumlength")
end if
if CLng(propValue) > 0 then
if Len(fieldValue) > CLng(propValue) then
errFlag = true
errLocal = errLocal & ssGetProperty(errEvent, "message")
end if
end if
end if
if errFlag then
Dim reExp, imgSrc
imgSrc = ssGetProperty(compNode, errTagName)
if imgSrc <> "" then
set reExp = new RegExp
reExp.Pattern = "\.\./"
reExp.Global = true
reExp.IgnoreCase = true
imgSrc = reExp.Replace(imgSrc, "")
set reExp = nothing
response.write "
" & vbcrlf
end if
else
response.write "
" & vbcrlf
end if
checkField = errLocal
end function
Function save(ByVal XMLDoc, dbPath)
dim cond, css, userExistence
if Len(request.form("origId")) = 0 then
cond = true
else
if request.form("origId") <> request.form(Application("LoginField")) then
cond = true
else
cond = false
end if
end if
userExistence = UserExist(XMLDoc, request.form(Application("LoginField")), dbPath)
if err.number <> 0 then
exit function
end if
if CBool(cond) AND userExistence then
errLocal = ssGetLocaleString("SS.Admin.Text.AlreadyExists", Array(Application("LoginField")))
errLocal = "
" & errLocal & "
"
save = errLocal
else
dim rs, fld, i, rowRec
set rs = RSFileContent(dbPath, "all")
tableHead = ssGetLine(dbPath)
allTHeads = split(tableHead,",")
if Len(request.form("origId")) > 0 then
with rs
.MoveFirst
do while not .EOF
i = 0
if Trim(.Fields(Application("LoginField"))) = Trim(request.form("origId")) then
For Each fld In .Fields
fld.value = request.form(allTHeads(i))
i = i + 1
next
.Update
exit do
end if
.MoveNext
loop
end with
else
with rs
.AddNew
i = 0
For Each fld In .Fields
fld.value = request.form(allTHeads(i))
i = i + 1
next
.Update
end with
end if
save = Update(dbPath, rs)
If Err.number <> 0 Then
Call ssRaiseFatalError(Err, "div", nof_debug)
exit function
End If
rs.close
end if
end function
%>