This commit is contained in:
龙腾猫跃
2024-03-02 17:53:55 +08:00
parent 031cd898f6
commit f78250020e
14 changed files with 329 additions and 298 deletions
+16
View File
@@ -10,6 +10,17 @@ Public Class FormMain
Dim FeatureList As New List(Of KeyValuePair(Of Integer, String))
'统计更新日志条目
#If BETA Then
If LastVersion < 317 Then 'Release 2.6.15
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复无法安装 Forge 的 Bug"))
FeatureCount += 2
BugCount += 2
End If
If LastVersion < 315 Then 'Release 2.6.14
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化 MC 下载,尝试解决各种导致 MC 下载失败的问题"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "由于 MCBBS 关站,移除其相关内容"))
FeatureCount += 17
BugCount += 16
End If
If LastVersion < 313 Then 'Release 2.6.13
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法启动 Forge 1.18.3+ 的 Bug"))
FeatureCount += 6
@@ -129,6 +140,11 @@ Public Class FormMain
'3:BUG+ IMP* FEAT-
'2:BUG* IMP-
'1:BUG-
If LastVersion < 316 Then 'Snapshot 2.6.15
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复无法安装 Forge 的 Bug"))
FeatureCount += 2
BugCount += 2
End If
If LastVersion < 314 Then 'Snapshot 2.6.14
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化 MC 下载,尝试解决各种导致 MC 下载失败的问题"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "由于 MCBBS 关站,移除其相关内容"))
Binary file not shown.

After

Width:  |  Height:  |  Size: 715 B

@@ -11,12 +11,12 @@ Public Module ModBase
#Region "声明"
'下列版本信息由更新器自动修改
Public Const VersionBaseName As String = "2.6.14" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.6.14." & VersionBranchCode '标准格式的四段式版本号
Public Const VersionBaseName As String = "2.6.15" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.6.15." & VersionBranchCode '标准格式的四段式版本号
#If BETA Then
Public Const VersionCode As Integer = 313 'Release
Public Const VersionCode As Integer = 317 'Release
#Else
Public Const VersionCode As Integer = 314 'Snapshot
Public Const VersionCode As Integer = 316 'Snapshot
#End If
'自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
+39 -28
View File
@@ -28,7 +28,7 @@ Public Module ModNet
''' </summary>
''' <param name="Url">网页的 Url。</param>
''' <param name="Encoding">网页的编码,通常为 UTF-8。</param>
Public Function NetGetCodeByClient(Url As String, Encoding As Encoding, Optional Accept As String = "application/json, text/javascript, */*; q=0.01") As String
Public Function NetGetCodeByClient(Url As String, Encoding As Encoding, Optional Accept As String = "application/json, text/javascript, */*; q=0.01", Optional UseBrowserUserAgent As Boolean = False) As String
Dim RetryCount As Integer = 0
Dim RetryException As Exception = Nothing
Dim StartTime As Long = GetTimeTick()
@@ -36,15 +36,15 @@ Public Module ModNet
Retry:
Select Case RetryCount
Case 0 '正常尝试
Return NetGetCodeByClient(Url, Encoding, 10000, Accept)
Return NetGetCodeByClient(Url, Encoding, 10000, Accept, UseBrowserUserAgent)
Case 1 '慢速重试
Thread.Sleep(500)
Return NetGetCodeByClient(Url, Encoding, 30000, Accept)
Return NetGetCodeByClient(Url, Encoding, 30000, Accept, UseBrowserUserAgent)
Case Else '快速重试
If GetTimeTick() - StartTime > 5500 Then
'若前两次加载耗费 5 秒以上,才进行重试
Thread.Sleep(500)
Return NetGetCodeByClient(Url, Encoding, 4000, Accept)
Return NetGetCodeByClient(Url, Encoding, 4000, Accept, UseBrowserUserAgent)
Else
Throw RetryException
End If
@@ -63,7 +63,7 @@ Retry:
End Select
End Try
End Function
Public Function NetGetCodeByClient(Url As String, Encoding As Encoding, Timeout As Integer, Accept As String) As String
Public Function NetGetCodeByClient(Url As String, Encoding As Encoding, Timeout As Integer, Accept As String, Optional UseBrowserUserAgent As Boolean = False) As String
Url = SecretCdnSign(Url)
Log("[Net] 获取客户端网络结果:" & Url & ",最大超时 " & Timeout)
Dim Request As CookieWebClient
@@ -77,7 +77,7 @@ Retry:
Request.Headers("Accept") = Accept
Request.Headers("Accept-Language") = "en-US,en;q=0.5"
Request.Headers("X-Requested-With") = "XMLHttpRequest"
SecretHeadersSign(Url, Request)
SecretHeadersSign(Url, Request, UseBrowserUserAgent)
Return Request.DownloadString(Url)
Catch ex As Exception
If ex.GetType.Equals(GetType(WebException)) AndAlso CType(ex, WebException).Status = WebExceptionStatus.Timeout Then
@@ -98,7 +98,7 @@ Retry:
''' <param name="Encode">网页的编码,通常为 UTF-8。</param>
''' <param name="BackupUrl">如果第一次尝试失败,换用的备用 URL。</param>
Public Function NetGetCodeByRequestRetry(Url As String, Optional Encode As Encoding = Nothing, Optional Accept As String = "",
Optional IsJson As Boolean = False, Optional BackupUrl As String = Nothing)
Optional IsJson As Boolean = False, Optional BackupUrl As String = Nothing, Optional UseBrowserUserAgent As Boolean = False)
Dim RetryCount As Integer = 0
Dim RetryException As Exception = Nothing
Dim StartTime As Long = GetTimeTick()
@@ -106,15 +106,15 @@ Retry:
Retry:
Select Case RetryCount
Case 0 '正常尝试
Return NetGetCodeByRequestOnce(Url, Encode, 10000, IsJson, Accept)
Return NetGetCodeByRequestOnce(Url, Encode, 10000, IsJson, Accept, UseBrowserUserAgent)
Case 1 '慢速重试
Thread.Sleep(500)
Return NetGetCodeByRequestOnce(If(BackupUrl, Url), Encode, 30000, IsJson, Accept)
Return NetGetCodeByRequestOnce(If(BackupUrl, Url), Encode, 30000, IsJson, Accept, UseBrowserUserAgent)
Case Else '快速重试
If GetTimeTick() - StartTime > 5500 Then
'若前两次加载耗费 5 秒以上,才进行重试
Thread.Sleep(500)
Return NetGetCodeByRequestOnce(If(BackupUrl, Url), Encode, 4000, IsJson, Accept)
Return NetGetCodeByRequestOnce(If(BackupUrl, Url), Encode, 4000, IsJson, Accept, UseBrowserUserAgent)
Else
Throw RetryException
End If
@@ -140,7 +140,7 @@ Retry:
''' </summary>
''' <param name="Url">网页的 Url。</param>
''' <param name="Encode">网页的编码,通常为 UTF-8。</param>
Public Function NetGetCodeByRequestMuity(Url As String, Optional Encode As Encoding = Nothing, Optional Accept As String = "", Optional IsJson As Boolean = False)
Public Function NetGetCodeByRequestMulty(Url As String, Optional Encode As Encoding = Nothing, Optional Accept As String = "", Optional IsJson As Boolean = False)
Dim Threads As New List(Of Thread)
Dim RequestResult = Nothing
Dim RequestEx As Exception = Nothing
@@ -182,7 +182,7 @@ RequestFinished:
Loop
Throw New Exception("未知错误")
End Function
Public Function NetGetCodeByRequestOnce(Url As String, Optional Encode As Encoding = Nothing, Optional Timeout As Integer = 30000, Optional IsJson As Boolean = False, Optional Accept As String = "")
Public Function NetGetCodeByRequestOnce(Url As String, Optional Encode As Encoding = Nothing, Optional Timeout As Integer = 30000, Optional IsJson As Boolean = False, Optional Accept As String = "", Optional UseBrowserUserAgent As Boolean = False)
If RunInUi() AndAlso Not Url.Contains("//127.") Then Throw New Exception("在 UI 线程执行了网络请求")
Url = SecretCdnSign(Url)
Log($"[Net] 获取网络结果:{Url},超时 {Timeout}ms{If(IsJson, ",要求 json", "")}")
@@ -192,7 +192,7 @@ RequestFinished:
If Url.StartsWith("https", StringComparison.OrdinalIgnoreCase) Then Request.ProtocolVersion = HttpVersion.Version11
Request.Timeout = Timeout
Request.Accept = Accept
SecretHeadersSign(Url, Request)
SecretHeadersSign(Url, Request, UseBrowserUserAgent)
Using res As HttpWebResponse = Request.GetResponse()
Using HttpStream As Stream = res.GetResponseStream()
HttpStream.ReadTimeout = Timeout
@@ -220,9 +220,9 @@ RequestFinished:
''' 以多线程下载网页文件的方式获取网页源代码。
''' </summary>
''' <param name="Url">网页的 Url。</param>
Public Function NetGetCodeByDownload(Url As String, Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False) As String
Public Function NetGetCodeByDownload(Url As String, Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False, Optional UseBrowserUserAgent As Boolean = False) As String
Dim Temp As String = PathTemp & "Cache\Code\" & Url.GetHashCode() & "_" & GetUuid()
Dim NewTask As New LoaderDownload("源码获取 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile({Url}, Temp, New FileChecker With {.IsJson = IsJson})})
Dim NewTask As New LoaderDownload("源码获取 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile({Url}, Temp, New FileChecker With {.IsJson = IsJson}, UseBrowserUserAgent)})
Try
NewTask.WaitForExitTime(Timeout, TimeoutMessage:="连接服务器超时(" & Url & ")")
NetGetCodeByDownload = ReadFile(Temp)
@@ -235,9 +235,9 @@ RequestFinished:
''' 以多线程下载网页文件的方式获取网页源代码。
''' </summary>
''' <param name="Urls">网页的 Url 列表。</param>
Public Function NetGetCodeByDownload(Urls As String(), Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False) As String
Public Function NetGetCodeByDownload(Urls As String(), Optional Timeout As Integer = 45000, Optional IsJson As Boolean = False, Optional UseBrowserUserAgent As Boolean = False) As String
Dim Temp As String = PathTemp & "Cache\Code\" & Urls(0).GetHashCode() & "_" & GetUuid()
Dim NewTask As New LoaderDownload("源码获取 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile(Urls, Temp, New FileChecker With {.IsJson = IsJson})})
Dim NewTask As New LoaderDownload("源码获取 " & GetUuid() & "#", New List(Of NetFile) From {New NetFile(Urls, Temp, New FileChecker With {.IsJson = IsJson}, UseBrowserUserAgent)})
Try
NewTask.WaitForExitTime(Timeout, TimeoutMessage:="连接服务器超时(第一下载源:" & Urls(0) & ")")
NetGetCodeByDownload = ReadFile(Temp)
@@ -252,7 +252,7 @@ RequestFinished:
''' </summary>
''' <param name="Url">网络 Url。</param>
''' <param name="LocalFile">下载的本地地址。</param>
Public Sub NetDownload(Url As String, LocalFile As String)
Public Sub NetDownload(Url As String, LocalFile As String, Optional UseBrowserUserAgent As Boolean = False)
Log("[Net] 直接下载文件:" & Url)
'初始化
@@ -268,7 +268,11 @@ RequestFinished:
'下载
Using Client As New WebClient
Try
If UseBrowserUserAgent Then
Client.Headers(HttpRequestHeader.UserAgent) = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
Else
Client.Headers(HttpRequestHeader.UserAgent) = "PCL2/" & VersionStandardCode
End If
Client.Headers(HttpRequestHeader.Referer) = "http://" & VersionCode & ".pcl2.server/"
Client.DownloadFile(Url, LocalFile)
Catch ex As Exception
@@ -369,7 +373,7 @@ RequestFinished:
''' <summary>
''' 发送一次网络请求并获取返回内容。
''' </summary>
Public Function NetRequestOnce(Url As String, Method As String, Data As Object, ContentType As String, Optional Timeout As Integer = 25000, Optional Headers As Dictionary(Of String, String) = Nothing, Optional MakeLog As Boolean = True) As String
Public Function NetRequestOnce(Url As String, Method As String, Data As Object, ContentType As String, Optional Timeout As Integer = 25000, Optional Headers As Dictionary(Of String, String) = Nothing, Optional MakeLog As Boolean = True, Optional UseBrowserUserAgent As Boolean = False) As String
If RunInUi() AndAlso Not Url.Contains("//127.") Then Throw New Exception("在 UI 线程执行了网络请求")
Url = SecretCdnSign(Url)
If MakeLog Then Log("[Net] 发起网络请求(" & Method & "," & Url & "),最大超时 " & Timeout)
@@ -392,7 +396,7 @@ RequestFinished:
End If
Req.ContentType = ContentType
Req.Timeout = Timeout
SecretHeadersSign(Url, Req)
SecretHeadersSign(Url, Req, UseBrowserUserAgent)
If Url.StartsWith("https", StringComparison.OrdinalIgnoreCase) Then Req.ProtocolVersion = HttpVersion.Version11
If Method = "POST" OrElse Method = "PUT" Then
Req.ContentLength = SendData.Length
@@ -790,6 +794,10 @@ RequestFinished:
''' 文件的校验规则。
''' </summary>
Public Check As FileChecker
''' <summary>
''' 下载时是否添加浏览器 UA。
''' </summary>
Public UseBrowserUserAgent As Boolean
''' <summary>
''' 上次记速时的时间。
@@ -889,7 +897,7 @@ RequestFinished:
''' 新建一个需要下载的文件。
''' </summary>
''' <param name="LocalPath">包含文件名的本地地址。</param>
Public Sub New(Urls As String(), LocalPath As String, Optional Check As FileChecker = Nothing)
Public Sub New(Urls As String(), LocalPath As String, Optional Check As FileChecker = Nothing, Optional UseBrowserUserAgent As Boolean = False)
Dim Sources As New List(Of NetSource)
Dim Count As Integer = 0
Urls = Urls.Distinct.ToArray
@@ -900,6 +908,7 @@ RequestFinished:
Me.Sources = Sources.ToArray
Me.LocalPath = LocalPath
Me.Check = Check
Me.UseBrowserUserAgent = UseBrowserUserAgent
Me.LocalName = GetFileNameFromPath(LocalPath)
End Sub
@@ -1030,7 +1039,7 @@ StartThread:
'HttpRequest.Proxy = Nothing 'new WebProxy(Ip, Port)
HttpRequest.Timeout = Timeout
HttpRequest.AddRange(Info.DownloadStart)
SecretHeadersSign(Info.Source.Url, HttpRequest)
SecretHeadersSign(Info.Source.Url, HttpRequest, UseBrowserUserAgent)
Using HttpResponse As HttpWebResponse = HttpRequest.GetResponse()
'文件大小校验
Dim ThreadFileSize = HttpResponse.ContentLength
@@ -1909,7 +1918,8 @@ Retry:
Log(ex, "下载管理启动线程 1 出错", LogLevel.Assert)
End Try
End Sub, "NetManager ThreadStarter Single")
RunInNewThread(Sub()
RunInNewThread(
Sub()
Try
Dim LastLoopTime As Long
While True
@@ -1955,18 +1965,19 @@ Retry:
NewThreadCount -= 1
End If
Next
'等待 40 ms:BMCLAPI 部分时候有 20QPS 的限制
Thread.Sleep(40)
Loop While NewThreadCount > 0 AndAlso IsSuccess
End If
'等待直至 120 ms
Do While GetTimeTick() - LastLoopTime < 120
Thread.Sleep(10)
Loop
'等待 40 ms
Thread.Sleep(40)
End While
Catch ex As Exception
Log(ex, "下载管理启动线程 2 出错", LogLevel.Assert)
End Try
End Sub, "NetManager ThreadStarter Odd")
RunInNewThread(Sub()
RunInNewThread(
Sub()
Try
Dim LastLoopTime As Long
NetTaskSpeedLimitLeftLast = GetTimeTick()
@@ -1196,7 +1196,7 @@ Retry:
''' </summary>
''' <param name="LocalAddress">目标本地文件夹,或完整的文件路径。会自动判断类型。</param>
Public Function ToNetFile(LocalAddress As String) As NetFile
Return New NetFile(DownloadAddress, LocalAddress & If(LocalAddress.EndsWith("\"), FileName, ""))
Return New NetFile(DownloadAddress, LocalAddress & If(LocalAddress.EndsWith("\"), FileName, ""), UseBrowserUserAgent:=True)
End Function
'实例化
@@ -452,7 +452,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 = NetGetCodeByRequestRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding.Default, "text/html")
Dim Result As String = NetGetCodeByRequestRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding.Default, "text/html", UseBrowserUserAgent:=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)")
@@ -589,7 +589,7 @@
Public Sub DlForgeVersionOfficialMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
Dim Result As String
Try
Result = NetGetCodeByDownload("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" & Loader.Input & ".html")
Result = NetGetCodeByDownload("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" & Loader.Input & ".html", UseBrowserUserAgent:=True)
Catch ex As Exception
If GetExceptionSummary(ex).Contains("(404)") Then
Throw New Exception("没有可用版本")
@@ -439,7 +439,7 @@ Retry:
'添加下载文件
FileList.Add(New NetFile(File("downloads").Select(Function(t) t.ToString.Replace("://edge.forgecdn", "://media.forgecdn")).ToArray, '修复 #2390
PathMcFolder & "versions\" & VersionName & "\" & File("path").ToString,
New FileChecker(ActualSize:=File("fileSize").ToObject(Of Long), Hash:=File("hashes")("sha1").ToString)))
New FileChecker(ActualSize:=File("fileSize").ToObject(Of Long), Hash:=File("hashes")("sha1").ToString), True))
Next
If FileList.Count > 0 Then
InstallLoaders.Add(New LoaderDownload("下载额外文件", FileList) With {.ProgressWeight = FileList.Count * 1.5}) '每个 Mod 需要 1.5s
@@ -57,7 +57,7 @@ RetryStart:
Url = Url.Replace("/256/256/", "/64/64/") '#3075:部分 Mod 不存在 64x64 图标,所以重试时不再缩小
End If
'下载图片
NetDownload(Url, LocalFileAddress & DownloadEnd)
NetDownload(Url, LocalFileAddress & DownloadEnd, True)
Dim LoadError As Exception = Nothing
RunInUiWait(
Sub()
@@ -59,7 +59,7 @@ RetryStart:
Url = Url.Replace("/256/256/", "/64/64/") '#3075:部分 Mod 不存在 64x64 图标,所以重试时不再缩小
End If
'下载图片
NetDownload(Url, LocalFileAddress & DownloadEnd)
NetDownload(Url, LocalFileAddress & DownloadEnd, True)
Dim LoadError As Exception = Nothing
RunInUiWait(
Sub()
@@ -51,6 +51,6 @@ Imports System.Runtime.InteropServices
' 可以指定所有值,也可以使用以下所示的 "*" 预置版本号和修订号
' 方法是按如下所示使用“*”
<Assembly: AssemblyVersion("2.6.14.0")>
<Assembly: AssemblyFileVersion("2.6.14.0")>
<Assembly: AssemblyVersion("2.6.15.0")>
<Assembly: AssemblyFileVersion("2.6.15.0")>
<Assembly: NeutralResourcesLanguage("")>
@@ -526,7 +526,7 @@ Public Module ModDownloadLib
'官方源
Dim PageData As String
Try
PageData = NetGetCodeByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile, New UTF8Encoding(False), 15000, "text/html")
PageData = NetGetCodeByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile, New UTF8Encoding(False), 15000, "text/html", True)
Task.Progress = 0.8
Sources.Add("https://optifine.net/" & RegexSearch(PageData, "downloadx\?f=[^""']+")(0))
Log("[Download] OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址:" & Sources(0))
@@ -691,7 +691,7 @@ Retry:
'官方源
Dim PageData As String
Try
PageData = NetGetCodeByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile, New UTF8Encoding(False), 15000, "text/html")
PageData = NetGetCodeByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile, New UTF8Encoding(False), 15000, "text/html", True)
Task.Progress = 0.8
Sources.Add("https://optifine.net/" & RegexSearch(PageData, "downloadx\?f=[^""']+")(0))
Log("[Download] OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址:" & Sources(0))
@@ -1317,7 +1317,8 @@ Retry:
If Version.Split(".")(0) >= 20 Then
Log("[Download] 检测为新版 Forge:" & Version)
Dim Libs As List(Of McLibToken) = Nothing
Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("分析 Mod 加载器支持库文件", Sub(Task As LoaderTask(Of String, List(Of NetFile)))
Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("分析 Mod 加载器支持库文件",
Sub(Task As LoaderTask(Of String, List(Of NetFile)))
Task.Output = New List(Of NetFile)
Dim Installer As ZipArchive = Nothing
Try
@@ -913,5 +913,8 @@
<Resource Include="Images\Icons\Disabled.png" />
<Resource Include="Images\Icons\Unavaliable.png" />
</ItemGroup>
<ItemGroup>
<Resource Include="Images\Heads\MCBBS.png" />
</ItemGroup>
<Import Project="$(MSBuildToolsPath)\Microsoft.VisualBasic.targets" />
</Project>
Binary file not shown.
Binary file not shown.