@@ -1,9 +1,216 @@
Public Module ModNet
Imports System . Drawing
Imports System . Net . Http
Imports System . Net . Http . Headers
Imports System . Threading . Tasks
Imports Newtonsoft . Json
Public Module ModNet
Public Const NetDownloadEnd As String = " .PCLDownloading "
Public Const NetDownloadEnd As String = " .PCLDownloading "
Public ReadOnly HttpProxy As New HttpWebProxyFactory ( )
Private ClientFactory As New HttpClientFactory ( )
Private Request As New HttpRequest ( )
Public Class HttpRequest
Public Sub New ( )
End Sub
Public Function GetRequestMessage ( RequestUrl As String ,
Optional Method As String = " GET " ,
Optional Headers As Dictionary ( Of String , String ) = Nothing ,
Optional Data As Byte ( ) = Nothing ,
Optional UseBrowserUA As Boolean = False ,
Optional RequireHeaderSign As Boolean = False ,
Optional RequireCdnSign As Boolean = False ) As HttpRequestMessage
Dim RequestMethod As HttpMethod = GetHttpMethod ( Method )
If RequireCdnSign Then RequestUrl = SecretCdnSign ( RequestUrl )
Dim RequestMessage As New HttpRequestMessage ( RequestMethod , RequestUrl )
'基本参数验证
If Data IsNot Nothing AndAlso Not { HttpMethod . Get , HttpMethod . Head } . Contains ( RequestMethod ) Then
RequestMessage . Content = New ByteArrayContent ( Data )
RequestMessage . Content . Headers . ContentLength = Data . Length
End If
If Headers IsNot Nothing Then
For Each Header In Headers
If Header . Key . ContainsF ( " Content " ) AndAlso RequestMessage . Content IsNot Nothing Then
'FixContentHeader 往下挪一行就 NullReference 了
FixContentHeader :
If Data Is Nothing OrElse RequestMessage . Content Is Nothing Then Continue For
If RequestMessage . Content . Headers . Contains ( Header . Key ) Then Continue For
If Not RequestMessage . Content . Headers . Contains ( Header . Key ) Then
If Header . Key . ToLower ( ) = " Content-Type " Then RequestMessage . Content . Headers . ContentType = New MediaTypeHeaderValue ( Header . Value )
RequestMessage . Content . Headers . TryAddWithoutValidation ( Header . Key , Header . Value )
End If
Else
'不知道为什么 Content-Type 标头会通过字符串验证然后加入不应该被加入的 HttpRequestMessage Headers
'这会导致 HttpRequestMessage 内部的标头验证失败,并抛出一个 Exception 导致网络请求失败
If Header . Key . ContainsF ( " Content " ) Then GoTo FixContentHeader
If RequestMessage . Headers . Contains ( Header . Key ) Then Continue For
RequestMessage . Headers . Add ( Header . Key , Header . Value )
End If
Next
End If
If RequireHeaderSign Then
SecretHeadersSign ( RequestUrl , requestMessage , UseBrowserUA )
End If
Return RequestMessage
End Function
' 发送请求
Public Function SendRequest ( Req As HttpRequestMessage ,
Optional RequireDecode As Boolean = True ,
Optional Encode As Encoding = Nothing ,
Optional Timeout As Integer = 25000 ,
Optional RequireReturnRespObj As Boolean = False )
Using CTS As New CancellationTokenSource ( Timeout )
Dim Client = ClientFactory . GetHttpClient ( )
Dim Resp As HttpResponseMessage = Client . SendAsync ( Req , HttpCompletionOption . ResponseHeadersRead , CTS . Token ) . GetAwaiter ( ) . GetResult ( )
If RequireReturnRespObj Then Return Resp
Resp . EnsureSuccessStatusCode ( )
CTS . CancelAfter ( Timeout )
Dim ResultStream = Resp . Content . ReadAsStreamAsync ( ) . GetAwaiter ( ) . GetResult ( )
Using DataStream As New MemoryStream ( )
ResultStream . CopyTo ( DataStream )
Dim Bytes = DataStream . ToArray ( )
Resp . Dispose ( )
Req . Dispose ( )
If RequireDecode Then
If Encode Is Nothing Then Encode = Encoding . UTF8
Return Encode . GetString ( Bytes )
Else
Return Bytes
End If
End Using
End Using
End Function
' 获取HttpMethod
Private Function GetHttpMethod ( Method As String ) As HttpMethod
Select Case Method ? . Trim ( ) . ToUpperInvariant ( )
Case " HEAD "
Return HttpMethod . Head
Case " POST "
Return HttpMethod . Post
Case " PUT "
Return HttpMethod . Put
Case " DELETE "
Return HttpMethod . Delete
Case Else
Return HttpMethod . Get
End Select
End Function
End Class
Public Class HttpWebProxyFactory
Implements IWebProxy
Public DisableHttpProxy As Boolean = True
Public ProxyAddress As String
Private CurrentProxy As WebProxy
Public RequiredReloadProxy As Boolean
Public RefreshSyncLock As New Object
Public SystemProxy As New WebProxy ( )
Public Sub New ( )
End Sub
Public Property Credentials As ICredentials Implements IWebProxy . Credentials
Get
Return AuthCredentials
End Get
Set ( value As ICredentials )
AuthCredentials = value
End Set
End Property
Private AuthCredentials As ICredentials
Public Function GetProxy ( destination As Uri ) As Uri Implements IWebProxy . GetProxy
Return GetProxy ( destination . AbsoluteUri ) . Address
End Function
Public Function GetProxy ( destination As String ) As WebProxy
If CurrentProxy IsNot Nothing AndAlso Not RequiredReloadProxy Then Return CurrentProxy
If RequiredReloadProxy OrElse CurrentProxy Is Nothing Then
If ProxyAddress IsNot Nothing OrElse
Not String . IsNullOrWhiteSpace ( ProxyAddress ) Then
SyncLock RefreshSyncLock
CurrentProxy = New WebProxy ( ProxyAddress , True )
If AuthCredentials IsNot Nothing Then CurrentProxy . Credentials = AuthCredentials
Return CurrentProxy
End SyncLock
Else
SyncLock RefreshSyncLock
CurrentProxy = New WebProxy ( )
If AuthCredentials IsNot Nothing Then CurrentProxy . Credentials = AuthCredentials
Return CurrentProxy
End SyncLock
End If
End If
Return Nothing
End Function
Public Function IsBypassed ( host As Uri ) As Boolean Implements IWebProxy . IsBypassed
If DisableHttpProxy Then Return True
If CurrentProxy Is Nothing Then
SyncLock RefreshSyncLock
CurrentProxy = GetProxy ( host . AbsoluteUri )
End SyncLock
End If
If CurrentProxy . IsBypassed ( host ) Then Return True
Return False
End Function
End Class
Public Class HttpClientFactory
Private PreviousClient As HttpClient
Private CurrentClient As HttpClient
Private HttpClientLock As New Object
Public ClientHandler As New HttpClientHandler ( ) With {
. UseProxy = True ,
. Proxy = HttpProxy ,
. AutomaticDecompression = DecompressionMethods . Deflate Or DecompressionMethods . GZip Or DecompressionMethods . None
}
Public Sub New ( )
HttpClientReload ( )
End Sub
Public Function GetHttpClient ( Optional Handler As HttpClientHandler = Nothing ) As HttpClient
SyncLock HttpClientLock
If Handler IsNot Nothing Then
ClientHandler = Handler
CurrentClient . Dispose ( )
CurrentClient = New HttpClient ( Handler )
Return CurrentClient
End If
If CurrentClient IsNot Nothing Then Return CurrentClient
CurrentClient = New HttpClient ( ClientHandler ) With { . Timeout = Timeout . InfiniteTimeSpan }
Return CurrentClient
End SyncLock
End Function
Public Sub HttpClientReload ( )
RunInNewThread (
Sub ( )
While True
Thread . Sleep ( TimeSpan . FromHours ( 6 ) )
If PreviousClient IsNot Nothing Then PreviousClient . Dispose ( )
PreviousClient = CurrentClient
CurrentClient = GetHttpClient ( )
End While
End Sub
)
End Sub
End Class
''' <summary>
''' <summary>
''' 测试 Ping。失败则返回 -1。
''' 测试 Ping。失败则返回 -1。
''' </summary>
''' </summary>
'''
Public Function Ping ( Ip As String , Optional Timeout As Integer = 10000 , Optional MakeLog As Boolean = True ) As Integer
Public Function Ping ( Ip As String , Optional Timeout As Integer = 10000 , Optional MakeLog As Boolean = True ) As Integer
Dim PingResult As NetworkInformation . PingReply
Dim PingResult As NetworkInformation . PingReply
Try
Try
@@ -62,30 +269,22 @@ Retry:
End Try
End Try
End Function
End Function
Public Function NetGetCodeByClient ( Url As String , Encoding As Encoding , Timeout As Integer , Accept As String , Optional UseBrowserUserAgent As Boolean = False ) As String
Public Function NetGetCodeByClient ( Url As String , Encoding As Encoding , Timeout As Integer , Accept As String , Optional UseBrowserUserAgent As Boolean = False ) As String
Url = SecretCdnSign ( Url )
Log ( " [Net] 获取客户端网络结果: " & Url & " ,最大超时 " & Timeout )
Log ( " [Net] 获取客户端网络结果: " & Url & " ,最大超时 " & Timeout )
Dim Request As CookieWebClient
Dim res As HttpWebResponse = Nothing
Dim HttpStream As Stream = Nothing
Try
Try
Request = New CookieWebClient With {
Dim Headers As New Dictionary ( Of String , String ) From {
. Encoding = Encoding ,
{ " Accept " , Accept }
. Timeout = Timeout
}
}
Request . Headers ( " Accept " ) = Accept
Using Req As HttpRequestMessage = Request . GetRequestMessage ( Url , Headers : = Headers , RequireHeaderSign : = True , RequireCdnSign : = True , UseBrowserUA : = UseBrowserUserAgent )
Request . Headers ( " Accept-Language " ) = " en-US,en;q=0.5 "
Req . Headers . AcceptLanguage . Add ( New StringWithQualityHeaderValue ( " en-US,en;q=0.5 " ) )
Request . Headers ( " X-Requested-With " ) = " XMLHttpRequest "
Req . Headers . TryAddWithoutValidation ( " X-Request-With " , " XMLHttpRequest " )
SecretHeadersSign ( Url , Request , UseBrowserUserAgent )
Dim Resp As String = Request . SendRequest ( Req , Encode : = Encoding , Timeout : = Timeout )
Return Request . DownloadString ( Url )
Return Resp
End Using
Catch ex As TaskCanceledException
Throw New TaskCanceledException ( " 连接服务器超时( " & Url & " ) " , ex )
Catch ex As Exception
Catch ex As Exception
If ex . GetType . Equals ( GetType ( WebException ) ) AndAlso CType ( ex , WebException ) . Status = WebExceptionStatus . Timeout Then
Throw New WebException ( " 获取结果失败, " & ex . Message & " ( " & Url & " ) " , ex )
Throw New TimeoutException ( " 连接服务器超时( " & Url & " ) " , ex )
Else
Throw New WebException ( " 获取结果失败, " & ex . Message & " ( " & Url & " ) " , ex )
End If
Finally
If Not IsNothing ( HttpStream ) Then HttpStream . Dispose ( )
If Not IsNothing ( res ) Then res . Dispose ( )
End Try
End Try
End Function
End Function
@@ -183,35 +382,23 @@ RequestFinished:
End Function
End Function
Public Function NetGetCodeByRequestOnce ( Url As String , Optional Encode As Encoding = Nothing , Optional Timeout As Integer = 30000 , Optional IsJson As Boolean = False , Optional Accept As String = " " , Optional UseBrowserUserAgent As Boolean = False )
Public Function NetGetCodeByRequestOnce ( Url As String , Optional Encode As Encoding = Nothing , Optional Timeout As Integer = 30000 , Optional IsJson As Boolean = False , Optional Accept As String = " " , Optional UseBrowserUserAgent As Boolean = False )
If RunInUi ( ) AndAlso Not Url . Contains ( " //127. " ) Then Throw New Exception ( " 在 UI 线程执行了网络请求 " )
If RunInUi ( ) AndAlso Not Url . Contains ( " //127. " ) Then Throw New Exception ( " 在 UI 线程执行了网络请求 " )
Url = SecretCdnSign ( Url )
Log ( $ " [Net] 获取网络结果:{Url},超时 {Timeout}ms{If(IsJson, " , 要求 json " , "" )} " )
Log ( $ " [Net] 获取网络结果:{Url},超时 {Timeout}ms{If(IsJson, " , 要求 json " , "" )} " )
Dim Request As HttpWebRequest = WebRequest . Create ( Url )
Dim Result As New List ( Of Byte )
Try
Try
If Url . StartsWithF ( " https " , True ) Then Request . ProtocolVersion = HttpVersion . Version11
Dim Headers As New Dictionary ( Of String , String ) From {
Request . Timeout = Timeout
{ " Accept " , If ( Accept = " " , " */* " , Accept ) }
Request . Accept = Accept
}
SecretHeadersSign ( Url , Request , UseBrowserUserAgent )
Using Req As HttpRequestMessage = Request . GetRequestMessage ( Url , Headers : = Headers , UseBrowserUA : = UseBrowserUserAgent , RequireHeaderSign : = True , RequireCdnSign : = True )
Using res As HttpWebResponse = Request . GetResponse ( )
Dim Resp As String = Request . SendRequest ( Req , Encode : = Encode , Timeout : = Timeout )
Using HttpStream As Stream = res . GetResponseStream ( )
Return If ( IsJson , GetJson ( Resp ) , Resp )
HttpStream . ReadTimeout = Timeout
Dim HttpData As Byte ( ) = New Byte ( 16384 ) { }
Using Reader As New StreamReader ( HttpStream , If ( Encode , Encoding . UTF8 ) )
Dim ResultString As String = Reader . ReadToEnd
Return If ( IsJson , GetJson ( ResultString ) , ResultString )
End Using
End Using
End Using
End Using
Catch ex As ThreadInterruptedException
Catch ex As ThreadInterruptedException
Throw
Throw
Catch ex As Exception
If TypeOf ex Is WebException AndAlso CType ( ex , WebException ) . Status = WebExceptionStatus . Timeout Then
Catch ex As TaskCanceledException
Throw New TimeoutException ( $ " 获取结果失败({CType(ex, WebException).Status}, { ex.Message}, {Url}) " , ex )
Throw New TimeoutException ( $ " 获取结果失败({ex.Message}, {Url}) " , ex )
Else
Catch ex As HttpRequestException
Throw New WebException ( $ " 获取结果失败({If(TypeOf ex Is WebException, CType(ex, WebException).Status & " , " , "" )}{ ex.Message}, {Url}) " , ex )
Throw New WebException ( $ " 获取结果失败({ex.Message}, {Url}) " , ex )
End If
Finally
Request . Abort ( )
End Try
End Try
End Function
End Function
@@ -265,7 +452,7 @@ RequestFinished:
'下载
'下载
Using Client As New WebClient
Using Client As New WebClient
Try
Try
SecretHeadersSign ( Url , Client , UseBrowserUserAgent )
'SecretHeadersSign(Url, Client, UseBrowserUserAgent)
Client . DownloadFile ( Url , LocalFile )
Client . DownloadFile ( Url , LocalFile )
Catch ex As Exception
Catch ex As Exception
File . Delete ( LocalFile )
File . Delete ( LocalFile )
@@ -314,7 +501,7 @@ RequestFinished:
''' <param name="Data">请求的内容。</param>
''' <param name="Data">请求的内容。</param>
''' <param name="ContentType">请求的套接字类型。</param>
''' <param name="ContentType">请求的套接字类型。</param>
''' <param name="DontRetryOnRefused">当返回 40x 时不重试。</param>
''' <param name="DontRetryOnRefused">当返回 40x 时不重试。</param>
Public Function NetRequestRetry ( Url As String , Method As String , Data As Object , ContentType As String , Optional DontRetryOnRefused As Boolean = True , Optional Headers As Dictionary ( Of String , String ) = Nothing ) As String
Public Function NetRequestRetry ( Url As String , Method As String , Data As Object , ContentType As String , Optional DontRetryOnRefused As Boolean = True , Optional Headers As Dictionary ( Of String , String ) = Nothing , Optional RequireReturnRespObj As Boolean = False ) As String
Dim RetryCount As Integer = 0
Dim RetryCount As Integer = 0
Dim RetryException As Exception = Nothing
Dim RetryException As Exception = Nothing
Dim StartTime As Long = GetTimeTick ( )
Dim StartTime As Long = GetTimeTick ( )
@@ -322,15 +509,15 @@ RequestFinished:
Retry :
Retry :
Select Case RetryCount
Select Case RetryCount
Case 0 '正常尝试
Case 0 '正常尝试
Return NetRequestOnce ( Url , Method , Data , ContentType , 15000 , Headers )
Return NetRequestOnce ( Url , Method , Data , ContentType , 15000 , Headers , RequiredReturnRespObj : = RequireReturnRespObj )
Case 1 '慢速重试
Case 1 '慢速重试
Thread . Sleep ( 500 )
Thread . Sleep ( 500 )
Return NetRequestOnce ( Url , Method , Data , ContentType , 25000 , Headers )
Return NetRequestOnce ( Url , Method , Data , ContentType , 25000 , Headers , RequiredReturnRespObj : = RequireReturnRespObj )
Case Else '快速重试
Case Else '快速重试
If GetTimeTick ( ) - StartTime > 5500 Then
If GetTimeTick ( ) - StartTime > 5500 Then
'若前两次加载耗费 5 秒以上,才进行重试
'若前两次加载耗费 5 秒以上,才进行重试
Thread . Sleep ( 500 )
Thread . Sleep ( 500 )
Return NetRequestOnce ( Url , Method , Data , ContentType , 4000 , Headers )
Return NetRequestOnce ( Url , Method , Data , ContentType , 4000 , Headers , RequiredReturnRespObj : = RequireReturnRespObj )
Else
Else
Throw RetryException
Throw RetryException
End If
End If
@@ -397,79 +584,35 @@ RequestFinished:
''' <summary>
''' <summary>
''' 发送一次网络请求并获取返回内容。
''' 发送一次网络请求并获取返回内容。
''' </summary>
''' </summary>
Public Function NetRequestOnce ( Url As String , Method As String , Data As Object , ContentType As String , Optional Timeout As Integer = 25000 , Optional Headers As Dictionary ( Of String , String ) = Nothing , Optional MakeLog As Boolean = True , Optional UseBrowserUserAgent As Boolean = False ) As String
Public Function NetRequestOnce ( Url As String , Method As String , Data As Object , ContentType As String , Optional Timeout As Integer = 25000 , Optional Headers As Dictionary ( Of String , String ) = Nothing , Optional MakeLog As Boolean = True , Optional UseBrowserUserAgent As Boolean = False , Optional RequiredReturnRespObj As Boolean = False ) As Object
If RunInUi ( ) AndAlso Not Url . Contains ( " //127. " ) Then Throw New Exception ( " 在 UI 线程执行了网络请求 " )
If RunInUi ( ) AndAlso Not Url . Contains ( " //127. " ) Then Throw New Exception ( " 在 UI 线程执行了网络请求 " )
Url = SecretCdnSign ( Url )
If MakeLog Then Log ( " [Net] 发起网络请求( " & Method & " , " & Url & " ),最大超时 " & Timeout )
If MakeLog Then Log ( " [Net] 发起网络请求( " & Method & " , " & Url & " ),最大超时 " & Timeout )
Dim DataStream As Stream = Nothing
Dim Resp As WebResponse = Nothing
Dim Req As HttpWebRequest
Try
Try
Req = WebRequest . Create ( Url )
Dim ReqHeaders As New Dictionary ( Of String , String )
Req . Method = Method
If ContentType IsNot Nothing AndAlso Data IsNot Nothing Then
Dim SendData As Byte ( )
' 可能指定了 Content-Type 但是 Headers 是 Nothing
If TypeOf Data Is Byte ( ) Then
If Headers IsNot Nothing Then
SendData = Data
If Not Headers . ContainsKey ( " Content-Type " ) Then Headers . Add ( " Content-Type " , ContentType )
Else
SendData = New UTF8Encoding ( False ) . GetBytes ( Data . ToString )
End If
If Headers IsNot Nothing Then
For Each Pair In Headers
Req . Headers . Add ( Pair . Key , Pair . Value )
Next
End If
Req . ContentType = ContentType
Req . Timeout = Timeout
SecretHeadersSign ( Url , Req , UseBrowserUserAgent )
If Url . StartsWithF ( " https " , True ) Then Req . ProtocolVersion = HttpVersion . Version11
If Method = " POST " OrElse Method = " PUT " Then
Req . ContentLength = SendData . Length
DataStream = Req . GetRequestStream ( )
DataStream . WriteTimeout = Timeout
DataStream . ReadTimeout = Timeout
DataStream . Write ( SendData , 0 , SendData . Length )
DataStream . Close ( )
End If
Resp = Req . GetResponse ( )
DataStream = Resp . GetResponseStream ( )
DataStream . WriteTimeout = Timeout
DataStream . ReadTimeout = Timeout
Using Reader As New StreamReader ( DataStream )
Return Reader . ReadToEnd ( )
End Using
Catch ex As ThreadInterruptedException
Throw
Catch ex As WebException
If ex . Status = WebExceptionStatus . Timeout Then
ex = New WebException ( $ " 连接服务器超时,请检查你的网络环境是否良好({ex.Message}, {Url}) " , ex )
Else
'获取请求失败的返回
Dim Res As String = " "
Try
If ex . Response Is Nothing Then Exit Try
DataStream = ex . Response . GetResponseStream ( )
DataStream . WriteTimeout = Timeout
DataStream . ReadTimeout = Timeout
Using Reader As New StreamReader ( DataStream )
Res = Reader . ReadToEnd ( )
End Using
Catch
End Try
If Res = " " Then
ex = New WebException ( $ " 网络请求失败({ex.Status}, {ex.Message}, {Url}) " , ex )
Else
Else
ex = New ResponsedWebException ( $ " 服务器返回错误({ex.Status}, {ex.Message}, {Url}) {vbCrLf}{Res} " , Res , ex )
If Not ReqHeaders . ContainsKey ( " Content-Type " ) Then ReqHeaders . Add ( " Content-Type " , ContentType )
End If
End If
End If
End If
Dim ReqData As Byte ( ) = If ( TypeOf Data Is String , Encoding . UTF8 . GetBytes ( Data ) , Data )
Dim Req As HttpRequestMessage = Request . GetRequestMessage ( Url , Method , If ( Headers , ReqHeaders ) , If ( Data IsNot Nothing , ReqData , Nothing ) , UseBrowserUserAgent , True , True )
Return Request . SendRequest ( Req , If ( RequiredReturnRespObj , False , True ) , Timeout : = Timeout , RequireReturnRespObj : = RequiredReturnRespObj )
Catch ex As ThreadInterruptedException
Throw
Catch ex As TaskCanceledException
Return New WebException ( $ " 连接服务器超时,请检查你的网络环境是否良好({ex.Message}, {Url}) " , ex )
Catch ex As HttpRequestException
If MakeLog Then Log ( ex , " NetRequestOnce 失败 " , LogLevel . Developer )
Throw New WebException ( ex . Message , ex )
Catch ex As Exception
ex = New WebException ( " 网络请求失败( " & Url & " ) " , ex )
If MakeLog Then Log ( ex , " NetRequestOnce 失败 " , LogLevel . Developer )
If MakeLog Then Log ( ex , " NetRequestOnce 失败 " , LogLevel . Developer )
Throw ex
Throw ex
Catch ex As Exception
ex = New WebException ( " 网络请求失败( " & Url & " ) " , ex )
If MakeLog Then Log ( ex , " NetRequestOnce 失败 " , LogLevel . Developer )
Throw ex
Finally
If DataStream IsNot Nothing Then DataStream . Dispose ( )
If Resp IsNot Nothing Then Resp . Dispose ( )
End Try
End Try
End Function
End Function
Public Class ResponsedWebException
Public Class ResponsedWebException
@@ -818,6 +961,7 @@ RequestFinished:
Get
Get
Return IsUnknownSize OrElse FileSize < FilePieceLimit
Return IsUnknownSize OrElse FileSize < FilePieceLimit
End Get
End Get
End Property
End Property
''' <summary>
''' <summary>
''' 为不需要分割的小文件进行临时存储。
''' 为不需要分割的小文件进行临时存储。
@@ -1055,8 +1199,9 @@ StartThread:
''' </summary>
''' </summary>
Private Sub Thread ( Info As NetThread )
Private Sub Thread ( Info As NetThread )
If ModeDebug OrElse Info . DownloadStart = 0 Then Log ( " [Download] " & LocalName & " " & Info . Uuid & " #:开始,起始点 " & Info . DownloadStart & " , " & Info . Source . Url )
If ModeDebug OrElse Info . DownloadStart = 0 Then Log ( " [Download] " & LocalName & " " & Info . Uuid & " #:开始,起始点 " & Info . DownloadStart & " , " & Info . Source . Url )
Dim HttpRequest As HttpWebRequest
Dim HttpRequest As HttpRequestMessage
Dim ResultStream As Stream = Nothing
Dim ResultStream As Stream = Nothing
Dim HttpResponse As HttpResponseMessage
'部分下载源真的特别慢,并且只需要一个请求,例如 Ping 为 20s,如果增长太慢,就会造成类似 2.5s 5s 7.5s 10s 12.5s... 的极大延迟
'部分下载源真的特别慢,并且只需要一个请求,例如 Ping 为 20s,如果增长太慢,就会造成类似 2.5s 5s 7.5s 10s 12.5s... 的极大延迟
'延迟过长会导致某些特别慢的链接迟迟不被掐死
'延迟过长会导致某些特别慢的链接迟迟不被掐死
Dim Timeout As Integer = Math . Min ( Math . Max ( ConnectAverage , 6000 ) * ( 1 + Info . Source . FailCount ) , 30000 )
Dim Timeout As Integer = Math . Min ( Math . Max ( ConnectAverage , 6000 ) * ( 1 + Info . Source . FailCount ) , 30000 )
@@ -1064,18 +1209,16 @@ StartThread:
Try
Try
Dim HttpDataCount As Integer = 0
Dim HttpDataCount As Integer = 0
If SourcesOnce . Contains ( Info . Source ) AndAlso Not Info . Equals ( Info . Source . Thread ) Then GoTo SourceBreak
If SourcesOnce . Contains ( Info . Source ) AndAlso Not Info . Equals ( Info . Source . Thread ) Then GoTo SourceBreak
'请求头
HttpRequest = Request . GetRequestMessage ( Info . Source . Url ,
HttpRequest = WebRequest . Create ( Info . Source . Url )
RequireHeaderSign : = True )
If Info . Source . Url . StartsWithF ( " https " , True ) Then HttpRequest . ProtocolVersion = HttpVersion . Version11
'可能出现结束减去起始等于或者小于 0 的情况,导致下载抛出 ArgumentOutOfRangeException
'HttpRequest.Proxy = Nothing 'new WebProxy(Ip, Port)
If Not Info . IsFirstThread Then HttpRequest . Headers . Range = New RangeHeaderValue ( Info . DownloadStart , Nothing )
HttpRequest . Timeout = Timeout
HttpResponse = Request . SendRequest ( HttpRequest , False , Timeout : = Timeout , RequireReturnRespObj : = True )
HttpRequest . AddRange ( Info . DownloadStart )
SecretHeadersSign ( Info . Source . Url , HttpRequest , UseBrowserUserAgent )
Dim ContentLength As Long = 0
Dim ContentLength As Long = 0
Using HttpResponse As HttpWebResponse = HttpRequest . GetResponse ( )
Using HttpResponse
If State = NetState . Error Then GoTo SourceBreak '快速中断
If State = NetState . Error Then GoTo SourceBreak '快速中断
If ModeDebug AndAlso HttpResponse . ResponseUri . OriginalString <> Info . Source . Url Then
If ModeDebug AndAlso HttpResponse . RequestMessage . RequestUri . ToString <> Info . Source . Url Then
Log ( $ " [Download] {LocalName} {Info.Uuid}#:重定向至 {HttpResponse.ResponseUri.Original String} " )
Log ( $ " [Download] {LocalName} {Info.Uuid}#:重定向至 {HttpResponse.RequestMessage.RequestUri.To String} " )
End If
End If
''从响应头获取文件名
''从响应头获取文件名
'If Info.IsFirstThread Then
'If Info.IsFirstThread Then
@@ -1087,7 +1230,8 @@ StartThread:
' End If
' End If
'End If
'End If
'文件大小校验
'文件大小校验
ContentLength = HttpResponse . ContentLength
ContentLength = HttpResponse . Content . Headers . ContentLength . GetValueOrDefault ( - 1 )
If ContentLength = - 1 Then
If ContentLength = - 1 Then
If FileSize > 1 Then
If FileSize > 1 Then
If Info . DownloadStart = 0 Then
If Info . DownloadStart = 0 Then
@@ -1136,11 +1280,12 @@ NotSupportRange:
SourcesOnce . Add ( Info . Source )
SourcesOnce . Add ( Info . Source )
End If
End If
End SyncLock
End SyncLock
Throw New WebException ( $ " 该下载源不支持分段下载:Range 起始于 {Info.DownloadStart},预期 ContentLength 为 {FileSize - Info.DownloadStart},返回 ContentLength 为 {ContentLength},总文件大小 {FileSize} " )
Throw New WebException ( $ " 该下载源不支持分段下载:Range 起始于 {Info.DownloadStart},预期 ContentLength 为 {FileSize - Info.DownloadStart},返回 ContentLength 为 {ContentLength},总文件大小 {FileSize} " )
ElseIf Not FileSize - Info . DownloadStart = ContentLength Then
ElseIf Not FileSize - Info . DownloadStart = ContentLength Then
Throw New WebException ( $ " 获取到的分段大小不一致:Range 起始于 {Info.DownloadStart},预期 ContentLength 为 {FileSize - Info.DownloadStart},返回 ContentLength 为 {ContentLength},总文件大小 {FileSize} " )
Throw New WebException ( $ " 获取到的分段大小不一致:Range 起始于 {Info.DownloadStart},预期 ContentLength 为 {FileSize - Info.DownloadStart},返回 ContentLength 为 {ContentLength},总文件大小 {FileSize} " )
End If
End If
'Log($" [Download] {LocalName} {Info.Uuid}#:通过大小检查,文件大小 {FileSize},起始点 {Info.DownloadStart}, ContentLength {ContentLength}")
Log ( $ " [Download] {LocalName} {Info.Uuid}#:通过大小检查,文件大小 {FileSize},起始点 {Info.DownloadStart}, ContentLength {ContentLength} " )
Info . State = NetState . Get
Info . State = NetState . Get
SyncLock LockState
SyncLock LockState
If State < NetState . Get Then State = NetState . Get
If State < NetState . Get Then State = NetState . Get
@@ -1154,8 +1299,7 @@ NotSupportRange:
ResultStream = New FileStream ( Info . Temp , FileMode . Create , FileAccess . Write , FileShare . Read )
ResultStream = New FileStream ( Info . Temp , FileMode . Create , FileAccess . Write , FileShare . Read )
End If
End If
'开始下载
'开始下载
Using HttpStream = HttpResponse . GetResponseStream ( )
Using HttpStream = HttpResponse . Content . ReadAsStreamAsync ( ) . GetAwaiter ( ) . GetResult ( )
HttpStream . ReadTimeout = Timeout
If Setup . Get ( " SystemDebugDelay " ) Then Threading . Thread . Sleep ( RandomInteger ( 50 , 3000 ) )
If Setup . Get ( " SystemDebugDelay " ) Then Threading . Thread . Sleep ( RandomInteger ( 50 , 3000 ) )
Dim HttpData As Byte ( ) = New Byte ( 16384 ) { }
Dim HttpData As Byte ( ) = New Byte ( 16384 ) { }
HttpDataCount = HttpStream . Read ( HttpData , 0 , 16384 )
HttpDataCount = HttpStream . Read ( HttpData , 0 , 16384 )
@@ -1345,7 +1489,7 @@ Wrong:
If State < NetState . Merge Then
If State < NetState . Merge Then
State = NetState . Merge
State = NetState . Merge
Else
Else
Return
Exit Sub
End If
End If
End SyncLock
End SyncLock
Dim RetryCount As Integer = 0
Dim RetryCount As Integer = 0
@@ -1355,7 +1499,8 @@ Retry:
SyncLock LockChain
SyncLock LockChain
'创建文件夹
'创建文件夹
If File . Exists ( LocalPath ) Then File . Delete ( LocalPath )
If File . Exists ( LocalPath ) Then File . Delete ( LocalPath )
Directory . CreateDirectory ( GetPathFromFullPath ( LocalPath ) )
Dim Info As New FileInfo ( LocalPath )
Info . Directory . Create ( )
'合并文件
'合并文件
If IsNoSplit Then
If IsNoSplit Then
'仅有一个线程,从缓存中输出
'仅有一个线程,从缓存中输出
@@ -1434,7 +1579,7 @@ Retry:
''' </summary>
''' </summary>
Private Sub Fail ( Optional RaiseEx As Exception = Nothing )
Private Sub Fail ( Optional RaiseEx As Exception = Nothing )
SyncLock LockState
SyncLock LockState
If State >= NetState . Finish Then Return
If State >= NetState . Finish Then Exit Sub
If RaiseEx IsNot Nothing Then Ex . Add ( RaiseEx )
If RaiseEx IsNot Nothing Then Ex . Add ( RaiseEx )
'凉凉
'凉凉
State = NetState . Error
State = NetState . Error
@@ -1450,10 +1595,10 @@ Retry:
Public Sub Abort ( CausedByTask As LoaderDownload )
Public Sub Abort ( CausedByTask As LoaderDownload )
'从特定任务中移除,如果它还属于其他任务,则继续下载
'从特定任务中移除,如果它还属于其他任务,则继续下载
Tasks . Remove ( CausedByTask )
Tasks . Remove ( CausedByTask )
If Tasks . Any Then Return
If Tasks . Any Then Exit Sub
' 确认中断
' 确认中断
SyncLock LockState
SyncLock LockState
If State >= NetState . Finish Then Return
If State >= NetState . Finish Then Exit Sub
State = NetState . Error
State = NetState . Error
End SyncLock
End SyncLock
InterruptAndDelete ( )
InterruptAndDelete ( )
@@ -1473,7 +1618,7 @@ Retry:
''' </summary>
''' </summary>
Public Sub Finish ( Optional PrintLog As Boolean = True )
Public Sub Finish ( Optional PrintLog As Boolean = True )
SyncLock LockState
SyncLock LockState
If State >= NetState . Finish Then Return
If State >= NetState . Finish Then Exit Sub
State = NetState . Finish
State = NetState . Finish
End SyncLock
End SyncLock
SyncLock NetManager . LockRemain
SyncLock NetManager . LockRemain
@@ -1600,7 +1745,7 @@ NextElement:
'输入检测
'输入检测
If Not Files . Any ( ) Then
If Not Files . Any ( ) Then
OnFinish ( )
OnFinish ( )
Return
Exit Sub
End If
End If
For Each File As NetFile In Files
For Each File As NetFile In Files
If File Is Nothing Then Throw New ArgumentException ( " 存在空文件请求! " )
If File Is Nothing Then Throw New ArgumentException ( " 存在空文件请求! " )
@@ -1657,14 +1802,13 @@ NextElement:
End Sub
End Sub
Private Sub StartCopy ( Files As List ( Of NetFile ) , FolderList As List ( Of String ) )
Private Sub StartCopy ( Files As List ( Of NetFile ) , FolderList As List ( Of String ) )
Try
Try
If ModeDebug Then Log ( $ " [Download] 检查线程分配文件数:{Files.Count},线程名:{Thread.CurrentThread.Name} " )
If ModeDebug Then Log ( " [Download] 检查线程分配文件数: " & Files . Count & " ,线程名: " & Thread . CurrentThread . Name )
'试图从已存在的 Minecraft 文件夹中寻找目标文件
'试图从已存在的 Minecraft 文件夹中寻找目标文件
Dim ExistFiles As New List ( Of KeyValuePair ( Of NetFile , String ) ) '{NetFile, Target As String}
Dim ExistFiles As New List ( Of KeyValuePair ( Of NetFile , String ) ) '{NetFile, Target As String}
For Each File As NetFile In Files
For Each File As NetFile In Files
Dim ExistFilePath As String = Nothing
Dim ExistFilePath As String = Nothing
'判断是否有已存在的文件
'判断是否有已存在的文件
If File . Check IsNot Nothing AndAlso McFolderList IsNot Nothing AndAlso PathMcFolder IsNot Nothing AndAlso
If File . Check IsNot Nothing AndAlso McFolderList IsNot Nothing AndAlso PathMcFolder IsNot Nothing AndAlso File . Check . CanUseExistsFile AndAlso File . LocalPath . StartsWithF ( PathMcFolder ) Then
File . Check . CanUseExistsFile AndAlso File . LocalPath . StartsWithF ( PathMcFolder ) Then
Dim Relative = File . LocalPath . Replace ( PathMcFolder , " " )
Dim Relative = File . LocalPath . Replace ( PathMcFolder , " " )
For Each Folder In FolderList
For Each Folder In FolderList
Dim Target = Folder & Relative
Dim Target = Folder & Relative
@@ -1690,7 +1834,7 @@ NextElement:
For Each FileToken In ExistFiles
For Each FileToken In ExistFiles
Dim File As NetFile = FileToken . Key
Dim File As NetFile = FileToken . Key
SyncLock LockState
SyncLock LockState
If File . State > NetState . WaitForCopy Then Return
If File . State > NetState . WaitForCopy Then Exit Sub
End SyncLock
End SyncLock
Dim LocalPath As String = FileToken . Value
Dim LocalPath As String = FileToken . Value
Dim RetryCount As Integer = 0
Dim RetryCount As Integer = 0
@@ -1701,7 +1845,7 @@ Retry:
File . Finish ( False )
File . Finish ( False )
Catch ex As Exception
Catch ex As Exception
RetryCount += 1
RetryCount += 1
Log ( ex , $ " 复制已存在的文件失败,重试第 {RetryCount} 次({LocalPath} -> {File.LocalPath}) " )
Log ( ex , String . Format ( " 复制已存在的文件失败,重试第 {2} 次({0} -> {1}) " , LocalPath , File . LocalPath , RetryCount ) )
If RetryCount < 3 Then
If RetryCount < 3 Then
Thread . Sleep ( 200 )
Thread . Sleep ( 200 )
GoTo Retry
GoTo Retry
@@ -1719,14 +1863,14 @@ Retry:
'要求全部文件完成
'要求全部文件完成
SyncLock FileRemainLock
SyncLock FileRemainLock
FileRemain -= 1
FileRemain -= 1
If FileRemain > 0 Then Return
If FileRemain > 0 Then Exit Sub
End SyncLock
End SyncLock
OnFinish ( )
OnFinish ( )
End Sub
End Sub
Public Sub OnFinish ( )
Public Sub OnFinish ( )
RaisePreviewFinish ( )
RaisePreviewFinish ( )
SyncLock LockState
SyncLock LockState
If State > LoadState . Loading Then Return
If State > LoadState . Loading Then Exit Sub
State = LoadState . Finished
State = LoadState . Finished
End SyncLock
End SyncLock
End Sub
End Sub
@@ -1739,7 +1883,7 @@ Retry:
End Sub
End Sub
Public Sub OnFail ( ExList As List ( Of Exception ) )
Public Sub OnFail ( ExList As List ( Of Exception ) )
SyncLock LockState
SyncLock LockState
If State > LoadState . Loading Then Return
If State > LoadState . Loading Then Exit Sub
If ExList Is Nothing OrElse Not ExList . Any ( ) Then ExList = New List ( Of Exception ) From { New Exception ( " 未知错误! " ) }
If ExList Is Nothing OrElse Not ExList . Any ( ) Then ExList = New List ( Of Exception ) From { New Exception ( " 未知错误! " ) }
'寻找第一个不是 404 的下载源
'寻找第一个不是 404 的下载源
Dim UsefulExs = ExList . Where ( Function ( e ) Not e . Message . Contains ( " (404) " ) ) . ToList
Dim UsefulExs = ExList . Where ( Function ( e ) Not e . Message . Contains ( " (404) " ) ) . ToList
@@ -1768,7 +1912,7 @@ Retry:
End Sub
End Sub
Public Overrides Sub Abort ( )
Public Overrides Sub Abort ( )
SyncLock LockState
SyncLock LockState
If State >= LoadState . Finished Then Return
If State >= LoadState . Finished Then Exit Sub
State = LoadState . Aborted
State = LoadState . Aborted
End SyncLock
End SyncLock
Log ( " [Download] " & Name & " 已取消! " )
Log ( " [Download] " & Name & " 已取消! " )
@@ -1885,7 +2029,7 @@ Retry:
''' 启动监控线程,用于新增下载线程。
''' 启动监控线程,用于新增下载线程。
''' </summary>
''' </summary>
Private Sub StartManager ( )
Private Sub StartManager ( )
If IsManagerStarted Then Return
If IsManagerStarted Then Exit Sub
IsManagerStarted = True
IsManagerStarted = True
Dim ThreadStarter =
Dim ThreadStarter =
Sub ( Id As Integer ) '0 或 1
Sub ( Id As Integer ) '0 或 1