2.8.8

2024-10-01 03:39:04 +08:00
parent d48ab143be
commit 76bf3c40d0
21 changed files with 242 additions and 287 deletions
@@ -12,13 +12,13 @@ Public Module ModBase
 #Region "声明"

    '下列版本信息由更新器自动修改
-    Public Const VersionBaseName As String = "2.8.7" '不含分支前缀的显示用版本名
-    Public Const VersionStandardCode As String = "2.8.7." & VersionBranchCode '标准格式的四段式版本号
+    Public Const VersionBaseName As String = "2.8.8" '不含分支前缀的显示用版本名
+    Public Const VersionStandardCode As String = "2.8.8." & VersionBranchCode '标准格式的四段式版本号
    Public Const CommitHash As String = "" 'Commit Hash，由 GitHub Workflow 自动替换
 #If BETA Then
-    Public Const VersionCode As Integer = 336 'Release
+    Public Const VersionCode As Integer = 340 'Release
 #Else
-    Public Const VersionCode As Integer = 337 'Snapshot
+    Public Const VersionCode As Integer = 339 'Snapshot
 #End If
    '自动生成的版本信息
    Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -1840,6 +1840,13 @@ RetryDir:

 #Region "系统"

+    ''' <summary>
+    ''' 指示接取到这个异常的函数进行重试。
+    ''' </summary>
+    Public Class RetryException
+        Inherits Exception
+    End Class
+
    ''' <summary>
    ''' 当前程序是否拥有管理员权限。
    ''' </summary>
@@ -2430,6 +2437,14 @@ Retry:
        Return rect.Contains(bounds.TopLeft) OrElse rect.Contains(bounds.BottomRight)
    End Function

+    ''' <summary>
+    ''' 控件是否受到 TextTrimming 属性影响，导致内容被截取。
+    ''' </summary>
+    <Extension> Public Function IsTextTrimmed(Control As TextBlock) As Boolean
+        Control.Measure(New Size(Double.MaxValue, Double.MaxValue))
+        Return Control.DesiredSize.Width > Control.ActualWidth
+    End Function
+
 #End Region

 #Region "Debug"
@@ -288,15 +288,13 @@
                End SyncLock
            End Try
            '检验输入以确定情况
-            If (Not IsForceRestart) AndAlso '不要求强行重启
-               ((Input IsNot Nothing AndAlso Input.Equals(Me.Input)) OrElse (Input Is Nothing AndAlso Me.Input Is Nothing)) AndAlso '输入相同
-               (State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已加载成功
+            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
+                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)
@@ -317,7 +315,7 @@
                Sub()
                    Try
                        IsForceRestarting = IsForceRestart
-                        If ModeDebug Then Log("[Loader] 加载线程 " & Name & " (" & Thread.CurrentThread.ManagedThreadId & ") 已启动")
+                        If ModeDebug Then Log("[Loader] 加载线程 " & Name & " (" & Thread.CurrentThread.ManagedThreadId & ") 已" & If(IsForceRestarting, "强制", "") & "启动")
                        LoadDelegate(Me)
                        If IsAborted Then
                            Log("[Loader] 加载线程 " & Name & " (" & Thread.CurrentThread.ManagedThreadId & ") 已中断但线程正常运行至结束，输出被弃用（最新线程：" & If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId) & "）", LogLevel.Developer)
@@ -441,12 +439,13 @@
                    Exit Sub
                End If
            End SyncLock
-            RunInThread(Sub()
-                            '中断加载器
-                            For Each Loader In Loaders
-                                Loader.Abort()
-                            Next
-                        End Sub)
+            RunInThread(
+            Sub()
+                '中断加载器
+                For Each Loader In Loaders
+                    Loader.Abort()
+                Next
+            End Sub)
        End Sub

        ''' <summary>
@@ -485,7 +484,7 @@
        Private Sub Update()
            If State = LoadState.Finished OrElse State = LoadState.Failed OrElse State = LoadState.Aborted Then Exit Sub
            Dim IsFinished As Boolean = True
-            Dim Ignore As Boolean = False
+            Dim Blocked As Boolean = False
            Dim Input As Object = Me.Input
            For Each Loader In Loaders
                Select Case Loader.State
@@ -493,28 +492,30 @@
                        '检查是否需要重启
                        If Loader.GetType.Name.StartsWithF("LoaderTask") Then '类型名后面带有泛型，必须用 StartsWith
                            If CType(Loader, Object).ShouldStart(If(Input IsNot Nothing AndAlso Loader.GetType.GenericTypeArguments.First Is Input.GetType, Input, Nothing), IgnoreReloadTimeout:=True) Then
-                                If ModeDebug Then Log("[Loader] 由于输入条件变更，重启已完成的加载器 " & Loader.Name)
+                                Log("[Loader] 由于输入条件变更，重启已完成的加载器 " & Loader.Name)
                                GoTo Restart
                            End If
                            '更新下一个加载器的输入
                            Input = CType(Loader, Object).Output
                        End If
+                        '如果不让继续启动，且已有加载器正在加载中，就不继续启动
+                        If Loader.Block AndAlso Not IsFinished Then Blocked = True
                    Case LoadState.Loading
                        '检查是否需要重启
                        If Loader.GetType.Name.StartsWithF("LoaderTask") Then
                            If CType(Loader, Object).ShouldStart(If(Input IsNot Nothing AndAlso Loader.GetType.GenericTypeArguments.First Is Input.GetType, Input, Nothing), IgnoreReloadTimeout:=True) Then
-                                If ModeDebug Then Log("[Loader] 由于输入条件变更，重启进行中的加载器 " & Loader.Name, LogLevel.Developer)
+                                Log("[Loader] 由于输入条件变更，重启进行中的加载器 " & Loader.Name, LogLevel.Developer)
                                GoTo Restart
                            End If
                        End If
                        '已经有正在加载中的了，不需要再启动了
                        IsFinished = False
-                        Ignore = True
+                        Blocked = True
                    Case Else
 Restart:
                        '未启动，则启动加载器
                        IsFinished = False
-                        If Ignore Then Continue For
+                        If Blocked Then Continue For
                        If Input IsNot Nothing Then
                            '若输入类型与下一个加载器相同才继续
                            Dim LoaderType As String = Loader.GetType.Name
@@ -528,8 +529,8 @@ Restart:
                        Else
                            Loader.Start(IsForceRestart:=IsForceRestarting)
                        End If
-                        '如果不让继续启动，那就不启动呗
-                        If Loader.Block Then Ignore = True
+                        '阻止继续
+                        If Loader.Block Then Blocked = True
                End Select
            Next
            If IsFinished Then
@@ -140,7 +140,7 @@ Retry:
    ''' </summary>
    ''' <param name="Url">网页的 Url。</param>
    ''' <param name="Encode">网页的编码，通常为 UTF-8。</param>
-    Public Function NetGetCodeByRequestMulty(Url As String, Optional Encode As Encoding = Nothing, Optional Accept As String = "", Optional IsJson As Boolean = False)
+    Public Function NetGetCodeByRequestMultiple(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
@@ -329,7 +329,7 @@ Retry:
    ''' <summary>
    ''' 同时发送多个网络请求并要求返回内容。
    ''' </summary>
-    Public Function NetRequestMulty(Url As String, Method As String, Data As Object, ContentType As String, Optional RequestCount As Integer = 4, Optional Headers As Dictionary(Of String, String) = Nothing, Optional MakeLog As Boolean = True)
+    Public Function NetRequestMultiple(Url As String, Method As String, Data As Object, ContentType As String, Optional RequestCount As Integer = 4, Optional Headers As Dictionary(Of String, String) = Nothing, Optional MakeLog As Boolean = True)
        Dim Threads As New List(Of Thread)
        Dim RequestResult = Nothing
        Dim RequestEx As Exception = Nothing
@@ -701,8 +701,7 @@ RequestFinished:
        ''' <summary>
        ''' 所属的文件列表任务。
        ''' </summary>
-        Public Tasks As New Concurrent.ConcurrentBag(Of LoaderDownload)
-
+        Public Tasks As New SynchronizedCollection(Of LoaderDownload)
        ''' <summary>
        ''' 所有下载源。
        ''' </summary>
@@ -1232,7 +1231,7 @@ SourceBreak:
                '根据情况判断，是否在多线程下禁用下载源（连续错误过多，或不支持断点续传）
                If 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)") OrElse ex.Message.Contains("(429)")) AndAlso Not Info.Source.Url.ContainsF("bmclapi")) OrElse 'BMCLAPI 的部分源在高频率请求下会返回 403、429，所以不应因此禁用下载源
+                   (ex.Message.Contains("(403)") AndAlso Not Info.Source.Url.ContainsF("bmclapi")) OrElse 'BMCLAPI 的部分源在高频率请求下会返回 403，所以不应因此禁用下载源
                   (Info.Source.FailCount >= MathClamp(NetTaskThreadLimit, 5, 30) AndAlso DownloadDone < 1) OrElse
                    Info.Source.FailCount > NetTaskThreadLimit + 2 Then
                    Dim IsThisFail As Boolean = False
@@ -1403,7 +1402,7 @@ Retry:
        ''' </summary>
        Public Sub Abort(CausedByTask As LoaderDownload)
            '从特定任务中移除，如果它还属于其他任务，则继续下载
-            Tasks.TryTake(CausedByTask)
+            Tasks.Remove(CausedByTask)
            If Tasks.Any Then Exit Sub
            '确认中断
            SyncLock LockState
@@ -99,7 +99,7 @@
                    Task.Output = New List(Of NetFile) From {BackAssetsFile}
                    '检查是否需要更新：每天只更新一次
                    If File.Exists(RealAddress) AndAlso Math.Abs((File.GetLastWriteTime(RealAddress).Date - Now.Date).TotalDays) < 1 Then
-                        Log("[Download] 无需更新资源文件索引")
+                        Log("[Download] 无需更新资源文件索引，取消")
                        Task.Abort()
                    End If
                End Sub))
@@ -1089,7 +1089,7 @@
        Dim Urls As New List(Of KeyValuePair(Of String, Integer))
        If McimUrl <> Url Then
            Select Case Setup.Get("ToolDownloadMod")
-                'UNDONE: 受 #4811 影响
+                'UNDONE: 在 MCIM 源稳定后回调
                Case 0
                    If ModeDebug Then
                        Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
@@ -1138,7 +1138,7 @@
        Dim Urls As New List(Of KeyValuePair(Of String, Integer))
        If McimUrl <> Url Then
            Select Case Setup.Get("ToolDownloadMod")
-                'UNDONE: 受 #4811 影响
+                'UNDONE: 在 MCIM 源稳定后回调
                Case 0
                    If ModeDebug Then
                        Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
@@ -106,7 +106,7 @@ Public Module ModLaunch
            '构造主加载器
            Dim Loaders As New List(Of LoaderBase) From {
                New LoaderTask(Of Integer, Integer)("获取 Java", AddressOf McLaunchJava) With {.ProgressWeight = 4, .Block = False},
-                McLoginLoader,
+                McLoginLoader, '.ProgressWeight = 15, .Block = False
                New LoaderCombo(Of String)("补全文件", DlClientFix(McVersionCurrent, False, AssetsIndexExistsBehaviour.DownloadInBackground)) With {.ProgressWeight = 15, .Show = False},
                New LoaderTask(Of String, List(Of McLibToken))("获取启动参数", AddressOf McLaunchArgumentMain) With {.ProgressWeight = 2},
                New LoaderTask(Of List(Of McLibToken), Integer)("解压文件", AddressOf McLaunchNatives) With {.ProgressWeight = 2},
@@ -529,8 +529,8 @@ Relogin:
            OAuthTokens = MsLoginStep1New(Data)
        Else
            '有 RefreshToken
-            OAuthTokens = MsLoginStep1Refresh(Input.OAuthRefreshToken) '要求重新打开登录网页认证
-            If OAuthTokens(0) = "Relogin" Then GoTo Relogin
+            OAuthTokens = MsLoginStep1Refresh(Input.OAuthRefreshToken)
+            If OAuthTokens(0) = "Relogin" Then GoTo Relogin '要求重新打开登录网页认证
        End If
        If Data.IsAborted Then Throw New ThreadInterruptedException
        Data.Progress = 0.25
@@ -838,9 +838,10 @@ LoginFinish:
        '参考：https://learn.microsoft.com/zh-cn/entra/identity-platform/v2-oauth2-device-code

        '初始请求
+Retry:
        McLaunchLog("开始微软登录步骤 1/6（原始登录）")
-        Dim PrepareJson As JObject = GetJson(NetRequestMulty("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", "POST",
-            $"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access", "application/x-www-form-urlencoded", 2))
+        Dim PrepareJson As JObject = GetJson(NetRequestRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", "POST",
+            $"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access", "application/x-www-form-urlencoded"))
        McLaunchLog("网页登录地址：" & PrepareJson("verification_uri").ToString)

        '弹窗
@@ -849,24 +850,31 @@ LoginFinish:
        While Converter.Result Is Nothing
            Thread.Sleep(100)
        End While
-        If TypeOf Converter.Result Is Exception Then
+        If TypeOf Converter.Result Is RetryException Then
+            If MyMsgBox($"请在登录时选择 {vbLQ}其他登录方法{vbRQ}，然后选择 {vbLQ}使用我的密码{vbRQ}。{vbCrLf}如果没有该选项，请选择 {vbLQ}设置密码{vbRQ}，设置完毕后再登录。",
+                "需要使用密码登录", "重新登录", "设置密码", "取消",
+                Button2Action:=Sub() OpenWebsite("https://account.live.com/password/Change")) = 1 Then
+                GoTo Retry
+            Else
+                Throw New Exception("$$")
+            End If
+        ElseIf TypeOf Converter.Result Is Exception Then
            Throw CType(Converter.Result, Exception)
        Else
            Return Converter.Result
        End If
    End Function
-
    '微软登录步骤 1，刷新登录：从 OAuth Code 或 OAuth RefreshToken 获取 {OAuth AccessToken, OAuth RefreshToken}
    Private Function MsLoginStep1Refresh(Code As String) As String()
        McLaunchLog("开始微软登录步骤 1/6（刷新登录）")

        Dim Result As String
        Try
-            Result = NetRequestMulty("https://login.live.com/oauth20_token.srf", "POST",
+            Result = NetRequestMultiple("https://login.live.com/oauth20_token.srf", "POST",
                $"client_id={OAuthClientId}&refresh_token={Uri.EscapeDataString(Code)}&grant_type=refresh_token&scope=XboxLive.signin%20offline_access",
                "application/x-www-form-urlencoded", 2)
        Catch ex As Exception
-            If ex.Message.Contains("must sign in again") OrElse ex.Message.Contains("invalid_grant") Then '#269
+            If ex.Message.Contains("must sign in again") OrElse (ex.Message.Contains("refresh_token") AndAlso ex.Message.Contains("is not valid")) Then '#269
                Return {"Relogin", ""}
            Else
                Throw
@@ -878,7 +886,6 @@ LoginFinish:
        Dim RefreshToken As String = ResultJson("refresh_token").ToString
        Return {AccessToken, RefreshToken}
    End Function
-
    '微软登录步骤 2：从 OAuth AccessToken 获取 XBLToken
    Private Function MsLoginStep2(AccessToken As String) As String
        McLaunchLog("开始微软登录步骤 2/6")
@@ -891,8 +898,8 @@ LoginFinish:
           },
           ""RelyingParty"": ""http://auth.xboxlive.com"",
           ""TokenType"": ""JWT""
-        }" 'TODO: 新版登录改为 ""RpsTicket"": ""d=" & AccessToken & """
-        Dim Result As String = NetRequestMulty("https://user.auth.xboxlive.com/user/authenticate", "POST", Request, "application/json", 3)
+        }"
+        Dim Result As String = NetRequestMultiple("https://user.auth.xboxlive.com/user/authenticate", "POST", Request, "application/json", 3)

        Dim ResultJson As JObject = GetJson(Result)
        Dim XBLToken As String = ResultJson("Token").ToString
@@ -914,7 +921,7 @@ LoginFinish:
                                 }"
        Dim Result As String
        Try
-            Result = NetRequestMulty("https://xsts.auth.xboxlive.com/xsts/authorize", "POST", Request, "application/json", 3)
+            Result = NetRequestMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", "POST", Request, "application/json", 3)
        Catch ex As Net.WebException
            '参考 https://github.com/PrismarineJS/prismarine-auth/blob/master/src/common/Constants.js
            If ex.Message.Contains("2148916227") Then
@@ -957,7 +964,7 @@ LoginFinish:
        Dim Request As String = New JObject(New JProperty("identityToken", $"XBL3.0 x={Tokens(1)};{Tokens(0)}")).ToString(0)
        Dim Result As String
        Try
-            Result = NetRequestMulty("https://api.minecraftservices.com/authentication/login_with_xbox", "POST", Request, "application/json", 2)
+            Result = NetRequestRetry("https://api.minecraftservices.com/authentication/login_with_xbox", "POST", Request, "application/json")
        Catch ex As Net.WebException
            Dim Message As String = GetExceptionSummary(ex)
            If Message.Contains("(429)") Then
@@ -979,7 +986,7 @@ LoginFinish:
    Private Sub MsLoginStep5(AccessToken As String)
        McLaunchLog("开始微软登录步骤 5/6")

-        Dim Result As String = NetRequestMulty("https://api.minecraftservices.com/entitlements/mcstore", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
+        Dim Result As String = NetRequestMultiple("https://api.minecraftservices.com/entitlements/mcstore", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
        Try
            Dim ResultJson As JObject = GetJson(Result)
            If Not (ResultJson.ContainsKey("items") AndAlso ResultJson("items").Any) Then
@@ -1000,7 +1007,7 @@ LoginFinish:

        Dim Result As String
        Try
-            Result = NetRequestMulty("https://api.minecraftservices.com/minecraft/profile", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
+            Result = NetRequestMultiple("https://api.minecraftservices.com/minecraft/profile", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
        Catch ex As Net.WebException
            Dim Message As String = GetExceptionSummary(ex)
            If Message.Contains("(429)") Then
@@ -1255,7 +1262,7 @@ LoginFinish:
    ''' 释放 Java Wrapper 并返回完整文件路径。
    ''' </summary>
    Public Function ExtractJavaWrapper() As String
-        Dim BaseDir As String = GetJavaWrapperDir()
+        Dim BaseDir As String = GetPureASCIIDir()
        Dim WrapperPath As String = BaseDir & "\JavaWrapper.jar"
        Log("[Java] 选定的 Java Wrapper 路径：" & WrapperPath)
        SyncLock ExtractJavaWrapperLock '避免 OptiFine 和 Forge 安装时同时释放 Java Wrapper 导致冲突
@@ -1287,9 +1294,10 @@ LoginFinish:
    Private ExtractJavaWrapperLock As New Object

    ''' <summary>
-    ''' 获取 Java Wrapper 所在的文件夹，不以 \ 结尾。
+    ''' 获取一个可用于临时存放文件的，不含任何特殊字符的文件夹路径。
+    ''' 返回值不以 \ 结尾。
    ''' </summary>
-    Public Function GetJavaWrapperDir() As String
+    Public Function GetPureASCIIDir() As String
        If (Path & "PCL").IsASCII() Then
            Return Path & "PCL"
        ElseIf PathAppdata.IsASCII() Then
@@ -1410,7 +1418,7 @@ LoginFinish:

        '添加 Java Wrapper 作为主 Jar
        If McLaunchJavaSelected.VersionCode >= 9 Then DataList.Add("--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED")
-        DataList.Add("-Doolloo.jlw.tmpdir=""" & GetJavaWrapperDir() & """")
+        DataList.Add("-Doolloo.jlw.tmpdir=""" & GetPureASCIIDir() & """")
        DataList.Add("-jar """ & ExtractJavaWrapper() & """")

        '添加 MainClass
@@ -1477,7 +1485,7 @@ NextVersion:

        '添加 Java Wrapper 作为主 Jar
        If McLaunchJavaSelected.VersionCode >= 9 Then DataList.Add("--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED")
-        DataList.Add("-Doolloo.jlw.tmpdir=""" & GetJavaWrapperDir() & """")
+        DataList.Add("-Doolloo.jlw.tmpdir=""" & GetPureASCIIDir() & """")
        DataList.Add("-jar """ & ExtractJavaWrapper() & """")

        '将 "-XXX" 与后面 "XXX" 合并到一起
@@ -539,7 +539,7 @@ RetryStart:
            '压缩 Subtitle
            ColumnSubtitle.Width = New GridLength(1, GridUnitType.Star)
            ColumnExtend.Width = New GridLength(0, GridUnitType.Pixel)
-        ElseIf Not ColumnExtend.Width.IsStar AndAlso ColumnSubtitle.ActualWidth > LabSubtitle.ActualWidth + 10 Then
+        ElseIf Not ColumnExtend.Width.IsStar AndAlso Not LabSubtitle.IsTextTrimmed Then
            '向右展开 Subtitle
            ColumnSubtitle.Width = GridLength.Auto
            ColumnExtend.Width = New GridLength(1, GridUnitType.Star)
@@ -280,7 +280,7 @@
            '当前音乐已播放结束，继续下一曲
            If CurrentWave.PlaybackState = NAudio.Wave.PlaybackState.Stopped AndAlso MusicAllList.Any Then MusicStartPlay(DequeueNextMusicAddress)
        Catch ex As Exception
-            Log("[Music] 播放音乐失败的文件完整路径：" & MusicCurrent)
+            Log(ex, "播放音乐出现内部错误（" & MusicCurrent & "）", LogLevel.Developer)
            If TypeOf ex Is NAudio.MmException AndAlso (ex.Message.Contains("NoDriver") OrElse ex.Message.Contains("BadDeviceId")) Then
                Hint("由于音频设备变更，音乐播放功能在重启 PCL 后才能恢复！", HintType.Critical)
                Thread.Sleep(1000000000)