api_response.asp

网人分类信息5.0商业版。非常优秀的分类信息系统。比较少见。

<%@ LANGUAGE = VBScript CodePage = 936%>
<!--#include file="../../inc/Conn.asp"-->
<!--#include file="../../Inc/Cls.Common.asp"-->
<!--#include file="../../Inc/Cls.Templates.asp"-->
<!-- #include file="Class_API.asp" -->
<%
Dim FoundErr,ErrMsg
Dim Action,syskey,username,password,CookieDate,appid,LastConsumeTime
Dim Sex,QQ,MSN,UserStatus,TrueName,Birthday,TelePhone,HomePage,userip,Question,Answer,province,city,address,LastLoginTime,Flag,UStatus,NowLoginTime
Dim XMLdom,API
If Request.QueryString("syskey")<>"" Then
	syskey=LCase(Request.QueryString("syskey"))
	username=Trim(request("username"))
	If ChkSyskey Then
		If Request.QueryString("password")<>"" Then
			password=Trim(request("password"))
			CookieDate=Trim(request("savecookie"))
			Call LoginUser(username,password,CookieDate)
		Else
			Call LogoutUser()
		End If 
	End If 
Else 
	Set API = New API_WRMPS
	API.LoadXmlFile False
	Set XMLdom = Server.CreateObject("Microsoft.XMLDOM")
	XMLdom.Async = False
	XMLdom.Load(Request)
	If API_Enable=False Then 
		ErrMsg=("<li>系统并未开启整合接口")
		FoundErr=True
		API.SendResult 1, ErrMsg
		Set API=Nothing
		Response.End
	End If 
	If XMLdom.parseError.errorCode <> 0 Then
		ErrMsg=("<li>接收数据出错，请重试")
		FoundErr=True
		API.SendResult 1, ErrMsg
		Set API=Nothing
		Response.End
	Else 
		appid = XMLdom.documentElement.selectSingleNode("//appid").text
		syskey = XMLdom.documentElement.selectSingleNode("//syskey").text
		Action = XMLdom.documentElement.selectSingleNode("//action").text
		UserName=XMLdom.documentElement.selectSingleNode("//username").text
	End If 
	
	If ChkSyskey Then
		Select Case Action
			Case "reguser"
				Call reguser()
			Case "login"
				Call LoginUser(UserName,PassWord,CookieDate)
			Case "logout"
				Call LogoutUser()
			Case "update"
				Call ModifyUserInfo()
			Case "delete"
				Call DelUser()
			Case "getinfo"
				Call GetUserinfo()
			Case "checkname"
				Call Checkname()
		End Select
	End If 
	'将处理结果返回到类文件中处理以便提交方得到该信息
	If FoundErr Then
		API.SendResult 1, ErrMsg
	Else
		API.SendResult 0,""
	End If
	Set XMLdom=Nothing 
	Set API=Nothing
End If

Sub Checkname()
	EMail=XMLdom.documentElement.selectSingleNode("//email").text
    If Int(WR_User(0)) < 1 Then
		ErrMsg="<li>会员注册功能暂时关闭，请稍侯再试"
		FoundErr=True
		Exit Sub 
	End If
    If WRUser.RegUserName(UserName) Then
		ErrMsg="<li>用户名禁止注册"
		FoundErr=True
		Exit Sub 
	End If
	If EMail="" Then 
		ErrMsg="<li>Email不能为空"
		FoundErr=True
		Exit Sub 
	End If	 
    Dim Rs
	If Not IsObject(Conn) Then Call DBConnBegin()
	Set Rs = Conn.Execute("Select Top 1 WM_ID From WM_Member Where WM_UserName ='"&UserName&"'")
	If Not Rs.Eof Then
		ErrMsg="<li>用户名已被注册，请更换<br>"
		FoundErr=True
	End If
	Rs.CLose
	Set Rs = Conn.Execute("Select Top 1 WM_ID From WM_Member Where WM_Email ='"&Email&"'")
	If Not Rs.Eof Then
		ErrMsg=ErrMsg&"<li>邮箱已被注册，请更换"
		FoundErr=True
	End If
	Rs.CLose
    Set Rs = Nothing
	If FoundErr=True Then Exit Sub 
End Sub 
'用户整合的注册函数
Sub reguser()
	Call GetXML()
    If Int(WR_User(0)) < 1 Then
		ErrMsg="<li>会员注册功能暂时关闭，请稍侯再试"
		FoundErr=True
		Exit Sub 
	End If
    If WRUser.RegUserName(UserName) Then
		ErrMsg="<li>此用户名禁止注册"
		FoundErr=True
		Exit Sub 
	End If
	If Not IsObject(Conn) Then Call DBConnBegin()
    If WRUser.RegIPTime Then
		ErrMsg="<li>系统限制同一IP注册时间间隔为"&WR_User(5)&"分钟"
		FoundErr=True
		Exit Sub 
	End If
	If PassWord="" Then 
		ErrMsg=ErrMsg&("<li>密码不能为空")
		FoundErr=True
	End If
	If Question="" Then Question = NUll
	If Answer="" Then Answer = Null
	If EMail="" Then 
		ErrMsg=ErrMsg&("<li>EMail不能为空")
		FoundErr=True
	End If	 
	If FoundErr Then Exit Sub 
	If userstatus = "" Then userstatus = 0
	If IsNumeric(userstatus) = False Then userstatus = 0
    Select Case Int(userstatus)
	  Case 0
	    UStatus = 1
	  Case 1,2,3
	    UStatus = 2
	  Case 4
	    UStatus = 0
	End Select
	If truename = "" Then truename = Null
	If Sex = "" Then Sex = 2
	If IsNumeric(Sex) = False Then Sex = 2
	If Sex <> 0 Or Sex <> 1 Then Sex  = Null
	If QQ = "" Then QQ = Null
	If address = "" Then address = Null
	If homepage = "" Then homepage = Null
    '写入数据库
	Dim RegSaveType
	RegSaveType = WRUser.RegSave(UserName,PassWord,EMail,Question,Answer,UStatus,truename,Sex,QQ,address,homepage)
	If IsNUll(RegSaveType) = False and RegSaveType <> "" Then
        ErrMsg = RegSaveType
		FoundErr = True
		Exit Sub 
	End If
End Sub 
'用户整合的登录函数
Sub LoginUser(UserName, PassWord, CookieDate)
    Dim LogType
	LogType = 0
    If PassWord = "" Or IsNull(PassWord) Then 
	  PassWord=XMLdom.documentElement.selectSingleNode("//password").text
	  CookieDate=XMLdom.documentElement.selectSingleNode("//savecookie").text
	  If PassWord<>"" and IsNull(PassWord) = False Then
	    PassWord=MD5(1,PassWord)
	    LogType = 1
	  Else
	    LogoutUser()
	    Exit Sub
	  End If
	End If 
	If UserName="" Then 
		ErrMsg=ErrMsg&("<li>用户名不能为空")
		FoundErr=True
	End If
	If FoundErr=True Then Exit Sub
	'WRMPS密码处理
    PassWord=Left(LCase(PassWord),10)
	
	Dim Rs, Sql, userurl
	If Not IsObject(Conn) Then Call DBConnBegin()
	Set Rs = server.CreateObject("adodb.recordset")
	Rs.Open "Select WM_PassWord,WM_ID,WM_Key,WM_GroupID,WM_Flag,WM_LastConsumeTime,WM_NowLoginTime From WM_Member Where WM_UserName = '"&UserName&"'",Conn,1,1
	If Not Rs.Eof Then
      If Rs(0) <> PassWord Then
	    Rs.Close: Set Rs = Nothing
		ErrMsg= ("<li>用户密码输入不正确"): FoundErr=True:Exit Sub
	  Else
	    Select Case Rs(2)
		  Case 0
		    Rs.Close: Set Rs = Nothing
			ErrMsg= ("<li>此用户还没有通过管理员审核"): FoundErr=True:Exit Sub
		  Case 2
	        Rs.Close: Set Rs = Nothing
			ErrMsg= ("<li>此用户已被锁定"): FoundErr=True:Exit Sub
		End Select
		LastConsumeTime = Rs(5)
		NowLoginTime = Rs(6)
		Flag = Rs(4)
		If Now() > Cdate(LastConsumeTime) + Int(Split(Split(Flag,"§")(0),"|")(2)) Then
		   Dim CountOut,Integral
	       Integral = Int(Split(Split(Flag,"§")(0),"|")(3))
	       CountOut = Int(Split(Split(Flag,"§")(0),"|")(4))
		   Call WRDB.SaveConsume(1,UserName,0,CountOut,Integral,0,"会员登录")
           Conn.Execute("Update WM_Member Set WM_LastConsumeTime = "&ConnTime&" where WM_UserName='"&UserName&"'")
		End If
		Call WRUser.Login(CookieDate,UserName,Rs(1),Rs(3),Flag,WRMPS.GetCache("FlagTime"),PassWord)
		If LogType > 0 Then
		  Conn.Execute("Update WM_Member Set WM_LastLoginTime = WM_NowLoginTime,WM_NowLoginTime = "&ConnTime&",WM_LastIP=WM_NowIP,WM_NowIP='"&Request.ServerVariables("REMOTE_ADDR")&"',WM_LoginNum=WM_LoginNum+1 where WM_UserName='"&UserName&"'")
	    End If
	  End If
	Else
	  Rs.Close: Set Rs = Nothing
	  ErrMsg=("<li>用户名不存在"): FoundErr=True:Exit Sub
    End If
End Sub  
'用户整合的登出函数
Sub LogoutUser()
	If FoundErr=True Then Exit Sub
	Call WRUser.Logout()
End Sub 
'用户整合的更新用户资料函数
Sub ModifyUserInfo()
	Call GetXML()
	If UserName="" Then 
		ErrMsg=("<li>用户名不能为空")
		FoundErr=True
		Exit Sub 
	End If
	Dim rs,EditSql
	If PassWord <> "" Then EditSql = ",WM_PassWord='"&MD5(2,PassWord)&"'"
	If Question <> "" Then EditSql = EditSql & ",WM_Question='"&Question&"'"
	If Answer <> "" Then EditSql = EditSql & ",WM_Answer='"&MD5(2,Answer)&"'"
	If Sex <> "" And IsNumeric(Sex) Then
	  Select Case Int(Sex)
	    Case 0,1
		  EditSql = EditSql & ",WM_Sex="&Sex
	  End Select
	End If
	If QQ <> "" Then EditSql = EditSql & ",WM_QQ='"&QQ&"'"
	If address <> "" Then EditSql = EditSql & ",WM_AddRess='"&address&"'"
	If homepage <> "" Then EditSql = EditSql & ",WM_Web='"&homepage&"'"
	If userstatus <> "" And IsNumeric(userstatus) Then
	  Select Case Int(userstatus)
	    Case 0
		  EditSql = EditSql & ",WM_Key=1"
	    Case 1,2,3
		  EditSql = EditSql & ",WM_Key=2"
	    Case 4
		  EditSql = EditSql & ",WM_Key=0"
	  End Select
	End If
	If Not IsObject(Conn) Then Call DBConnBegin()
    If truename <> "" Then
	  If WRUser.ChkRZEdit(UserName,"TRUENAME") Then
	    ErrMsg=("<li>您已通过实名认证，真实性名不能修改")
		FoundErr=True
		Exit Sub
	  Else
	    EditSql = EditSql & ",WM_TrueName='"&truename&"'"
	  End If
	End If
    If EMail <> "" Then
	  If WRUser.ChkRZEdit(UserName,"EMAIL") Then
	    ErrMsg=("<li>您已通过邮箱认证，邮箱地址不能修改")
		FoundErr=True
		Exit Sub
	  Else
	    EditSql = EditSql & ",WM_Email='"&EMail&"'"
	  End If
	End If
	If Len(EditSql) > 0 Then 
	  If Left(EditSql,1) = "," Then EditSql = Right(EditSql,Len(EditSql)-1)
	  If Len(EditSql) > 0 Then 
	    Conn.Execute("Update WM_Member Set "&EditSql&" where WM_UserName='"&UserName&"'")
        Call WRMPS.SCache("FlagTime",Now())
	  End If
	End If
End Sub 
'用户整合的删除用户函数   
Sub DelUser()
	If UserName="" Then 
		ErrMsg=("<li>用户名不能为空")
		FoundErr=True
		Exit Sub 
	End If
	Dim a_i
	If Not IsObject(Conn) Then Call DBConnBegin()
	If InStr(UserName,",")>0 Then
		UserName=Split(UserName,",")
		For a_i=0 To UBound(UserName)
		  Conn.Execute("Delete From WM_Member where WM_UserName='"&UserName(a_i)&"'")
		Next
	Else
		Conn.Execute("Delete From WM_Member where WM_UserName='"&UserName&"'")
	End If
End Sub
'用户整合的获取用户信息函数
Sub GetUserinfo()
	If UserName="" Then 
		ErrMsg=("<li>用户名不能为空")
		FoundErr=True
		Exit Sub 
	End If
	Dim rs,sql
	If Not IsObject(Conn) Then Call DBConnBegin()
	Set Rs = server.CreateObject("adodb.recordset")
	Sql = "Select * From WM_Member where WM_UserName='" & UserName & "'"
	Rs.Open Sql, Conn, 1, 1
	If Not Rs.eof Then 
			API.UserName=UserName
			API.PassWord=Rs("WM_PassWord")  '网人系统密码为 16 位加密后取前 10 位
			API.EMail=Rs("WM_Email")
			API.Question=Rs("WM_Question")
			API.Answer=Rs("WM_Answer")  '网人系统密码为 16 位加密后取前 10 位
			API.TrueName=Rs("WM_TrueName")
			API.Sex=Rs("WM_Sex")
			API.QQ=Rs("WM_QQ")
			API.AddRess=Rs("WM_AddRess")
			API.Web=Rs("WM_Web")
			Select Case Rs("WM_Key")
			  Case 0
  			    API.UserStatus=4
			  Case 1
  			    API.UserStatus=0
			  Case 2
  			    API.UserStatus=1
			End Select
			API.GetUser
	Else 
			ErrMsg=("<li>用户名不存在")
			FoundErr=True
			Exit Sub
	End If 
	Rs.close
	Set Rs=Nothing
End Sub 
'接收提交过来的XML数据
Sub GetXML()
	On Error Resume Next
	PassWord=XMLdom.documentElement.selectSingleNode("//password").text
	EMail=XMLdom.documentElement.selectSingleNode("//email").text
	Question=XMLdom.documentElement.selectSingleNode("//question").text
	Answer=XMLdom.documentElement.selectSingleNode("//answer").text
	truename=XMLdom.documentElement.selectSingleNode("//truename").text
	Sex=XMLdom.documentElement.selectSingleNode("//gender").text
	QQ=XMLdom.documentElement.selectSingleNode("//qq").text
	address=XMLdom.documentElement.selectSingleNode("//address").text
	homepage=XMLdom.documentElement.selectSingleNode("//homepage").text
	userstatus=XMLdom.documentElement.selectSingleNode("//userstatus").text
	CookieDate=XMLdom.documentElement.selectSingleNode("//savecookie").text
End Sub 
'验证提交信息的合法性，目前MD5文件为16位，只能验证提交的位数再判定（考虑新版本增加参数）
Function ChkSyskey()
	ChkSyskey=True
	syskey=LCase(syskey)
	If Len(syskey)=32 Then 
		If Mid(syskey,9,16)<>MD5(1,UserName&API_Key) Then
			ErrMsg=("<li>安全码验证未通过")
			FoundErr=True
			ChkSyskey=False
		End If 
	ElseIf Len(syskey)=16 Then 
		If syskey<>MD5(1,UserName&API_Key) Then
			ErrMsg=("<li>安全码验证未通过")
			FoundErr=True
			ChkSyskey=False
		End If 
	ElseIf Len(syskey)=10 Then 
		If syskey<>MD5(2,UserName&API_Key) Then
			ErrMsg=("<li>安全码验证未通过")
			FoundErr=True
			ChkSyskey=False
		End If 
	Else 
		ErrMsg=("<li>安全码不合法")
		FoundErr=True
		ChkSyskey=False
	End If 	
End Function 
%>