This commit is contained in:
龙腾猫跃
2025-09-10 01:07:30 +08:00
parent ee385912f8
commit 2210da6fda
62 changed files with 2620 additions and 2122 deletions
+35 -27
View File
@@ -13,13 +13,13 @@ Public Module ModBase
#Region "声明"
'下列版本信息由更新器自动修改
Public Const VersionBaseName As String = "2.10.6" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.10.6." & VersionBranchCode '标准格式的四段式版本号
Public Const VersionBaseName As String = "2.10.7" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.10.7." & VersionBranchCode '标准格式的四段式版本号
Public Const CommitHash As String = "" 'Commit Hash,由 GitHub Workflow 自动替换
#If BETA Then
Public Const VersionCode As Integer = 367 'Release
#Else
Public Const VersionCode As Integer = 366 'Snapshot
Public Const VersionCode As Integer = 368 'Snapshot
#End If
'自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -1283,7 +1283,7 @@ Re:
Return Nothing
Catch ex As Exception
Log(ex, "检查文件出错")
Return GetExceptionSummary(ex)
Return ex.GetBrief()
End Try
End Function
End Class
@@ -1329,6 +1329,14 @@ Re:
''' </summary>
Public Function DeleteDirectory(Path As String, Optional IgnoreIssue As Boolean = False) As Integer
If Not Directory.Exists(Path) Then Return 0
If Not Path.EndsWithF("\") Then Path &= "\"
If Path.EndsWith(":\") OrElse
Path = Environment.GetFolderPath(Environment.SpecialFolder.Desktop) & "\" OrElse
Path = Environment.GetFolderPath(Environment.SpecialFolder.DesktopDirectory) & "\" OrElse
Path = Environment.GetFolderPath(Environment.SpecialFolder.MyDocuments) & "\" Then '#7030
Throw New UnauthorizedAccessException("这是重要的系统文件夹,无法删除:" & Path)
End If
'实际删除
Dim DeletedCount As Integer = 0
Dim Files As String()
Try
@@ -1364,6 +1372,7 @@ RetryFile:
RetryDir:
Try
Directory.Delete(Path, True)
Catch ex As DirectoryNotFoundException
Catch ex As Exception
If Not RetriedDir AndAlso Not RunInUi() Then
RetriedDir = True
@@ -1420,10 +1429,10 @@ RetryDir:
Public vbRQ As Char = Convert.ToChar(8221)
''' <summary>
''' 提取 Exception 的具体描述与堆栈。
''' 提取 Exception 与 Inner Exception 的详细描述与堆栈信息。返回内容总是多于一行。
''' </summary>
''' <param name="ShowAllStacks">是否必须显示所有堆栈。通常用于判定堆栈信息。</param>
Public Function GetExceptionDetail(Ex As Exception, Optional ShowAllStacks As Boolean = False) As String
<Extension> Public Function GetDetail(Ex As Exception, Optional ShowAllStacks As Boolean = False) As String
If Ex Is Nothing Then Return "无可用错误信息!"
'获取最底层的异常
@@ -1450,17 +1459,17 @@ RetryDir:
Loop
'构造输出信息
Dim CommonReason As String = AnalyzeCommonReason(InnerEx, DescList)
If CommonReason Is Nothing Then
Dim UsualReason As String = AnalyzeUsualReason(InnerEx, Ex, DescList)
If UsualReason Is Nothing Then
Return DescList.Join(vbCrLf)
Else
Return CommonReason & vbCrLf & vbCrLf & "————————————" & vbCrLf & "详细错误信息:" & vbCrLf & DescList.Join(vbCrLf)
Return UsualReason & vbCrLf & vbCrLf & "————————————" & vbCrLf & "详细错误信息:" & vbCrLf & DescList.Join(vbCrLf)
End If
End Function
''' <summary>
''' 提取 Exception 描述,汇总到一行。
''' 提取 Exception 与 Inner Exception 的描述,汇总到一行。
''' </summary>
Public Function GetExceptionSummary(Ex As Exception) As String
<Extension> Public Function GetBrief(Ex As Exception) As String
If Ex Is Nothing Then Return "无可用错误信息!"
'获取最底层的异常
@@ -1479,28 +1488,27 @@ RetryDir:
Dim Desc As String = Join(DescList, vbCrLf & "→ ")
'构造输出信息
Dim CommonReason As String = AnalyzeCommonReason(InnerEx, DescList)
If CommonReason IsNot Nothing Then
Return CommonReason & "详细错误:" & DescList.First
Dim UsualReason As String = AnalyzeUsualReason(InnerEx, Ex, DescList)
If UsualReason IsNot Nothing Then
Return UsualReason & "详细错误:" & DescList.First
Else
DescList.Reverse() '让最深层错误在最左边
Return Join(DescList, " ← ")
End If
End Function
Private Function AnalyzeCommonReason(InnerEx As Exception, DescList As List(Of String)) As String
Private Function AnalyzeUsualReason(InnerEx As Exception, OuterEx As Exception, DescList As List(Of String)) As String
If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then
Return "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装,请先卸载较新版本的 .NET Framework,然后再尝试安装。"
ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then
Return "PCL 的权限不足。请尝试右键 PCL,选择以管理员身份运行。"
Return "PCL 的权限不足。请尝试右键 PCL 选择以管理员身份运行,或将目标从 C 盘或桌面挪到其他硬盘。"
ElseIf TypeOf InnerEx Is OutOfMemoryException Then
Return "你的电脑运行内存不足,导致 PCL 无法继续运行。请在关闭一部分不需要的程序后再试。"
ElseIf TypeOf InnerEx Is Runtime.InteropServices.COMException Then
Return "由于操作系统或显卡存在问题,导致出现错误。请尝试重启 PCL。"
ElseIf TypeOf InnerEx Is SocketException AndAlso DescList.Any(Function(l) l.Contains("WSAStartup")) Then
Return "请尝试卸载中国移动云盘,然后再试。"
ElseIf {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝",
"操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) DescList.Any(Function(l) l.Contains(s))) Then
Return "你的网络环境不佳,导致难以连接到服务器。请稍后重试,或使用 VPN 以改善网络环境。"
ElseIf OuterEx.IsNetworkRelated() Then
Return "你的网络环境不佳,请稍后再试,或使用 VPN 改善网络环境。"
Else
Return Nothing
End If
@@ -2981,10 +2989,10 @@ Retry:
If TypeOf Ex Is ThreadInterruptedException Then Return
'获取错误信息
Dim ExFull As String = Desc & ":" & GetExceptionDetail(Ex)
Dim ExFull As String = $"{Desc}:{Ex.GetDetail()}"
'输出日志
Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Desc}:{GetExceptionDetail(Ex, True)}{vbCrLf}" '减轻同步锁占用
Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Desc}:{Ex.GetDetail(True)}{vbCrLf}" '减轻同步锁占用
If ModeDebug Then
SyncLock LogListLock
LogList.Append(AppendText)
@@ -3002,19 +3010,19 @@ Retry:
Case LogLevel.Normal
#If DEBUG Then
Case LogLevel.Developer
Dim ExLine As String = Desc & ":" & GetExceptionSummary(Ex)
Dim ExLine As String = Desc & ":" & Ex.GetBrief()
Hint("[开发者模式] " & ExLine, HintType.Info, False)
Case LogLevel.Debug
Dim ExLine As String = Desc & ":" & GetExceptionSummary(Ex)
Dim ExLine As String = Desc & ":" & Ex.GetBrief()
Hint("[调试模式] " & ExLine, HintType.Info, False)
#Else
Case LogLevel.Developer
Case LogLevel.Debug
Dim ExLine As String = Desc & ":" & GetExceptionSummary(Ex)
Dim ExLine As String = Desc & ":" & Ex.GetBrief()
If ModeDebug Then Hint("[调试模式] " & ExLine, HintType.Info, False)
#End If
Case LogLevel.Hint
Dim ExLine As String = Desc & ":" & GetExceptionSummary(Ex)
Dim ExLine As String = Desc & ":" & Ex.GetBrief()
Hint(ExLine, HintType.Critical, False)
Case LogLevel.Msgbox
MyMsgBox(ExFull, Title, IsWarn:=True)
@@ -3093,8 +3101,8 @@ Retry:
Url &= "&" & WebUtility.UrlEncode(Datas(i)) & "=" & WebUtility.UrlEncode(Datas(i + 1).Replace(vbCrLf, vbLf))
Next
NetRequestByClient(Url, MakeLog:=False)
Catch
Log("[System] 匿名数据上报失败", LogLevel.Debug)
Catch ex As Exception
Log(ex, "匿名数据上报失败")
End Try
End Sub, "Telemetry", ThreadPriority.Lowest)
End Sub
@@ -290,11 +290,12 @@
'检验输入以确定情况
If IsForceRestart Then Return True '强制要求重启
If ((Input Is Nothing) <> (Me.Input Is Nothing)) OrElse (Input IsNot Nothing AndAlso Not Input.Equals(Me.Input)) Then Return True '输入不同
If (State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已结束
(IgnoreReloadTimeout OrElse ReloadTimeout = -1 OrElse LastFinishedTime = 0 OrElse GetTimeTick() - LastFinishedTime < ReloadTimeout) Then '没有超时
Return False '则不重试
If (State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已结束…
(IgnoreReloadTimeout OrElse ReloadTimeout = -1 OrElse
LastFinishedTime = 0 OrElse GetTimeTick() - LastFinishedTime < ReloadTimeout) Then '…且没有超时…
Return False '…则不重试
Else
Return True '需要开始
Return True '否则需要重启
End If
End Function
Public Overrides Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False)
+337 -213
View File
@@ -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)}),{Method},{Url}" &
$"错误码 {Response.StatusCode} ({CInt(Response.StatusCode)}),{Method},{Url},{HostIp}" &
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},{HostIp})", WebExceptionStatus.Timeout)
Else
Throw New Exception($"网络请求出现意外异常({Method}, {Url},{HostIp})", 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},{Th.Source.Url}")
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)}),{Th.Source.Url}") '状态码检查
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}:ContentLength 返回了 -1,无法确定是否支持分段下载,视作不支持")
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}({GetString(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},ContentLength {ContentLength}")
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)}),{Th.Source.Url}") '状态码检查
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}:ContentLength 返回了 -1,无法确定是否支持分段下载,视作不支持")
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}({GetString(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},ContentLength {ContentLength}")
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}({Th.DownloadStart}~{Th.DownloadEnd})")
RecordIPReliability(HostIp, 0.5)
End If
Catch ex As Exception
Log($"[Download] {LocalName}:出错,{If(TypeOf ex Is TaskCanceledException, $"已超时({Timeout}ms)", GetExceptionDetail(ex))}")
Log($"[Download] {LocalName}:出错,{If(TypeOf ex Is OperationCanceledException, $"已超时({Timeout}ms)", ex.GetDetail())},{HostIp}")
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, "无错误信息。")}({s.Url})"), vbCrLf)
Dim Detail As String = Join(File.Sources.Select(Function(s) $"{If(s.Ex Is Nothing, "无错误信息。", s.Ex.GetBrief())}({s.Url})"), 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
@@ -191,7 +191,7 @@ Public Class ValidateExceptSame
Me.ErrorMessage = ErrorMessage
Me.IgnoreCase = IgnoreCase
End Sub
Public Sub New(Excepts As IEnumerable, Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False)
Public Sub New(Excepts As IEnumerable(Of String), Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False)
Me.Excepts = New ObjectModel.Collection(Of String)
For Each Data As String In Excepts
Me.Excepts.Add(Data)
@@ -199,6 +199,11 @@ Public Class ValidateExceptSame
Me.ErrorMessage = ErrorMessage
Me.IgnoreCase = IgnoreCase
End Sub
Public Sub New(Except As String, Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False)
Me.Excepts = New ObjectModel.Collection(Of String) From {Except}
Me.ErrorMessage = ErrorMessage
Me.IgnoreCase = IgnoreCase
End Sub
Public Overrides Function Validate(Str As String) As String
If Str Is Nothing Then Return ErrorMessage.Replace("%", "null")
For Each Ch As String In Excepts
@@ -347,7 +347,7 @@
Case 4475 : Tags.Add("冒险")
Case 4476 : Tags.Add("探索")
Case 4477 : Tags.Add("小游戏")
Case 4471 : Tags.Add("科幻")
Case 4474 : Tags.Add("科幻")
Case 4736 : Tags.Add("空岛")
Case 5128 : Tags.Add("原版改良")
Case 4487 : Tags.Add("FTB")
@@ -1161,9 +1161,9 @@ Retry:
ElseIf [Error] IsNot Nothing Then
'有结果但是有错误
If CurseForgeFailed Then
Storage.ErrorMessage = $"无法连接到 CurseForge,所以目前仅显示了来自 Modrinth 的内容,搜索结果可能不全。{vbCrLf}请稍后重试,或使用 VPN 以改善网络环境。"
Storage.ErrorMessage = $"无法连接到 CurseForge,所以目前仅显示了来自 Modrinth 的内容,搜索结果可能不全。{vbCrLf}请稍后再试,或使用 VPN 改善网络环境。"
Else
Storage.ErrorMessage = $"无法连接到 Modrinth,所以目前仅显示了来自 CurseForge 的内容,搜索结果可能不全。{vbCrLf}请稍后重试,或使用 VPN 以改善网络环境。"
Storage.ErrorMessage = $"无法连接到 Modrinth,所以目前仅显示了来自 CurseForge 的内容,搜索结果可能不全。{vbCrLf}请稍后再试,或使用 VPN 改善网络环境。"
End If
End If
@@ -1354,7 +1354,7 @@ Retry:
''' </summary>
''' <param name="LocalAddress">目标本地文件夹,或完整的文件路径。会自动判断类型。</param>
Public Function ToNetFile(LocalAddress As String) As NetFile
Return New NetFile(DownloadUrls, LocalAddress & If(LocalAddress.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash), UseBrowserUserAgent:=True)
Return New NetFile(DownloadUrls, LocalAddress & If(LocalAddress.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash), SimulateBrowserHeaders:=True)
End Function
'实例化
@@ -1395,10 +1395,9 @@ Retry:
If Hash Is Nothing Then Hash = CType(Data("hashes"), JArray).ToList.FirstOrDefault(Function(s) s("algo").ToObject(Of Integer) = 2)?("value")
'DownloadAddress
Dim Url = Data("downloadUrl").ToString
If Url = "" Then Url = $"https://media.forgecdn.net/files/{CInt(Id.ToString.Substring(0, 4))}/{CInt(Id.ToString.Substring(4))}/{FileName}"
Url = Url.Replace(FileName, WebUtility.UrlEncode(FileName)) '对文件名进行编码
DownloadUrls = HandleCurseForgeDownloadUrls(Url) '对脑残 CurseForge 的下载地址进行多种修正
DownloadUrls.AddRange(DownloadUrls.Select(Function(u) DlSourceModGet(u)).ToList) '添加镜像源,这个写法是为了让镜像源排在后面
If Url = "" Then Url = $"https://edge.forgecdn.net/files/{CInt(Id.ToString.Substring(0, 4))}/{CInt(Id.ToString.Substring(4))}/{FileName}"
DownloadUrls = HandleCurseForgeDownloadUrls(Url.Replace(FileName, WebUtility.UrlEncode(FileName))) '对脑残 CurseForge 的下载地址进行多种修正
DownloadUrls.Add(DlSourceModGet(Url)) '添加镜像源;注意 MCIM 源不支持 URL 编码后的文件名,必须传入 URL 编码前的文件名
DownloadUrls = DownloadUrls.Distinct.ToList '最终去重
'Dependencies
If Data.ContainsKey("dependencies") Then
@@ -485,7 +485,7 @@ Done:
'崩溃报告分析,高优先级
If LogCrash IsNot Nothing Then
If LogCrash.Contains("Unable to make protected final java.lang.Class java.lang.ClassLoader.defineClass") Then AppendReason(CrashReason.Java版本过高)
If LogCrash.Contains("Failed loading config file ") Then AppendReason(CrashReason.Mod配置文件导致游戏崩溃, {TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Failed loading config file .+ for modid )[^\n]+"), "").TrimEnd(vbCrLf)).First, If(RegexSeek(LogCrash, "(?<=Failed loading config file ).+(?= of type)"), "").TrimEnd(vbCrLf)})
If LogCrash.Contains("Failed loading config file ") Then AppendReason(CrashReason.Mod配置文件导致游戏崩溃, {TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Failed loading config file .+ for modid )[^\n]+"), "").TrimEnd(vbCrLf)).First, If(RegexSeek(LogCrash, "(?<=Failed loading config file ).+(?= of type)"), "").TrimEnd(vbCrLf)}) '#7071
End If
'游戏日志分析
@@ -542,8 +542,8 @@ Done:
If LogMc.Contains("Found a duplicate mod") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "Found a duplicate mod[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
If LogMc.Contains("Found duplicate mods") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=Mod ID: ')\w+?(?=' from mod files:)").Distinct.ToList)
If LogMc.Contains("ModResolutionException: Duplicate") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "ModResolutionException: Duplicate[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
If LogMc.Contains("Incompatible mods found!") Then '#5006
AppendReason(CrashReason.Mod互不兼容, If(RegexSeek(LogMc, "(?<=Incompatible mods found![\s\S]+: )[\s\S]+?(?=\tat )"), ""))
If LogMc.Contains("Incompatible mods found!") Then '#5006, #5115
AppendReason(CrashReason.Mod互不兼容, If(RegexSeek(LogMc, "(?<=Incompatible mods found![\s\S]+: )[\s\S]+?(?=\tat )"), "").BeforeFirst("更多信息:").Replace("Some of your mods are incompatible with the game or each other!", "").Trim((vbCrLf & " ").ToCharArray))
End If
If LogMc.Contains("Missing or unsupported mandatory dependencies:") Then
AppendReason(CrashReason.Mod缺少前置或MC版本错误,
@@ -581,6 +581,7 @@ Done:
End If
If LogCrash.Contains("Multiple entries with same key: ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Multiple entries with same key: )[^=]+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
If LogCrash.Contains("LoaderExceptionModCrash: Caught exception from ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=LoaderExceptionModCrash: Caught exception from )[^\n]+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
If LogCrash.Contains("Failed loading config file ") Then AppendReason(CrashReason.Mod配置文件导致游戏崩溃, {TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Failed loading config file .+ for modid )[^\n]+"), "").TrimEnd(vbCrLf)).First, If(RegexSeek(LogCrash, "(?<=Failed loading config file ).+(?= of type)"), "").TrimEnd(vbCrLf)})
End If
End Sub
@@ -658,7 +659,7 @@ Done:
End If
'Mod 解析错误(常见于 Fabric 前置校验失败)
If LogMc.Contains("Mod resolution failed") Then AppendReason(CrashReason.Mod加载器报错)
'Mixin 失败可以导致大量 Mod 实例创建失败
'Mixin 失败可以导致大量 Mod 实例创建失败,因此需要放到低优先级中
If LogMc.Contains("Failed to create mod instance.") Then AppendReason(CrashReason.Mod初始化失败, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModID: )[^,]+"), If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModId )[^\n]+(?= for )"), "")).TrimEnd(vbCrLf)))
'注意:Fabric 的 Warnings were found! 不一定是崩溃原因,它可能是单纯的警报
End If
@@ -717,7 +718,7 @@ NextStack:
"preinit", "preload", "machine", "reflect", "channel", "general", "handler", "content", "systems", "modules", "service",
"fastutil", "optifine", "internal", "platform", "override", "fabricmc", "neoforge",
"injection", "listeners", "scheduler", "minecraft", "universal", "multipart", "neoforged", "microsoft",
"transformer", "transformers", "minecraftforge", "blockentity", "spongepowered", "electronwill"
"transformer", "transformers", "minecraftforge", "blockentity", "spongepowered", "electronwill", "concurrent"
}.Contains(Word.ToLower) Then Continue For
PossibleWords.Add(Word.Trim)
Next
@@ -949,7 +950,7 @@ NextStack:
Dim Additional As List(Of String) = Reason.Value
Select Case Reason.Key
Case CrashReason.Java虚拟机参数有误
Results.Add("由于 Java 虚拟机参数有误,导致游戏无法继续运行。\n请检查高级启动选项中设置的 Java 虚拟机参数是否有误。")
Results.Add("由于 Java 参数有误,导致游戏无法继续运行。\n请检查高级选项中的 Java 虚拟机参数和游戏参数设置是否有误。")
Case CrashReason.Mod文件被解压
Results.Add("由于 Mod 文件被解压了,导致游戏无法继续运行。\n直接把整个 Mod 文件放进 Mod 文件夹中即可,若解压就会导致游戏出错。\n\n请删除 Mod 文件夹中已被解压的 Mod,然后再启动游戏。")
Case CrashReason.内存不足
@@ -1030,14 +1031,17 @@ NextStack:
End If
Case CrashReason.特定实体导致崩溃
If Additional.Count = 1 Then
Dim entityInfo As String = Additional.First
If entityInfo.StartsWith("minecraft:player") Then
Results.Add("游戏似乎因为玩家实体 " & entityInfo & " 出现了问题。\n\n这通常是因为玩家数据损坏或世界存档问题导致的。\n请尝试以下解决方案:\n - 创建一个新世界,观察游戏是否正常运行\n - 如果新世界正常,可能需要删除或修复当前世界的玩家数据文件\n - 也可能是某个 Mod 与玩家实体处理存在冲突,尝试逐个禁用近期安装的 Mod\n - 如果问题持续存在,建议备份重要数据后重新创建世界\h")
If Additional.First.Contains("minecraft:player") Then
If Additional.First.Contains(" ") Then
Results.Add($"游戏因为位于 {Additional.First.AfterFirst(" ")} 的玩家实体导致了崩溃。\h")
Else
Results.Add($"游戏因为玩家实体导致了崩溃。\h")
End If
Else
Results.Add("游戏似乎因为实体 " & entityInfo & " 出现了问题。\n\n请尝试以下解决方案:\n - 创建一个新世界,并尝试生成该类型的实体,观察游戏运行情况\n - 如果新世界中该实体正常,问题可能在于当前世界的数据损坏\n - 如果新世界中仍然崩溃,可能是某个 Mod 导致了实体处理异常\n - 尝试逐个禁用可能影响实体的 Mod(如生物类、AI 类 Mod)\n - 也可以尝试使用指令删除该坐标附近的实体\h")
Results.Add($"游戏因为实体 {Additional.First} 导致了崩溃。\h")
End If
Else
Results.Add("游戏似乎因为世界中的某些实体出现了问题。\n\n请尝试以下解决方案:\n - 创建一个新世界,观察游戏的运行情况\n - 如果新世界正常运行,则是当前世界的实体数据导致出错\n - 可以尝试使用指令清理异常实体\n - 如果问题持续存在,可能是某个处理实体的 Mod 存在问题\n - 建议逐个禁用近期安装的 Mod,特别是涉及生物、AI 或实体处理的 Mod\h")
Results.Add($"游戏因为下列实体导致了崩溃:{Additional.Join("、")}\h")
End If
Case CrashReason.OptiFine与Forge不兼容
Results.Add("由于 OptiFine 与当前版本的 Forge 不兼容,导致了游戏崩溃。\n\n请前往 OptiFine 官网(https://optifine.net/downloads)查看 OptiFine 所兼容的 Forge 版本,并严格按照对应版本重新安装游戏。")
@@ -198,7 +198,7 @@
Private IsNewClientVersionHinted As Boolean = False
Private Sub DlClientListMojangMain(Loader As LoaderTask(Of String, DlClientListResult))
Dim StartTime As Long = GetTimeTick()
Dim Json As JObject = GetJson(NetRequestByClientRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json"))
Dim Json As JObject = GetJson(NetRequestByClientRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json", RequireJson:=True))
Try
Dim Versions As JArray = Json("versions")
If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Json.ToString & ")")
@@ -235,7 +235,7 @@
''' </summary>
Public DlClientListBmclapiLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Bmclapi", AddressOf DlClientListBmclapiMain)
Private Sub DlClientListBmclapiMain(Loader As LoaderTask(Of String, DlClientListResult))
Dim Json As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json"))
Dim Json As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json", RequireJson:=True))
Try
Dim Versions As JArray = Json("versions")
If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Json.ToString & ")")
@@ -413,7 +413,7 @@
''' </summary>
Public DlOptiFineListBmclapiLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Bmclapi", AddressOf DlOptiFineListBmclapiMain)
Private Sub DlOptiFineListBmclapiMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult))
Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/optifine/versionList"))
Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/optifine/versionList", RequireJson:=True))
Try
Dim Versions As New List(Of DlOptiFineListEntry)
For Each Token As JObject In Json
@@ -483,7 +483,7 @@
''' </summary>
Public DlForgeListOfficialLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Official", AddressOf DlForgeListOfficialMain)
Private Sub DlForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlForgeListResult))
Dim Result As String = NetRequestByClientRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding:=Encoding.Default, Accept:="text/html", UseBrowserUserAgent:=True)
Dim Result As String = NetRequestByClientRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding:=Encoding.Default, Accept:="text/html", SimulateBrowserHeaders:=True)
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Result & ")")
'获取所有版本信息
Dim Names As List(Of String) = RegexSearch(Result, "(?<=a href=""index_)[0-9.]+(_pre[0-9]?)?(?=.html)")
@@ -631,9 +631,9 @@
Try
Result = NetRequestByLoader("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" &
Loader.Input.Replace("-", "_") & '兼容 Forge 1.7.10-pre4,#4057
".html", UseBrowserUserAgent:=True)
".html", SimulateBrowserHeaders:=True)
Catch ex As Exception
If GetExceptionSummary(ex).Contains("(404)") Then
If ex.GetBrief().Contains("(404)") Then
Throw New Exception("不可用")
Else
Throw
@@ -701,7 +701,7 @@
''' </summary>
Public Sub DlForgeVersionBmclapiMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" &
Loader.Input.Replace("-", "_"))) '兼容 Forge 1.7.10-pre4,#4057
Loader.Input.Replace("-", "_"), RequireJson:=True)) '兼容 Forge 1.7.10-pre4,#4057
Dim Versions As New List(Of DlForgeVersionEntry)
Try
Dim Recommended As String = McDownloadForgeRecommendedGet(Loader.Input)
@@ -835,8 +835,8 @@
Public DlNeoForgeListOfficialLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Official", AddressOf DlNeoForgeListOfficialMain)
Private Sub DlNeoForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
'获取版本列表 JSON
Dim ResultLatest As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge")
Dim ResultLegacy As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge")
Dim ResultLatest As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge", RequireJson:=True)
Dim ResultLegacy As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge", RequireJson:=True)
If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足(" & ResultLatest & ")")
'解析
Try
@@ -853,8 +853,8 @@
Public DlNeoForgeListBmclapiLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Bmclapi", AddressOf DlNeoForgeListBmclapiMain)
Public Sub DlNeoForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
'获取版本列表 JSON
Dim ResultLatest As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge")
Dim ResultLegacy As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge")
Dim ResultLatest As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge", RequireJson:=True)
Dim ResultLegacy As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge", RequireJson:=True)
If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足(" & ResultLatest & ")")
'解析
Try
@@ -959,7 +959,7 @@
''' </summary>
Public DlLiteLoaderListOfficialLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Official", AddressOf DlLiteLoaderListOfficialMain)
Private Sub DlLiteLoaderListOfficialMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult))
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://dl.liteloader.com/versions/versions.json"))
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://dl.liteloader.com/versions/versions.json", RequireJson:=True))
Try
Dim Json As JObject = Result("versions")
Dim Versions As New List(Of DlLiteLoaderListEntry)
@@ -987,7 +987,7 @@
''' </summary>
Public DlLiteLoaderListBmclapiLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Bmclapi", AddressOf DlLiteLoaderListBmclapiMain)
Private Sub DlLiteLoaderListBmclapiMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult))
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json"))
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json", RequireJson:=True))
Try
Dim Json As JObject = Result("versions")
Dim Versions As New List(Of DlLiteLoaderListEntry)
@@ -1058,7 +1058,7 @@
''' </summary>
Public DlFabricListOfficialLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Official", AddressOf DlFabricListOfficialMain)
Private Sub DlFabricListOfficialMain(Loader As LoaderTask(Of Integer, DlFabricListResult))
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://meta.fabricmc.net/v2/versions"))
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://meta.fabricmc.net/v2/versions", RequireJson:=True))
Try
Dim Output = New DlFabricListResult With {.IsOfficial = True, .SourceName = "Fabric 官方源", .Value = Result}
If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项")
@@ -1073,7 +1073,7 @@
''' </summary>
Public DlFabricListBmclapiLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Bmclapi", AddressOf DlFabricListBmclapiMain)
Private Sub DlFabricListBmclapiMain(Loader As LoaderTask(Of Integer, DlFabricListResult))
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions"))
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions", RequireJson:=True))
Try
Dim Output = New DlFabricListResult With {.IsOfficial = False, .SourceName = "BMCLAPI", .Value = Result}
If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项")
@@ -1130,7 +1130,7 @@
Dim Exs As String = ""
For Each Source In Urls
Try
Return GetJson(NetRequestByClient(Source.Key, Method, Content, ContentType, Timeout:=Source.Value * 1000, Encoding:=Encoding.UTF8))
Return GetJson(NetRequestByClient(Source.Key, Method, Content, ContentType, Timeout:=Source.Value * 1000, Encoding:=Encoding.UTF8, RequireJson:=True))
Catch ex As Exception
Exs += ex.Message + vbCrLf
End Try
@@ -10,7 +10,7 @@
'路径
''' <summary>
''' Java.exe 文件的完整路径。
''' java.exe 文件的完整路径。
''' </summary>
Public ReadOnly Property PathJava As String
Get
@@ -18,15 +18,7 @@
End Get
End Property
''' <summary>
''' Javaw.exe 文件的完整路径。
''' </summary>
Public ReadOnly Property PathJavaw As String
Get
Return PathFolder & "javaw.exe"
End Get
End Property
''' <summary>
''' Javaw.exe 文件所在文件夹的路径,以 \ 结尾。
''' java.exe 文件所在文件夹的路径,以 \ 结尾。
''' </summary>
Public PathFolder As String
''' <summary>
@@ -102,20 +94,13 @@
Dim Output As String = Nothing
Try
'确定文件存在
If Not File.Exists(PathJavaw) Then
Throw New FileNotFoundException("未找到 javaw.exe 文件", PathJavaw)
End If
If Not File.Exists(PathFolder & "java.exe") Then
Throw New FileNotFoundException("未找到 java.exe 文件", PathFolder & "java.exe")
End If
If File.Exists(PathFolder & "pdf-bookmark") Then
Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326
End If
If Not File.Exists(PathJava) Then Throw New FileNotFoundException("未找到 java.exe 文件", PathJava)
If File.Exists(PathFolder & "pdf-bookmark") Then Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326
IsJre = Not File.Exists(PathFolder & "javac.exe")
'运行 -version
Output = ShellAndGetOutput(PathFolder & "java.exe", "-version", 15000).ToLower
Output = ShellAndGetOutput(PathJava, "-version", 15000).ToLower
If Output = "" Then Throw New ApplicationException("尝试运行该 Java 失败")
If ModeDebug Then Log("[Java] Java 检查输出:" & PathFolder & "java.exe" & vbCrLf & Output)
If ModeDebug Then Log("[Java] Java 检查输出:" & PathJava & vbCrLf & Output)
If Output.Contains("/lib/ext exists") Then Throw New ApplicationException("无法运行该 Java,请在删除 Java 文件夹中的 /lib/ext 文件夹后再试")
If Output.Contains("a fatal error") Then Throw New ApplicationException("无法运行该 Java,该 Java 或系统存在问题")
'获取详细信息
@@ -136,17 +121,17 @@
End If
Is64Bit = Output.Contains("64-bit")
If Version.Minor <= 4 OrElse Version.Minor >= 100 Then Throw New ApplicationException("分析详细信息失败,获取的版本为 " & Version.ToString)
'基于 #3649,在 64 位系统上禁用 32 位 Java
'#3649:在 64 位系统上禁用 32 位 Java
If Not Is64Bit AndAlso Not Is32BitSystem Then Throw New Exception("该 Java 为 32 位版本,请安装 64 位的 Java")
'基于 #2249 发现 JRE 17 似乎也导致了 Forge 安装失败,干脆禁用更多版本的 JRE
'#2249:JRE 17 似乎会导致 Forge 安装失败,干脆禁用更多版本的 JRE
If IsJre AndAlso VersionCode >= 16 Then Throw New Exception("由于高版本 JRE 对游戏的兼容性很差,因此不再允许使用。你可以使用对应版本的 JDK,而非 JRE!")
Catch ex As ApplicationException
Throw ex
Catch ex As ThreadInterruptedException
Throw ex
Catch ex As Exception
Log("[Java] 检查失败的 Java 输出:" & PathFolder & "java.exe" & vbCrLf & If(Output, "无程序输出"))
Throw New Exception("检查 Java 失败(" & If(PathJavaw, "Nothing") & ")", ex)
Log("[Java] 检查失败的 Java 输出:" & If(PathJava, "Nothing") & vbCrLf & If(Output, "无程序输出"))
Throw New Exception("检查 Java 失败(" & If(PathJava, "Nothing") & ")", ex)
End Try
IsChecked = True
End Sub
@@ -689,7 +674,7 @@ Wait:
"应用", "运行", "前置", "mojang", "官启", "新建文件夹", "eclipse", "microsoft", "hotspot",
"runtime", "x86", "x64", "forge", "原版", "optifine", "官方", "启动", "hmcl", "mod", "高清",
"download", "launch", "程序", "path", "version", "baka", "pcl", "zulu", "local", "packages",
"4297127d64ec6", "1.", "启动", "jbr-"}
"4297127d64ec6", "1.", "启动", "jbr"}
For Each FolderInfo As DirectoryInfo In OriginalPath.EnumerateDirectories
If FolderInfo.Attributes.HasFlag(FileAttributes.ReparsePoint) Then Continue For '跳过符号链接
Dim SearchEntry = GetFolderNameFromPath(FolderInfo.Name).ToLower '用于搜索的字符串
@@ -178,7 +178,7 @@ NextInner:
GoTo NextInner
Else
'没有特殊处理过的错误信息
McLaunchLog("错误:" & GetExceptionDetail(ex))
McLaunchLog("错误:" & ex.GetDetail())
Log(ex,
If(IsSavingBatch, "导出启动脚本失败", "Minecraft 启动失败"), LogLevel.Msgbox,
If(IsSavingBatch, "导出启动脚本失败", "启动失败"))
@@ -187,7 +187,7 @@ NextInner:
Telemetry("Minecraft 启动失败",
"Version", McVersionCurrent.Version.ToString,
"LoginType", GetStringFromEnum(CType(Setup.Get("LoginType"), McLoginType)),
"Exception", FilterUserName(FilterAccessToken(GetExceptionDetail(ex), "*"), "*"))
"Exception", FilterUserName(FilterAccessToken(ex.GetDetail(), "*"), "*"))
End If
Throw
End If
@@ -609,12 +609,8 @@ SkipLogin:
McLoginRequestValidate(Data)
GoTo LoginFinish
Catch ex As Exception
Dim AllMessage = GetExceptionDetail(ex)
McLaunchLog("验证登录失败:" & AllMessage)
If (AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout")) AndAlso Not AllMessage.Contains("403") Then
McLaunchLog("已触发超时登录失败")
Throw New Exception("$登录失败:你的网络环境不佳,导致难以连接到海外服务器。" & vbCrLf & "请稍后重试,或使用加速器或 VPN 以改善网络环境。")
End If
Log(ex, "验证登录失败")
If IsNetworkRelated(ex) Then Throw New Exception("$登录失败:你的网络环境不佳,导致难以连接到海外服务器。" & vbCrLf & "请稍后再试,或使用加速器、VPN 改善网络环境。")
End Try
Data.Progress = 0.25
'尝试刷新登录
@@ -624,7 +620,7 @@ Refresh:
McLoginRequestRefresh(Data, NeedRefresh)
GoTo LoginFinish
Catch ex As Exception
McLaunchLog("刷新登录失败:" & GetExceptionDetail(ex))
McLaunchLog("刷新登录失败:" & ex.GetDetail())
If WasRefreshed Then Throw New Exception("二轮刷新登录失败", ex)
End Try
Data.Progress = If(NeedRefresh, 0.85, 0.45)
@@ -634,7 +630,7 @@ Refresh:
If Data.IsAborted Then Throw New ThreadInterruptedException
NeedRefresh = McLoginRequestLogin(Data)
Catch ex As Exception
McLaunchLog("登录失败:" & GetExceptionDetail(ex))
McLaunchLog("登录失败:" & ex.GetDetail())
Throw
End Try
If NeedRefresh Then
@@ -699,7 +695,7 @@ LoginFinish:
'发送登录请求
Dim RequestData As New JObject(
New JProperty("accessToken", AccessToken), New JProperty("clientToken", ClientToken), New JProperty("requestUser", True))
NetRequestByClientRetry(
NetRequestByClient(
Data.Input.BaseUrl & "/validate", HttpMethod.Post,
Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None),
Headers:={{"Accept-Language", "zh-CN"}},
@@ -726,7 +722,7 @@ LoginFinish:
New JProperty("requestUser", True)
).ToString(Newtonsoft.Json.Formatting.None),
Headers:={{"Accept-Language", "zh-CN"}},
ContentType:="application/json; charset=utf-8"))
ContentType:="application/json; charset=utf-8", RequireJson:=True))
'将登录结果输出
If LoginJson("selectedProfile") Is Nothing Then Throw New Exception("选择的角色 " & Setup.Get("Cache" & Data.Input.Token & "Name") & " 无效!")
Data.Output.AccessToken = LoginJson("accessToken").ToString
@@ -756,7 +752,7 @@ LoginFinish:
Data.Input.BaseUrl & "/authenticate", HttpMethod.Post,
Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None),
Headers:={{"Accept-Language", "zh-CN"}},
ContentType:="application/json; charset=utf-8"))
ContentType:="application/json; charset=utf-8", RequireJson:=True))
'检查登录结果
If LoginJson("availableProfiles").Count = 0 Then
If Data.Input.ForceReselectProfile Then Hint("你还没有创建角色,无法更换!", HintType.Critical)
@@ -814,13 +810,14 @@ LoginFinish:
McLaunchLog("登录成功(Login, " & Data.Input.Token & ")")
Return NeedRefresh
Catch ex As Exception
Dim AllMessage As String = GetExceptionSummary(ex)
Dim AllMessage As String = ex.GetBrief()
Log(ex, "登录失败原始错误信息", LogLevel.Normal)
'读取服务器返回的错误
If TypeOf ex Is ResponsedWebException Then
Dim ErrorMessage As String = Nothing
Try
ErrorMessage = GetJson(DirectCast(ex, ResponsedWebException).Response)("errorMessage")
Dim Response = DirectCast(ex, ResponsedWebException).Response
If ErrorMessage.ContainsF("errorMessage", True) Then ErrorMessage = GetJson(Response)("errorMessage")
Catch
End Try
If Not String.IsNullOrWhiteSpace(ErrorMessage) Then
@@ -838,7 +835,7 @@ LoginFinish:
End If
End If
'通用关键字检测
If AllMessage.Contains("403") Then
If AllMessage.Contains("(403)") Then
Select Case Data.Input.Type
Case McLoginType.Auth
Throw New Exception("$登录失败,以下为可能的原因:" & vbCrLf &
@@ -852,8 +849,8 @@ LoginFinish:
If(Data.Input.UserName.Contains("@"), "", " - 登录账号应为邮箱或统一通行证账号,而非游戏角色 ID。" & vbCrLf) &
" - 只注册了账号,但没有加入对应服务器。")
End Select
ElseIf AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout") OrElse AllMessage.Contains("网络请求失败") OrElse AllMessage.Contains("408") OrElse AllMessage.Contains("由于连接方在一段时间后没有正确答复或连接的主机没有反应,连接尝试失败。") Then
Throw New Exception("$登录失败:你的网络环境不佳,导致难以连接到海外服务器。" & vbCrLf & "请稍后重试,或使用加速器或 VPN 以改善网络环境。")
ElseIf ex.IsNetworkRelated() Then
Throw New Exception("$登录失败:你的网络环境不佳,导致难以连接到海外服务器。" & vbCrLf & "请稍后再试,或使用加速器、VPN 改善网络环境。")
ElseIf ex.Message.StartsWithF("$") Then
Throw
Else
@@ -872,7 +869,7 @@ Retry:
McLaunchLog("开始微软登录步骤 1/6(原始登录)")
Dim PrepareJson As JObject = GetJson(NetRequestByClientRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", HttpMethod.Post,
Content:=$"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access",
ContentType:="application/x-www-form-urlencoded"))
ContentType:="application/x-www-form-urlencoded", RequireJson:=True))
McLaunchLog("网页登录地址:" & PrepareJson("verification_uri").ToString)
'弹窗
@@ -907,6 +904,7 @@ Retry:
Headers:={{"Accept-Language", "en-US,en;q=0.5"}, {"X-Requested-With", "XMLHttpRequest"}},
ThreadCount:=2)
Catch ex As ResponsedWebException
'修改错误列表时,同时检查 MyMsgLogin.xaml.vb 中的对应代码
Dim Response = ex.Response
If Response.ContainsF("must sign in again", True) OrElse Response.ContainsF("password expired", True) OrElse
(Response.Contains("refresh_token") AndAlso Response.Contains("is not valid")) Then '#269
@@ -941,7 +939,7 @@ Retry:
""TokenType"": ""JWT""
}"
Dim Result As String = NetRequestByClientMultiple("https://user.auth.xboxlive.com/user/authenticate", HttpMethod.Post,
Content:=Request, ContentType:="application/json")
Content:=Request, ContentType:="application/json", RequireJson:=True)
Dim ResultJson As JObject = GetJson(Result)
Dim XBLToken As String = ResultJson("Token").ToString
Return XBLToken
@@ -963,7 +961,7 @@ Retry:
Dim Result As String
Try
Result = NetRequestByClientMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", HttpMethod.Post,
Content:=Request, ContentType:="application/json")
Content:=Request, ContentType:="application/json", RequireJson:=True)
Catch ex As ResponsedWebException
'参考 https://github.com/PrismarineJS/prismarine-auth/blob/master/src/common/Constants.js
If ex.Response.Contains("2148916227") Then
@@ -975,7 +973,7 @@ Retry:
End If
Throw New Exception("$$")
ElseIf ex.Response.Contains("2148916235") Then
MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请使用加速器或 VPN。", "登录失败", "我知道了")
MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请使用加速器或 VPN,然后再试。", "登录失败", "我知道了")
Throw New Exception("$$")
ElseIf ex.Response.Contains("2148916238") Then
If MyMsgBox("该账号年龄不足,你需要先修改出生日期,然后才能登录。" & vbCrLf &
@@ -994,15 +992,11 @@ Retry:
End If
End Try
Try '这个 Try 块仅为了追踪 #6683 而添加
Dim ResultJson As JObject = GetJson(Result)
Dim XSTSToken As String = ResultJson("Token").ToString
Dim UHS As String = ResultJson("DisplayClaims")("xui")(0)("uhs").ToString
Return {XSTSToken, UHS}
Catch
Log("[Launch] 返回内容:" & vbCrLf & Result)
Throw
End Try
Dim ResultJson As JObject = GetJson(Result)
Return {
ResultJson("Token"), 'XSTSToken
ResultJson("DisplayClaims")("xui")(0)("uhs") 'UHS
}
End Function
'微软登录步骤 4:从 {XSTSToken, UHS} 获取 Minecraft AccessToken
Private Function MsLoginStep4(Tokens As String()) As String
@@ -1012,9 +1006,9 @@ Retry:
Dim Result As String
Try
Result = NetRequestByClientRetry("https://api.minecraftservices.com/authentication/login_with_xbox", HttpMethod.Post,
Content:=Request, ContentType:="application/json")
Content:=Request, ContentType:="application/json", RequireJson:=True)
Catch ex As Net.WebException
Dim Message As String = GetExceptionSummary(ex)
Dim Message As String = ex.GetBrief()
If Message.Contains("(429)") Then
Log(ex, "微软登录第 4 步汇报 429")
Throw New Exception("$登录尝试太过频繁,请等待几分钟后再试!")
@@ -1026,16 +1020,14 @@ Retry:
End If
End Try
Dim ResultJson As JObject = GetJson(Result)
Dim AccessToken As String = ResultJson("access_token").ToString
Return AccessToken
Return GetJson(Result)("access_token").ToString
End Function
'微软登录步骤 5:验证微软账号是否持有 MC,这也会刷新 XGP
Private Sub MsLoginStep5(AccessToken As String)
McLaunchLog("开始微软登录步骤 5/6")
Dim Result As String = NetRequestByClientMultiple("https://api.minecraftservices.com/entitlements/mcstore",
ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}})
ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}}, RequireJson:=True)
Try
Dim ResultJson As JObject = GetJson(Result)
If Not (ResultJson.ContainsKey("items") AndAlso ResultJson("items").Any) Then
@@ -1057,9 +1049,9 @@ Retry:
Dim Result As String
Try
Result = NetRequestByClientMultiple("https://api.minecraftservices.com/minecraft/profile",
ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}})
Catch ex As Net.WebException
Dim Message As String = GetExceptionSummary(ex)
ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}}, RequireJson:=True)
Catch ex As WebException
Dim Message As String = ex.GetBrief()
If Message.Contains("(429)") Then
Log(ex, "微软登录第 6 步汇报 429")
Throw New Exception("$登录尝试太过频繁,请等待几分钟后再试!")
@@ -1130,7 +1122,7 @@ Retry:
If Len(Uuid) = 32 Then Return Uuid
'从官网获取
Try
Dim GotJson As JObject = GetJson(NetRequestByClientRetry("https://api.mojang.com/users/profiles/minecraft/" & Name))
Dim GotJson As JObject = GetJson(NetRequestByClientRetry("https://api.mojang.com/users/profiles/minecraft/" & Name, RequireJson:=True))
If GotJson Is Nothing Then Throw New FileNotFoundException("正版玩家档案不存在(" & Name & ")")
Uuid = If(GotJson("id"), "")
Catch ex As Exception
@@ -1495,6 +1487,9 @@ Retry:
DataList.Add(Version.JsonObject("mainClass"))
End If
'处理 DataList 的换行符
DataList = DataList.Select(Function(d) d.Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, " ").Trim).ToList
Return Join(DataList, " ")
End Function
Private Function McLaunchArgumentsJvmNew(Version As McVersion) As String
@@ -1538,9 +1533,7 @@ NextVersion:
'Authlib-Injector
If McLoginLoader.Output.Type = "Auth" Then
If McLaunchJavaSelected.VersionCode >= 6 Then DataList.Add("-Djavax.net.ssl.trustStoreType=WINDOWS-ROOT") '信任系统根证书(5252#)
Dim Server As String = If(McLoginLoader.Input.Type = McLoginType.Legacy,
"http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录
Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent))
Dim Server As String = Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent)
Try
Dim Response As String = NetRequestByClientRetry(Server, Encoding:=Encoding.UTF8)
DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server &
@@ -1562,7 +1555,7 @@ NextVersion:
'如果不合并,会导致 Forge 1.17 启动无效,它有两个 --add-exports,进一步导致其中一个在后面被去重
Dim DeDuplicateDataList As New List(Of String)
For i = 0 To DataList.Count - 1
Dim CurrentEntry As String = DataList(i)
Dim CurrentEntry As String = DataList(i).Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, " ").Trim
If DataList(i).StartsWithF("-") Then
Do While i < DataList.Count - 1
If DataList(i + 1).StartsWithF("-") Then
@@ -1803,7 +1796,7 @@ NextVersion:
File.Delete(FilePath)
Catch ex As UnauthorizedAccessException
McLaunchLog("删除原 dll 访问被拒绝,这通常代表有一个 MC 正在运行,跳过解压:" & FilePath)
McLaunchLog("实际的错误信息:" & GetExceptionSummary(ex))
McLaunchLog("实际的错误信息:" & ex.GetDetail())
Exit For
End Try
End If
@@ -1823,7 +1816,7 @@ NextVersion:
File.Delete(FileName)
Catch ex As UnauthorizedAccessException
McLaunchLog("删除多余文件访问被拒绝,跳过删除步骤")
McLaunchLog("实际的错误信息:" & GetExceptionSummary(ex))
McLaunchLog("实际的错误信息:" & ex.GetDetail())
Return
End Try
Next
@@ -1849,7 +1842,7 @@ NextVersion:
'要求 Java 使用高性能显卡
If Setup.Get("LaunchAdvanceGraphicCard") Then
Try
SetGPUPreference(McLaunchJavaSelected.PathJavaw)
SetGPUPreference(McLaunchJavaSelected.PathJava)
SetGPUPreference(PathWithName)
Catch ex As Exception
If IsAdmin() Then
@@ -1857,7 +1850,7 @@ NextVersion:
Else
Log(ex, "直接调整显卡设置失败,将以管理员权限重启 PCL 再次尝试")
Try
If RunAsAdmin($"--gpu ""{McLaunchJavaSelected.PathJavaw}""") = ProcessReturnValues.TaskDone Then
If RunAsAdmin($"--gpu ""{McLaunchJavaSelected.PathJava}""") = ProcessReturnValues.TaskDone Then
McLaunchLog("以管理员权限重启 PCL 并调整显卡设置成功")
Else
Throw New Exception("调整过程中出现异常")
@@ -2218,7 +2211,7 @@ IgnoreCustomSkin:
'启动信息
Dim GameProcess = New Process()
Dim StartInfo As New ProcessStartInfo(McLaunchJavaSelected.PathJavaw)
Dim StartInfo As New ProcessStartInfo(McLaunchJavaSelected.PathJava) '使用 javaw.exe 会导致 #6263
'设置环境变量
Dim Paths As New List(Of String)(StartInfo.EnvironmentVariables("Path").Split(";"))
@@ -2231,13 +2224,13 @@ IgnoreCustomSkin:
StartInfo.UseShellExecute = False
StartInfo.RedirectStandardOutput = True
StartInfo.RedirectStandardError = True
StartInfo.CreateNoWindow = False
StartInfo.CreateNoWindow = True
StartInfo.Arguments = McLaunchArgument
GameProcess.StartInfo = StartInfo
'开始进程
GameProcess.Start()
McLaunchLog("已启动游戏进程:" & McLaunchJavaSelected.PathJavaw)
McLaunchLog("已启动游戏进程:" & McLaunchJavaSelected.PathJava)
If Loader.IsAborted Then
McLaunchLog("由于取消启动,已强制结束游戏进程") '#1631
GameProcess.Kill()
@@ -86,7 +86,7 @@ Public Module ModMinecraft
Next
If Not Renamed Then CacheMcFolderList.Add(New McFolder With {.Name = Name, .Path = Path, .Type = McFolderType.Custom})
Catch ex As Exception
MyMsgBox("失效的 Minecraft 文件夹:" & vbCrLf & Path & vbCrLf & vbCrLf & GetExceptionSummary(ex), "Minecraft 文件夹失效", IsWarn:=True)
MyMsgBox("失效的 Minecraft 文件夹:" & vbCrLf & Path & vbCrLf & vbCrLf & ex.GetBrief(), "Minecraft 文件夹失效", IsWarn:=True)
Log(ex, $"无法访问 Minecraft 文件夹 {Path}")
End Try
Next
@@ -695,7 +695,7 @@ Recheck:
Catch ex As Exception
Log(ex, "依赖版本检查出错(" & Name & ")")
State = McVersionState.Error
Info = "未知错误:" & GetExceptionSummary(ex)
Info = "未知错误:" & ex.GetBrief()
Return False
End Try
@@ -808,7 +808,7 @@ ExitDataLoad:
WriteIni(Path & "PCL\Setup.ini", "VersionOriginalSub", Version.McCodeSub)
End If
Catch ex As Exception
Info = "未知错误:" & GetExceptionSummary(ex)
Info = "未知错误:" & ex.GetBrief()
Logo = PathImage & "Blocks/RedstoneBlock.png"
State = McVersionState.Error
Log(ex, "加载版本失败(" & Name & ")", LogLevel.Feedback)
@@ -1186,6 +1186,7 @@ OnLoaded:
If Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(200, 3000))
Catch ex As ThreadInterruptedException
Catch ex As Exception
If Loader.IsAborted Then Return '#5617
WriteIni(Path & "PCL.ini", "VersionCache", "") '要求下次重新加载
Log(ex, "加载 .minecraft 版本列表失败", LogLevel.Feedback)
End Try
@@ -1592,11 +1593,11 @@ OnLoaded:
''' <summary>
''' 获取 Uuid 对应的皮肤文件地址,失败将抛出异常。
''' </summary>
Public Function McSkinGetAddress(Uuid As String, Type As String) As String
If Uuid = "" Then Throw New Exception("Uuid 为空。")
If Uuid.StartsWithF("00000") Then Throw New Exception("离线 Uuid 无正版皮肤文件。")
Public Function McSkinGetAddress(UUID As String, Type As String) As String
If UUID = "" Then Throw New Exception("UUID 为空。")
If UUID.StartsWithF("00000") AndAlso Type <> "Auth" Then Throw New Exception("离线 UUID 无正版皮肤文件:" & UUID)
'尝试读取缓存
Dim CacheSkinAddress As String = ReadIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid)
Dim CacheSkinAddress As String = ReadIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", UUID)
If Not CacheSkinAddress = "" Then Return CacheSkinAddress
'获取皮肤地址
Dim Url As String
@@ -1610,7 +1611,7 @@ OnLoaded:
Case Else
Throw New ArgumentException("皮肤地址种类无效:" & If(Type, "null"))
End Select
Dim SkinString = NetRequestByClientRetry(Url & Uuid)
Dim SkinString = NetRequestByClientRetry(Url & UUID, RequireJson:=True)
If SkinString = "" Then Throw New Exception("皮肤返回值为空,可能是未设置自定义皮肤的用户")
'处理皮肤地址
Dim SkinValue As String
@@ -1635,8 +1636,8 @@ OnLoaded:
SkinValue = If(SkinUrl.Contains("minecraft.net/"), SkinUrl.Replace("http://", "https://"), SkinUrl)
End If
'保存缓存
WriteIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid, SkinValue)
Log("[Skin] UUID " & Uuid & " 对应的皮肤文件为 " & SkinValue)
WriteIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", UUID, SkinValue)
Log("[Skin] UUID " & UUID & " 对应的皮肤文件为 " & SkinValue)
Return SkinValue
End Function
@@ -1966,7 +1967,7 @@ OnLoaded:
Try
Log("[Minecraft] 开始获取统一通行证下载信息")
'测试链接:https://auth.mc-user.com:233/00000000000000000000000000000000/
DownloadInfo = GetJson(NetRequestByClientRetry("https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version)))
DownloadInfo = GetJson(NetRequestByClientRetry("https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version), RequireJson:=True))
Catch ex As Exception
Log(ex, "获取统一通行证下载信息失败")
End Try
@@ -1983,16 +1984,20 @@ OnLoaded:
'Authlib-Injector 文件
If Setup.Get("VersionServerLogin", Version:=Version) = 4 Then
Dim TargetFile = PathPure & "\authlib-injector.jar"
Dim TargetFile = PathPure & "authlib-injector.jar"
Dim DownloadInfo As JObject = Nothing
'获取下载信息
Try
Log("[Minecraft] 开始获取 Authlib-Injector 下载信息")
DownloadInfo = GetJson(NetRequestByClientRetry(
"https://authlib-injector.yushi.moe/artifact/latest.json",
BackupUrl:="https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json"))
BackupUrl:="https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json", RequireJson:=True))
Catch ex As Exception
Log(ex, "获取 Authlib-Injector 下载信息失败")
If File.Exists(TargetFile) Then
Log(ex, "获取 Authlib-Injector 下载信息失败")
Else
Throw New Exception("获取 Authlib-Injector 下载信息失败", ex)
End If
End Try
'校验文件
If DownloadInfo IsNot Nothing Then
@@ -2415,7 +2420,12 @@ NextEntry:
Public Function FilterUserName(Raw As String, FilterChar As Char) As String
If Raw.Contains(":\Users\") Then
For Each Token In RegexSearch(Raw, "(?<=:\\Users\\)[^\\]+")
Raw = Raw.Replace("\" & Token, "\" & New String(FilterChar, Token.Count))
Raw = Raw.Replace("\Users\" & Token, "\Users\" & New String(FilterChar, Token.Count))
Next
End If
If Raw.Contains(":/Users/") Then
For Each Token In RegexSearch(Raw, "(?<=:/Users/)[^/]+")
Raw = Raw.Replace("/Users/" & Token, "/Users/" & New String(FilterChar, Token.Count))
Next
End If
Return Raw
@@ -1113,8 +1113,8 @@ Finished:
End Sub, "Mod List Detail Loader CurseForge")
'等待线程结束
Do Until EndedThreadCount = 2
If Loader.IsAborted Then Return
Thread.Sleep(10)
If Loader.IsAborted Then Return
Loop
'保存缓存
Mods = Mods.Where(Function(m) m.Comp IsNot Nothing).ToList()
@@ -1126,6 +1126,7 @@ Finished:
Next
WriteFile(PathTemp & "Cache\LocalMod.json", Cache.ToString(If(ModeDebug, Newtonsoft.Json.Formatting.Indented, Newtonsoft.Json.Formatting.None)))
'刷新边栏
If Loader.IsAborted Then Return
If FrmVersionMod?.Filter = PageVersionMod.FilterType.CanUpdate Then
RunInUi(Sub() FrmVersionMod?.RefreshUI()) '同步 “可更新” 列表 (#4677)
Else
@@ -1212,7 +1213,7 @@ Finished:
If ReqVersionHead = ReqVersionTail Then
VersionRequire = "应为 " & ReqVersionHead
ElseIf ReqVersionHead.Contains(".") AndAlso ReqVersionTail.Contains(".") Then
VersionRequire = "应为 " & ReqVersionHead & " 至 " & ReqVersionTail
VersionRequire = $"应为 {ReqVersionHead} 至 {ReqVersionTail}"
ElseIf ReqVersionHead.Contains(".") Then
If ReqVersionHeadCanEqual Then
VersionRequire = "最低应为 " & ReqVersionHead
@@ -1230,7 +1231,7 @@ Finished:
End If
'检查前置 Mod 是否存在,并获取其版本
If Not CurrentDependencies.ContainsKey(ReqId) Then
Result.Add("缺少前置 Mod:" & ReqId & If(VersionRequire = "", "", ",其版本" & VersionRequire) & "。" & vbCrLf & " - " & ModEntity.FileName)
Result.Add($"缺少前置 Mod:{ReqId}{If(VersionRequire = "", "", ",其版本" & VersionRequire)}。{vbCrLf} - {ModEntity.FileName}")
Continue For
End If
Dim CurrentVersion As String = If(CurrentDependencies(ReqId)(0), "0.0")
@@ -1239,7 +1240,7 @@ Finished:
If ReqVersionHead.Contains(".") Then
If VersionSortInteger(ReqVersionHead, CurrentVersion) > If(ReqVersionHeadCanEqual, 0, -1) Then
Result.Add(ReqId.Substring(0, 1).ToUpper & ReqId.Substring(1) & " 版本过低,其版本" & VersionRequire & ",而当前版本为 " & CurrentVersion & "。" & vbCrLf &
" - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", vbCrLf & " - 前置:" & CurrentDependencies(ReqId)(1), ""))
" - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", $"{vbCrLf} - 前置:{CurrentDependencies(ReqId)(1)}", ""))
Continue For
End If
End If
@@ -1247,26 +1248,26 @@ Finished:
If ReqVersionTail.Contains(".") Then
If VersionSortInteger(CurrentVersion, ReqVersionTail) > If(ReqVersionTailCanEqual, 0, -1) Then
Result.Add(ReqId.Substring(0, 1).ToUpper & ReqId.Substring(1) & " 版本过高,其版本" & VersionRequire & ",而当前版本为 " & CurrentVersion & "。" & vbCrLf &
" - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", vbCrLf & " - 前置:" & CurrentDependencies(ReqId)(1), ""))
" - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", $"{vbCrLf} - 前置:{CurrentDependencies(ReqId)(1)}", ""))
Continue For
End If
End If
Else
If Not CurrentDependencies.ContainsKey(Dependency.Key) Then
Result.Add("缺少前置 Mod:" & Dependency.Key & "。" & vbCrLf & " - " & ModEntity.FileName)
Result.Add($"缺少前置 Mod:{Dependency.Key}。{vbCrLf} - {ModEntity.FileName}")
Continue For
End If
End If
Next
Catch ex As Exception
Result.Add("检查 Mod 时出错:" & GetExceptionSummary(ex) & vbCrLf & " - " & ModEntity.FileName)
Result.Add($"检查 Mod 时出错:{ex.GetBrief()}{vbCrLf} - {ModEntity.FileName}")
Log(ex, "检查 Mod 时出错")
End Try
Next
If Not Result.Any() Then
Log("[Minecraft] Mod 检查未发现异常")
Else
Log("[Minecraft] Mod 检查异常结果:" & vbCrLf & Join(Result, vbCrLf))
Log($"[Minecraft] Mod 检查异常结果:{vbCrLf}{Join(Result, vbCrLf)}")
End If
Return Result
End Function
@@ -72,7 +72,7 @@ Public Module ModModpack
If FullNames(1) = "modpack.zip" OrElse FullNames(1) = "modpack.mrpack" Then PackType = 9 : Exit Try '带启动器的压缩包
Next
Catch ex As Exception
If GetExceptionDetail(ex, True).Contains("Error.WinIOError") Then
If ex.GetDetail(True).Contains("Error.WinIOError") Then
Throw New Exception("打开整合包文件失败", ex)
ElseIf File.EndsWithF(".rar", True) Then
Throw New Exception("PCL 无法处理 rar 格式的压缩包,请在解压后重新压缩为 zip 格式再试", ex)
@@ -166,6 +166,15 @@ Retry:
End If
IniClearCache(VersionIni) '重置缓存,避免被安装过程中写入的 ini 覆盖
End Sub
''' <summary>
''' 弹窗提示整合包中存在不兼容的加载器。
''' 如果取消,则抛出 CancelledException。
''' </summary>
''' <exception cref="CancelledException" />
Private Sub NotifyIncompatibleLoader(LoaderName As String)
If MyMsgBox($"整合包中存在不兼容的加载器:{LoaderName}{vbCrLf}如果你知道如何手动安装它,可以先选择跳过,然后在整合包下载结束后手动安装。",
"不兼容的加载器", "取消", $"不安装 {LoaderName} 并继续") = 1 Then Throw New CancelledException
End Sub
#Region "不同类型整合包的安装方法"
@@ -211,7 +220,8 @@ Retry:
Log("[ModPack] 整合包 Fabric 版本:" & Id)
FabricVersion = Id.Replace("fabric-", "")
Else
Log("[ModPack] 未知 Mod 加载器:" & Id)
'ElseIf Id.StartsWithF("quilt-") Then
NotifyIncompatibleLoader(Id)
End If
Next
'解压
@@ -376,12 +386,9 @@ Retry:
Case "fabric-loader" 'eg. 0.14.14
FabricVersion = Entry.Value.ToString
Log("[ModPack] 整合包 Fabric 版本:" & FabricVersion)
Case "quilt-loader" 'eg. 1.0.0
Hint("PCL 暂不支持安装需要 Quilt 的整合包!", HintType.Critical)
Throw New CancelledException
Case Else
Hint($"无法安装整合包,其中出现了未知的 Mod 加载器 {Entry.Value}!", HintType.Critical)
Throw New CancelledException
'Case "quilt-loader" 'eg. 1.0.0
NotifyIncompatibleLoader(Entry.Name)
End Select
Next
'获取版本名
@@ -633,7 +640,8 @@ Retry:
If PackJson("components") Is Nothing Then Throw New Exception("该 MMC 整合包未提供游戏版本信息,无法安装!")
Dim Request As New McInstallRequest With {.TargetVersionName = VersionName, .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\"}
For Each Component In PackJson("components")
Select Case If(Component("uid"), "").ToString
If Not Component.Contains("uid") Then Continue For
Select Case Component("uid").ToString
Case "org.lwjgl"
Log("[ModPack] 已跳过 LWJGL 项")
Case "net.minecraft"
@@ -644,9 +652,9 @@ Retry:
Request.NeoForgeVersion = Component("version")
Case "net.fabricmc.fabric-loader"
Request.FabricVersion = Component("version")
Case "org.quiltmc.quilt-loader" 'eg. 1.0.0
Hint("PCL 暂不支持安装需要 Quilt 的整合包!", HintType.Critical)
Throw New CancelledException
Case Else
'Case "org.quiltmc.quilt-loader" 'eg. 1.0.0
NotifyIncompatibleLoader(Component("uid"))
End Select
Next
'构造加载器
@@ -397,12 +397,6 @@ EndHint:
'下载页面声明
Public FrmDownloadLeft As PageDownloadLeft
Public FrmDownloadInstall As PageDownloadInstall
Public FrmDownloadClient As PageDownloadClient
Public FrmDownloadOptiFine As PageDownloadOptiFine
Public FrmDownloadLiteLoader As PageDownloadLiteLoader
Public FrmDownloadForge As PageDownloadForge
Public FrmDownloadNeoForge As PageDownloadNeoForge
Public FrmDownloadFabric As PageDownloadFabric
Public FrmDownloadMod As PageDownloadMod
Public FrmDownloadPack As PageDownloadPack
Public FrmDownloadDataPack As PageDownloadDataPack
+4 -3
View File
@@ -80,15 +80,16 @@ Friend Module ModSecret
''' <summary>
''' 设置 Headers 的 UA、Referer。
''' </summary>
Friend Sub SecretHeadersSign(Url As String, ByRef Req As HttpRequestMessage, Optional UseBrowserUserAgent As Boolean = False)
Friend Sub SecretHeadersSign(Url As String, ByRef Req As HttpRequestMessage, Optional SimulateBrowserHeaders As Boolean = False)
If Req.Headers.UserAgent.Any Then Return
If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then
Req.Headers.Add("User-Agent", "LogStatistic") '#4951
ElseIf UseBrowserUserAgent Then
ElseIf SimulateBrowserHeaders Then
Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode} Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36")
Else
Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode}")
End If
Req.Headers.Add("Referer", $"http://{VersionCode}.open.pcl2.server/")
If Not SimulateBrowserHeaders Then Req.Headers.Add("Referer", $"http://{VersionCode}.open.pcl2.server/")
If Url.Contains("api.curseforge.com") Then Req.Headers.Add("x-api-key", CurseForgeAPIKey)
End Sub