自从很早以前出了个DPO的接口,感觉好像是把动网、网易、OBlog三个程序融合到了一起,但是刀刀他们所有的程序其实有严重的问题,根本就不能支持多个域名下面访问,花了两天的时间终于明白了程序运行的所以然,呵呵,下面是研究的过程,代码很粗糙先放出来先,至于多个域名下面的Cookies的问题还在解决中。
文件目录:
/API/Response.xml,Request.xml,API_Config.asp,API_Function.asp,API_Response.asp
Response.Xml,Reequest.Xml:跟原先的一样,不用做大的修改,只要把AppID改成你目前的程序就可以了;
API_Config.asp:主要就是路径改下,其他不变
API_Function.asp:模仿了感觉写的OBlog的程序代码
<%
Class DPO_API_SHOP
Private ObjHttp,XmlDoc,AppID,API_Key,StrXmlPath,ReType,APO_AppID
Private Sub Class_Initialize()
AppID = " shop "
' On Error Resume Next
Set objHttp = Server.CreateObject( " MSXML2.ServerXMLHTTP.3.0 " )
Set XmlDoc = Server.CreateObject( " MSXML2.FreeThreadedDOMDocument.3.0 " )
End Sub
' 读取XML模板文件,当值为True时是请求信息模板,反之是返回信息模板
Public Sub LoadXmlFile(IsRequest)
If IsRequest Then
StrXmlPath = Server.MapPath( " /API/Request.xml " )
Else
StrXmlPath = Server.Mappath( " /Api/Response.xml " )
End If
XmlDoc.Load(StrXmlPath)
End Sub
' 返回信息到请求端
Public Function SendResult(status,strMsg)
SetNodeValue " appid " , AppID
SetNodeValue " status " , status
SetNodeValue " message " ,strMsg
Response.ContentType = " text/xml "
Response.Charset = " gb2312 "
Response.Clear
Response.Write " <?xml version= "" 1.0 "" encoding= "" gb2312 "" ?> "
Response.Write XmlDoc.documentElement.xml
End Function
' 将读取到XML模板中的各个元素赋值
Private Function SetNodeValue(StrNodeName,StrNodeValue)
If IsNull(StrNodeValue) or StrNodeValue = "" Then Exit Function
' On Error Resume Next
XmlDoc.SelectSingleNode( " // " & StrNodeName).text = StrNodeValue
If Err Then
ErrMsg = ErrMsg & " 写入信息发生错误。 "
FoundErr = True
Exit Function
End If
End Function
End Class
%>
Class DPO_API_SHOP
Private ObjHttp,XmlDoc,AppID,API_Key,StrXmlPath,ReType,APO_AppID
Private Sub Class_Initialize()
AppID = " shop "
' On Error Resume Next
Set objHttp = Server.CreateObject( " MSXML2.ServerXMLHTTP.3.0 " )
Set XmlDoc = Server.CreateObject( " MSXML2.FreeThreadedDOMDocument.3.0 " )
End Sub
' 读取XML模板文件,当值为True时是请求信息模板,反之是返回信息模板
Public Sub LoadXmlFile(IsRequest)
If IsRequest Then
StrXmlPath = Server.MapPath( " /API/Request.xml " )
Else
StrXmlPath = Server.Mappath( " /Api/Response.xml " )
End If
XmlDoc.Load(StrXmlPath)
End Sub
' 返回信息到请求端
Public Function SendResult(status,strMsg)
SetNodeValue " appid " , AppID
SetNodeValue " status " , status
SetNodeValue " message " ,strMsg
Response.ContentType = " text/xml "
Response.Charset = " gb2312 "
Response.Clear
Response.Write " <?xml version= "" 1.0 "" encoding= "" gb2312 "" ?> "
Response.Write XmlDoc.documentElement.xml
End Function
' 将读取到XML模板中的各个元素赋值
Private Function SetNodeValue(StrNodeName,StrNodeValue)
If IsNull(StrNodeValue) or StrNodeValue = "" Then Exit Function
' On Error Resume Next
XmlDoc.SelectSingleNode( " // " & StrNodeName).text = StrNodeValue
If Err Then
ErrMsg = ErrMsg & " 写入信息发生错误。 "
FoundErr = True
Exit Function
End If
End Function
End Class
%>
API_Response.asp:做了很大的改动,目前还不知道这样的改动是不是会造成程序不稳定,先发布出来先
<%
@ LANGUAGE
=
VBScript CodePage
=
936
%>
<!-- #include file = " ../Inc/Conn.asp " -->
<!-- #include file = " ../Inc/MD5.asp " -->
<!-- #Include File = " API_Config.asp " -->
<!-- #include file = " API_Function.asp " -->
<%
Dim FoundErr,ErrMsg
Dim Action,SysKey,UserNam,UserPass,AppID,UserMail,Question,Answer
Dim XMLDom,ShopAPI
Set ShopAPI = New DPO_API_SHOP
ShopAPI.LoadXmlFile False
Set XMLdom = Server.CreateObject( " Microsoft.XMLDOM " )
XMLdom.Async = False
XMLdom.Load(Request)
If API_Enable = False Then
ErrMsg = ErrMsg & " 系统并未开启整合接口! "
FoundErr = True
ShopAPI.SendResult 1 , ErrMsg
Set ShopAPI = Nothing
Response.End
End If
If XMLdom.parseError.errorCode <> 0 Then
ErrMsg = ErrMsg & " 接收数据出错,请重试! "
FoundErr = True
ShopAPI.SendResult 1 , ErrMsg
Set ShopAPI = 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 = True Then
Select Case Action
Case " checkname "
Call CheckName()
Case " reguser "
Call RegUser()
Case " login "
Call Login()
End Select
If FoundErr Then
ShopAPI.SendResult 1 , ErrMsg
Else
ShopAPI.SendResult 0 , ""
End If
Else
ShopAPI.SendResult 1 , " 安全验证码不正确。 "
End If
Set XMLDom = Nothing
Set ShopAPI = Nothing
' **************************************************
' 函数名:CheckName
' 作 用:判断用户名称是否可以注册
' **************************************************
Function CheckName()
Set Rs = Conn.Execute( " Select UserName From [User] Where UserName=' " & UserName & " ' " )
If Not (Rs.Eof Or Rs.Bof) Then
ErrMsg = ErrMsg & " 用户名已经存在,请更换。 "
FoundErr = True
CheckName = True
Else
CheckName = False
End If
Rs.Close
Set Rs = Nothing
End Function
' **************************************************
' 函数名:CheckEMail
' 作 用:判断用户邮件是否可以注册
' **************************************************
Function CheckEMail()
UserMail = XMLdom.documentElement.selectSingleNode( " //email " ).text
Set Rs = Conn.Execute( " Select UserMail From [User] Where UserMail=' " & UserMail & " ' " )
If Not (Rs.Eof Or Rs.Bof) Then
ErrMsg = ErrMsg & " 邮件地址已经存在,请更换。 "
FoundErr = True
CheckEMail = True
Else
CheckEMail = False
End If
Rs.Close
Set Rs = Nothing
End Function
' **************************************************
' 函数名:RegUser
' 作 用:注册新的登录帐号
' **************************************************
Function RegUser()
If CheckName = True Or CheckEMail = True Then
FoundErr = True
Exit Function
End If
Call GetXML()
Set Rs = Server.CreateObject( " Adodb.RecordSet " )
Sql = " Select * From [User] "
Rs.Open Sql,Conn, 1 , 3
Rs.AddNew
Rs( " UserName " ) = UserName
Rs( " UserPass " ) = MD5(UserPass, 32 )
Rs( " UserMail " ) = UserMail
Rs( " Question " ) = Question
Rs( " Answer " ) = MD5(Answer, 32 )
Rs.UpDate
Rs.Close
Set Rs = Nothing
FoundErr = False
End Function
' **************************************************
' 函数名:Login
' 作 用:用户登录系统
' **************************************************
Function Login()
PassWord = XMLdom.documentElement.selectSingleNode( " //password " ).text
If UserName = "" Then
ErrMsg = ErrMsg & ( " 登录名称不能为空。 " )
FoundErr = True
Exit Function
End If
If PassWord = "" Then
ErrMsg = ErrMsg & ( " 登录密码不能为空。 " )
FoundErr = True
Exit Function
End If
PassWord = Md5(PassWord, 32 )
Set Rs = Server.CreateObject( " Adodb.RecordSet " )
Sql = " Select UserName,UserPass From [User] Where UserName=' " & UserName & " ' "
Rs.Open Sql,Conn, 1 , 3
If Not (Rs.Eof Or Rs.Bof) Then
If Rs( " UserPass " ) = PassWord Then
Response.Cookies( " SunLeaf_User " ).Domain = " .sunleaf.net "
Response.Cookies( " SunLeaf_User " ).Expires = DateAdd( " d " , 1 , Now)
Response.Cookies( " SunLeaf_User " ) = UserName
Else
ErrMsg = ErrMsg & " 登录密码错误。 "
FoundErr = True
End If
Else
ErrMsg = ErrMsg & " 登录帐号不存在。 "
FoundErr = True
End If
Rs.Close
Set Rs = Nothing
End Function
' **************************************************
' 函数名:GetXML
' 作 用:接收提交过来的XML数据
' **************************************************
Function GetXML()
On Error Resume Next
UserPass = XMLdom.documentElement.selectSingleNode( " //password " ).text
UserMail = XMLdom.documentElement.selectSingleNode( " //email " ).text
Question = XMLdom.documentElement.selectSingleNode( " //question " ).text
Answer = XMLdom.documentElement.selectSingleNode( " //answer " ).text
End Function
' **************************************************
' 函数名:ChkSyskey
' 作 用:判断API_KEY是否一致
' **************************************************
Function ChkSyskey()
If IsNull(UserName) or UserName = "" or IsNull(SysKey) or SysKey = "" Then
ChkSyskey = False
Exit Function
End If
SysKey = LCase(SysKey)
If Len(SysKey) = 32 Then SysKey = Mid(SysKey, 9 , 16 )
Dim StrEnKey
StrEnKey = Md5(UserName & API_Key, 16 )
If LCase(SysKey) = LCase(StrEnKey) Then
ChkSyskey = True
Else
ChkSyskey = False
End If
End Function
%>
<!-- #include file = " ../Inc/Conn.asp " -->
<!-- #include file = " ../Inc/MD5.asp " -->
<!-- #Include File = " API_Config.asp " -->
<!-- #include file = " API_Function.asp " -->
<%
Dim FoundErr,ErrMsg
Dim Action,SysKey,UserNam,UserPass,AppID,UserMail,Question,Answer
Dim XMLDom,ShopAPI
Set ShopAPI = New DPO_API_SHOP
ShopAPI.LoadXmlFile False
Set XMLdom = Server.CreateObject( " Microsoft.XMLDOM " )
XMLdom.Async = False
XMLdom.Load(Request)
If API_Enable = False Then
ErrMsg = ErrMsg & " 系统并未开启整合接口! "
FoundErr = True
ShopAPI.SendResult 1 , ErrMsg
Set ShopAPI = Nothing
Response.End
End If
If XMLdom.parseError.errorCode <> 0 Then
ErrMsg = ErrMsg & " 接收数据出错,请重试! "
FoundErr = True
ShopAPI.SendResult 1 , ErrMsg
Set ShopAPI = 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 = True Then
Select Case Action
Case " checkname "
Call CheckName()
Case " reguser "
Call RegUser()
Case " login "
Call Login()
End Select
If FoundErr Then
ShopAPI.SendResult 1 , ErrMsg
Else
ShopAPI.SendResult 0 , ""
End If
Else
ShopAPI.SendResult 1 , " 安全验证码不正确。 "
End If
Set XMLDom = Nothing
Set ShopAPI = Nothing
' **************************************************
' 函数名:CheckName
' 作 用:判断用户名称是否可以注册
' **************************************************
Function CheckName()
Set Rs = Conn.Execute( " Select UserName From [User] Where UserName=' " & UserName & " ' " )
If Not (Rs.Eof Or Rs.Bof) Then
ErrMsg = ErrMsg & " 用户名已经存在,请更换。 "
FoundErr = True
CheckName = True
Else
CheckName = False
End If
Rs.Close
Set Rs = Nothing
End Function
' **************************************************
' 函数名:CheckEMail
' 作 用:判断用户邮件是否可以注册
' **************************************************
Function CheckEMail()
UserMail = XMLdom.documentElement.selectSingleNode( " //email " ).text
Set Rs = Conn.Execute( " Select UserMail From [User] Where UserMail=' " & UserMail & " ' " )
If Not (Rs.Eof Or Rs.Bof) Then
ErrMsg = ErrMsg & " 邮件地址已经存在,请更换。 "
FoundErr = True
CheckEMail = True
Else
CheckEMail = False
End If
Rs.Close
Set Rs = Nothing
End Function
' **************************************************
' 函数名:RegUser
' 作 用:注册新的登录帐号
' **************************************************
Function RegUser()
If CheckName = True Or CheckEMail = True Then
FoundErr = True
Exit Function
End If
Call GetXML()
Set Rs = Server.CreateObject( " Adodb.RecordSet " )
Sql = " Select * From [User] "
Rs.Open Sql,Conn, 1 , 3
Rs.AddNew
Rs( " UserName " ) = UserName
Rs( " UserPass " ) = MD5(UserPass, 32 )
Rs( " UserMail " ) = UserMail
Rs( " Question " ) = Question
Rs( " Answer " ) = MD5(Answer, 32 )
Rs.UpDate
Rs.Close
Set Rs = Nothing
FoundErr = False
End Function
' **************************************************
' 函数名:Login
' 作 用:用户登录系统
' **************************************************
Function Login()
PassWord = XMLdom.documentElement.selectSingleNode( " //password " ).text
If UserName = "" Then
ErrMsg = ErrMsg & ( " 登录名称不能为空。 " )
FoundErr = True
Exit Function
End If
If PassWord = "" Then
ErrMsg = ErrMsg & ( " 登录密码不能为空。 " )
FoundErr = True
Exit Function
End If
PassWord = Md5(PassWord, 32 )
Set Rs = Server.CreateObject( " Adodb.RecordSet " )
Sql = " Select UserName,UserPass From [User] Where UserName=' " & UserName & " ' "
Rs.Open Sql,Conn, 1 , 3
If Not (Rs.Eof Or Rs.Bof) Then
If Rs( " UserPass " ) = PassWord Then
Response.Cookies( " SunLeaf_User " ).Domain = " .sunleaf.net "
Response.Cookies( " SunLeaf_User " ).Expires = DateAdd( " d " , 1 , Now)
Response.Cookies( " SunLeaf_User " ) = UserName
Else
ErrMsg = ErrMsg & " 登录密码错误。 "
FoundErr = True
End If
Else
ErrMsg = ErrMsg & " 登录帐号不存在。 "
FoundErr = True
End If
Rs.Close
Set Rs = Nothing
End Function
' **************************************************
' 函数名:GetXML
' 作 用:接收提交过来的XML数据
' **************************************************
Function GetXML()
On Error Resume Next
UserPass = XMLdom.documentElement.selectSingleNode( " //password " ).text
UserMail = XMLdom.documentElement.selectSingleNode( " //email " ).text
Question = XMLdom.documentElement.selectSingleNode( " //question " ).text
Answer = XMLdom.documentElement.selectSingleNode( " //answer " ).text
End Function
' **************************************************
' 函数名:ChkSyskey
' 作 用:判断API_KEY是否一致
' **************************************************
Function ChkSyskey()
If IsNull(UserName) or UserName = "" or IsNull(SysKey) or SysKey = "" Then
ChkSyskey = False
Exit Function
End If
SysKey = LCase(SysKey)
If Len(SysKey) = 32 Then SysKey = Mid(SysKey, 9 , 16 )
Dim StrEnKey
StrEnKey = Md5(UserName & API_Key, 16 )
If LCase(SysKey) = LCase(StrEnKey) Then
ChkSyskey = True
Else
ChkSyskey = False
End If
End Function
%>
目前存在问题:不能在多个域名下面同时登录,即使是二级域名好像也不可以,真是奇怪了不知道是什么地方的问题,还在解决中。去刀刀博客上面找了下面,好像只有数据同步的工具也没有说在多个域名下面运行这个程序的说,怪怪怪。