<%
' SAPE.ru -- Интеллектуальная система купли-продажи ссылок
'
' ASP-клиент, версия 0.5 от 04.07.2007
'
' По всем вопросам обращайтесь на support@sape.ru
' Читайте: http://www.sape.ru/faq.php
dim sapeVersion
dim sapeUser
dim sapeHost
dim sapeUrl
dim rawFileName
dim incFileName
dim updateTimeout
dim linksClassName
dim linksPrefix
dim defaultDocument
dim defaultDocumentCount
%><%
sapeVersion = "0.5"
sapeUser = "16eba884dc64f82e38fb149a1039ffc0" ' user id
sapeHost = "internetmarketing.ru" ' host id
sapeUrl = "http://dispenser-01.sape.ru/" ' links engine url
rawFileName = "c:\inetpub_114\internetmarketing\16eba884dc64f82e38fb149a1039ffc0\sapeRaw.txt" ' raw file (from sape)
incFileName = "c:\inetpub_114\internetmarketing\16eba884dc64f82e38fb149a1039ffc0\sape.inc" ' include file with links
updateTimeout = 60 ' timeout for keywords update (min)
linksHeader = "
" ' links header
linksFooter = "
" ' links footer
defaultDocument = Array("default.asp", "default.stm", "default.html") ' default site document
defaultDocumentCount = 3
%><%
' getLinks()
getLinksUpdate()
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
sub getLinksUpdate()
dim lastUpdateTime
' init vars
if isEmpty(Application("lastUpdateTime")) then
Application("lastUpdateTime") = DateAdd("d", -1, Now)
Application("lastUpdateTimeLocked") = false
end if
' if lastUpdateTime is older than specified timeout and update process is not locked ----> update keywords cache
if ( DateDiff("n", Application("lastUpdateTime"), Now) > updateTimeout ) and ( Application("lastUpdateTimeLocked") = false ) then
Application("lastUpdateTimeLocked") = true
call getLinks()
Application("lastUpdateTime") = Now
Application("lastUpdateTimeLocked") = false
end if
end sub
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
sub getLinks()
dim responseBody
dim rawString
' get response body
responseBody = getResponseBody()
if Trim(responseBody)="" then
exit sub
end if
' save raw file
if not saveRawFile(responseBody) then
exit sub
end if
' get raw string
rawString = getRawFile()
if Trim(rawString)="" then
exit sub
end if
' save inc file
if not saveIncFile( parseRawString(rawString) ) then
exit sub
end if
end sub
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
' get raw file contents
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
function getRawFile()
on error resume next
set fso = Server.CreateObject("Scripting.FileSystemObject")
set f = fso.OpenTextFile(rawFileName,1)
getRawFile = f.ReadAll()
if err<>0 then
getRawFile = ""
response.write "Нет доступа на чтение файла: " & rawFileName & ". Выставите необходимые права на папку."
exit function
end if
set f = Nothing
set fso = Nothing
end function
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
' save raw file
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
function saveRawFile(responseBody)
on error resume next
dim stream
set stream = Server.CreateObject("ADODB.Stream")
stream.Open()
stream.Type = 1
stream.write( responseBody )
stream.SaveToFile rawFileName,2
if err<>0 then
saveRawFile = false
response.write "Нет доступа на запись файла: " & rawFileName & ". Выставите необходимые права на папку."
exit function
end if
stream.Close()
set stream = Nothing
saveRawFile = true
end function
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
' get links raw string
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
function getResponseBody()
on error resume next
dim xmlHttp, url
url = sapeUrl & "/code.php?" & "user=" & sapeUser & "&host=" & sapeHost
set xmlHttp = Server.CreateObject("MSXML2.ServerxmlHttp")
xmlHttp.open "GET", url, false
xmlHttp.setRequestHeader "Pragma", "no-cache"
xmlHttp.setRequestHeader "Cache-Control", "no-cache, must-revalidate"
xmlHttp.setRequestHeader "Expires", "Mon, 26 Jul 1997 05:00:00 GMT"
xmlHttp.setRequestHeader "User-Agent", "SAPE_Client ASP " & sapeVersion
xmlHttp.send
if xmlHttp.status<>200 then
'response.write "Не могу подключиться к серверу: " & url
getResponseBody = ""
exit function
end if
if err<>0 then
response.write "При подключении к серверу возникла ошибка: " & err.description
err.clear
getResponseBody = ""
exit function
end if
getResponseBody = xmlHttp.responseBody
set xmlHttp = nothing
end function
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
function saveIncFile(strg)
on error resume next
set fso = Server.CreateObject("Scripting.FileSystemObject")
set f = fso.OpenTextFile(incFileName,2,true)
f.Write strg
if err<>0 then
saveIncFile = false
response.write "Нет доступа на запись файла: " & incFileName & ". Выставите необходимые права на папку."
exit function
end if
f.Close
set f = Nothing
set fso = Nothing
saveIncFile = true
end function
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------
%>
<%
function CheckParam(param)
CheckParam = (InStr(LCase(Request.QueryString), param) > 0)
end function
dim linksCheckUrl
linksCheckUrl = Request.ServerVariables("URL")
select case LCase(linksCheckUrl)
case LCase("__for_user__")
%>
<%
case LCase("16eba884dc64f82e38fb149a1039ffc0")
%>
<%
case LCase("__for_host__")
%>
<%
case LCase("http://internetmarketing.ru")
%>
<%
case LCase("__sape_ips__")
%>
<%
case LCase("188.72.80.205")
%>
<%
case LCase("188.72.80.201")
%>
<%
case else
%><%
end select
%>
|
|
