《单域名下整合动网、动易、OBlog程序》

        自从很早以前出了个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
%>

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
%>

目前存在问题：不能在多个域名下面同时登录，即使是二级域名好像也不可以，真是奇怪了不知道是什么地方的问题，还在解决中。去刀刀博客上面找了下面，好像只有数据同步的工具也没有说在多个域名下面运行这个程序的说，怪怪怪。