api_response.asp

重庆宽频P2P电影小偷程序,可以做一个大型的电影站了

<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<%
'******************************************************
'文件名： API_Response.asp
'描　述： 动易系统PDO远程接口文件
'版　本： 动易2006正式版及更高版本适用
'Copyright 2006 PowerEasy Inc. All Rights Reserved.
'Code Writer: EricWu (小李刀刀)
'******************************************************
%>
<!-- #Include File = "../Conn.asp" -->
<!-- #Include File = "../Inc/Function.asp" -->
<!-- #Include File = "../Inc/Md5.asp" -->
<!-- #Include File = "API_Config.asp"-->
<!-- #Include File = "API_Function.asp"-->
<%
Dim recXml
sPE_Items(conSyskey,1) = Trim(Request.QueryString(sPE_Items(conSysKey,0)))
sPE_Items(conUsername,1) = Trim(Request.QueryString(sPE_Items(conUserName,0)))
sPE_Items(conPassword,1) = Trim(Request.QueryString(sPE_Items(conPassword,0)))
sPE_Items(conSavecookie,1) = Trim(Request.QueryString(sPE_Items(conSavecookie,0)))
If sPE_Items(conSyskey,1) <> "" Then
    If sPE_Items(conUsername,1) <> "" Then
        If sPE_Items(conPassword,1) <> "" Then
            WriteCookies
            Response.Write ""
        Else
            CleanCookies
            Response.Write ""
        End If
    End If
Else
    DealResponse
End If

Sub WriteCookies()
    Dim strRndPass
    If Not CheckSysKey(sPE_Items(conUsername,1),sPE_Items(conSyskey,1)) Then
        Exit Sub
    End If
    strRndPass = GetRndPassword(16)
    If sPE_Items(conSavecooke,1) <> "" Then
        sPE_Items(conSavecooke,1) = PE_CLng(sPE_Items(conSavecooke,1))
    End If
    Dim iSubDomainIndex,strSite_Sn
    If Enable_SubDomain Then
        For iSubDomainIndex = 0 To UBound(arrSubDomains)
            strSite_Sn = LCase(arrSubDomains(iSubDomainIndex) & Replace(Replace(DomainRoot & InstallDir, "/", ""), ".", ""))
            Response.Cookies(strSite_Sn).Domain = DomainRoot
            Select Case sPE_Items(conSavecooke,1)
            Case 0
                'not save
            Case 1
                Response.Cookies(strSite_Sn).Expires = Date + 1
            Case 2
                Response.Cookies(strSite_Sn).Expires = Date + 31
            Case 3
                Response.Cookies(strSite_Sn).Expires = Date + 365
            End Select
            Response.Cookies(strSite_Sn)("UserName") = sPE_Items(conUsername,1)
            Response.Cookies(strSite_Sn)("UserPassword") = sPE_Items(conPassword,1)
            Response.Cookies(strSite_Sn)("LastPassword") = strRndPass
            Response.Cookies(strSite_Sn)("CookieDate") = sPE_Items(conSavecooke,1)
        Next
    Else
        Select Case sPE_Items(conSavecooke,1)
            Case 0
                'not save
            Case 1
                Response.Cookies(Site_Sn).Expires = Date + 1
            Case 2
                Response.Cookies(Site_Sn).Expires = Date + 31
            Case 3
                Response.Cookies(Site_Sn).Expires = Date + 365
        End Select
        Response.Cookies(Site_Sn)("UserName") = sPE_Items(conUsername,1)
        Response.Cookies(Site_Sn)("UserPassword") = sPE_Items(conPassword,1)
        Response.Cookies(Site_Sn)("LastPassword") = strRndPass
        Response.Cookies(Site_Sn)("CookieDate") = sPE_Items(conSavecooke,1)
    End If
    sPE_Items(conUserName,1) = ReplaceBadChar(sPE_Items(conUserName,1))
    UserTrueIP = ReplaceBadChar(UserTrueIP)
    Conn.Execute("UPDATE PE_User Set LastPassword='" & strRndPass & "',LastLoginIP='" & UserTrueIP & "',LastLoginTime=" & PE_Now & ",LoginTimes=LoginTimes+1 WHERE UserName='" & sPE_Items(conUsername,1) & "'")
End Sub

Sub CleanCookies()
    If Not CheckSysKey(sPE_Items(conUsername,1),sPE_Items(conSyskey,1)) Then
        Exit Sub
    End If
    Dim iSubDomainIndex,strSite_Sn, iItem
    If Enable_SubDomain Then
        For iSubDomainIndex = 0 To UBound(arrSubDomains)
            strSite_Sn = LCase(arrSubDomains(iSubDomainIndex) & Replace(Replace(DomainRoot & InstallDir, "/", ""), ".", ""))
            Response.Cookies(strSite_Sn).Domain = DomainRoot
            For Each iItem In Request.Cookies(strSite_Sn)
                Response.Cookies(strSite_Sn)(iItem) = ""
            Next
        Next
    Else
        For Each iItem In Request.Cookies(Site_Sn)
            Response.Cookies(Site_Sn)(iItem) = ""
        Next
    End If

End Sub

Sub DealResponse()
    On Error Resume Next
    If createXmlDom Then
        sMyXmlDoc.Load Request
        If sMyXmlDoc.parseError.errorCode <> 0 Then
            FoundErr = True
            ErrMsg = sMyXmlDoc.parseError.reason & "001"
        Else
            sPE_Items(conSyskey,1) = getNodeText(sPE_Items(conSysKey,0))
            sPE_Items(conUsername,1) = getNodeText(sPE_Items(conUserName,0))
            sPE_Items(conAction,1) = getNodeText(sPE_Items(conAction,0))
            
            If sPE_Items(conSysKey,1) = "" Or sPE_Items(conUsername,1) = "" Or sPE_Items(conAction,1) = "" Then
                FoundErr = True
                ErrMsg = "未包含必须元素，数据同步被拒绝!"
            End If
            If Not CheckSysKey(sPE_Items(conUsername,1),sPE_Items(conSyskey,1)) Then
                FoundErr = True
                ErrMsg = "安全码不符，数据同步被拒绝!"
            End If
        End If
    Else
        FoundErr = True
        ErrMsg = "服务器不支持MSXML对象。"
    End If
    If Err Then
        FoundErr = True
        ErrMsg = Err.Description
        Err.Clear
        WriteErrXml
        Exit Sub
    End If
    If FoundErr Then
        sPE_Items(conStatus,1) = "1"
        sPE_Items(conMessage,1) = ErrMsg
        prepareXML False
        WriteXml
        Exit Sub
    End If
    '已处理的元素：syskey,username
    '错误检测完成，开始处理数据
    sPE_Items(conAction,1) = getNodeText(sPE_Items(conAction,0))
    '已处理的元素：syskey,username,action
    Select Case sPE_Items(conAction,1)
        Case "checkname"
            Call checkUser
        Case "reguser"
            Call createUser
        Case "login"
            Call loginUser
        Case "logout"
            Call CleanCookies
        Case "update"
            Call UpdateUser
        Case "delete"
            Call DeleteUser
        Case "getinfo"
            Call GetUserInfo
    End Select
    If FoundErr Then
        sPE_Items(conStatus,1) = "1"
        sPE_Items(conMessage,1) = ErrMsg
        prepareXML(False)
        WriteXml
        Exit Sub
    Else
        sPE_Items(conStatus,1) = "0"
        prepareXML(False)
        WriteXml
    End If        
End Sub

Sub checkUser
    sPE_Items(conEmail,1) = getNodeText(sPE_Items(conEmail,0))
    CheckUserName(sPE_Items(conUsername,1))
    CheckUserEmail(sPE_Items(conEmail,1))
End Sub

Sub createUser
    sPE_Items(conEmail,1) = getNodeText(sPE_Items(conEmail,0))
    If CheckUserName(sPE_Items(conUsername,1)) = False Or CheckUserEmail(sPE_Items(conEmail,1)) = False Then
        Exit Sub
    End If
    Dim rsConfig,PresentExp,PresentMoney,PresentPoint,PresentValidNum,PresentValidUnit
    Set rsConfig = Conn.Execute("select top 1 * from PE_Config")
    If rsConfig.BOF And rsConfig.EOF Then
        rsConfig.Close
        Set rsConfig = Nothing
        FoundErr = True
        ErrMsg = "网站配置数据丢失！系统无法正常运行！"
    Else
        PresentExp = rsConfig("PresentExp")
        PresentMoney = rsConfig("PresentMoney")
        PresentPoint = rsConfig("PresentPoint")
        PresentValidNum = rsConfig("PresentValidNum")
        PresentValidUnit = rsConfig("PresentValidUnit")
    End If
    rsConfig.Close
    Set rsConfig = Nothing
    
    prepareData True
    
    Dim sqlReg, rsReg, trs, RndPassword,CheckNum
    Set trs = Conn.Execute("select max(UserID) from PE_User")
    If IsNull(trs(0)) Then
        UserID = 1
    Else
        UserID = trs(0) + 1
    End If
    Set trs = Nothing

    RndPassword = GetRndPassword(16)
    Set rsReg = Server.CreateObject("adodb.recordset")
    rsReg.OPEN "SELECT * FROM PE_User WHERE UserID=0",Conn,1,3
    rsReg.addnew
    rsReg("UserID") = UserID
    rsReg("ClientID") = 0
    rsReg("ContacterID") = 0
    rsReg("UserType") = 0
    rsReg("UserName") = sPE_Items(conUsername,1)
    rsReg("UserPassword") = MD5(sPE_Items(conPassword,1), 16)
    rsReg("LastPassword") = RndPassword
    rsReg("Question") = sPE_Items(conQuestion,1)
    rsReg("Answer") = MD5(sPE_Items(conAnswer,1), 16)
    rsReg("Email") = sPE_Items(conEmail,1)
    rsReg("RegTime") = PE_CDate(sPE_Items(conJointime,1))
    rsReg("LoginTimes") = 0
    If sPE_Items(conUserstatus,1) = "1" Then
            rsReg("IsLocked") = True
    Else
        rsReg("IsLocked") = False
    End If
    rsReg("Balance") = PresentMoney
    rsReg("UserExp") = PresentExp
    rsReg("PostItems") = 0
    rsReg("PassedItems") = 0
    rsReg("DelItems") = 0
    rsReg("UnsignedItems") = ""
    rsReg("UnreadMsg") = 0
    rsReg("arrClass_Browse") = ""
    rsReg("arrClass_View") = ""
    rsReg("arrClass_Input") = ""
    rsReg("UserSetting") = ""
    rsReg("UserFriendGroup") = "黑名单$我的好友"
    rsReg("LoginTimes") = 1
    rsReg("LastLoginIP") = sPE_Items(conUserip,1)
    rsReg("LastLoginTime") = Now()
    rsReg("LastPresentTime") = Now()
    If sPE_Items(conUserstatus,1) = "4" Then
        Set trs = Conn.Execute("select GroupID,GroupSetting from PE_UserGroup where GroupType=1")
    Else
        Set trs = Conn.Execute("select GroupID,GroupSetting from PE_UserGroup where GroupType=2")
    End If
    Dim GroupID, GroupSetting
    GroupID = trs(0)
    GroupSetting = Split(trs(1), ",")
    Set trs = Nothing
    rsReg("GroupID") = GroupID
    rsReg("UserPoint") = PresentPoint
    rsReg("BeginTime") = FormatDateTime(Now(), 2)
    rsReg("ValidNum") = PresentValidNum
    rsReg("ValidUnit") = PresentValidUnit
    Randomize
    CheckNum = CStr(Int(7999 * Rnd + 2000)) & CStr(Int(7999 * Rnd + 2000))
    rsReg("CheckNum") = CheckNum
    rsReg("SpecialPermission") = False
    rsReg.Update
    rsReg.Close
    Set rsReg = Nothing
    
    Dim intIndex,NeedContacter
    NeedContacter = False
    For intIndex = 11 to 20
        If sPE_Items(intIndex,1) <> "" Then
            NeedContacter = True
            Exit For
        End If
    Next
    
    If NeedContacter Then
        Dim ContacterID, sqlContacter, rsContacter
        Set trs = Conn.Execute("select max(ContacterID) from PE_Contacter")
        If IsNull(trs(0)) Then
            ContacterID = 1
        Else
            ContacterID = trs(0) + 1