@@ -1,4 +1,7 @@
Imports System . Net . Http . Headers
Imports System . Net . Sockets
Imports System . Runtime . CompilerServices
Imports System . Security . Policy
Imports System . Threading . Tasks
Imports CacheCow . Client
@@ -11,15 +14,28 @@ Public Module ModNet
''' </summary>
Public Function NetRequestByClient ( Url As String , Optional Method As HttpMethod = Nothing ,
Optional Content As Object = Nothing , Optional ContentType As String = Nothing , Optional Accept As String = " */* " ,
Optional Timeout As Integer = 25000 , Optional Headers As String ( , ) = Nothing ,
Optional Encoding As Encoding = Nothing , Optional UseBrowserUserAgent As Boolean = False , Optional MakeLog As Boolean = True ) As String
Optional Timeout As Integer = 25000 , Optional Headers As String ( , ) = Nothing , Optional RequireJson As Boolean = False ,
Optional Encoding As Encoding = Nothing , Optional SimulateBrowserHeaders As Boolean = False , Optional MakeLog As Boolean = True ) As String
If Method Is Nothing Then Method = HttpMethod . Get
If MakeLog Then Log ( " [Net] 发起网络请求（ " & Method . Method & " ， " & Url & " ），最大超时 " & Timeout )
Try
Dim HeaderDictionary = If ( Headers , { } ) . ToDictionary
If ContentType IsNot Nothing Then HeaderDictionary ( " Content-Type " ) = ContentType
If Accept IsNot Nothing Then HeaderDictionary ( " Accept " ) = Accept
Return If ( Encoding , Encoding . UTF8 ) . GetString ( SendRequest ( Url , Method , Content , HeaderDictionary , Timeout : = Timeout , Encoding : = Encoding , UseBrowserUserAgent : = UseBrowserUserAgent ) )
Dim Result = If ( Encoding , Encoding . UTF8 ) . GetString ( SendRequest ( Url , Method , Content , HeaderDictionary , Timeout : = Timeout , Encoding : = Encoding , SimulateBrowserHeaders : = SimulateBrowserHeaders ) )
'检查结果是否为完整 JSON（在 #6683 中可能返回空，在被 GFW 截断时可能不完整）
'在此处检查并报错，可以让 NetRequestByClientRetry 等方法进行重试
If RequireJson Then
Result = Result . Trim ( ( vbCrLf & " " ) . ToCharArray ) 'Authlib-Injector 的结果会在末尾附带一个空行
If Not ( Result . StartsWithF ( " { " ) AndAlso Result . EndsWithF ( " } " ) ) AndAlso
Not ( Result . StartsWithF ( " [ " ) AndAlso Result . EndsWithF ( " ] " ) ) Then
Throw New FormatException ( " 返回结果并非 JSON 格式： " &
If ( Result . Length > 2000 , Result . Substring ( 0 , 1000 ) & " ... " & Result . Substring ( Result . Length - 1000 ) , Result ) )
End If
End If
Return Result
Catch ex As FormatException
Throw
Catch ex As ThreadInterruptedException
Throw
Catch ex As Exception
@@ -34,8 +50,8 @@ Public Module ModNet
''' <param name="BackupUrl">如果第一次尝试失败，换用的备用 URL。</param>
Public Function NetRequestByClientRetry ( Url As String , Optional Method As HttpMethod = Nothing , Optional BackupUrl As String = Nothing ,
Optional Content As Object = Nothing , Optional ContentType As String = Nothing , Optional Accept As String = " */* " ,
Optional Headers As String ( , ) = Nothing ,
Optional Encoding As Encoding = Nothing , Optional UseBrowserUserAgent As Boolean = False ) As String
Optional Headers As String ( , ) = Nothing , Optional RequireJson As Boolean = False ,
Optional Encoding As Encoding = Nothing , Optional SimulateBrowserHeaders As Boolean = False ) As String
Dim RetryCount As Integer = 0
Dim RetryException As Exception = Nothing
Dim StartTime As Long = GetTimeTick ( )
@@ -43,15 +59,15 @@ Public Module ModNet
Retry :
Select Case RetryCount
Case 0 '正常尝试
Return NetRequestByClient ( Url , Method , Content , ContentType , Accept , 10000 , Headers , Encoding , UseBrowserUserAgent )
Return NetRequestByClient ( Url , Method , Content , ContentType , Accept , 10000 , Headers , RequireJson , Encoding , SimulateBrowserHeaders )
Case 1 '慢速重试
Thread . Sleep ( 500 )
Return NetRequestByClient ( Url , Method , Content , ContentType , Accept , 30000 , Headers , Encoding , UseBrowserUserAgent )
Return NetRequestByClient ( Url , Method , Content , ContentType , Accept , 30000 , Headers , RequireJson , Encoding , SimulateBrowserHeaders )
Case Else '快速重试
If GetTimeTick ( ) - StartTime > 5500 Then
'若前两次加载耗费 5 秒以上，才进行重试
Thread . Sleep ( 500 )
Return NetRequestByClient ( Url , Method , Content , ContentType , Accept , 4000 , Headers , Encoding , UseBrowserUserAgent )
Return NetRequestByClient ( Url , Method , Content , ContentType , Accept , 4000 , Headers , RequireJson , Encoding , SimulateBrowserHeaders )
Else
Throw RetryException
End If
@@ -78,8 +94,8 @@ Retry:
''' </summary>
Public Function NetRequestByClientMultiple ( Url As String , Optional Method As HttpMethod = Nothing , Optional ThreadCount As Integer = 3 ,
Optional Content As Object = Nothing , Optional ContentType As String = Nothing , Optional Accept As String = " */* " ,
Optional Headers As String ( , ) = Nothing , Optional Timeout As Integer = 25000 ,
Optional Encoding As Encoding = Nothing , Optional UseBrowserUserAgent As Boolean = False ) As String
Optional Headers As String ( , ) = Nothing , Optional RequireJson As Boolean = False , Optional Timeout As Integer = 25000 ,
Optional Encoding As Encoding = Nothing , Optional SimulateBrowserHeaders As Boolean = False ) As String
Dim Threads As New List ( Of Thread )
Dim RequestResult = Nothing
Dim RequestEx As Exception = Nothing
@@ -88,7 +104,7 @@ Retry:
Dim th As New Thread (
Sub ( )
Try
RequestResult = NetRequestByClient ( Url , Method , Content , ContentType , Accept , Timeout , Headers , Encoding , UseBrowserUserAgent )
RequestResult = NetRequestByClient ( Url , Method , Content , ContentType , Accept , Timeout , Headers , RequireJson , Encoding , SimulateBrowserHeaders )
Catch ex As Exception
FailCount += 1
RequestEx = ex
@@ -127,16 +143,16 @@ RequestFinished:
''' 以多线程下载网页文件的方式获取内容。
''' 不支持缓存协商；若需缓存协商，需要换用 NetRequestByClient。
''' </summary>
Public Function NetRequestByLoader ( Url As String , Optional Timeout As Integer = 45000 , Optional IsJson As Boolean = False , Optional UseBrowserUserAgent As Boolean = False ) As String
Return NetRequestByLoader ( { Url } , Timeout , IsJson , UseBrowserUserAgent )
Public Function NetRequestByLoader ( Url As String , Optional Timeout As Integer = 45000 , Optional IsJson As Boolean = False , Optional SimulateBrowserHeaders As Boolean = False ) As String
Return NetRequestByLoader ( { Url } , Timeout , IsJson , SimulateBrowserHeaders )
End Function
''' <summary>
''' 以多线程下载网页文件的方式获取内容。
''' 不支持缓存协商；若需缓存协商，需要换用 NetRequestByClient。
''' </summary>
Public Function NetRequestByLoader ( Urls As IEnumerable ( Of String ) , Optional Timeout As Integer = 45000 , Optional IsJson As Boolean = False , Optional UseBrowserUserAgent As Boolean = False ) As String
Public Function NetRequestByLoader ( Urls As IEnumerable ( Of String ) , Optional Timeout As Integer = 45000 , Optional IsJson As Boolean = False , Optional SimulateBrowserHeaders As Boolean = False ) As String
Dim Temp As String = RequestTaskTempFolder ( ) & " download.txt "
Dim NewTask As New LoaderDownload ( " 源码获取 " & GetUuid ( ) & " # " , New List ( Of NetFile ) From { New NetFile ( Urls , Temp , New FileChecker With { . IsJson = IsJson } , UseBrowserUserAgent ) } )
Dim NewTask As New LoaderDownload ( " 源码获取 " & GetUuid ( ) & " # " , New List ( Of NetFile ) From { New NetFile ( Urls , Temp , New FileChecker With { . IsJson = IsJson } , SimulateBrowserHeaders ) } )
Try
NewTask . WaitForExitTime ( Timeout , TimeoutMessage : = " 连接服务器超时（第一下载源： " & Urls . First & " ） " )
NetRequestByLoader = ReadFile ( Temp )
@@ -154,7 +170,7 @@ RequestFinished:
''' 通过网络请求直接下载小文件，若文件已存在将被覆盖。
''' 不建议用于下载大文件。
''' </summary>
Public Sub NetDownloadByClient ( Url As String , LocalPath As String )
Public Sub NetDownloadByClient ( Url As String , LocalPath As String , Optional SimulateBrowserHeaders As Boolean = False )
Log ( $ " [Net] 通过网络请求直接下载小文件：{Url} → {LocalPath} " )
'初始化文件路径
Try
@@ -165,7 +181,7 @@ RequestFinished:
End Try
'下载
Try
File . WriteAllBytes ( LocalPath , SendRequest ( Url , HttpMethod . Get ) )
File . WriteAllBytes ( LocalPath , SendRequest ( Url , HttpMethod . Get , SimulateBrowserHeaders : = SimulateBrowserHeaders ) )
Catch ex As Exception
File . Delete ( LocalPath )
Throw New WebException ( $ " 通过网络请求直接下载小文件失败（{LocalPath}） " , ex )
@@ -175,16 +191,16 @@ RequestFinished:
''' <summary>
''' 通过多线程下载引擎下载文件。
''' </summary>
Public Sub NetDownloadByLoader ( Url As String , LocalPath As String , Optional LoaderToSyncProgress As LoaderBase = Nothing , Optional Check As FileChecker = Nothing , Optional UseBrowserUserAgent As Boolean = False )
NetDownloadByLoader ( { Url } , LocalPath , LoaderToSyncProgress , Check , UseBrowserUserAgent )
Public Sub NetDownloadByLoader ( Url As String , LocalPath As String , Optional LoaderToSyncProgress As LoaderBase = Nothing , Optional Check As FileChecker = Nothing , Optional SimulateBrowserHeaders As Boolean = False )
NetDownloadByLoader ( { Url } , LocalPath , LoaderToSyncProgress , Check , SimulateBrowserHeaders )
End Sub
''' <summary>
''' 通过多线程下载引擎下载文件。
''' </summary>
''' <param name="Urls">文件的 Url 列表。</param>
''' <param name="LocalPath">下载的本地地址。</param>
Public Sub NetDownloadByLoader ( Urls As IEnumerable ( Of String ) , LocalPath As String , Optional LoaderToSyncProgress As LoaderBase = Nothing , Optional Check As FileChecker = Nothing , Optional UseBrowserUserAgent As Boolean = False )
Dim NewTask As New LoaderDownload ( $ " 文件下载 {GetUuid()}# " , New List ( Of NetFile ) From { New NetFile ( Urls , LocalPath , Check , UseBrowserUserAgent ) } )
Public Sub NetDownloadByLoader ( Urls As IEnumerable ( Of String ) , LocalPath As String , Optional LoaderToSyncProgress As LoaderBase = Nothing , Optional Check As FileChecker = Nothing , Optional SimulateBrowserHeaders As Boolean = False )
Dim NewTask As New LoaderDownload ( $ " 文件下载 {GetUuid()}# " , New List ( Of NetFile ) From { New NetFile ( Urls , LocalPath , Check , SimulateBrowserHeaders ) } )
Try
NewTask . WaitForExit ( LoaderToSyncProgress : = LoaderToSyncProgress )
Catch ex As Exception
@@ -201,36 +217,37 @@ RequestFinished:
'基础请求函数
Private Function SendRequest ( Url As String , Method As HttpMethod ,
Optional Content As Object = Nothing , Optional Headers As Dictionary ( Of String , String ) = Nothing ,
Optional UseBrowserUserAgent As Boolean = False , Optional Timeout As Integer = 25000 , Optional Encoding As Encoding = Nothing ) As Byte ( )
Optional SimulateBrowserHeaders As Boolean = False , Optional Timeout As Integer = 25000 , Optional Encoding As Encoding = Nothing ) As Byte ( )
If RunInUi ( ) AndAlso Not Url . Contains ( " //127. " ) Then Throw New Exception ( " 在 UI 线程执行了网络请求 " )
Dim Request As HttpRequestMessage = Nothing , CancelToken As CancellationTokenSource = Nothing , Response As HttpResponseMessage = Nothing
Dim Request As HttpRequestMessage = Nothing , CancelToken As CancellationTokenSource = Nothing ,
Response As HttpResponseMessage = Nothing , HostIp As String = Nothing
Try
Static Client As HttpClient = ClientExtensions . CreateClient ( New FileCacheStore . FileStore ( PathTemp & " Cache/Http/ " ) , New HttpClientHandler With {
. AutomaticDecompression = DecompressionMethods . Deflate Or DecompressionMethods . GZip Or DecompressionMethods . None ,
. UseCookies = False '不设为 False 就不能从 Header 手动传入 Cookies
} )
Url = SecretCdnSign ( Url )
Request = New HttpRequestMessage ( Method , Url )
'写入 Content
If Content IsNot Nothing AndAlso Request . Method <> HttpMethod . Get AndAlso Request . Method <> HttpMethod . Head Then
Dim Bytes As Byte ( ) = If ( TypeOf Content Is Byte ( ) , Content , If ( Encoding , Encoding . UTF8 ) . GetBytes ( Content . ToString ) )
Request . Content = New ByteArrayContent ( Bytes )
Request . Content . Headers . ContentLength = Bytes . Length
If TypeOf Content Is HttpContent Then
Request . Content = DirectCast ( Content , HttpContent )
ElseIf TypeOf Content Is Byte ( ) Then
Request . Content = New ByteArrayContent ( DirectCast ( Content , Byte ( ) ) )
ElseIf Content IsNot Nothing Then
Request . Content = New ByteArrayContent ( If ( Encoding , Encoding . UTF8 ) . GetBytes ( Content . ToString ( ) ) )
End If
End If
'写入 Headers
If Headers IsNot Nothing Then
For Each Header In Headers
If Header . Key . ToLower = " content-type " Then
Request . Content ? . Headers . TryAddWithoutValidation ( Header . Key , Header . Value )
Else
Request . Headers . Add ( Header . Key , Header . Value )
End If
Next
End If
SecretHeadersSign ( Url , Request , UseBrowserUserAgent )
'发送请求
For Each Header In If ( Headers , New Dictionary ( Of String , String ) )
If Header . Key . ToLower = " content-type " Then
Request . Content ? . Headers . TryAddWithoutValidation ( Header . Key , Header . Value )
Else
Request . Headers . Add ( Header . Key , Header . Value )
End If
Next
SecretHeadersSign ( Url , Request , SimulateBrowserHeaders )
'DNS 解析
CancelToken = New CancellationTokenSource ( Timeout )
Response = Client . SendAsync ( Request , HttpCompletionOption . ResponseHeadersRead , CancelToken . Token ) . GetAwaiter ( ) . GetResult ( )
HostIp = DnsLookup ( Request , CancelToken )
'发送请求
Response = RequestClient . SendAsync ( Request , HttpCompletionOption . ResponseHeadersRead , CancelToken . Token ) . GetAwaiter ( ) . GetResult ( )
Dim ResponseStream = Response . Content . ReadAsStreamAsync ( ) . GetAwaiter ( ) . GetResult ( )
Dim ResponseBytes As Byte ( )
Using Stream As New MemoryStream
@@ -239,28 +256,111 @@ RequestFinished:
End Using
'输出
If Response . IsSuccessStatusCode Then
RecordIPReliability ( HostIp , 0 . 5 )
Return ResponseBytes
Else
RecordIPReliability ( HostIp , - 0 . 7 )
Dim ResponseMessage = If ( Encoding , Encoding . UTF8 ) . GetString ( ResponseBytes )
Throw New ResponsedWebException (
$ " 错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})， ， " &
$ " 错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})， ， ， " &
If ( String . IsNullOrEmpty ( ResponseMessage ) , " " , vbCrLf & ResponseMessage ) , ResponseMessage )
End If
Catch ex As ThreadInterruptedException
Throw
Catch ex As ResponsedWebException
Throw
Catch ex As TaskCanceledException 'CancellationTokenSource 超时
Throw New WebException ( $ " 连接服务器超时，请检查你的网络环境是否良好（{Method}, {Url}） " , WebExceptionStatus . Timeout )
Catch ex As DnsLookupException
Throw
Catch ex As Exception
Throw New Exception ( $ " 网络请求出现意外异常（{Method}, {Url}） " , ex )
RecordIPReliability ( HostIp , - 1 )
If TypeOf ex Is OperationCanceledException Then 'CancellationToken 超时
Throw New WebException ( $ " 连接服务器超时，请稍后再试，或使用 VPN 改善网络环境（{Method}, {Url}， ） " , WebExceptionStatus . Timeout )
Else
Throw New Exception ( $ " 网络请求出现意外异常（{Method}, {Url}， ） " , ex )
End If
Finally
Request ? . Dispose ( )
CancelToken ? . Dispose ( )
Response ? . Dispose ( )
End Try
End Function
Private RequestClient As HttpClient = ClientExtensions . CreateClient ( New FileCacheStore . FileStore ( PathTemp & " Cache/Http/ " ) , New HttpClientHandler With {
. AutomaticDecompression = DecompressionMethods . Deflate Or DecompressionMethods . GZip Or DecompressionMethods . None ,
. UseCookies = False '不设为 False 就不能从 Header 手动传入 Cookies
} )
''' <summary>
''' 进行 DNS 解析。它仅在选择的 IP 与系统默认的不一致时才对 URL 中的 Host 进行替换。
''' 返回请求时应使用的 IP；若为 IPv6，则加上了方括号。
''' </summary>
''' <exception cref="DnsLookupException"></exception>
Private Function DnsLookup ( Request As HttpRequestMessage , CancelToken As CancellationTokenSource ) As String
Dim GetIPReliability = Function ( Key ) IPReliability . GetOrDefault ( Key . ToString , 0 )
'初步 DNS 解析
Dim Host = Request . RequestUri . Host
Dim DnsTask As Task ( Of IPAddress ( ) ) = Nothing
Try
DnsTask = Dns . GetHostAddressesAsync ( Host )
DnsTask . Wait ( CancelToken . Token )
Catch ex As Exception
Throw New DnsLookupException ( $ " DNS 解析失败，请检查你的网络连接（{Host}） " , ex )
End Try
Dim Candidates As IPAddress ( ) = DnsTask . Result . ToArray
If Not Candidates . Any Then Throw New DnsLookupException ( $ " DNS 解析无结果，请检查你的网络连接（{Host}） " )
'若同时存在 IPv4 和 IPv6 地址，仅选择其中一类（因为 GFW 可能只屏蔽了 IPv4 或 IPv6）
Dim IPv4Targets = Candidates . Where ( Function ( i ) i . AddressFamily = AddressFamily . InterNetwork ) . ToArray
Dim IPv6Targets = Candidates . Where ( Function ( i ) i . AddressFamily = AddressFamily . InterNetworkV6 ) . ToArray
If IPv4Targets . Any AndAlso IPv6Targets . Any Then
Dim IPv4Reliability = IPv4Targets . Average ( Function ( i ) GetIPReliability ( i ) )
Dim IPv6Reliability = IPv6Targets . Average ( Function ( i ) GetIPReliability ( i ) )
If Host = " api.modrinth.com " Then IPv6Reliability -= 0 . 1 '让 Modrinth 优先使用 IPv4 地址（#6887）
Candidates = If ( IPv4Reliability >= IPv6Reliability , IPv4Targets , IPv6Targets )
End If
'选择可靠度最高的 IP
Dim MaxReliability As Double = Candidates . Max ( Function ( i ) GetIPReliability ( i ) )
Dim Target As IPAddress = Candidates . First ( Function ( i ) GetIPReliability ( i ) = MaxReliability )
Dim TargetIp As String = If ( Target . AddressFamily = AddressFamily . InterNetworkV6 , $ " [{Target}] " , Target . ToString )
If Target IsNot Candidates . First Then
'优选结果与系统默认 IP 不一致，替换域名并设置 Host 头
If ModeDebug Then Log ( $ " [Net] DNS 结果：{Host} → {Target}，所有可能的 IP 与可靠度：{DnsTask.Result.Select(Function(i) $ " { i } → { GetIPReliability ( i ) : 0 . 000 } " ).Join( " ； " )} " )
Request . Headers . Host = Host
Dim Builder As New UriBuilder ( Request . RequestUri )
Builder . Host = TargetIp
Request . RequestUri = Builder . Uri
End If
If Not IPReliability . ContainsKey ( TargetIp ) Then IPReliability ( TargetIp ) = - 0 . 01 '预先降低一点，这样快速的重复请求会使用不同的 IP 以提高成功率
Return TargetIp
End Function
''' <summary>
''' 记录每个 IP 地址的请求可靠度。
''' 通常取值 -1 ~ +0.5，越高越好。未尝试过的 IP 应视为 0。
''' </summary>
Private IPReliability As New Dictionary ( Of String , Double )
''' <summary>
''' 根据请求结果，记录 IP 地址的可靠度。
''' </summary>
Private Sub RecordIPReliability ( IP As String , Result As Double )
If IP Is Nothing Then Return
If Not IPReliability . ContainsKey ( IP ) Then IPReliability ( IP ) = 0
IPReliability ( IP ) = ( IPReliability ( IP ) + Result ) / 2
End Sub
''' <summary>
''' DNS 解析失败引发的异常。
''' </summary>
Private Class DnsLookupException
Inherits Exception
Public Sub New ( Message As String , Optional InnerException As Exception = Nothing )
MyBase . New ( Message , InnerException )
End Sub
Public Sub New ( Message As String )
MyBase . New ( Message )
End Sub
End Class
''' <summary>
''' 当网络请求失败时引发的异常。
''' 附带 Response 属性，可用于获取远程服务器给予的回复。
''' </summary>
Public Class ResponsedWebException
Inherits WebException
''' <summary>
@@ -277,6 +377,10 @@ RequestFinished:
#Region "多线程下载引擎"
Private ThreadClient As New HttpClient ( New HttpClientHandler With {
. AutomaticDecompression = DecompressionMethods . Deflate Or DecompressionMethods . GZip Or DecompressionMethods . None
} )
''' <summary>
''' 最大线程数。
''' </summary>
@@ -581,12 +685,12 @@ RequestFinished:
End SyncLock
End Function
''' <summary>
''' 是否已经没有 可用源了 。
''' 是否存在 可用源。
''' </summary>
Public Function HasAvailableSource ( Optional AllowOnceSource As Boolean = True ) As Boolean
SyncLock LockSource
If AllowOnceSource AndAlso SourcesOnce . Any Then Return True
If Sources . Any ( Function ( s ) Not s . IsFailed ) Then Return True
If Sources . Any ( Function ( s ) Not s . IsFailed ) Then Return True '存在多线程可用源
If AllowOnceSource AndAlso SourcesOnce . Any Then Return True '存在单线程可用源
End SyncLock
Return False
End Function
@@ -648,7 +752,7 @@ RequestFinished:
''' <summary>
''' 下载时是否添加浏览器 UA。
''' </summary>
Public UseBrowserUserAgent As Boolean
Public SimulateBrowserHeaders As Boolean
''' <summary>
''' 上次记速时的时间。
@@ -746,7 +850,7 @@ RequestFinished:
''' 新建一个需要下载的文件。
''' </summary>
''' <param name="LocalPath">包含文件名的本地地址。</param>
Public Sub New ( Urls As IEnumerable ( Of String ) , LocalPath As String , Optional Check As FileChecker = Nothing , Optional UseBrowserUserAgent As Boolean = False )
Public Sub New ( Urls As IEnumerable ( Of String ) , LocalPath As String , Optional Check As FileChecker = Nothing , Optional SimulateBrowserHeaders As Boolean = False )
Dim Sources As New List ( Of NetSource )
Dim Count As Integer = 0
Urls = Urls . Distinct . ToArray
@@ -757,7 +861,7 @@ RequestFinished:
Me . Sources = Sources
Me . LocalPath = LocalPath
Me . Check = Check
Me . UseBrowserUserAgent = UseBrowserUserAgent
Me . SimulateBrowserHeaders = SimulateBrowserHeaders
Me . LocalName = GetFileNameFromPath ( LocalPath )
End Sub
@@ -768,17 +872,17 @@ RequestFinished:
Public Function TryBeginThread ( ) As NetThread
Try
'条件检测
If NetTaskThreadCount >= NetTaskThreadLimit OrElse Not HasAvailableSource ( ) OrElse
( IsNoSplit AndAlso Threads IsNot Nothing AndAlso Threads . State <> NetState . Error ) Then Return Nothing
If State >= NetState . Merge OrElse State = NetState . WaitForCheck Then Return Nothing
SyncLock LockState
If State < NetState . Connect Then State = NetState . Connect
End SyncLock
'初始化参数
Dim StartPosition As Long , StartSource As NetSource = Nothing
Dim Th As Thread , ThreadInfo As NetThread
SyncLock LockChain
'条件检测
SyncLock LockSource
If NetTaskThreadCount >= NetTaskThreadLimit OrElse Not HasAvailableSource ( ) OrElse
( IsNoSplit AndAlso Threads IsNot Nothing AndAlso Threads . State <> NetState . Error ) Then Return Nothing
If State >= NetState . Merge OrElse State = NetState . WaitForCheck Then Return Nothing
SyncLock LockState
If State < NetState . Connect Then State = NetState . Connect
End SyncLock
'初始化参数
'获取线程起点与下载源
'不分割
If IsNoSplit Then GoTo StartSingleThreadDownload
@@ -789,6 +893,8 @@ StartSingleThreadDownload:
Reset ( )
State = NetState . Get
End If
End SyncLock
SyncLock LockChain
'首个开始点
If Threads Is Nothing Then
StartPosition = 0
@@ -805,7 +911,9 @@ StartSingleThreadDownload:
End If
Next
'是否禁用多线程，以及规定碎片大小
Dim TargetUrl As String = GetSource ( ) . Url
Dim Source As NetSource = GetSource ( )
If Source Is Nothing Then Return Nothing
Dim TargetUrl As String = Source . Url
If TargetUrl . Contains ( " pcl2-server " ) OrElse TargetUrl . Contains ( " bmclapi " ) OrElse TargetUrl . Contains ( " github.com " ) OrElse
TargetUrl . Contains ( " optifine.net " ) OrElse TargetUrl . Contains ( " modrinth " ) OrElse TargetUrl . Contains ( " momot.rs " ) Then Return Nothing
'寻找最大碎片
@@ -850,7 +958,7 @@ StartThread:
Return ThreadInfo
Catch ex As Exception
Log ( ex , " 尝试开始下载线程失败（ " & If ( LocalName , " Nothing " ) & " ） " , LogLevel . Hint )
Fail ( New Exception ( $ " 尝试开始下载线程失败（{LocalName}） " , ex ) )
Return Nothing
End Try
End Function
@@ -859,7 +967,9 @@ StartThread:
''' </summary>
Private Sub Thread ( Th As NetThread )
If ModeDebug OrElse Th . DownloadStart = 0 Then Log ( $ " [Download] {LocalName}：开始，起始点 {Th.DownloadStart}， " )
Dim ResultStream As Stream = Nothing
Dim ResultStream As Stream = Nothing , HttpRequest As HttpRequestMessage = Nothing ,
Response As HttpResponseMessage = Nothing , ResponseStream As Stream = Nothing ,
CancelToken As CancellationTokenSource = Nothing , HostIp As String = " "
'部分下载源真的特别慢，并且只需要一个请求，例如 Ping 为 20s，如果增长太慢，就会造成类似 2.5s 5s 7.5s 10s 12.5s... 的极大延迟
'延迟过长会导致某些特别慢的链接迟迟不被掐死
Dim Timeout As Integer = Math . Min ( Math . Max ( ConnectAverage , 6000 ) * ( 1 + Th . Source . FailCount ) , 30000 )
@@ -867,145 +977,140 @@ StartThread:
Try
Dim HttpDataCount As Integer = 0
If SourcesOnce . Contains ( Th . Source ) AndAlso Th <> Th . Source . SingleThread Then GoTo SourceBreak
Dim HttpRequest As New HttpRequestMessage ( HttpMethod . Get , Th . Source . Url )
SecretHeadersSign ( Th . Source . Url , HttpRequest , UseBrowserUserAgent )
HttpRequest = New HttpRequestMessage ( HttpMethod . Get , Th . Source . Url )
SecretHeadersSign ( Th . Source . Url , HttpRequest , SimulateBrowserHeaders )
CancelToken = New CancellationTokenSource ( Timeout )
HostIp = DnsLookup ( HttpRequest , CancelToken ) 'DNS 预解析
If Not Th . IsFirstThread Then HttpRequest . Headers . Range = New RangeHeaderValue ( Th . DownloadStart , Nothing )
Dim ContentLength As Long = 0
Using CancelToken As New CancellationTokenSource ( Timeout )
Static Client As New HttpClient ( New HttpClientHandler With {
. AutomaticDecompression = DecompressionMethods . Deflate Or DecompressionMethods . GZip Or DecompressionMethods . None
} )
Using Response As HttpResponseMessage = Client . SendAsync ( HttpRequest , HttpCompletionOption . ResponseHeadersRead , CancelToken . Token ) . GetAwaiter ( ) . GetResult ( )
If Not Response . IsSuccessStatusCode Then Throw New Exception ( $ " 错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})， " ) '状态码检查
If State = NetState . Error Then GoTo SourceBreak '快速中断
If ModeDebug AndAlso Response . RequestMessage . RequestUri . ToString < >Th . Source . Url Then Log ( $ " [Download] {LocalName}：重定向至 {Response.RequestMessage.RequestUri} " )
'文件大小校验
ContentLength = Response . Content . Headers . ContentLength . GetValueOrDefault ( - 1 )
If ContentLength = - 1 Then
If FileSize > 1 Then
If Th . DownloadStart = 0 Then
Log ( $ " [Download] {LocalName}：文件大小未知，但已从其他下载源获取，不作处理 " )
Else
Log ( $ " [Download] {LocalName}： " )
GoTo NotSupportRange
End If
Else
FileSize = - 1 : IsUnknownSize = True
Log ( $ " [Download] {LocalName}：文件大小未知 " )
End If
ElseIf ContentLength < 0 Then
Throw New Exception ( " 获取片大小失败，结果为 " & ContentLength & " 。 " )
ElseIf Th . IsFirstThread Then
If Check IsNot Nothing Then
If ContentLength < Check . MinSize AndAlso Check . MinSize > 0 Then
Throw New Exception ( $ " 文件大小不足，获取结果为 {ContentLength}，要求至少为 {Check.MinSize}。 " )
End If
If ContentLength <> Check . ActualSize AndAlso Check . ActualSize > 0 Then
Throw New Exception ( $ " 文件大小不一致，获取结果为 {ContentLength}，要求必须为 {Check.ActualSize}。 " )
End If
End If
FileSize = ContentLength : IsUnknownSize = False
Log ( $ " [Download] {LocalName}：文件大小 {ContentLength}（ ） " )
'若文件大小大于 50 M，进行剩余磁盘空间校验
If ContentLength > 50 * 1024 * 1024 Then
For Each Drive As DriveInfo In DriveInfo . GetDrives
Dim DriveName As String = Drive . Name . First . ToString
Dim RequiredSpace = If ( PathTemp . StartsWithF ( DriveName ) , ContentLength * 1 . 1 , 0 ) +
If ( LocalPath . StartsWithF ( DriveName ) , ContentLength + 5 * 1024 * 1024 , 0 )
If Drive . TotalFreeSpace < RequiredSpace Then
Throw New Exception ( DriveName & " 盘空间不足，无法进行下载。 " & vbCrLf & " 需要至少 " & GetString ( RequiredSpace ) & " 空间，但当前仅剩余 " & GetString ( Drive . TotalFreeSpace ) & " 。 " &
If ( PathTemp . StartsWithF ( DriveName ) , vbCrLf & vbCrLf & " 下载时需要与文件同等大小的空间存放缓存，你可以在设置中调整缓存文件夹的位置。 " , " " ) )
End If
Next
End If
ElseIf FileSize < 0 Then
Throw New Exception ( " 非首线程运行时，尚未获取文件大小 " )
ElseIf Th . DownloadStart > 0 AndAlso ContentLength = FileSize Then
NotSupportRange :
SyncLock LockSource
If SourcesOnce . Contains ( Th . Source ) Then
GoTo SourceBreak
Else
SourcesOnce . Add ( Th . Source )
End If
End SyncLock
Throw New WebException ( $ " 该下载源不支持分段下载：Range 起始于 {Th.DownloadStart}，预期 ContentLength 为 {FileSize - Th.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize} " )
ElseIf Not FileSize - Th . DownloadStart = ContentLength Then
Throw New WebException ( $ " 获取到的分段大小不一致：Range 起始于 {Th.DownloadStart}，预期 ContentLength 为 {FileSize - Th.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize} " )
End If
'Log($"[Download] {LocalName} {Info.Uuid}#：通过大小检查，文件大小 {FileSize}，起始点 {Info.DownloadStart}，
Th . State = NetState . Get
SyncLock LockState
If State < NetState . Get Then State = NetState . Get
End SyncLock
'创建缓存文件
If IsNoSplit Then
Th . Temp = Nothing
Cache = New MemoryStream
ResultStream = Cache
Response = ThreadClient . SendAsync ( HttpRequest , HttpCompletionOption . ResponseHeadersRead , CancelToken . Token ) . GetAwaiter ( ) . GetResult ( )
If Not Response . IsSuccessStatusCode Then Throw New Exception ( $ " 错误码 {Response.StatusCode} ({CInt(Response.StatusCode)})， " ) '状态码检查
If State = NetState . Error Then GoTo SourceBreak '快速中断
If ModeDebug AndAlso Response . RequestMessage . RequestUri . ToString <> Th . Source . Url Then Log ( $ " [Download] {LocalName}：重定向至 {Response.RequestMessage.RequestUri} " )
'文件大小校验
ContentLength = Response . Content . Headers . ContentLength . GetValueOrDefault ( - 1 )
If ContentLength = - 1 Then
If FileSize > 1 Then
If Th . DownloadStart = 0 Then
Log ( $ " [Download] {LocalName}：文件大小未知，但已从其他下载源获取，不作处理 " )
Else
Th . Temp = $ " {PathTemp}Download\{Uuid}_{Th.Uuid}_{RandomInteger(0, 999999)}.tmp "
ResultStream = New FileStream ( Th . Temp , FileMode . Create , FileAccess . Write , FileShare . Read )
Log ( $ " [Download] {LocalName}： " )
GoTo NotSupportRange
End If
'开始下载
Using ResponseStream = Response . Content . ReadAsStreamAsync ( ) . GetAwaiter ( ) . GetResult ( )
If Setup . Get ( " SystemDebugDelay " ) Then Threading . Thread . Sleep ( RandomInteger ( 50 , 3000 ) )
Dim ResponseBytes As Byte ( ) = New Byte ( 16384 ) { }
HttpDataCount = ResponseStream . ReadAsync ( ResponseBytes , 0 , 16384 , CancelToken . Token ) . GetAwaiter ( ) . GetResult ( )
While ( IsUnknownSize OrElse Th . DownloadUndone > 0 ) AndAlso '判断是否下载完成
HttpDataCount > 0 AndAlso Not IsProgramEnded AndAlso State < NetState . Merge AndAlso ( Not Th . Source . IsFailed OrElse Th . Source . SingleThread = Th )
'限速
While NetTaskSpeedLimitHigh > 0 AndAlso NetTaskSpeedLimitLeft <= 0
Threading . Thread . Sleep ( 16 )
End While
Dim RealDataCount As Integer = If ( IsUnknownSize , HttpDataCount , Math . Min ( HttpDataCount , Th . DownloadUndone ) )
SyncLock NetTaskSpeedLimitLeftLock
If NetTaskSpeedLimitHigh > 0 Then NetTaskSpeedLimitLeft -= RealDataCount
End SyncLock
Dim DeltaTime = GetTimeTick ( ) - Th . LastReceiveTime
If DeltaTime > 1000000 Then DeltaTime = 1 '时间刻反转导致出现极大值
If RealDataCount > 0 Then
'有数据
If Th . DownloadDone = 0 Then
'第一次接受到数据
Th . State = NetState . Download
SyncLock LockState
If State < NetState . Download Then State = NetState . Download
End SyncLock
SyncLock LockCount
ConnectCount += 1
ConnectTime += GetTimeTick ( ) - Th . InitTime
End SyncLock
End If
SyncLock LockCount
Th . Source . FailCount = 0
For Each Task In Tasks
Task . FailCount = 0
Next
End SyncLock
NetManager . DownloadDone += RealDataCount
SyncLock LockDone
DownloadDone += RealDataCount
End SyncLock
Th . DownloadDone += RealDataCount
ResultStream . Write ( ResponseBytes , 0 , RealDataCount )
'检查速度是否过慢
If DeltaTime > 1500 AndAlso DeltaTime > RealDataCount AndAlso '数据包间隔大于 1.5s，且速度小于 1.5K/s
Th . Source . SingleThread Is Nothing Then '并非单线程下载
Throw New TimeoutException ( " 由于速度过慢断开链接，下载 " & RealDataCount & " B，消耗 " & DeltaTime & " ms。 " )
End If
Th . LastReceiveTime = GetTimeTick ( )
'已完成
If Th . DownloadUndone = 0 AndAlso Not IsUnknownSize Then Exit While
ElseIf Th . LastReceiveTime > 0 AndAlso DeltaTime > Timeout Then
'无数据，且已超时
Throw New TimeoutException ( " 操作超时，无数据。 " )
End If
HttpDataCount = ResponseStream . Read ( ResponseBytes , 0 , 16384 )
End While
End Using
End Using
End Using
Else
FileSize = - 1 : IsUnknownSize = True
Log ( $ " [Download] {LocalName}：文件大小未知 " )
End If
ElseIf ContentLength < 0 Then
Throw New Exception ( " 获取片大小失败，结果为 " & ContentLength & " 。 " )
ElseIf Th . IsFirstThread Then
If Check IsNot Nothing Then
If ContentLength < Check . MinSize AndAlso Check . MinSize > 0 Then
Throw New Exception ( $ " 文件大小不足，获取结果为 {ContentLength}，要求至少为 {Check.MinSize}。 " )
End If
If ContentLength <> Check . ActualSize AndAlso Check . ActualSize > 0 Then
Throw New Exception ( $ " 文件大小不一致，获取结果为 {ContentLength}，要求必须为 {Check.ActualSize}。 " )
End If
End If
FileSize = ContentLength : IsUnknownSize = False
Log ( $ " [Download] {LocalName}：文件大小 {ContentLength}（ ） " )
'若文件大小大于 50 M，进行剩余磁盘空间校验
If ContentLength > 50 * 1024 * 1024 Then
For Each Drive As DriveInfo In DriveInfo . GetDrives
Dim DriveName As String = Drive . Name . First . ToString
Dim RequiredSpace = If ( PathTemp . StartsWithF ( DriveName ) , ContentLength * 1 . 1 , 0 ) +
If ( LocalPath . StartsWithF ( DriveName ) , ContentLength + 5 * 1024 * 1024 , 0 )
If Drive . TotalFreeSpace < RequiredSpace Then
Throw New Exception ( DriveName & " 盘空间不足，无法进行下载。 " & vbCrLf & " 需要至少 " & GetString ( RequiredSpace ) & " 空间，但当前仅剩余 " & GetString ( Drive . TotalFreeSpace ) & " 。 " &
If ( PathTemp . StartsWithF ( DriveName ) , vbCrLf & vbCrLf & " 下载时需要与文件同等大小的空间存放缓存，你可以在设置中调整缓存文件夹的位置。 " , " " ) )
End If
Next
End If
ElseIf FileSize < 0 Then
Throw New Exception ( " 非首线程运行时，尚未获取文件大小 " )
ElseIf Th . DownloadStart > 0 AndAlso ContentLength = FileSize Then
NotSupportRange :
SyncLock LockSource
If SourcesOnce . Contains ( Th . Source ) Then
GoTo SourceBreak
Else
SourcesOnce . Add ( Th . Source )
End If
End SyncLock
Throw New WebException ( $ " 该下载源不支持分段下载：Range 起始于 {Th.DownloadStart}，预期 ContentLength 为 {FileSize - Th.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize} " )
ElseIf Not FileSize - Th . DownloadStart = ContentLength Then
Throw New WebException ( $ " 获取到的分段大小不一致：Range 起始于 {Th.DownloadStart}，预期 ContentLength 为 {FileSize - Th.DownloadStart}，返回 ContentLength 为 {ContentLength}，总文件大小 {FileSize} " )
End If
'Log($"[Download] {LocalName} {Info.Uuid}#：通过大小检查，文件大小 {FileSize}，起始点 {Info.DownloadStart}，
Th . State = NetState . Get
SyncLock LockState
If State < NetState . Get Then State = NetState . Get
End SyncLock
'创建缓存文件
If IsNoSplit Then
Th . Temp = Nothing
Cache = New MemoryStream
ResultStream = Cache
Else
Th . Temp = $ " {PathTemp}Download\{Uuid}_{Th.Uuid}_{RandomInteger(0, 999999)}.tmp "
ResultStream = New FileStream ( Th . Temp , FileMode . Create , FileAccess . Write , FileShare . Read )
End If
'开始下载
ResponseStream = Response . Content . ReadAsStreamAsync ( ) . GetAwaiter ( ) . GetResult ( )
If Setup . Get ( " SystemDebugDelay " ) Then Threading . Thread . Sleep ( RandomInteger ( 50 , 3000 ) )
Dim ResponseBytes As Byte ( ) = New Byte ( 16384 ) { }
HttpDataCount = ResponseStream . ReadAsync ( ResponseBytes , 0 , 16384 , CancelToken . Token ) . GetAwaiter ( ) . GetResult ( )
While ( IsUnknownSize OrElse Th . DownloadUndone > 0 ) AndAlso '判断是否下载完成
HttpDataCount > 0 AndAlso Not IsProgramEnded AndAlso State < NetState . Merge AndAlso ( Not Th . Source . IsFailed OrElse Th . Source . SingleThread = Th )
'限速
While NetTaskSpeedLimitHigh > 0 AndAlso NetTaskSpeedLimitLeft <= 0
Threading . Thread . Sleep ( 16 )
End While
Dim RealDataCount As Integer = If ( IsUnknownSize , HttpDataCount , Math . Min ( HttpDataCount , Th . DownloadUndone ) )
SyncLock NetTaskSpeedLimitLeftLock
If NetTaskSpeedLimitHigh > 0 Then NetTaskSpeedLimitLeft -= RealDataCount
End SyncLock
Dim DeltaTime = GetTimeTick ( ) - Th . LastReceiveTime
If DeltaTime > 1000000 Then DeltaTime = 1 '避免时间刻反转导致出现极大值
If RealDataCount > 0 Then
'有数据
If Th . DownloadDone = 0 Then
'第一次接受到数据
Th . State = NetState . Download
SyncLock LockState
If State < NetState . Download Then State = NetState . Download
End SyncLock
SyncLock LockCount
ConnectCount += 1
ConnectTime += GetTimeTick ( ) - Th . InitTime
End SyncLock
End If
SyncLock LockCount
Th . Source . FailCount = 0
For Each Task In Tasks
Task . FailCount = 0
Next
End SyncLock
NetManager . DownloadDone += RealDataCount
SyncLock LockDone
DownloadDone += RealDataCount
End SyncLock
Th . DownloadDone += RealDataCount
ResultStream . Write ( ResponseBytes , 0 , RealDataCount )
'已完成
If Th . DownloadUndone = 0 AndAlso Not IsUnknownSize Then Exit While
'检查速度是否过慢
If DeltaTime > 5000 AndAlso DeltaTime > RealDataCount AndAlso '数据包间隔大于 5s，且速度小于 1K/s
Th . Source . SingleThread Is Nothing Then '且并非单线程下载
Throw New TimeoutException ( " 由于速度过慢断开链接，下载 " & RealDataCount & " B，消耗 " & DeltaTime & " ms。 " )
End If
Th . LastReceiveTime = GetTimeTick ( )
ElseIf Th . LastReceiveTime > 0 AndAlso DeltaTime > Timeout Then
'无数据，且已超时
Throw New TimeoutException ( " 操作超时，无数据。 " )
End If
HttpDataCount = ResponseStream . Read ( ResponseBytes , 0 , 16384 )
End While
SourceBreak :
If State = NetState . Error OrElse ( Th . Source . IsFailed AndAlso Th . Source . SingleThread <> Th ) OrElse ( Th . DownloadUndone > 0 AndAlso Not IsUnknownSize ) Then
'被外部中断
@@ -1018,16 +1123,24 @@ SourceBreak:
'本线程完成
Th . State = NetState . Finish
If ModeDebug Then Log ( $ " [Download] {LocalName}：完成，已下载 {Th.DownloadDone}（ ） " )
RecordIPReliability ( HostIp , 0 . 5 )
End If
Catch ex As Exception
Log ( $ " [Download] {LocalName}：出错，{If(TypeOf ex Is Task CanceledException, $ " 已超时 （ { Timeout } ms ） " , GetExceptionDetail(ex)) } " )
Log ( $ " [Download] {LocalName}：出错，{If(TypeOf ex Is Operation CanceledException, $ " 已超时 （ { Timeout } ms ） " , ex.GetDetail())}， } " )
RecordIPReliability ( HostIp , - 0 . 7 )
SourceFail ( Th , ex , False )
Finally
'释放资源
HttpRequest ? . Dispose ( )
Response ? . Dispose ( )
ResponseStream ? . Dispose ( )
CancelToken ? . Dispose ( )
If Not IsNoSplit Then ResultStream ? . Dispose ( )
'改变计数
SyncLock NetTaskThreadCountLock
NetTaskThreadCount -= 1
End SyncLock
'合并
If Not IsNoSplit Then ResultStream ? . Dispose ( )
If ( ( FileSize >= 0 AndAlso DownloadDone >= FileSize ) OrElse ( FileSize = - 1 AndAlso DownloadDone > 0 ) ) AndAlso
State < NetState . Merge AndAlso Th . State <> NetState . Error Then Merge ( Th )
End Try
@@ -1046,7 +1159,7 @@ SourceBreak:
If IsMergeFailure OrElse
ex . Message . Contains ( " 该下载源不支持 " ) OrElse ex . Message . Contains ( " 未能解析 " ) OrElse ex . Message . Contains ( " (404) " ) OrElse
ex . Message . Contains ( " (502) " ) OrElse ex . Message . Contains ( " 无返回数据 " ) OrElse ex . Message . Contains ( " 空间不足 " ) OrElse ex . Message . Contains ( " 获取到的分段大小不一致 " ) OrElse
( ex . Message . Contains ( " (403) " ) AndAlso Not Th . Source . Url . ContainsF ( " bmclapi " ) ) OrElse 'BMCLAPI 的部分源在高频率请求下会返回 403，所以不应因此禁用下载源
( ( ex . Message . Contains ( " (403) " ) OrElse ex . Message . Contains ( " (429) " ) ) AndAlso Not Th . Source . Url . ContainsF ( " bmclapi " ) ) OrElse 'BMCLAPI 的部分源在高频率请求下会返回 403/429 ，所以不应因此禁用下载源
( Th . Source . FailCount >= MathClamp ( NetTaskThreadLimit , 5 , 30 ) AndAlso DownloadDone < 1 ) OrElse Th . Source . FailCount > NetTaskThreadLimit + 2 Then
'当一个下载源有多个线程在下载时，只选择其中一个线程进行后续处理
Dim IsThisFail As Boolean = False
@@ -1140,10 +1253,10 @@ SourceBreak:
Dim RetryCount As Integer = 0
Try
Retry :
'创建文件夹
If File . Exists ( LocalPath ) Then File . Delete ( LocalPath )
Directory . CreateDirectory ( GetPathFromFullPath ( LocalPath ) )
SyncLock LockChain
'创建文件夹
If File . Exists ( LocalPath ) Then File . Delete ( LocalPath )
Directory . CreateDirectory ( GetPathFromFullPath ( LocalPath ) )
'合并文件
If IsNoSplit Then
'仅有一个线程，从缓存中输出
@@ -1386,13 +1499,13 @@ NextElement:
If File Is Nothing Then Throw New ArgumentException ( " 存在空文件请求！ " )
For Each Source As NetSource In File . Sources
If Not ( Source . Url . StartsWithF ( " https:// " , True ) OrElse Source . Url . StartsWithF ( " http:// " , True ) ) Then
Source . Ex = New ArgumentException ( " 输入的下载链接不正确！ " )
Source . Ex = New ArgumentException ( " 输入的下载链接不正确： " & Source . Url )
Source . IsFailed = True
End If
Next
If Not File . HasAvailableSource ( ) Then Throw New ArgumentException ( " 输入的下载链接不正确！ " )
If Not File . LocalPath . ToLower . Contains ( " :\ " ) Then Throw New ArgumentException ( " 输入的本地文件地址不正确！ " )
If File . LocalPath . EndsWithF ( " \ " ) Then Throw New ArgumentException ( " 请输入含文件名的完整文件路径！ " )
If Not File . LocalPath . ToLower . Contains ( " :\ " ) Then Throw New ArgumentException ( " 输入的本地文件地址不正确： " & File . LocalPath )
If File . LocalPath . EndsWithF ( " \ " ) Then Throw New ArgumentException ( " 请输入含文件名的完整文件路径： " & File . LocalPath )
'文件夹检测
Dim DirPath As String = New FileInfo ( File . LocalPath ) . Directory . FullName
If Not Directory . Exists ( DirPath ) Then Directory . CreateDirectory ( DirPath )
@@ -1522,12 +1635,12 @@ Retry:
If State > LoadState . Loading Then Return
If ExList Is Nothing OrElse Not ExList . Any ( ) Then ExList = New List ( Of Exception ) From { New Exception ( " 未知错误！ " ) }
'寻找有效的错误信息
Dim UsefulExs = ExList . Where ( Function ( e ) TypeOf e IsNot TaskCanceledException AndAlso TypeOf e IsNot ThreadInterruptedException ) . ToList
Dim UsefulExs = ExList . Where ( Function ( e ) TypeOf e IsNot OperationCanceledException AndAlso TypeOf e IsNot ThreadInterruptedException ) . ToList
[ Error ] = If ( UsefulExs . FirstOrDefault , ExList . FirstOrDefault )
'获取实际失败的文件
For Each File In Files
If File . State <> NetState . Error Then Continue For
Dim Detail As String = Join ( File . Sources . Select ( Function ( s ) $ " {If(s.Ex?.Message , " 无错误信息 。 " ） （ ） " ) , vbCrLf )
Dim Detail As String = Join ( File . Sources . Select ( Function ( s ) $ " {If(s.Ex Is Nothing , " 无错误信息 。 " , s.Ex.GetBrief()) }（ ） " ) , vbCrLf )
[ Error ] = New Exception ( " 文件下载失败： " & File . LocalPath & vbCrLf &
" 各下载源的错误如下： " & vbCrLf & Detail ,
[ Error ] )
@@ -1547,7 +1660,7 @@ Retry:
'在退出同步锁后再进行日志输出
Dim ErrOutput As New List ( Of String )
For Each Ex As Exception In ExList
ErrOutput . Add ( GetExceptionDetail ( Ex ) )
ErrOutput . Add ( Ex . GetDetail ( ) )
Next
Log ( " [Download] " & Join ( ErrOutput . Distinct . ToArray , vbCrLf ) )
End Sub
@@ -1697,7 +1810,7 @@ Retry:
For Each File As NetFile In WaitingFiles
If NetTaskThreadCount >= NetTaskThreadLimit Then Continue While '最大线程数检查
Dim NewThread = File . TryBeginThread ( )
If NewThread IsNot Nothing AndAlso NewThread . Source . Url . Contains ( " bmclapi " ) Then Thread . Sleep ( 30 ) '减少 BMCLAPI 请求频率（目前每分钟限制 4000 次）
If NewThread IsNot Nothing AndAlso NewThread . Source . Url . Contains ( " bmclapi " ) Then Thread . Sleep ( 40 ) '减少 BMCLAPI 请求频率（目前每分钟限制 4000 次）
Next
'为进行中的文件追加线程
If Speed >= NetTaskSpeedLimitLow Then Continue While '下载速度足够，无需新增
@@ -1717,7 +1830,7 @@ Retry:
'新增线程
If PreparingCount > DownloadingCount Then Continue For '准备中的线程已多于下载中的线程，不再新增
Dim NewThread = File . TryBeginThread ( )
If NewThread IsNot Nothing AndAlso NewThread . Source . Url . Contains ( " bmclapi " ) Then Thread . Sleep ( 30 ) '减少 BMCLAPI 请求频率（目前每分钟限制 4000 次）
If NewThread IsNot Nothing AndAlso NewThread . Source . Url . Contains ( " bmclapi " ) Then Thread . Sleep ( 40 ) '减少 BMCLAPI 请求频率（目前每分钟限制 4000 次）
Next
End While
Catch ex As Exception
@@ -1842,4 +1955,15 @@ Retry:
End If
End Function
''' <summary>
''' 判断某个 Exception 是否为网络问题所导致。
''' </summary>
<Extension> Public Function IsNetworkRelated ( Ex As Exception ) As Boolean
If TypeOf Ex Is DnsLookupException Then Return True
Dim Detail = Ex . GetDetail ( )
If Detail . Contains ( " (403) " ) Then Return False
Return { " (408) " , " 超时 " , " timeout " , " 网络请求失败 " , " 连接尝试失败 " , " 远程主机强迫关闭了 " , " 远程方已关闭传输流 " , " 未能解析此远程名称 " , " 由于目标计算机积极拒绝 " } .
Any ( Function ( k ) Detail . ContainsF ( k , True ) )
End Function
End Module
龙腾猫跃