modglobal.bas

来自「用VB写的一个代理服务器程序.rar复件 用VB写的一个代理服务器程序.rar」· BAS 代码 · 共 239 行

Attribute VB_Name = "modGlobal"
Option Explicit

Public Sub Main()
    If (App.PrevInstance = False) Then
        frmMain.Show
    End If
End Sub

Public Function IsHTTPHeader(Data As String) As Boolean
'判断是否为HTTP请求头
    Const HEADER_HTTP = "HTTP"
    Const METHOD_GET = "GET"
    Const METHOD_POST = "POST"
    Const METHOD_HEAD = "HEAD"
    Const METHOD_PROPFIND = "PROPFIND"
    Const METHOD_OPTION = "OPTIONS"
    Const METHOD_CONNECT = "CONNECT"
    Dim lpos As Long, Method As String

    lpos = InStr(1, Data, " ", vbTextCompare)
    If lpos <> 0 Then
        Method = UCase(Left$(Data, lpos - 1))
        Select Case Method
            Case HEADER_HTTP, METHOD_GET, METHOD_POST, _
                 METHOD_HEAD, METHOD_PROPFIND, METHOD_OPTION, _
                 METHOD_CONNECT
                 IsHTTPHeader = True
        End Select
    End If
End Function
'生成包含验证信息的头(header)
Public Function GenerateAuthorizationHeader(Header As String, _
        ProxyAuthorizationString As String) As String
    
    Dim tmpString As String, AuthorizationString As String

    tmpString = Header
    
    If InStr(ProxyAuthorizationString, "Proxy-Authorization") <> 0 Then
        '找到"Proxy-Authorization"字样
        tmpString = DeleteHttpHeader(tmpString, "Proxy-Connection")
        tmpString = DeleteHttpHeader(tmpString, "Proxy-Authorization")
        '添加"Proxy-Connection: Keep-Alive"
        AuthorizationString = "Proxy-Connection: Keep-Alive" & vbCrLf
    Else
        '未找到
        tmpString = DeleteHttpHeader(tmpString, "Connection")
        tmpString = DeleteHttpHeader(tmpString, "WWW-Authorization")
        '添加"Proxy-Connection: Keep-Alive"
        AuthorizationString = "Connection: Keep-Alive" & vbCrLf
    End If
    
    AuthorizationString = AuthorizationString & ProxyAuthorizationString
    tmpString = Replace(tmpString, vbCrLf, vbCrLf & AuthorizationString, 1, 1)
    GenerateAuthorizationHeader = tmpString
End Function

'删除头中的某段信息
Public Function DeleteHttpHeader(Header As String, HeaderCaption As String) As String
    Dim lpos As Long
    Dim endpos As Long
    Dim HeaderData As String
    '寻找信息
    lpos = InStr(1, Header, HeaderCaption & ":", vbTextCompare)
    If lpos <> 0 Then
        '信息结束处
        endpos = InStr(lpos + 1, Header, vbCrLf, vbTextCompare)
        HeaderData = Mid$(Header, lpos, endpos - lpos)
        DeleteHttpHeader = Replace(Header, HeaderData & vbCrLf, "", 1, 1, vbTextCompare)
    Else
        DeleteHttpHeader = Header
    End If
    
End Function

'向头中添加信息
Public Function AddHttpHeader(Header As String, HeaderCaption As String, HeaderValue As String) As String
    Dim lpos As Long
    Dim endpos As Long
    Dim HeaderData As String
    '寻找标识
    lpos = InStr(1, Header, HeaderCaption & ":", vbTextCompare)
    If lpos <> 0 Then
        endpos = InStr(lpos + 1, Header, vbCrLf, vbTextCompare)
        HeaderData = Mid$(Header, lpos, endpos - lpos)
        '添加信息
        AddHttpHeader = Replace(Header, HeaderData & vbCrLf, _
                        HeaderCaption & ": " & HeaderValue _
                        & vbCrLf, 1, 1, vbTextCompare)
    Else
        AddHttpHeader = Replace(Header, vbCrLf, vbCrLf & _
                        HeaderCaption & ": " & HeaderValue & _
                        vbCrLf, 1, 1, vbTextCompare)
    End If
    
End Function

'过滤请求头中的某些标识
Public Function FilterRequestHeader(Header As String) As String
    
    Dim tmpString As String

    tmpString = Header
    If Filter_Reload Then
        '添加/更改变量的值
        tmpString = AddHttpHeader(tmpString, "Pragma", "no-cache")
        tmpString = AddHttpHeader(tmpString, "Cache-Control", "no-cache")
    End If
    
    If Filter_Disable_Cookie Then
        '删除Cookie相关信息
        tmpString = DeleteHttpHeader(tmpString, "Cookie")
    End If
    
    If Filter_Hide_UserAgent Then
        '用户代理
        If UserAgent <> "" Then
            tmpString = AddHttpHeader(tmpString, "User-Agent", UserAgent)
        Else
            tmpString = AddHttpHeader(tmpString, "User-Agent", C_USER_AGENT_PPS)
        End If
    End If
    
    If Not UseProxy And Left(LCase(GetResource(Header)), Len("http://" & LCase(GetHttpHeader(Header, "Host")) & "/")) = "http://" & LCase(GetHttpHeader(Header, "Host")) & "/" Then
        '是否使用代理服务器
        tmpString = Replace(tmpString, "http://" & LCase(GetHttpHeader(Header, "Host")) & "/", "/")
    End If
    
    FilterRequestHeader = tmpString
End Function

Public Function GetResource(Header As String) As String
Dim lpos As Long, tmpString As String
Dim Methode As String, Resource As String, Version As String

    tmpString = Header
    tmpString = GetToken(tmpString, vbCrLf)
    tmpString = tmpString & " "
    Methode = GetToken(tmpString, " ")
    Resource = GetToken(tmpString, " ")
    Version = GetToken(tmpString, " ")
    
    GetResource = Resource
End Function

'过滤响应头中某些信息
Public Function FilterResponseHeader(Header As String) As String
Dim tmpString As String

    tmpString = Header
    If Filter_Hide_Server Then
        '隐藏服务器信息
        If PersonalProxyName <> "" Then
            tmpString = AddHttpHeader(tmpString, "Server", PersonalProxyName)
        Else
            tmpString = AddHttpHeader(tmpString, "Server", C_PERSONAL_PROXY)
        End If
    End If
    If Filter_Hide_Proxy Then
        '隐藏代理服务器信息
        If LocalComputerName <> "" Then
            tmpString = AddHttpHeader(tmpString, "Via", LocalComputerName)
        Else
            tmpString = DeleteHttpHeader(tmpString, "Via")
        End If
    End If
    If Filter_Disable_Cookie Then
        '禁止cookie
        tmpString = DeleteHttpHeader(tmpString, "Set-Cookie")
    End If
    
    FilterResponseHeader = tmpString
End Function

'获取HTTP头(header)
Public Function GetHttpHeader(Header As String, HeaderCaption As String) As String
    Dim lpos As Long
    Dim endpos As Long
    Dim HeaderData As String
    '寻找开始位置
    lpos = InStr(1, Header, HeaderCaption & ":", vbTextCompare)
    If lpos <> 0 Then
        '结束位置
        endpos = InStr(lpos + 1, Header, vbCrLf, vbTextCompare)
        HeaderData = Mid$(Header, lpos + Len(HeaderCaption) + 2, endpos - (lpos + Len(HeaderCaption) + 2))
    End If
    GetHttpHeader = HeaderData
    
End Function

Public Function IsInUserCollection(Col As Collection, Key As String) As Boolean
Dim i As Long
    
    For i = 1 To Col.Count
        If GetUser(Col(i).Key) = GetUser(Key) And GetPassword(Col(i).Key) = GetPassword(Key) Then
            IsInUserCollection = True
            Exit For
        End If
    Next i
End Function

Public Function IsInCollection(Col As Collection, Key As String) As Boolean
'*** Note : do not set the ide to break on all error but use break on unhandled error
'***        or the this checking won't work
Dim i As Long

    On Error GoTo errHandler
    
    If Col(Key).Key = Key Then
        IsInCollection = True
    End If
    Exit Function
    
errHandler:
End Function

'获取令牌
Public Function GetToken(sData As String, Delimiter As String) As String
    Dim tmpString As String, lpos As Long
    '寻找分隔符
    lpos = InStr(1, sData, Delimiter, vbTextCompare)
    If lpos <> 0 Then
        '有分隔符,则取分隔符后面部分
        tmpString = Left$(sData, lpos - 1)
        sData = Mid$(sData, lpos + Len(Delimiter))
    Else
        '无分隔符,则取全部
        tmpString = sData
        sData = ""
    End If
    GetToken = tmpString
End Function

Public Function FormatByte(Number As Double) As String
    FormatByte = Format(Number / 1024, "#,##0.00")
End Function