From 5ef1d60e2e0bef93d606f16647e54049cde1ef00 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=E9=BE=99=E8=85=BE=E7=8C=AB=E8=B7=83?= <1043137532@qq.com>
Date: Thu, 10 Nov 2022 20:22:47 +0800
Subject: [PATCH] =?UTF-8?q?=E7=94=B1=E4=BA=8E=E8=81=94=E6=9C=BA=E5=B7=B2?=
=?UTF-8?q?=E8=A2=AB=E7=A6=81=E7=94=A8=EF=BC=8C=E5=85=AC=E5=BC=80=E8=81=94?=
=?UTF-8?q?=E6=9C=BA=E9=83=A8=E5=88=86=E4=BB=A3=E7=A0=81?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
---
.gitignore | 3 -
licence.txt => LICENCE | 0
.../Pages/PageLink/PageLinkHiper.xaml.vb | 952 +++++++++++++
.../Pages/PageLink/PageLinkIoi.xaml.vb | 1262 +++++++++++++++++
4 files changed, 2214 insertions(+), 3 deletions(-)
rename licence.txt => LICENCE (100%)
create mode 100644 Plain Craft Launcher 2/Pages/PageLink/PageLinkHiper.xaml.vb
create mode 100644 Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml.vb
diff --git a/.gitignore b/.gitignore
index c346e334..efe225f7 100644
--- a/.gitignore
+++ b/.gitignore
@@ -349,9 +349,6 @@ ModSetup.vb
PageOtherAbout.*
PageOtherTest.*
PageSetupUI.*
-# 公开联机代码可能导致安全风险
-Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml.vb
-Plain Craft Launcher 2/Pages/PageLink/PageLinkHiPer.xaml.vb
# 开发者工具
ModDevelop.vb
# 不公开底层函数库，以免抄袭
diff --git a/licence.txt b/LICENCE
similarity index 100%
rename from licence.txt
rename to LICENCE
diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkHiper.xaml.vb b/Plain Craft Launcher 2/Pages/PageLink/PageLinkHiper.xaml.vb
new file mode 100644
index 00000000..4c0ffa62
--- /dev/null
+++ b/Plain Craft Launcher 2/Pages/PageLink/PageLinkHiper.xaml.vb
@@ -0,0 +1,952 @@
+Public Class PageLinkHiper
+ Public Const RequestVersion As Char = "2"
+
+ '记录的启动情况
+ Public Shared IsServerSide As Boolean
+ Private Shared HostIp As String
+ Private Shared HostPort As Integer
+
+#Region "初始化"
+
+ '加载器初始化
+ Private Sub LoaderInit() Handles Me.Initialized
+ PageLoaderInit(Load, PanLoad, PanContent, PanAlways, InitLoader, AutoRun:=False)
+ '注册自定义的 OnStateChanged
+ AddHandler InitLoader.OnStateChangedUi, AddressOf OnLoadStateChanged
+ End Sub
+
+ Private IsLoad As Boolean = False
+ Private Sub OnLoaded() Handles Me.Loaded
+ If IsLoad Then Exit Sub
+ IsLoad = True
+ '启动监视线程
+ If Not IsWatcherStarted Then RunInNewThread(AddressOf WatcherThread, "Hiper Watcher")
+ '读取索引码
+ Try
+ Dim Time As String = Setup.Get("LinkHiperCertTime")
+ If Time = "" Then
+ Log("[HiPer] 没有缓存凭证")
+ ElseIf Date.Parse(Time) > Date.Now Then
+ TextCert.Text = Setup.Get("LinkHiperCertLast")
+ Log("[HiPer] 缓存凭证尚未过期：" & Time)
+ CurrentSubpage = Subpages.PanSelect
+ Else
+ Log("[HiPer] 缓存凭证已过期：" & Time)
+ LabCertTitle.Text = "输入索引码"
+ LabCertDesc.Text = "你的 HiPer 索引码已经过期，请输入新的索引码。" & vbCrLf & "如果实在没有索引码，可以在左侧选择 IOI 方式联机。"
+ End If
+ Catch ex As Exception
+ Log(ex, "读取缓存凭证失败")
+ Setup.Set("LinkHiperCertTime", "")
+ End Try
+ End Sub
+
+#End Region
+
+#Region "加载步骤"
+
+ Public Shared PathHiper As String = PathAppdata & "联机模块\"
+ Public Shared WithEvents InitLoader As New LoaderCombo(Of Integer)("HiPer 初始化", {
+ New LoaderTask(Of Integer, Integer)("网络环境：连通检测", AddressOf InitPingCheck) With {.Block = False, .ProgressWeight = 0.5},
+ New LoaderTask(Of Integer, Integer)("网络环境：IP 检测", AddressOf InitIpCheck) With {.Block = False, .ProgressWeight = 1},
+ New LoaderTask(Of Integer, Integer)("检查网络环境", AddressOf InitCheck) With {.ProgressWeight = 0.5},
+ New LoaderTask(Of Integer, List(Of NetFile))("获取所需文件", AddressOf InitGetFile) With {.ProgressWeight = 4},
+ New LoaderDownload("下载所需文件", New List(Of NetFile)) With {.ProgressWeight = 4},
+ New LoaderTask(Of Integer, Integer)("启动联机模块", AddressOf InitLaunch) With {.ProgressWeight = 7}
+ })
+
+ '检查网络状态
+ Private Shared Sub InitPingCheck(Task As LoaderTask(Of Integer, Integer))
+ PingTime = 0
+ Try
+ Log("[HiPer] 网络检测：连通检测开始")
+ Dim StartTime = Date.Now.Ticks
+ Dim Result As String = NetGetCodeByClient("https://www.baidu.com/duty/", Encoding.UTF8, 20000, "")
+ Dim DuringTime As Integer = (Date.Now.Ticks - StartTime) / 10000
+ If Result.Contains("百度") Then
+ Log("[HiPer] 网络检测：连通检测成功（" & DuringTime & "ms）")
+ PingTime = DuringTime
+ Else
+ Log("[HiPer] 网络检测：连通检测失败（获取的内容有误）")
+ PingTime = -1
+ End If
+ Catch ex As ThreadInterruptedException
+ Catch ex As Exception
+ Log(ex, "连通检测失败")
+ PingTime = -1
+ End Try
+ End Sub
+ Private Shared Sub InitIpCheck()
+ IpCheckStatus = LoadState.Loading
+ Try
+ Log("[HiPer] 网络检测：IP 地址检测开始")
+ Dim IpCheckResult As String = NetRequestOnce("https://ipinfo.io/json", "GET", "", "application/json", 10000)
+ Dim Country As String = GetJson(IpCheckResult)("country")
+ IpIsInChina = Country = "CN"
+ IpCheckStatus = LoadState.Finished
+ Log("[HiPer] 网络检测：IP 地址检测结果：" & Country)
+ Catch ex As ThreadInterruptedException
+ IpCheckStatus = LoadState.Aborted
+ Catch ex As Exception
+ Log(ex, "IP 地址检测失败")
+ IpCheckStatus = LoadState.Failed
+ IpIsInChina = True
+ End Try
+ End Sub
+ Private Shared PingTime As Integer, IpCheckStatus As LoadState = LoadState.Loading, IpIsInChina As Boolean
+ Private Shared Sub InitCheck(Task As LoaderTask(Of Integer, Integer))
+ '检查协议
+ If Not Setup.Get("LinkEula") Then
+Reopen:
+ Select Case MyMsgBox("PCL2 的联机服务由速聚授权提供。" & vbCrLf & "在使用前，你需要同意速聚的用户服务协议和隐私政策。", "协议授权", "同意", "拒绝", "查看用户服务协议和隐私政策")
+ Case 1
+ Setup.Set("LinkEula", True)
+ Case 2
+ Throw New Exception("$你拒绝了用户服务协议……")
+ Case 3
+ OpenWebsite("https://mp.weixin.qq.com/mp/appmsgalbum?__biz=MzkxMTMyODk3Mg==&action=getalbum&album_id=2585385685407514625&scene=173&from_msgid=2247483720&from_itemidx=1&count=3&nolastread=1#wechat_redirect")
+ GoTo Reopen
+ End Select
+ End If
+ '等待网络环境检查加载器结束
+ SetLoadDesc("正在检查网络环境……", "检查网络环境")
+ Do While Task.State = LoadState.Loading AndAlso Not (PingTime <> 0 AndAlso IpCheckStatus <> LoadState.Loading)
+ Thread.Sleep(50)
+ Loop
+ '获取网络环境检查结果
+ If IpCheckStatus = LoadState.Finished AndAlso Not IpIsInChina Then
+ If MyMsgBox("检测到你的 IP 不在中国，这会导致联机变得非常不稳定。" & vbCrLf &
+ "如果你正开着加速器或者 VPN，请先关闭它们，然后再继续……", "警告", "继续", "取消", IsWarn:=True, ForceWait:=True) = 2 Then
+ Throw New Exception("$请在关闭加速器或者 VPN 后点击重试。")
+ End If
+ Task.Progress = 0.5
+ InitIpCheck() '重新进行检查
+ End If
+ '没有联网
+ If IpCheckStatus = LoadState.Failed AndAlso PingTime = -1 Then
+ Throw New Exception("$PCL2 没法连上网……" & vbCrLf & "如果你改变了网络环境，请重启 PCL2。")
+ End If
+ End Sub
+
+ '获取所需文件
+ Private Shared Sub InitGetFile(Task As LoaderTask(Of Integer, List(Of NetFile)))
+ '初始化
+ SetLoadDesc("正在初始化……", "初始化")
+ Directory.CreateDirectory(PathHiper)
+ WriteFile(PathHiper & "HiPer 联机模块.vbs", "createobject(""wscript.shell"").run """"""" & PathHiper & "HiPer 联机模块.exe"""" v"", 0", Encoding:=Encoding.GetEncoding("GB18030")) '准备启动脚本
+ '获取索引码文件
+ SetLoadDesc("正在获取索引码文件……", "获取索引码文件")
+ Dim Cert As String = RunInUiWait(Function() FrmLinkHiper.TextCert.Text)
+ Log("[Hiper] 联机索引码：" & Cert)
+ If Cert = Setup.Get("LinkHiperCertLast") AndAlso File.Exists(PathHiper & "cert.yml") Then
+ Log("[Hiper] 索引码与上次输入的一致，跳过获取步骤")
+ Else
+ Dim CertRaw As String
+ Try
+ CertRaw = NetRequestOnce("https://cert.mcer.cn/" & Cert & ".yml", "GET", "", "")
+ Catch ex As Exception
+ If GetString(ex).Contains("(404)") Then
+ Throw New CertOutdatedException '索引码无效或已过期
+ ElseIf GetString(ex).Contains("too many requests") Then
+ Throw New Exception("你的尝试太频繁了，请暂时啥都别点，等两分钟后再试……")
+ Else
+ Throw
+ End If
+ End Try
+ If Not CertRaw.Contains("WARNING <<< AUTO SYNC AREA") Then Throw New Exception("获取到的索引码文件内容有误！")
+ WriteFile(PathHiper & "cert.yml", CertRaw)
+ Setup.Set("LinkHiperCertLast", Cert)
+ Setup.Set("LinkHiperCertTime", "")
+ End If
+ Task.Progress = 0.25
+ '获取 CPU 架构
+ SetLoadDesc("正在获取 CPU 架构……", "获取 CPU 架构")
+ Dim Architecture As String
+ Select Case GetType(String).Assembly.GetName().ProcessorArchitecture
+ Case Reflection.ProcessorArchitecture.X86
+ Architecture = "386"
+ Case Reflection.ProcessorArchitecture.Amd64
+ Architecture = "amd64"
+ Case Reflection.ProcessorArchitecture.Arm
+ Architecture = "arm64"
+ Case Else
+ Architecture = "arm64"
+ Log("[Hiper] 当前 CPU 架构为 " & GetStringFromEnum(GetType(String).Assembly.GetName().ProcessorArchitecture) & "，没有最适合的项，这可能会导致联机模块无法启动！", LogLevel.Debug)
+ End Select
+ Log("[Hiper] CPU 架构：" & Architecture)
+ '检查更新：hiper.exe
+ SetLoadDesc("正在检查联机模块本体更新……", "检查联机模块本体更新")
+ Dim RequiredFiles As New List(Of NetFile)
+ Dim Checksums As String = Nothing, ChecksumHiper As String = Nothing
+ If File.Exists(PathHiper & "HiPer 联机模块.exe") Then
+ Try
+ Checksums = NetGetCodeByDownload({
+ "http://mirror.hiper.cn.s2.the.bb/packages.sha1",
+ "http://mirror.hiper.cn.s3.the.bb:175/packages.sha1",
+ "https://gitcode.net/to/hiper/-/raw/master/packages.sha1",
+ "https://cert.mcer.cn/mirror/packages.sha1"
+ })
+ Catch ex As Exception
+ Log(ex, "获取联机模块更新信息失败，将会强制启动联机模块", LogLevel.Hint)
+ GoTo FinishHiperFileCheck
+ End Try
+ ChecksumHiper = RegexSeek(Checksums, "[0-9a-f]{40}(?= windows-" & Architecture & "/hiper.exe)")
+ If ChecksumHiper Is Nothing Then
+ Log("[Hiper] 未找到联机模块更新信息，将会强制启动联机模块", LogLevel.Hint)
+ GoTo FinishHiperFileCheck
+ End If
+ Log("[Hiper] hiper.exe 的所需 SHA1：" & ChecksumHiper)
+ If ChecksumHiper = GetAuthSHA1(PathHiper & "HiPer 联机模块.exe") Then
+ Log("[Hiper] hiper.exe 文件校验通过，无需重新下载")
+ GoTo FinishHiperFileCheck
+ End If
+ End If
+ Log("[Hiper] 需要重新下载 hiper.exe")
+ RequiredFiles.Add(New NetFile({"http://mirror.hiper.cn.s2.the.bb/windows-" & Architecture & "/hiper.exe",
+ "http://mirror.hiper.cn.s3.the.bb:175/windows-" & Architecture & "/hiper.exe",
+ "https://gitcode.net/to/hiper/-/raw/master/windows-" & Architecture & "/hiper.exe?inline=false",
+ "https://cert.mcer.cn/mirror/windows-" & Architecture & "/hiper.exe"},
+ PathHiper & "HiPer 联机模块.exe",
+ New FileChecker(Hash:=ChecksumHiper, MinSize:=1024 * 200))) 'Hash 的默认值即为 Nothing，所以 Checksum 可以为 Nothing
+FinishHiperFileCheck:
+ Task.Progress = 0.5
+ '检查更新：wintun.dll
+ Dim ChecksumWintun As String = Nothing
+ If File.Exists(PathHiper & "wintun.dll") Then
+ Try
+ If Checksums Is Nothing Then
+ Checksums = NetGetCodeByDownload({
+ "http://mirror.hiper.cn.s2.the.bb/packages.sha1",
+ "http://mirror.hiper.cn.s3.the.bb:175/packages.sha1",
+ "https://gitcode.net/to/hiper/-/raw/master/packages.sha1",
+ "https://cert.mcer.cn/mirror/packages.sha1"
+ })
+ End If
+ Catch ex As Exception
+ Log(ex, "获取联机模块更新信息失败，将会强制启动联机模块", LogLevel.Hint)
+ GoTo FinishWintunFileCheck
+ End Try
+ ChecksumWintun = RegexSeek(Checksums, "[0-9a-f]{40}(?= windows-" & Architecture & "/wintun.dll)")
+ If ChecksumWintun Is Nothing Then
+ Log("[Hiper] 未找到联机模块更新信息，将会强制启动联机模块", LogLevel.Hint)
+ GoTo FinishWintunFileCheck
+ End If
+ Log("[Hiper] wintun.dll 的所需 SHA1：" & ChecksumWintun)
+ If ChecksumWintun = GetAuthSHA1(PathHiper & "wintun.dll") Then
+ Log("[Hiper] wintun.dll 文件校验通过，无需重新下载")
+ GoTo FinishWintunFileCheck
+ End If
+ End If
+ Log("[Hiper] 需要重新下载 wintun.dll")
+ RequiredFiles.Add(New NetFile({"http://mirror.hiper.cn.s2.the.bb/windows-" & Architecture & "/wintun.dll",
+ "http://mirror.hiper.cn.s3.the.bb:175/windows-" & Architecture & "/wintun.dll",
+ "https://gitcode.net/to/hiper/-/raw/master/windows-" & Architecture & "/wintun.dll?inline=false",
+ "https://cert.mcer.cn/mirror/windows-" & Architecture & "/wintun.dll"},
+ PathHiper & "wintun.dll",
+ New FileChecker(Hash:=ChecksumWintun, MinSize:=1024 * 200))) 'Hash 的默认值即为 Nothing，所以 Checksum 可以为 Nothing
+FinishWintunFileCheck:
+ Task.Progress = 0.75
+ '检查更新：MCB
+ If Not IsServerSide Then
+ SetLoadDesc("正在检查联机模块组件更新……", "检查联机模块组件更新")
+ Dim ChecksumMcb As String = Nothing
+ If File.Exists(PathHiper & "MCB 联机模块.exe") Then
+ Try
+ Checksums = NetGetCodeByDownload({
+ "http://mirror.hiper.cn.s2.the.bb/utils/minecraft-broadcast/packages.sha1",
+ "http://mirror.hiper.cn.s3.the.bb:175/utils/minecraft-broadcast/packages.sha1",
+ "https://gitcode.net/to/hiper/-/raw/master/utils/minecraft-broadcast/packages.sha1",
+ "https://cert.mcer.cn/mirror/utils/minecraft-broadcast/packages.sha1"
+ })
+ Catch ex As Exception
+ Log(ex, "获取联机模块组件更新信息失败，将会强制启动联机模块组件", LogLevel.Hint)
+ GoTo FinishMcbFileCheck
+ End Try
+ ChecksumMcb = RegexSeek(Checksums, "[0-9a-f]{40}(?= mcb-windows-" & Architecture & ".exe)")
+ If ChecksumMcb Is Nothing Then
+ Log("[Hiper] 未找到联机模块组件更新信息，将会强制启动联机模块组件", LogLevel.Hint)
+ GoTo FinishMcbFileCheck
+ End If
+ Log("[Hiper] mcb.exe 的所需 SHA1：" & ChecksumMcb)
+ If ChecksumMcb = GetAuthSHA1(PathHiper & "MCB 联机模块.exe") Then
+ Log("[Hiper] mcb.exe 文件校验通过，无需重新下载")
+ GoTo FinishMcbFileCheck
+ End If
+ End If
+ Log("[Hiper] 需要重新下载 mcb.exe")
+ RequiredFiles.Add(New NetFile({
+ "http://mirror.hiper.cn.s2.the.bb/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe",
+ "http://mirror.hiper.cn.s3.the.bb:175/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe",
+ "https://gitcode.net/to/hiper/-/raw/master/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe?inline=false",
+ "https://cert.mcer.cn/mirror/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe"},
+ PathHiper & "MCB 联机模块.exe",
+ New FileChecker(Hash:=ChecksumMcb, MinSize:=1024 * 200))) 'Hash 的默认值即为 Nothing，所以 Checksum 可以为 Nothing
+FinishMcbFileCheck:
+ End If
+ '添加 point.yml
+ RequiredFiles.Add(New NetFile({"https://cert.mcer.cn/point.yml"}, PathHiper & "point.yml", New FileChecker(MinSize:=200)))
+ '开始下载
+ SetLoadDesc("正在下载联机模块……", "下载联机模块")
+ Task.Output = RequiredFiles
+ End Sub
+ Public Class CertOutdatedException
+ Inherits Exception
+ End Class
+ '启动联机模块
+ Private Shared Sub InitLaunch(Task As LoaderTask(Of Integer, Integer))
+ '关闭运行中的 HiPer，然后再刷新凭证文件
+ SetLoadDesc("正在关闭运行中的联机模块……", "关闭运行中的联机模块")
+ HiperStop(True)
+ '准备凭证文件
+ SetLoadDesc("正在准备索引码文件……", "准备索引码文件")
+ Dim CertFile As String = ReadFile(PathHiper & "cert.yml")
+ '添加防火墙配置
+ If IsServerSide Then
+ CertFile += ("\n\ninbound:\n port: " & HostPort & "\n proto: tcp\n host: any").Replace("\n", vbCrLf)
+ Else
+ CertFile += ("\n\noutbound:\n port: " & HostPort & "\n proto: tcp\n host: " & HostIp).Replace("\n", vbCrLf)
+ End If
+ CertFile += "\nlogging:\n format: json".Replace("\n", vbCrLf)
+ '更新 point.yml 段
+ Const SyncAreaRegex As String = "(?<=#[ ]*WARNING >>> AUTO SYNC AREA)[\s\S]+?(?=#[ ]*WARNING <<< AUTO SYNC AREA)"
+ CertFile = CertFile.Replace(RegexSeek(CertFile, SyncAreaRegex), RegexSeek(ReadFile(PathHiper & "point.yml"), SyncAreaRegex))
+ WriteFile(PathHiper & "config.yml", CertFile)
+ AllNodes = RegexSearch(CertFile.Replace(vbLf, "cr"), "(?<="")[0-9]+.[0-9]+.[0-9]+.[0-9]+(?=""( )?:( )?cr - "")").Distinct.
+ Where(Function(l) Not (l = "6.6.1.1" OrElse l = "6.6.2.2" OrElse l = "6.6.3.3")).ToList
+ If AllNodes.Count < 2 Then Throw New Exception("$索引码文件格式有误，未找到节点 IP！")
+ Task.Progress = 0.05
+ '尝试启动
+ HiperStart(Task) '启动失败会直接抛出异常
+ Task.Progress = 0.2
+ '检查连接情况
+ SetLoadDesc("正在连接到联机节点 (1/2)……" & If(IpIsInChina, "", vbCrLf & "由于网络不在中国，可能要花费很长时间。"), "检查联机节点")
+ If Not IsServerSide AndAlso HostIp = HiperIp Then Throw New Exception("$还搁这自己连自己？！不是吧？！")
+ Dim PingNodeResults As New List(Of Integer)
+ Dim UnpingedNodes As New List(Of String)(AllNodes)
+ Do Until PingNodeResults.Count >= 2 OrElse Task.IsAborted
+ Dim SelectedNode = RandomOne(UnpingedNodes)
+ Dim PingNode = Ping(SelectedNode, 4000)
+ If PingNode = -1 Then
+ Task.Progress += (If(PingNodeResults.Count = 0, 0.58, 0.88) - Task.Progress) * 0.3
+ Else
+ SetLoadDesc("正在连接到联机节点 (2/2)……" & If(IpIsInChina, "", vbCrLf & "由于网络不在中国，可能要花费很长时间。"), "检查联机节点")
+ Task.Progress = 0.6
+ PingNodeResults.Add(PingNode)
+ UnpingedNodes.Remove(SelectedNode)
+ End If
+ Loop
+ PingNodes = PingNodeResults.Min
+ Task.Progress = 0.9
+ '与房主 Ping 一下看看
+ If Not IsServerSide Then
+ SetLoadDesc("正在连接到房主……", "检查房主")
+ HostPing = -1 '实际上不使用本次 Ping 的结果，因为它真的偏大……
+ Do
+ Dim PingHost = Ping(HostIp, 4000, False)
+ If PingHost = -1 Then
+ Thread.Sleep(500)
+ Else
+ Exit Do
+ End If
+ Loop Until Task.IsAborted
+ '在等待 2 秒后再次触发 Ping，以刷新显示的 Ping
+ RunInNewThread(Sub()
+ Thread.Sleep(2000)
+ TaskPingHost.Start(True, IsForceRestart:=True)
+ End Sub, "HiPer Delayed Ping")
+ End If
+ '刷新完成页面
+ SetLoadDesc("正在加载完成页面……", "加载完成页面")
+ RunInUiWait(AddressOf FrmLinkHiper.WatcherTimer1)
+ End Sub
+ Private Shared PingNodes As Integer, AllNodes As List(Of String)
+
+#End Region
+
+#Region "进程管理"
+
+ Private Shared _HiperState As LoadState = LoadState.Waiting
+ Public Shared Property HiperState As LoadState
+ Get
+ Return _HiperState
+ End Get
+ Set(value As LoadState)
+ _HiperState = value
+ RunInUi(Sub() If FrmLinkLeft IsNot Nothing Then CType(FrmLinkLeft.ItemHiper.Buttons(0), MyIconButton).Visibility = If(HiperState = LoadState.Finished OrElse HiperState = LoadState.Loading, Visibility.Visible, Visibility.Collapsed))
+ End Set
+ End Property
+ Public Shared Sub ModuleStopManually() '关闭联机模块按钮
+ HiperExit(False)
+ End Sub
+
+ Private Shared HiperIp As String = Nothing
+ Private Shared HiperProcessId As Integer = -1, McbProcessId As Integer = -1
+ Private Shared HiperCertTime As Date = Date.Now
+
+ '''
+ ''' 若程序正在运行，则结束程序进程，同时初始化状态数据。返回是否关闭了相关进程。
+ '''
+ Public Shared Function HiperStop(SleepWhenKilled As Boolean) As Boolean
+ HiperStop = False
+ '修改凭证
+ Dim ConfigContent As String = ReadFile(PathHiper & "config.yml")
+ If Not ConfigContent.Contains("enable: false") Then
+ WriteFile(PathHiper & "config.yml", ConfigContent & vbCrLf & "enable: false")
+ End If
+ '关闭所有进程
+ For Each ProcessObject In Process.GetProcesses
+ Dim IsHiper As Boolean = ProcessObject.ProcessName = "HiPer 联机模块"
+ Dim IsMcb As Boolean = ProcessObject.ProcessName = "MCB 联机模块"
+ If Not IsHiper AndAlso Not IsMcb Then Continue For
+ HiperStop = True
+ Try
+ If IsMcb Then
+ ProcessObject.Kill()
+ Log("[HiPer] 已结束进程 PID " & ProcessObject.Id & "：" & ProcessObject.ProcessName)
+ If HiperStop AndAlso SleepWhenKilled Then Thread.Sleep(1000) '等待 1 秒确认进程已退出
+ Else 'IsHiper
+ If SleepWhenKilled Then
+ Thread.Sleep(4000) '等待 4 秒确认进程已退出
+ If Not ProcessObject.HasExited Then
+ ProcessObject.Kill()
+ Log("[HiPer] 已结束进程 PID " & ProcessObject.Id & "：" & ProcessObject.ProcessName)
+ End If
+ End If
+ End If
+ Catch ex As Exception
+ Log(ex, "结束进程失败（" & ProcessObject.Id & "，" & ProcessObject.ProcessName & "）")
+ End Try
+ Next
+ '初始化
+ HiperState = LoadState.Waiting
+ HiperProcessId = -1 : McbProcessId = -1
+ HiperCertTime = Nothing
+ End Function
+ '''
+ ''' 启动程序，并等待初始化完成后退出运行，同时更新 HiperIp。
+ ''' 若启动失败，则会直接抛出异常。
+ ''' 若程序正在运行，则会先停止其运行。
+ '''
+ Public Shared Sub HiperStart(Task As LoaderTask(Of Integer, Integer))
+ Try
+ SetLoadDesc("正在启动联机模块……", "启动联机模块")
+ PossibleFailReason = Nothing
+ '启动 Hiper
+ Log("[Hiper] 启动 Hiper 进程")
+ DeleteDirectory(PathHiper & "logs") '清理日志
+ Dim HiperInfo = New ProcessStartInfo With {
+ .FileName = "wscript",
+ .Arguments = """" & PathHiper & "HiPer 联机模块.vbs""",
+ .Verb = "runas" '需要管理员权限
+ }
+ Dim HiperVbsProcess As New Process() With {.StartInfo = HiperInfo}
+ HiperVbsProcess.Start()
+ '查找真正的 Hiper 进程
+ SetLoadDesc("联机模块正在启动……", "联机模块加载")
+ Do
+ Dim GotProcesses = Process.GetProcesses.
+ Where(Function(l) l.ProcessName = "HiPer 联机模块" AndAlso Math.Abs((l.StartTime - Date.Now).TotalMinutes) < 1)
+ If GotProcesses.Count > 0 Then
+ HiperProcessId = GotProcesses.First.Id
+ Log("[Hiper] 已发现 Hiper 进程，PID：" & HiperProcessId)
+ Exit Do
+ End If
+ Thread.Sleep(50)
+ Loop While Task.State = LoadState.Loading AndAlso Not Task.IsAborted
+ If HiperProcessId = -1 Then Throw New Exception("联机模块未能成功启动！")
+ HiperState = LoadState.Loading
+ Task.Progress = 0.15
+ '抓取日志
+ Dim LogLine As Integer = 0
+ Do
+ Thread.Sleep(100)
+ If Not File.Exists(PathHiper & "logs\hiper.log") Then Continue Do
+ Dim LogLines As String() = ReadFile(PathHiper & "logs\hiper.log").TrimEnd(vbLf).Split(vbLf)
+ For i = LogLine To LogLines.Count - 1
+ HiperLogLine(LogLines(i), Task)
+ Next
+ LogLine = LogLines.Count
+ Loop While HiperState = LoadState.Loading AndAlso Not Task.IsAborted AndAlso Process.GetProcesses.Any(Function(l) l.Id = HiperProcessId)
+ '输出
+ If HiperState = LoadState.Finished Then
+ Log("[Hiper] Hiper 启动完成")
+ ElseIf PossibleFailReason IsNot Nothing AndAlso PossibleFailReason.Contains("索引码已过期") Then
+ Throw New CertOutdatedException()
+ Else
+ Throw New Exception(If(PossibleFailReason, "联机模块因未知原因启动失败！"))
+ End If
+ '启动 MCB
+ Task.Progress = 0.25
+ If Not IsServerSide Then
+ Try
+ Log("[Hiper] 启动 MCB 进程")
+ Dim McbInfo = New ProcessStartInfo With {
+ .FileName = PathHiper & "MCB 联机模块.exe", .WorkingDirectory = PathHiper,
+ .UseShellExecute = False, .CreateNoWindow = True,
+ .RedirectStandardError = True, .RedirectStandardOutput = True,
+ .Arguments = "-addr " & HostIp & ":" & HostPort & " -motd ""PCL2 联机房间"""
+ }
+ Dim McbProcess As New Process() With {.StartInfo = McbInfo}
+ McbProcess.Start()
+ McbProcessId = McbProcess.Id
+ Catch ex As Exception
+ Throw New Exception("联机模块组件启动失败", ex)
+ End Try
+ End If
+ Catch ex As Exception
+ Try
+ HiperStop(True) '由于启动失败停止进程
+ Catch
+ End Try
+ HiperState = LoadState.Failed
+ Throw
+ End Try
+ End Sub
+
+ 'Hiper 日志
+ Private Shared Sub HiperLogLine(Content As String, Task As LoaderTask(Of Integer, Integer))
+
+ '检查报错
+ Dim ContentTest As String = Content.ToLower
+ Dim ErrorMessage As String = Nothing
+ Dim ContentJson As JObject = Nothing
+ If Content.StartsWith("{""") AndAlso Content.EndsWith("}") Then
+ ContentJson = GetJson(Content)
+ ContentTest = If(ContentJson("error"), ContentJson("msg")).ToString.ToLower
+ ErrorMessage = ContentJson("error")
+ End If
+ If ContentTest.Contains("hiper certificate for this host is expired") Then
+ PossibleFailReason = "$你的索引码已过期，请更换新的索引码！"
+ ElseIf ContentTest.Contains("error creating interface: access is denied") Then
+ PossibleFailReason = "$没有获得管理员权限，无法创建网络通道！"
+ ElseIf ContentTest.Contains("cannot create a file when that file already exists") Then
+ PossibleFailReason = "$请不要重复开启多个联机模块！"
+ ElseIf Content.Contains("failed to load config") Then
+ PossibleFailReason = "$索引码文件内容存在错误！"
+ ElseIf Content.Contains("system cannot find the file specified") Then
+ PossibleFailReason = "$创建网络通道失败！" & vbCrLf & "如果你曾启动过 VPN 软件，请先打开那个软件，然后关掉它，最后再重试。虽然不知道为啥，但这样大概管用……"
+ End If
+ If PossibleFailReason Is Nothing AndAlso ErrorMessage IsNot Nothing Then PossibleFailReason = ErrorMessage
+
+ '检查结束
+ If ContentJson IsNot Nothing Then
+ Dim Message As String = ContentJson("msg")
+ If Message = "HiPer interface is active" Then
+ HiperIp = ContentJson("network").ToString.Split("/").First
+ If IsServerSide Then HostIp = HiperIp
+ Log("[Hiper] Hiper 启动完成，IP：" & HiperIp)
+ HiperState = LoadState.Finished
+ ElseIf Message = "Validity of client certificate" Then
+ Dim VaildTime As String = ContentJson("valid")
+ Date.TryParseExact(VaildTime, "yyyy-MM-dd HH:mm:ss", Globalization.CultureInfo.InvariantCulture, Globalization.DateTimeStyles.None, HiperCertTime)
+ Log("[Hiper] 索引码到期时间：" & HiperCertTime.ToString)
+ Setup.Set("LinkHiperCertTime", HiperCertTime.ToString)
+ End If
+ End If
+
+ '写入日志
+ If ModeDebug OrElse Content.Contains("""error""") Then Log("[Hiper] " & Content)
+
+ End Sub
+ Private Shared PossibleFailReason As String = Nothing
+
+#End Region
+
+#Region "监视线程"
+
+ '主 Timer 线程
+ Private IsWatcherStarted As Boolean = False
+ Private Sub WatcherThread()
+ Dim Sec15 As Integer = 0
+ Do While True
+ Try
+ For i = 1 To 5
+ Thread.Sleep(200)
+ If InitLoader.State = LoadState.Loading Then
+ RunInUi(AddressOf UpdateProgress)
+ End If
+ Next
+ Thread.Sleep(1000)
+ Sec15 += 1
+ WatcherTimer1()
+ If Sec15 = 15 Then
+ Sec15 = 0
+ WatcherTimer15()
+ End If
+ Catch ex As Exception
+ Log(ex, "联机模块主时钟出错", LogLevel.Feedback)
+ Thread.Sleep(20000)
+ End Try
+ Loop
+ End Sub
+
+ '每 1 秒执行的 Timer
+ Private Sub WatcherTimer1()
+ If HiperState <> LoadState.Finished Then Exit Sub
+ RunInUi(Sub()
+ '索引码剩余时间
+ Dim Span As TimeSpan = HiperCertTime - Date.Now
+ If Span.TotalDays >= 30 Then
+ LabFinishTime.Text = "> 30 天"
+ ElseIf Span.TotalDays >= 4 Then
+ LabFinishTime.Text = Span.Days & " 天"
+ ElseIf Span.TotalDays >= 1 Then
+ LabFinishTime.Text = Span.Days & " 天" & If(Span.Hours > 0, " " & Span.Hours & " 小时", "")
+ ElseIf Span.TotalMinutes >= 10 Then
+ LabFinishTime.Text = Span.Hours & ":" & Span.Minutes.ToString.PadLeft(2, "0") & "'"
+ Else
+ LabFinishTime.Text = Span.Minutes & "'" & Span.Seconds.ToString.PadLeft(2, "0") & """"
+ End If
+ '提示索引码即将到期
+ If Span.TotalSeconds <= 5 * 60 AndAlso Span.TotalSeconds > 5 * 60 - 1 AndAlso Setup.Get("LinkHiperCertWarn") Then
+ MyMsgBox("你的索引码还有不到 5 分钟就要过期了！" & vbCrLf & "你可以在设置中关闭这个提示……", "索引码即将过期", "我知道了……")
+ ShowWindowToTop(Handle)
+ Beep()
+ End If
+ '检查索引码到期
+ If Span.TotalSeconds < 2 Then
+ LabCertTitle.Text = "索引码已过期"
+ LabCertDesc.Text = "你的 HiPer 索引码已经过期，请输入新的索引码。" & vbCrLf & "如果实在没有索引码，可以在左侧选择 IOI 方式联机。"
+ TextCert.Text = ""
+ HiperExit(True)
+ ShowWindowToTop(Handle)
+ Beep()
+ Exit Sub
+ End If
+ '网络质量
+ Dim QualityScore As Integer = If(IpIsInChina, 0, -2)
+ QualityScore -= Math.Ceiling((Math.Min(PingTime, 600) + Math.Min(PingNodes, 600)) / 80)
+ Select Case QualityScore
+ Case Is >= -1
+ LabFinishQuality.Text = "优秀"
+ Case Is >= -2
+ LabFinishQuality.Text = "优良"
+ Case Is >= -3
+ LabFinishQuality.Text = "良好"
+ Case Is >= -5
+ LabFinishQuality.Text = "一般"
+ Case Is >= -7
+ LabFinishQuality.Text = "较差"
+ Case Else
+ LabFinishQuality.Text = "很差"
+ End Select
+ 'Ping
+ If HostPing <> -1 Then
+ If FrmLinkHiper IsNot Nothing AndAlso FrmLinkHiper.LabFinishPing.IsLoaded Then
+ FrmLinkHiper.LabFinishPing.Text = HostPing & "ms"
+ End If
+ End If
+ End Sub)
+ End Sub
+ '每 15 秒执行的 Timer
+ Private Shared HostPing As Integer = -1
+ Private Sub WatcherTimer15()
+ If Not (HiperState = LoadState.Finished OrElse HiperState = LoadState.Loading) Then Exit Sub
+ '检查 HiPer 崩溃
+ Try
+ Process.GetProcessById(HiperProcessId)
+ Catch
+ Dim LogLines = ReadFile(PathHiper & "logs\hiper.log").TrimEnd(vbLf).Split(vbLf)
+ HiperExit(False)
+ MyMsgBox("由于联机模块异常退出，已退出联机房间。" & vbCrLf & vbCrLf &
+ "联机模块最后的日志：" & vbCrLf & Join(LogLines.Skip(LogLines.Count - 3).ToList, vbCrLf), "联机断开")
+ End Try
+ '下面的部分需要完全完成加载
+ If HiperState <> LoadState.Finished Then Exit Sub
+ '检查 MCB 崩溃
+ Try
+ If Not IsServerSide Then Process.GetProcessById(McbProcessId)
+ Catch
+ HiperExit(False)
+ MyMsgBox("由于 MCB 联机模块异常退出，已退出联机房间。", "联机断开")
+ End Try
+ '重新检查 Ping
+ If Not IsServerSide Then
+ Dim PingHostFailedCount As Integer = 0
+ Do
+ TaskPingHost.WaitForExit(True, IsForceRestart:=True)
+ If TaskPingHost.Output = -1 Then
+ PingHostFailedCount += 1
+ Log("[HiPer] Ping 房主失败（第 " & PingHostFailedCount & " 次）")
+ If PingHostFailedCount >= 3 Then
+ HiperExit(False) : MyMsgBox("与房主断开连接，已退出联机房间。", "联机断开") : Exit Sub
+ End If
+ Else
+ If PingHostFailedCount > 0 Then Log("[HiPer] Ping 房主已恢复成功（" & HostPing & "ms）")
+ Exit Do
+ End If
+ Loop While True
+ End If
+ End Sub
+
+#End Region
+
+#Region "PanCert | 索引码输入页面"
+
+ '检测输入
+ Private Sub TextCert_ValidateChanged(sender As Object, e As EventArgs) Handles TextCert.ValidateChanged
+ BtnCertDone.IsEnabled = TextCert.ValidateResult = ""
+ End Sub
+ Private Sub TextCert_KeyUp(sender As Object, e As KeyEventArgs) Handles TextCert.KeyUp
+ If e.Key = Key.Enter AndAlso BtnCertDone.IsEnabled Then BtnCertDone_Click() '允许回车确认
+ End Sub
+
+ '确认
+ Private Sub BtnCertDone_Click() Handles BtnCertDone.Click
+ CurrentSubpage = Subpages.PanSelect
+ End Sub
+
+#End Region
+
+#Region "PanSelect | 种类选择页面"
+
+ '返回
+ Private Sub BtnSelectReturn_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnSelectReturn.MouseLeftButtonUp
+ LabCertTitle.Text = "输入索引码"
+ LabCertDesc.Text = "你需要获取索引码才能使用 HiPer。" & vbCrLf & "如果实在没有索引码，可以在左侧选择 IOI 方式联机。"
+ CurrentSubpage = Subpages.PanCert
+ End Sub
+
+ '创建房间
+ Private Sub BtnSelectCreate_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnSelectCreate.MouseLeftButtonUp
+ '获取端口号
+ Dim PortInput As String = MyMsgBoxInput("", New ObjectModel.Collection(Of Validate) From {
+ New ValidateInteger(2, 65535),
+ New ValidateExceptSame({"55555", "55557"}, "端口不能为 %！")
+ }, "在 MC 的暂停画面选择【对局域网开放】", "输入端口号", "确定", "取消")
+ If PortInput Is Nothing Then Exit Sub
+ '开始
+ RoomCreate(Val(PortInput))
+ End Sub
+ Private Sub RoomCreate(Port As Integer)
+ '记录信息
+ HostIp = Nothing : HostPort = Port
+ IsServerSide = True
+ '启动
+ InitLoader.Start(IsForceRestart:=True)
+ End Sub
+
+ '加入房间
+ Private Sub BtnSelectJoin_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnSelectJoin.MouseLeftButtonUp
+ '获取信息
+ Dim Code As String = MyMsgBoxInput("", New ObjectModel.Collection(Of Validate) From {New ValidateLength(8, 99)}, "",
+ "输入联机码", "确定", "取消")
+ If Code Is Nothing Then Exit Sub
+ '记录信息
+ If Not Code.EndsWith(RequestVersion) OrElse Not Code.StartsWith("P") Then GoTo WrongCode
+ Dim Ip As String, Port As Integer
+ Try
+ Dim IpAndPort As Long = RadixConvert(Code.Substring(1, Code.Length - 2).ToUpper, 36, 10)
+ 'IpAndPort = HostPort + IpParts(0) * 65536 + IpParts(1) * 65536 * 256 + IpParts(2) * 65536 * 256 * 256 + IpParts(3) * 65536 * 256 * 256 * 256
+ Ip = Math.Floor(IpAndPort / (65536L * 256 * 256 * 256))
+ IpAndPort = IpAndPort Mod (65536L * 256 * 256 * 256)
+ Ip = Math.Floor(IpAndPort / (65536L * 256 * 256)) & "." & Ip
+ IpAndPort = IpAndPort Mod (65536L * 256 * 256)
+ Ip = Math.Floor(IpAndPort / (65536L * 256)) & "." & Ip
+ IpAndPort = IpAndPort Mod (65536L * 256)
+ Ip = Math.Floor(IpAndPort / (65536L)) & "." & Ip
+ Port = IpAndPort Mod 65536
+ Catch
+ GoTo WrongCode
+ End Try
+ '启动
+ RoomJoin(Ip, Port)
+ Exit Sub
+WrongCode:
+ If Not Code.StartsWith("P") AndAlso Code.Length >= 49 Then Hint("你输入的可能是 IOI 的联机码，请在左侧的联机方式中选择 IOI！", HintType.Critical) : Exit Sub
+ If Code.StartsWith("P") AndAlso Not Code.EndsWith(RequestVersion) Then Hint("你的 PCL2 版本与房主的 PCL2 版本不一致！", HintType.Critical) : Exit Sub
+ Hint("你输入的联机码无效！", HintType.Critical)
+ End Sub
+ Private Sub RoomJoin(Ip As String, Port As Integer)
+ '记录信息
+ HostIp = Ip : HostPort = Port
+ IsServerSide = False
+ '启动
+ InitLoader.Start(IsForceRestart:=True)
+ End Sub
+
+#End Region
+
+#Region "PanLoad | 加载中页面"
+
+ '承接状态切换的 UI 改变
+ Private Sub OnLoadStateChanged(Loader As LoaderBase, NewState As LoadState, OldState As LoadState)
+ Select Case NewState
+ Case LoadState.Loading
+ UpdateProgress(0)
+ If IsServerSide Then
+ LabLoadTitle.Text = "正在创建联机房间"
+ Log("[Hiper] 正在创建联机房间，端口 " & HostPort)
+ Else
+ LabLoadTitle.Text = "正在加入联机房间"
+ Log("[Hiper] 正在加入联机房间，目标 IP " & HostIp & ":" & HostPort)
+ End If
+ LabLoadDesc.Text = "正在初始化……"
+ LoadStep = "准备初始化"
+ Case LoadState.Failed
+ UpdateProgress(1)
+ If IsServerSide Then
+ LabLoadTitle.Text = "创建联机房间失败"
+ Else
+ LabLoadTitle.Text = "加入联机房间失败"
+ End If
+ Dim RealException As Exception = If(Loader.Error.InnerException, Loader.Error)
+ If TypeOf RealException Is CertOutdatedException Then
+ LabCertTitle.Text = "索引码无效"
+ LabCertDesc.Text = "你的 HiPer 索引码无效或者已经过期！" & vbCrLf & "请重新输入索引码。"
+ HiperExit(True)
+ ElseIf RealException.Message.StartsWith("$") Then
+ LabLoadDesc.Text = RealException.Message.TrimStart("$") & vbCrLf &
+ "点击镐子重试，或者点击灰色的 × 取消。"
+ Else
+ LabLoadDesc.Text = LoadStep & "失败：" & GetString(RealException) & vbCrLf &
+ "点击镐子重试，或者点击灰色的 × 取消。"
+ End If
+ Log(Loader.Error, "HiPer 联机尝试失败")
+ Case LoadState.Finished
+ UpdateProgress(1)
+ CurrentSubpage = Subpages.PanFinish
+ BtnFinishPing.Visibility = If(IsServerSide, Visibility.Collapsed, Visibility.Visible)
+ LineFinishPing.Visibility = If(IsServerSide, Visibility.Collapsed, Visibility.Visible)
+ BtnFinishCopy.Visibility = If(IsServerSide, Visibility.Visible, Visibility.Collapsed)
+ If IsServerSide Then
+ LabFinishTitle.Text = "已创建联机房间"
+ LabFinishDesc.Text = "已在端口 " & HostPort & " 创建了联机房间。" & vbCrLf & "点击下方的复制联机码按钮，然后把联机码发给朋友吧！"
+ Else
+ LabFinishTitle.Text = "已加入联机房间"
+ LabFinishDesc.Text = "启动游戏，进入多人游戏页面后稍等片刻，房间就会出现在服务器列表的最下方。" & vbCrLf & "如果提示无效会话，不要退出联机房间，重新启动游戏即可！"
+ End If
+ LabFinishIp.Text = HostIp & ":" & HostPort
+ Log("[Hiper] 已完成连接")
+ End Select
+ End Sub
+ Private Shared LoadStep As String = "准备初始化"
+ Private Shared Sub SetLoadDesc(Intro As String, [Step] As String)
+ Log("[Hiper] 连接步骤：" & Intro)
+ LoadStep = [Step]
+ RunInUiWait(Sub()
+ If FrmLinkHiper Is Nothing OrElse Not FrmLinkHiper.LabLoadDesc.IsLoaded Then Exit Sub
+ FrmLinkHiper.LabLoadDesc.Text = Intro
+ FrmLinkHiper.UpdateProgress()
+ End Sub)
+ End Sub
+
+ '承接重试
+ Private Sub CardLoad_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles CardLoad.MouseLeftButtonUp
+ If Not InitLoader.State = LoadState.Failed Then Exit Sub
+ InitLoader.Start(IsForceRestart:=True)
+ End Sub
+
+ '取消加载
+ Private Sub CancelLoad() Handles BtnLoadCancel.Click
+ If InitLoader.State = LoadState.Loading Then
+ CurrentSubpage = Subpages.PanSelect
+ InitLoader.Abort()
+ Else
+ InitLoader.State = LoadState.Waiting
+ End If
+ HiperStop(False)
+ End Sub
+
+ '进度改变
+ Private Sub UpdateProgress(Optional Value As Double = -1)
+ If Value = -1 Then Value = InitLoader.Progress
+ Dim DisplayingProgress As Double = ColumnProgressA.Width.Value
+ If Math.Round(Value - DisplayingProgress, 3) = 0 Then Exit Sub
+ If DisplayingProgress > Value Then
+ ColumnProgressA.Width = New GridLength(Value, GridUnitType.Star)
+ ColumnProgressB.Width = New GridLength(1 - Value, GridUnitType.Star)
+ AniStop("Hiper Progress")
+ Else
+ Dim NewProgress As Double = If(Value = 1, 1, (Value - DisplayingProgress) * 0.2 + DisplayingProgress)
+ AniStart({
+ AaGridLengthWidth(ColumnProgressA, NewProgress - ColumnProgressA.Width.Value, 300, Ease:=New AniEaseOutFluent),
+ AaGridLengthWidth(ColumnProgressB, (1 - NewProgress) - ColumnProgressB.Width.Value, 300, Ease:=New AniEaseOutFluent)
+ }, "Hiper Progress")
+ End If
+ End Sub
+ Private Sub CardResized() Handles CardLoad.SizeChanged
+ RectProgressClip.Rect = New Rect(0, 0, CardLoad.ActualWidth, 12)
+ End Sub
+
+#End Region
+
+#Region "PanFinish | 加载完成页面"
+
+ '复制 IP
+ Private Sub BtnFinishIp_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnFinishIp.MouseLeftButtonUp
+ ClipboardSet(LabFinishIp.Text)
+ End Sub
+
+ '退出
+ Private Sub BtnFinishExit_Click(sender As Object, e As EventArgs) Handles BtnFinishExit.Click
+ If IsServerSide AndAlso MyMsgBox("你确定要关闭联机房间吗？", "确认退出", "确定", "取消", IsWarn:=True) = 2 Then Exit Sub
+ HiperExit(False)
+ End Sub
+
+ '复制联机码
+ Private Sub BtnFinishCopy_Click(sender As Object, e As EventArgs) Handles BtnFinishCopy.Click
+ Dim IpParts = HostIp.Split(".").Select(Function(l) Val(l)).ToList
+ Dim IpAndPort As Long = HostPort + IpParts(0) * 65536 + IpParts(1) * 65536 * 256 + IpParts(2) * 65536 * 256 * 256 + IpParts(3) * 65536 * 256 * 256 * 256
+ ClipboardSet("P" & RadixConvert(IpAndPort, 10, 36) & RequestVersion, False)
+ Hint("已复制联机码！", HintType.Finish)
+ End Sub
+
+ 'Ping 房主
+ Private Sub BtnFinishPing_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnFinishPing.MouseLeftButtonUp
+ LabFinishPing.Text = "检测中"
+ If TaskPingHost.State = LoadState.Loading Then Exit Sub
+ TaskPingHost.Start(True, IsForceRestart:=True)
+ End Sub
+ Private Shared TaskPingHost As New LoaderTask(Of Boolean, Integer)("HiPer Ping Host",
+ Sub(Task As LoaderTask(Of Boolean, Integer))
+ HostPing = -1
+ HostPing = Ping(HostIp, 5000, Task.Input)
+ End Sub)
+
+#End Region
+
+#Region "子页面管理"
+
+ Public Enum Subpages
+ PanCert
+ PanSelect
+ PanFinish
+ End Enum
+ Private _CurrentSubpage As Subpages = Subpages.PanCert
+ Public Property CurrentSubpage As Subpages
+ Get
+ Return _CurrentSubpage
+ End Get
+ Set(value As Subpages)
+ If _CurrentSubpage = value Then Exit Property
+ _CurrentSubpage = value
+ Log("[Hiper] 子页面更改为 " & GetStringFromEnum(value))
+ PageOnContentExit()
+ If value = Subpages.PanSelect Then
+ LabSelectCode.Text = "(" & TextCert.Text.Substring(0, Math.Min(TextCert.Text.Length, 3)) & "…)"
+ End If
+ End Set
+ End Property
+
+ Private Sub PageLinkHiper_OnPageEnter() Handles Me.PageEnter
+ FrmLinkHiper.PanCert.Visibility = If(CurrentSubpage = Subpages.PanCert, Visibility.Visible, Visibility.Collapsed)
+ FrmLinkHiper.PanSelect.Visibility = If(CurrentSubpage = Subpages.PanSelect, Visibility.Visible, Visibility.Collapsed)
+ FrmLinkHiper.PanFinish.Visibility = If(CurrentSubpage = Subpages.PanFinish, Visibility.Visible, Visibility.Collapsed)
+ End Sub
+
+ Private Shared Sub HiperExit(ExitToCertPage As Boolean)
+ Log("[Hiper] 要求退出 Hiper（当前加载器状态为 " & GetStringFromEnum(InitLoader.State) & "）")
+ HiperStop(False)
+ If InitLoader.State = LoadState.Loading Then InitLoader.Abort()
+ If InitLoader.State = LoadState.Failed Then InitLoader.State = LoadState.Waiting
+ RunInUi(Sub()
+ If FrmLinkHiper Is Nothing OrElse Not FrmLinkHiper.IsLoaded Then Exit Sub
+ FrmLinkHiper.CurrentSubpage = If(ExitToCertPage, Subpages.PanCert, Subpages.PanSelect)
+ FrmLinkHiper.PageOnContentExit()
+ End Sub)
+ End Sub
+
+#End Region
+
+End Class
diff --git a/Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml.vb b/Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml.vb
new file mode 100644
index 00000000..f95e6a31
--- /dev/null
+++ b/Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml.vb
@@ -0,0 +1,1262 @@
+Imports System.Net
+Imports System.Net.Sockets
+
+Public Class PageLinkIoi
+ Public Const RequestVersion As Integer = 4
+ Public Const IoiVersion As Integer = 10 '由于已关闭更新渠道，在提升 IoiVersion 时必须提升 RequestVersion
+ Public Shared PathIoi As String = PathAppdata & "联机模块\IOI 联机模块.exe"
+
+#Region "初始化"
+
+ '页面初始化
+ Private IsLoad As Boolean = False
+ Private Sub MeLoaded() Handles Me.Loaded
+
+ '重复加载部分
+ PanBack.ScrollToHome()
+ RefreshUi()
+
+ '非重复加载部分
+ If IsLoad Then Exit Sub
+ IsLoad = True
+
+ '更新线程
+ RunInNewThread(Sub()
+ Do While True
+ Thread.Sleep(200)
+ If FrmMain.PageCurrent.Page = FormMain.PageType.Link AndAlso FrmMain.PageCurrentSub = FormMain.PageSubType.LinkIoi Then RunInUiWait(Sub() FrmLinkIoi.RefreshUi())
+ RefreshWorker()
+ Loop
+ End Sub, "Link Timer")
+
+ End Sub
+
+ '加载器初始化与左边栏处理
+ Private Sub LoaderInit() Handles Me.Initialized
+ PageLoaderInit(Load, PanLoad, PanBack, PanAlways, InitLoader, Sub()
+ End Sub)
+ End Sub
+
+ '初始化加载器与步骤
+ Public Shared WithEvents InitLoader As New LoaderCombo(Of Integer)("联机模块初始化", {
+ New LoaderTask(Of Integer, Integer)("端口检查", AddressOf InitPortCheck) With {.ProgressWeight = 1},
+ New LoaderTask(Of Integer, Integer)("启动请求核心", AddressOf StartSocketListener) With {.ProgressWeight = 1},
+ New LoaderTask(Of Integer, List(Of NetFile))("初次启动尝试", AddressOf InitFirst) With {.ProgressWeight = 4},
+ New LoaderDownload("下载更新文件", New List(Of NetFile)) With {.ProgressWeight = 6},
+ New LoaderTask(Of List(Of NetFile), Boolean)("二次启动尝试", AddressOf InitSecond) With {.ProgressWeight = 3},
+ New LoaderTask(Of Boolean, Boolean)("创建请求核心房间", AddressOf InitRequest) With {.ProgressWeight = 2}
+ })
+ '判断端口是否被占用
+ Private Shared Sub InitPortCheck()
+ '检查协议
+ If Not Setup.Get("LinkEula") Then
+Reopen:
+ Select Case MyMsgBox("PCL2 的联机服务由速聚授权提供。" & vbCrLf & "在使用前，你需要同意速聚的用户服务协议和隐私政策。", "协议授权", "同意", "拒绝", "查看用户服务协议和隐私政策")
+ Case 1
+ Setup.Set("LinkEula", True)
+ Case 2
+ Throw New Exception("你拒绝了用户服务协议……")
+ Case 3
+ OpenWebsite("https://mp.weixin.qq.com/mp/appmsgalbum?__biz=MzkxMTMyODk3Mg==&action=getalbum&album_id=2585385685407514625&scene=173&from_msgid=2247483720&from_itemidx=1&count=3&nolastread=1#wechat_redirect")
+ GoTo Reopen
+ End Select
+ End If
+ '先掐死
+ IoiStop(True)
+ '检查端口
+ Dim HasConflict As Boolean = False
+ For Each Port In Net.NetworkInformation.IPGlobalProperties.GetIPGlobalProperties().GetActiveTcpListeners()
+ If Port.Port <> 55555 AndAlso Port.Port <> 55557 Then Continue For
+ Log("[IOI] 发现端口 " & Port.Port & " 被占用")
+ HasConflict = True
+ Next
+ If Not HasConflict Then Exit Sub
+ '对应的报错
+ For Each Line As String In ShellAndGetOutput("netstat", "-ano", 30000).Split({vbCrLf}, StringSplitOptions.RemoveEmptyEntries)
+ If Not (Line.Contains("127.0.0.1:55555") OrElse Line.Contains("127.0.0.1:55557")) Then Continue For
+ Dim ProcessName As String
+ Try
+ ProcessName = Process.GetProcessById(Line.Split(" ").Last).ProcessName
+ Catch ex As Exception
+ Log(ex, "获取占用端口的进程信息失败，假定进程已结束")
+ Continue For
+ End Try
+ If ProcessName = "联机模块" Then
+ Throw New Exception("由于一个已知问题，请在重启电脑后再尝试使用联机功能")
+ ElseIf ProcessName = "Idle" Then
+ '不知道为啥反正又没占用了
+ Log("[IOI] 未发现占用此端口的程序，继续执行")
+ Else
+ Throw New Exception("端口被程序 " & ProcessName & " 占用，无法启动联机模块，请在任务管理器关闭此程序后再试")
+ End If
+ Next
+ End Sub
+ '下载更新前尝试启动
+ Private Shared Sub InitFirst(Task As LoaderTask(Of Integer, List(Of NetFile)))
+ '初次启动尝试
+ If IoiVersion <> Setup.Get("LinkIoiVersion") Then
+ Log("[IOI] 设置版本强制要求联机模块更新")
+ Setup.Set("LinkIoiVersion", IoiVersion)
+ ElseIf File.Exists(PathIoi) Then
+ Task.Progress = 0.2
+ CheckFirewall()
+ If IoiStart() Then
+ '已完成启动与初始化
+ Task.Output = New List(Of NetFile)
+ Exit Sub
+ Else
+ '需要更新
+ IoiStop(True)
+ File.Delete(PathIoi)
+ GoTo StartDownload
+ End If
+ '如果抛出异常则直接使加载器失败
+ End If
+ '开始下载
+StartDownload:
+ Task.Progress = 0.8
+ Log("[IOI] 需要下载联机模块")
+ If File.Exists(PathTemp & "联机模块.zip") Then File.Delete(PathTemp & "联机模块.zip")
+ Task.Output = New List(Of NetFile) From {New NetFile(
+ {"https://gitcode.net/to/cato_bin/-/raw/master/ioi_v2_x" & If(Is32BitSystem, 32, 64) & ".zip",
+ "http://mirror.hiper.cn.s2.the.bb/ioi_v2_x" & If(Is32BitSystem, 32, 64) & ".zip",
+ "http://mirror.hiper.cn.s3.the.bb:175/ioi_v2_x" & If(Is32BitSystem, 32, 64) & ".zip",
+ "https://pcl2-server-1253424809.file.myqcloud.com/link/ioi_v2_x" & If(Is32BitSystem, 32, 64) & ".zip{CDN}"},
+ PathTemp & "联机模块.zip")}
+ End Sub
+ '下载更新后尝试启动
+ Private Shared Sub InitSecond(Task As LoaderTask(Of List(Of NetFile), Boolean))
+ '若首次尝试已经成功，则直接跳过
+ If IoiState = LoadState.Finished Then Exit Sub
+ '解压更新包
+ Log("[IOI] 解压联机模块以完成下载")
+ If File.Exists(PathTemp & "ioi.exe") Then File.Delete(PathTemp & "ioi.exe")
+ If File.Exists(PathIoi) Then File.Delete(PathIoi)
+ Compression.ZipFile.ExtractToDirectory(PathTemp & "联机模块.zip", PathTemp)
+ File.Delete(PathTemp & "联机模块.zip")
+ CopyFile(PathTemp & "ioi.exe", PathIoi)
+ File.Delete(PathTemp & "ioi.exe")
+ Task.Progress = 0.4
+ '再次尝试启动
+ CheckFirewall()
+ If IoiStart() Then Exit Sub
+ IoiStop(True)
+ Throw New Exception("联机模块初始化失败")
+ End Sub
+ '在 IOI 启动后建立 55557 房间
+ Private Shared Sub InitRequest()
+ Try
+ Dim Result As JObject = GetJson(NetRequestOnce("http://127.0.0.1:55555/api/port?proto=tcp&port=55557" & "&password=" & IoiPassword, "PUT", "", "", 100000))
+ If Result("msg") IsNot Nothing Then Throw New InvalidOperationException(Result("msg").ToString)
+ Catch ex As InvalidOperationException
+ 'API 返回的错误
+ Log("创建请求核心房间失败：" & ex.Message, LogLevel.Msgbox)
+ Catch ex As Exception
+ '常规错误
+ Log(ex, "创建请求核心房间失败", LogLevel.Msgbox)
+ End Try
+ End Sub
+
+ '检查防火墙权限，并添加对应的权限
+ Private Shared Sub CheckFirewall()
+ Try
+ Log("[IOI] Windows 防火墙：检测开始")
+ If Not PageLinkLeft.FirewallIsBlock(PathIoi) Then Exit Try
+ If PageLinkLeft.FirewallPolicy.CurrentProfile.ExceptionsNotAllowed Then
+ '禁止白名单
+ MyMsgBox("由于 Windows 防火墙阻止了所有传入连接，PCL2 无法获取防火墙通行权限。" & vbCrLf &
+ "联机会有很大概率失败，就算连上了，延迟也会变高……" & vbCrLf & vbCrLf &
+ "请先关闭 Windows 防火墙中的 " & vbLQ & "阻止所有传入连接" & vbRQ & " 选项，然后重启 PCL2。", "遭到防火墙拦截")
+ ElseIf IsAdmin() Then
+ '有管理员权限
+ Log("[IOI] Windows 防火墙：尝试添加防火墙通行权限")
+ Try
+ PageLinkLeft.FirewallAddAuthorized("Plain Craft Launcher 启动器（IOI 联机模块）", PathIoi)
+ Catch ex As Exception
+ Log(ex, "无法将联机模块添加至防火墙白名单，可能导致联机失败", LogLevel.Msgbox)
+ End Try
+ Else
+ '无管理员权限
+ If MyMsgBox("由于你开启了 Windows 防火墙，PCL2 需要获取防火墙通行权限。" & vbCrLf & vbCrLf &
+ "若继续，PCL2 将尝试以管理员权限重新启动。" & vbCrLf &
+ "若拒绝，联机模块可能会被防火墙拦截，联机会有很大概率失败。", "需要管理员权限", "继续", "拒绝") = 1 Then
+ Log("[IOI] Windows 防火墙：尝试提升权限")
+ If RerunAsAdmin("--link ioi") Then
+ FrmMain.EndProgram(False) '已重新运行
+ Else
+ Hint("获取管理员权限失败，请尝试右键 PCL2，选择 " & vbLQ & "以管理员身份运行" & vbRQ & "，然后再进入联机页面！", HintType.Critical)
+ End If
+ Else
+ Hint("在没有防火墙权限的情况下尝试联机，很可能会导致联机失败！", HintType.Critical)
+ End If
+ End If
+ Log("[IOI] Windows 防火墙：无防火墙通行权限")
+ Catch ex As Exception
+ Log(ex, "无法检测防火墙状态，可能导致联机失败", LogLevel.Msgbox)
+ End Try
+ End Sub
+
+#End Region
+
+#Region "进程管理"
+
+ Private Shared IoiId As String, IoiPassword As String
+ Private Shared IoiProcess As Process = Nothing
+ Private Shared IoiState As LoadState = LoadState.Waiting
+
+ '''
+ ''' 若 Ioi 正在运行，则结束 Ioi 进程，同时初始化状态数据。返回是否关闭了对应进程。
+ '''
+ Public Shared Function IoiStop(SleepWhenKilled As Boolean) As Boolean
+ IoiStop = False
+ '发送断开信息
+ Try
+ If IoiProcess IsNot Nothing AndAlso Not IoiProcess.HasExited Then
+ For i = 0 To UserList.Count - 1
+ If i > UserList.Count - 1 Then Exit For
+ Dim User = UserList.Values(i)
+ SendDisconnectRequest(User)
+ Next
+ End If
+ Catch ex As Exception
+ Log(ex, "结束 IOI 进程时发送 Disconnect 信息失败")
+ End Try
+ '关闭所有 Ioi 进程
+ For Each ProcessObject In Process.GetProcesses
+ If ProcessObject.ProcessName <> "IOI 联机模块" Then Continue For
+ IoiStop = True
+ Try
+ ProcessObject.Kill()
+ Log("[IOI] 已关闭联机模块：" & ProcessObject.Id)
+ If SleepWhenKilled Then Thread.Sleep(3000) '等待 3 秒确认进程已退出
+ Catch ex As Exception
+ Log(ex, "关闭联机模块失败（" & ProcessObject.Id & "）")
+ End Try
+ Next
+ '初始化
+ IoiProcess = Nothing
+ IoiId = Nothing
+ IoiPassword = Nothing
+ IoiState = LoadState.Waiting
+ UserList = New Dictionary(Of String, LinkUserIoi)
+ RoomListForMe = New List(Of RoomEntry)
+ End Function
+ '''
+ ''' 启动 Ioi，并等待初始化完成后退出运行，同时更新 IoiId 与 IoiPassword。
+ ''' 正常初始化返回 True，需要更新返回 False，其余情况抛出异常。
+ ''' 若 Ioi 正在运行，则会先停止其运行。
+ '''
+ Public Shared Function IoiStart() As Boolean
+ IoiStop(True)
+ Log("[IOI] 启动联机模块进程")
+ Dim Info = New ProcessStartInfo With {
+ .FileName = PathIoi,
+ .UseShellExecute = False,
+ .CreateNoWindow = True,
+ .RedirectStandardError = True,
+ .RedirectStandardOutput = True,
+ .WorkingDirectory = PathTemp
+ }
+ IoiProcess = New Process() With {.StartInfo = Info}
+ Using outputWaitHandle As New AutoResetEvent(False)
+ Using errorWaitHandle As New AutoResetEvent(False)
+ AddHandler IoiProcess.OutputDataReceived, Function(sender, e)
+ Try
+ If e.Data Is Nothing Then
+ outputWaitHandle.[Set]()
+ Else
+ IoiLogLine(e.Data)
+ End If
+ Catch ex As ObjectDisposedException
+ Catch ex As Exception
+ Log(ex, "读取联机模块信息失败")
+ IoiState = LoadState.Failed
+ End Try
+ Return Nothing
+ End Function
+ AddHandler IoiProcess.ErrorDataReceived, Function(sender, e)
+ Try
+ If e.Data Is Nothing Then
+ errorWaitHandle.[Set]()
+ Else
+ IoiLogLine(e.Data)
+ End If
+ Catch ex As ObjectDisposedException
+ Catch ex As Exception
+ Log(ex, "读取联机模块错误信息失败")
+ IoiState = LoadState.Failed
+ End Try
+ Return Nothing
+ End Function
+ IoiProcess.Start()
+ IoiState = LoadState.Loading
+ IoiProcess.BeginOutputReadLine()
+ IoiProcess.BeginErrorReadLine()
+ '等待
+ Do Until IoiProcess.HasExited OrElse IoiState <> LoadState.Loading
+ Thread.Sleep(10)
+ Loop
+ '输出
+ If IoiState = LoadState.Finished Then
+ Log("[IOI] 联机模块启动成功")
+ Return True
+ Else
+ Throw New Exception("联机模块启动失败")
+ End If
+ 'Select Case IoiState
+ ' Case LoadState.Finished
+ ' Log("[IOI] 联机模块启动成功")
+ ' Return True
+ ' Case LoadState.Aborted
+ ' Log("[IOI] 联机模块要求更新")
+ ' Return False
+ ' Case LoadState.Failed
+ ' Log("[IOI] 联机模块启动出现异常")
+ ' Return False
+ ' Case Else 'LoadState.Loading
+ ' Throw New Exception("联机模块启动失败，请检查你的网络连接")
+ 'End Select
+ End Using
+ End Using
+ End Function
+
+ 'Ioi 日志
+ Private Shared Sub IoiLogLine(Content As String)
+
+ '初始化
+ If Content.Contains(" > http://127.0.0.1:55555/") Then Exit Sub
+ If Content.Contains("All done") Then
+ If IoiId IsNot Nothing AndAlso IoiPassword IsNot Nothing Then
+ IoiState = LoadState.Finished
+ Else
+ Log("[IOI] 联机模块汇报初始化完成，但未提供账户信息")
+ IoiState = LoadState.Failed
+ End If
+ Exit Sub
+ End If
+ If Content.Contains("Password :: ") Then
+ IoiPassword = Content.Split({"Password :: "}, StringSplitOptions.None)(1)
+ Exit Sub '为保证安全不记录密码到 Log
+ End If
+
+ '初始化
+ If Content.Contains("ID :: ") Then IoiId = Content.Split({"ID :: "}, StringSplitOptions.None)(1)
+ If Content.Contains("Initialization failed") OrElse Content.Contains("The version is ") Then IoiState = LoadState.Aborted
+
+ '系统回应
+ If Content.Contains("'portssub' from ") Then LastPortsId = Content.Split(" ").Last
+ If Content.Contains("Listening tcp ") Then
+ If UserList.ContainsKey(LastPortsId) Then
+ DictionaryAdd(UserList(LastPortsId).Ports, Content.Split(" ").Last, RegexSeek(Content, "(?<=Listening tcp )[^:]+"))
+ Else
+ Log("[IOI] 未在列表中的用户出现意料外的连接信息")
+ NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & LastPortsId & "&password=" & IoiPassword, "DELETE", "", "", 500)
+ End If
+ End If
+
+ '断开连接
+ If Content.Contains("Closed tcp connection from ") AndAlso Content.Contains(":55557") Then
+ For i = 0 To UserList.Count - 1
+ Dim User = UserList.Values(i)
+ If Not Content.Contains(User.Ports(55557)) OrElse User.IsDisposed Then Continue For
+ Log("[IOI] 检测到 55557 端口断开（" & User.DisplayName & "）")
+ UserRemove(User, True)
+ Exit For
+ Next
+ End If
+
+ '写入日志
+ If Not Content.Contains("read /dev/stdin: The handle is invalid.") AndAlso LogLinesCount < If(ModeDebug, 10000, 1000) Then
+ LogLinesCount += 1
+ Log("[IOI] " & Content)
+ End If
+
+ End Sub
+ Private Shared LogLinesCount As Integer = 0
+ Private Shared LastPortsId As String = "" '上一个收到 portssub 的 ID，用于记录端口
+
+#End Region
+
+#Region "时钟"
+
+ 'UI 线程刷新
+ Private Shared UserListIdentifyCache As String = ""
+ Private Shared RoomListIdentifyCache As String = ""
+ Public Sub RefreshUi()
+ Try
+ '确认用户列表缓存
+ Dim UserListIdentify As String = Join(UserList, vbCrLf)
+ If UserListIdentify <> UserListIdentifyCache Then
+ UserListIdentifyCache = UserListIdentify
+ '刷新列表项
+ PanUserList.Children.Clear()
+ For i = 0 To UserList.Count - 1
+ If i > UserList.Count - 1 Then Exit For
+ PanUserList.Children.Add(UserList.Values(i).ToListItem)
+ Next
+ '刷新列表标题
+ CardUser.Title = "已连接的玩家 (" & PanUserList.Children.Count & ")"
+ End If
+ '刷新用户列表项
+ For Each UserItem As MyListItem In PanUserList.Children
+ CType(UserItem.Tag, LinkUserIoi).RefreshUi(UserItem)
+ Next
+ '确认房间列表缓存
+ Dim RoomListIdentify As String = Join(GetRoomList(), vbCrLf)
+ If RoomListIdentify <> RoomListIdentifyCache Then
+ RoomListIdentifyCache = RoomListIdentify
+ '刷新列表项
+ PanRoom.Children.Clear()
+ For Each Room In GetRoomList()
+ PanRoom.Children.Add(Room.ToListItem)
+ Next
+ End If
+ '刷新房间列表项
+ For Each RoomItem As MyListItem In PanRoom.Children
+ CType(RoomItem.Tag, RoomEntry).RefreshUi(RoomItem)
+ Next
+ '刷新操作提示
+ If UserList.Count = 0 Then
+ If RoomListForMe.Count = 0 Then
+ LabHint.Text = "若想创建房间，请点击创建房间按钮，并按说明进行操作。" & vbCrLf & "若想加入他人的房间，请点击建立连接，然后输入对方的联机码。"
+ Else
+ LabHint.Text = "若想让其他人加入你的房间，请点击复制联机码，然后让你的朋友输入你的联机码以建立连接。"
+ End If
+ Else
+ If GetRoomList.Count = 0 Then
+ LabHint.Text = "若想创建房间，请点击创建房间按钮，然后输入对局域网开放后 MC 显示的端口号，或本地服务端的端口号。"
+ ElseIf RoomListForMe.Count = 0 Then
+ '已有连接，本人没有房间，对方有房间
+ LabHint.Text = "若想加入某个房间，直接点击该房间即可获取说明。"
+ Else
+ '已有连接，且本人有房间
+ LabHint.Text = "指向你所创建的房间，能在右侧找到修改房间名称、关闭房间等选项。" &
+ If(RoomListForMe.Count <> GetRoomList.Count, vbCrLf & "若想加入其他人的房间，直接点击该房间即可获取说明。", "")
+ End If
+ End If
+ Catch ex As Exception
+ Log(ex, "联机模块 UI 时钟运行失败", LogLevel.Feedback)
+ End Try
+ End Sub
+
+ '工作线程刷新
+ Public Sub RefreshWorker()
+ Try
+ '检测退出
+ If InitLoader.State = LoadState.Finished AndAlso IoiProcess.HasExited Then
+ Log("[IOI] 联机模块出现异常！", LogLevel.Hint)
+ ModuleStopManually()
+ End If
+ '检测用户
+ For i = 0 To UserList.Values.Count - 1
+ If i > UserList.Values.Count - 1 Then Exit For
+ Dim User = UserList.Values(i)
+ If User.Progress < 1 Then Continue For '跳过连接中的用户
+ '发送心跳包
+ If Date.Now - User.LastSend > New TimeSpan(0, 0, RandomInteger(50, 30)) Then
+ RunInNewThread(Sub()
+ Try
+ SendUpdateRequest(User, 1)
+ Catch ex As Exception
+ Log(ex, "心跳包发送失败（" & User.DisplayName & "）", LogLevel.Normal)
+ End Try
+ End Sub, "Link Heartbeat " & User.Id)
+ End If
+ '检测被动离线
+ If Date.Now - User.LastReceive > New TimeSpan(0, 2, 0) Then
+ SendDisconnectRequest(User)
+ Hint("与 " & User.DisplayName & " 的连接已中断！", HintType.Critical)
+ End If
+ Next
+ Catch ex As Exception
+ Log(ex, "联机模块工作时钟运行失败", LogLevel.Feedback)
+ End Try
+ End Sub
+
+#End Region
+
+#Region "发送请求"
+
+ '''
+ ''' 发送 Portsub 请求并等待获取控制台端口。进度将从 0 变化至 80%。
+ '''
+ Private Shared Sub SendPortsubRequest(User As LinkUserIoi)
+ Log("[IOI] 尝试建立连接：" & User.Id)
+ '向对方发送 portsub 请求
+ Dim Retry As Integer = 0
+RetryLink:
+ Dim Result As JObject = GetJson(NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "PUT", "", "", 100000))
+ '失败与重试
+ If Result("msg") IsNot Nothing Then
+ Dim ErrorMessage As String = Result("msg").ToString
+ Select Case ErrorMessage
+ Case "failed to find any peer in table"
+ Retry += 1
+ ErrorMessage = "我方网络环境不佳，连接失败。" '初始化对等机列表超时
+ Log("[IOI] 尝试建立连接结果：未找到对等机，第 " & Retry & " 级重试")
+ Case "routing: not found"
+ Retry += 4
+ ErrorMessage = "我方或对方网络环境不佳，或对方已关闭联机模块，未找到路由。" '未知情况
+ Log("[IOI] 尝试建立连接结果：无法连接到路由，第 " & Retry & " 级重试")
+ Case "you are already connected to specified host"
+ If User.IsDisposed Then Throw New ThreadInterruptedException("用户对象已被释放")
+ Log("[IOI] 尝试建立连接结果：已与对方连接")
+ GoTo Done
+ 'Retry += 1
+ 'NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 100000)
+ 'ErrorMessage = "已与对方连接。" '双向连接偶尔导致
+ 'Log("[IOI] 已与对方连接，尝试中断现有连接，第 " & Retry & " 级重试")
+ Case "dial backoff"
+ Retry += 20
+ ErrorMessage = "对方网络环境不佳，或对方已关闭联机模块。请尝试让对方主动连接你，而不是你去连接对方。" 'NAT2 连 NAT4 导致
+ Log("[IOI] 尝试建立连接结果：NAT 异常，第 " & Retry & " 级重试")
+ Case Else
+ If ErrorMessage.Contains("all dials failed") Then
+ Retry += 8
+ ErrorMessage = "我方或对方网络环境不佳，或对方已关闭联机模块，连接失败。" '网络不佳，或对方已关闭模块
+ Log("[IOI] 尝试建立连接结果：连接失败，第 " & Retry & " 级重试")
+ Else
+ Retry += 8
+ Log("[IOI] 尝试建立连接结果：未知错误（" & ErrorMessage & "），第 " & Retry & " 级重试")
+ End If
+ End Select
+ If User.IsDisposed Then Throw New ThreadInterruptedException("用户对象已被释放")
+ If Retry <= 64 Then
+ User.Progress = Retry * 0.01 + 0.05
+ Thread.Sleep(3000)
+ GoTo RetryLink
+ Else
+ Throw New InvalidOperationException(ErrorMessage)
+ End If
+ End If
+ Log("[IOI] 尝试建立连接结果：成功")
+ '等待获取对方端口
+Done:
+ Dim WaitCount As Integer = 0
+ Do Until User.Ports.ContainsKey(55555) AndAlso User.Ports.ContainsKey(55557)
+ WaitCount += 1
+ User.Progress = 0.7 + WaitCount / 200 * 0.1 '70% ~ 80%
+ If WaitCount = 100 Then Throw New Exception("连接超时，请尝试重新连接（未收到端口回报）！")
+ Thread.Sleep(150)
+ Loop
+ User.Progress = 0.8
+ End Sub
+
+ '''
+ ''' 向控制台发送 Connect 请求。
+ '''
+ Private Shared Sub SendConnectRequest(User As LinkUserIoi)
+ Dim RawJson As New JObject()
+ RawJson("version") = RequestVersion
+ RawJson("name") = GetPlayerName()
+ RawJson("id") = IoiId
+ RawJson("type") = "connect"
+ User.Send(RawJson)
+ End Sub
+
+ '''
+ ''' 向控制台发送 Update 请求。
+ '''
+ Private Shared Sub SendUpdateRequest(User As LinkUserIoi, Stage As Integer, Optional Unique As Long = -1)
+ If Unique = -1 Then Unique = GetTimeTick()
+ Dim RawJson As New JObject
+ RawJson("name") = GetPlayerName()
+ RawJson("id") = IoiId
+ RawJson("type") = "update"
+ RawJson("stage") = Stage
+ RawJson("unique") = Unique
+ If Stage < 3 Then
+ Dim Rooms As New JArray
+ For Each Room In RoomListForMe
+ Dim RoomObject As New JObject
+ RoomObject("name") = Room.DisplayName
+ RoomObject("port") = Room.Port
+ Rooms.Add(RoomObject)
+ Next
+ RawJson("rooms") = Rooms
+ DictionaryAdd(User.PingPending, Unique, Date.Now)
+ End If
+ User.Send(RawJson)
+ End Sub
+
+ '''
+ ''' 尝试发送断开请求，并将其从用户列表中移除。
+ '''
+ Private Shared Sub SendDisconnectRequest(User As LinkUserIoi, Optional Message As String = Nothing, Optional IsError As Boolean = False)
+ Dim RawJson As New JObject()
+ RawJson("id") = IoiId
+ RawJson("type") = "disconnect"
+ If Message IsNot Nothing Then
+ RawJson("message") = Message
+ RawJson("isError") = IsError
+ End If
+ Try
+ User.Send(RawJson)
+ Thread.Sleep(50)
+ Catch
+ End Try
+ NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
+ User.Dispose()
+ End Sub
+
+#End Region
+
+#Region "左边栏操作"
+
+ '刷新连接
+ Private Shared Sub BtnListRefresh_Click(sender As MyIconButton, e As EventArgs)
+ Dim User As LinkUserIoi = sender.Tag
+ User.PingRecord.Clear()
+ FrmLinkIoi.RefreshUi()
+ RunInThread(Sub()
+ Try
+ SendUpdateRequest(User, 1)
+ Catch ex As Exception
+ If InitLoader.State = LoadState.Finished Then Log(ex, "刷新与 " & User.DisplayName & " 的连接失败", LogLevel.Hint)
+ End Try
+ End Sub)
+ End Sub
+ '断开连接
+ Private Shared Sub BtnListDisconnect_Click(sender As MyIconButton, e As EventArgs)
+ Dim User As LinkUserIoi = sender.Tag
+ sender.IsEnabled = False
+ RunInThread(Sub()
+ If User.Progress < 1 AndAlso User.RelativeThread IsNot Nothing AndAlso User.RelativeThread.IsAlive Then
+ NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
+ User.Dispose()
+ Else
+ SendDisconnectRequest(User, GetPlayerName() & " 主动断开了连接！")
+ End If
+ End Sub)
+ End Sub
+ '复制联机码
+ Public Shared Sub BtnLeftCopy_Click() Handles BtnLeftCopy.Click
+ ClipboardSet(IoiId.Substring(4) & SecretEncrypt(GetPlayerName), False)
+ Hint("已复制联机码！", HintType.Finish)
+ End Sub
+
+#End Region
+
+#Region "玩家名"
+
+ '''
+ ''' 获取当前的玩家名。
+ '''
+ Public Shared Function GetPlayerName() As String
+ '自动生成玩家名
+ If AutogenPlayerName Is Nothing Then
+ If IsPlayerNameValid(McLoginName) Then
+ AutogenPlayerName = McLoginName()
+ Else
+ AutogenPlayerName = "玩家 " & CType(GetHash(If(UniqueAddress, "")) Mod 1048576, Integer).ToString("x5").ToUpper
+ End If
+ End If
+ '获取玩家自定义的名称
+ Dim CustomName As String = Setup.Get("LinkName").ToString.Trim()
+ If CustomName <> "" Then
+ If IsPlayerNameValid(CustomName) Then
+ Return CustomName.Trim
+ Else
+ Hint("你所设置的玩家名存在异常，已被重置！", HintType.Critical)
+ Setup.Set("LinkName", "")
+ End If
+ End If
+ '使用自动生成的玩家名
+ Return AutogenPlayerName
+ End Function
+ Private Shared AutogenPlayerName As String = Nothing '并非由玩家自定义，而是自动生成的玩家名
+ '''
+ ''' 检查某个玩家名是否合法。
+ '''
+ Private Shared Function IsPlayerNameValid(Name As String) As Boolean
+ For Each ValidateRule As Validate In {New ValidateNullOrWhiteSpace, New ValidateLength(0, 20), New ValidateFilter}
+ If Not String.IsNullOrEmpty(ValidateRule.Validate(Name)) Then Return False
+ Next
+ Return True
+ End Function
+
+#End Region
+
+#Region "请求核心"
+
+ Private Shared Listener As Socket = Nothing
+ '''
+ ''' 启动 Socket 监听核心。
+ '''
+ Public Shared Sub StartSocketListener()
+ If Listener IsNot Nothing Then Exit Sub '已经启动过了
+ Listener = New Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp) With {.ReceiveTimeout = 1000000000, .SendTimeout = 1000000000}
+ Listener.SetSocketOption(SocketOptionLevel.Socket, SocketOptionName.ReuseAddress, True)
+ Try
+ Listener.Bind(New IPEndPoint(IPAddress.Any, 55557))
+ Catch ex As Exception
+ Log(ex, "初次启动 Socket 监听核心失败，开始重试")
+ Thread.Sleep(1000)
+ Listener.Bind(New IPEndPoint(IPAddress.Any, 55557))
+ End Try
+ Listener.Listen(100)
+ Log("[IOI] 已启动 Socket 监听核心")
+ RunInNewThread(Sub()
+ While True
+ Try
+ '获取新的 Socket
+ Dim bytes(1024) As Byte
+ Dim ClientSocket As Socket = Listener.Accept()
+ '获取初始输入信息
+ Dim RequestInput As String = Encoding.UTF8.GetString(bytes, 0, ClientSocket.Receive(bytes))
+ If Not RequestInput.StartsWith("PCL - ") Then Exit Sub
+ Dim RawData As String
+ Try
+ RawData = SecretDecrypt(WebUtility.UrlDecode(RequestInput.Substring(6)))
+ Log("[IOI] 接收到新的 Socket：" & RawData)
+ PageLinkIoi.ReceiveJson(GetJson(RawData), ClientSocket)
+ Catch ex As Exception
+ Log(ex, "新的 Socket 处理出错（内容：" & RequestInput & "）")
+ End Try
+ Catch ex As Exception
+ Log(ex, "Socket 监听出错")
+ Thread.Sleep(3000) '防止死循环出错
+ End Try
+ End While
+ End Sub, "Socket Listener")
+ End Sub
+
+#End Region
+
+#Region "用户核心"
+
+ '用户基类
+ Public MustInherit Class LinkUserBase
+ Implements IDisposable
+
+ '基础数据
+ Public Uuid As Integer = GetUuid()
+ Public Id As String
+ Public DisplayName As String
+
+ '请求管理
+ Public Socket As Socket = Nothing
+ Public Sub Send(Request As JObject)
+ If Socket Is Nothing Then Throw New Exception("该用户尚未绑定 Socket")
+ Dim Data As String = Request.ToString(Newtonsoft.Json.Formatting.None)
+ If ModeDebug Then Log("[IOI] 发送联机数据包（" & DisplayName & "）：" & Data)
+ Data = "PCL - " & WebUtility.UrlEncode(SecretEncrypt(Data))
+ Me.LastSend = Date.Now
+ Socket.Send(Encoding.UTF8.GetBytes(Data))
+ End Sub
+ Public ListenerThread As Thread = Nothing
+ Public Sub StartListener()
+ If ListenerThread IsNot Nothing Then Exit Sub
+ '启动监听
+ ListenerThread = RunInNewThread(Sub()
+ Try
+ Dim bytes(1024) As Byte
+ While PageLinkIoi.UserList.ContainsValue(Me)
+ Dim RequestInput As String = Encoding.UTF8.GetString(bytes, 0, Socket.Receive(bytes))
+ If Not RequestInput.StartsWith("PCL - ") Then Exit Sub
+ Dim RawData As String = SecretDecrypt(WebUtility.UrlDecode(RequestInput.Substring(6)))
+ If ModeDebug Then Log("[IOI] 接收联机数据包（" & DisplayName & "）：" & RawData)
+ PageLinkIoi.ReceiveJson(GetJson(RawData)) '调用去实际的联机模块
+ End While
+ Catch ex As ThreadInterruptedException
+ Log("[IOI] 用户监听已中断（" & DisplayName & "）")
+ Catch ex As Exception
+ If IsDisposed Then Exit Sub
+ If ex.GetType.Equals(GetType(SocketException)) AndAlso CType(ex, SocketException).SocketErrorCode = 10053 Then
+ Log("[IOI] 客户端已关闭（" & DisplayName & "）")
+ PageLinkIoi.UserRemove(CType(Me, PageLinkIoi.LinkUserIoi), True)
+ Exit Sub
+ End If
+ Log(ex, "用户监听出错（" & DisplayName & "）")
+ PageLinkIoi.UserRemove(CType(Me, PageLinkIoi.LinkUserIoi), True)
+ End Try
+ End Sub, "Link Listener " & DisplayName)
+ End Sub
+ Public Sub BindSocket(Socket As Socket)
+ If Me.Socket IsNot Nothing Then Throw New Exception("该用户已经绑定了 Socket")
+ Me.Socket = Socket
+ StartListener()
+ End Sub
+
+ 'Ping
+ '0：与 Ping 计算无关，不回应
+ '1：A to B，2：B to A，3：A to B
+ Public PingPending As New Dictionary(Of Long, Date)
+ Public PingRecord As New Queue(Of Integer)
+
+ '心跳包
+ Public LastSend As Date = Date.Now
+ Public LastReceive As Date = Date.Now
+
+ '类型转换
+ Public Sub New(Id As String, DisplayName As String)
+ Me.Id = Id
+ Me.DisplayName = DisplayName
+ Log("[IOI] 无通信包的新用户对象：" & ToString())
+ End Sub
+ Public Sub New(Id As String, DisplayName As String, Socket As Socket)
+ Me.Id = Id
+ Me.DisplayName = DisplayName
+ Me.Socket = Socket
+ Log("[IOI] 新用户对象：" & ToString())
+ StartListener()
+ End Sub
+ Public Overrides Function ToString() As String
+ Return DisplayName & " @ " & Id & " #" & Uuid
+ End Function
+ Public Shared Widening Operator CType(User As LinkUserBase) As String
+ Return User.ToString
+ End Operator
+
+ '释放资源
+ Public IsDisposed As Boolean = False
+ Protected Overridable Sub Dispose(IsDisposing As Boolean)
+ If Socket IsNot Nothing Then Socket.Dispose()
+ If ListenerThread IsNot Nothing AndAlso ListenerThread.IsAlive Then ListenerThread.Interrupt()
+ End Sub
+ Public Sub Dispose() Implements IDisposable.Dispose
+ If Not IsDisposed Then
+ IsDisposed = True
+ Dispose(True)
+ End If
+ GC.SuppressFinalize(Me)
+ End Sub
+ End Class
+
+ '用户对象
+ Public Shared UserList As New Dictionary(Of String, LinkUserIoi)
+ Public Class LinkUserIoi
+ Inherits LinkUserBase
+ Public Sub New(Id As String, DisplayName As String, Socket As Socket)
+ MyBase.New(Id, DisplayName, Socket)
+ End Sub
+ Public Sub New(Id As String, DisplayName As String)
+ MyBase.New(Id, DisplayName)
+ End Sub
+
+ '基础数据
+ Public Ports As New Dictionary(Of Integer, String)
+ Public Rooms As New List(Of RoomEntry)
+
+ '进度与 UI
+ Public Progress As Double = 0
+ Public RelativeThread As Thread = Nothing
+
+ Public Function GetDescription() As String
+ Return If(Progress < 1,
+ "正在连接，" & Math.Round(Progress * 100) & "%",
+ "已连接，" & If(PingRecord.Count = 0, "检查延迟中", Math.Round(PingRecord.Average) & "ms"))
+ End Function
+ Public Function ToListItem() As MyListItem
+ Dim Item As New MyListItem With {
+ .Title = DisplayName, .Height = 42, .Tag = Me, .Type = MyListItem.CheckType.None,
+ .PaddingRight = 60,
+ .Logo = "pack://application:,,,/images/Blocks/Grass.png"}
+ '绑定图标按钮
+ Dim BtnRefresh As New MyIconButton With {.Logo = Logo.IconButtonRefresh, .LogoScale = 0.85, .ToolTip = "刷新", .Tag = Me}
+ AddHandler BtnRefresh.Click, AddressOf BtnListRefresh_Click
+ ToolTipService.SetPlacement(BtnRefresh, Primitives.PlacementMode.Bottom)
+ ToolTipService.SetHorizontalOffset(BtnRefresh, -10)
+ ToolTipService.SetVerticalOffset(BtnRefresh, 5)
+ ToolTipService.SetShowDuration(BtnRefresh, 2333333)
+ ToolTipService.SetInitialShowDelay(BtnRefresh, 200)
+ Dim BtnClose As New MyIconButton With {.Logo = Logo.IconButtonCross, .LogoScale = 0.85, .ToolTip = "断开", .Tag = Me}
+ AddHandler BtnClose.Click, AddressOf BtnListDisconnect_Click
+ ToolTipService.SetPlacement(BtnClose, Primitives.PlacementMode.Bottom)
+ ToolTipService.SetHorizontalOffset(BtnClose, -10)
+ ToolTipService.SetVerticalOffset(BtnClose, 5)
+ ToolTipService.SetShowDuration(BtnClose, 2333333)
+ ToolTipService.SetInitialShowDelay(BtnClose, 200)
+ Item.Buttons = {BtnRefresh, BtnClose}
+ '刷新并返回
+ RefreshUi(Item)
+ Return Item
+ End Function
+ Public Sub RefreshUi(RelatedListItem As MyListItem)
+ RelatedListItem.Title = DisplayName
+ RelatedListItem.Info = GetDescription()
+ RelatedListItem.Buttons(0).Visibility = If(Progress = 1, Visibility.Visible, Visibility.Collapsed)
+ End Sub
+
+ '释放
+ Protected Overrides Sub Dispose(IsDisposing As Boolean)
+ Log("[IOI] 用户资源释放（IOI, " & DisplayName & "）")
+ If RelativeThread IsNot Nothing AndAlso RelativeThread.IsAlive Then RelativeThread.Interrupt()
+ UserList.Remove(Id)
+ MyBase.Dispose(IsDisposing)
+ End Sub
+ End Class
+
+ '房间对象
+ Private Shared RoomListForMe As New List(Of RoomEntry)
+
+ Private Function GetRoomList() As List(Of RoomEntry)
+ Dim RoomList As New List(Of RoomEntry)(RoomListForMe)
+ For i = 0 To UserList.Count - 1
+ If i > UserList.Count - 1 Then Exit For
+ RoomList.AddRange(UserList.Values(i).Rooms)
+ Next
+ Return RoomList
+ End Function
+ Public Class RoomEntry
+
+ '基础数据
+ Public Port As Integer
+ Public DisplayName As String
+ Public User As LinkUserIoi = Nothing '若 IsOwner = True，则此项为 Nothing
+ Public IsOwner As Boolean
+ Public ReadOnly Property Ip As String
+ Get
+ If IsOwner Then
+ Return "localhost:" & Port
+ Else
+ Return User.Ports(Port) & ":" & Port
+ End If
+ End Get
+ End Property
+
+ '类型转换
+ Public Sub New(Port As Integer, DisplayName As String, Optional User As LinkUserIoi = Nothing)
+ Me.IsOwner = User Is Nothing
+ Me.User = User
+ Me.DisplayName = DisplayName
+ Me.Port = Port
+ End Sub
+ Public Overrides Function ToString() As String
+ Return DisplayName & " - " & Port & " - " & IsOwner
+ End Function
+ Public Shared Widening Operator CType(Room As RoomEntry) As String
+ Return Room.ToString
+ End Operator
+ Public Shared Function SelectPort(Room As RoomEntry) As Integer
+ Return Room.Port
+ End Function
+
+ 'UI
+ Public Function GetDescription() As String
+ If IsOwner Then
+ Return "由我创建，端口 " & Port
+ Else
+ Return "由 " & User.DisplayName & " 创建，端口 " & Port
+ End If
+ End Function
+ Public Function ToListItem() As MyListItem
+ Dim Item As New MyListItem With {
+ .Title = DisplayName, .Height = 42, .Info = GetDescription(), .Tag = Me, .PaddingRight = If(IsOwner, 60, 0),
+ .Type = If(IsOwner, MyListItem.CheckType.None, MyListItem.CheckType.Clickable),
+ .Logo = "pack://application:,,,/images/Blocks/" & If(IsOwner, "GrassPath", "Grass") & ".png"}
+ If IsOwner Then
+ '绑定图标按钮
+ Dim BtnEdit As New MyIconButton With {.Logo = Logo.IconButtonEdit, .LogoScale = 1, .ToolTip = "修改名称", .Tag = Me}
+ AddHandler BtnEdit.Click, AddressOf BtnRoomEdit_Click
+ ToolTipService.SetPlacement(BtnEdit, Primitives.PlacementMode.Bottom)
+ ToolTipService.SetHorizontalOffset(BtnEdit, -22)
+ ToolTipService.SetVerticalOffset(BtnEdit, 5)
+ ToolTipService.SetShowDuration(BtnEdit, 2333333)
+ ToolTipService.SetInitialShowDelay(BtnEdit, 200)
+ Dim BtnClose As New MyIconButton With {.Logo = Logo.IconButtonCross, .LogoScale = 0.85, .ToolTip = "关闭", .Tag = Me}
+ AddHandler BtnClose.Click, AddressOf BtnRoomClose_Click
+ ToolTipService.SetPlacement(BtnClose, Primitives.PlacementMode.Bottom)
+ ToolTipService.SetHorizontalOffset(BtnClose, -10)
+ ToolTipService.SetVerticalOffset(BtnClose, 5)
+ ToolTipService.SetShowDuration(BtnClose, 2333333)
+ ToolTipService.SetInitialShowDelay(BtnClose, 200)
+ Item.Buttons = {BtnEdit, BtnClose}
+ Else
+ '绑定点击事件
+ AddHandler Item.Click, AddressOf BtnRoom_Click
+ End If
+ Return Item
+ End Function
+ Public Sub RefreshUi(RelatedListItem As MyListItem)
+ RelatedListItem.Title = DisplayName
+ RelatedListItem.Info = GetDescription()
+ End Sub
+
+ End Class
+
+#End Region
+
+ '正向与反向连接
+ Public Shared Sub BtnLeftCreate_Click() Handles BtnLeftCreate.Click
+ '获取信息
+ Dim Code As String = MyMsgBoxInput("", New ObjectModel.Collection(Of Validate) From {New ValidateLength(9, 99999)}, "", "输入对方的联机码", "确定", "取消")
+ If Code Is Nothing Then Exit Sub
+ '检查
+ If Code.StartsWith("P") AndAlso Code.Length < 48 Then
+ Hint("你输入的可能是 HiPer 的联机码，请在左侧的联机方式中选择 HiPer！", HintType.Critical) : Exit Sub
+ End If
+ Dim Id As String, DisplayName As String
+ Try '解密失败检查
+ Id = "12D3" & Code.Substring(0, 48)
+ DisplayName = SecretDecrypt(Code.Substring(48))
+ Catch
+ Hint("你输入的联机码有误！", HintType.Critical)
+ Exit Sub
+ End Try
+ If Id = IoiId Then '自我连接检查
+ Hint("我连我自己？搁这卡 Bug 呢？", HintType.Critical)
+ Exit Sub
+ End If
+ '开始
+ Dim User As New LinkUserIoi(Id, DisplayName)
+ User.RelativeThread = RunInNewThread(Sub()
+ Dim WaitCount As Integer = 0
+ Try
+ '加入列表
+ If UserList.ContainsKey(Id) Then
+ Hint(UserList(Id).DisplayName & " 已在列表中，无需再次连接！")
+ Exit Sub
+ Else
+ UserList.Add(Id, User)
+ End If
+ '发送 portsub 请求（0% -> 80%）
+ SendPortsubRequest(User)
+ '构建 Socket（81% -> 82%）
+ Dim ClientSocket As New Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp) With {.ReceiveTimeout = 1000000000, .SendTimeout = 1000000000}
+ ClientSocket.Connect(New IPEndPoint(IPAddress.Parse(User.Ports(55557)), 55557))
+ User.BindSocket(ClientSocket)
+ User.Progress = 0.82
+ '发送 connect 请求（83% -> 85%）
+ SendConnectRequest(User)
+ User.Progress = 0.85
+ '等待对方向自己请求
+ Log("[IOI] 加入成功，等待反向请求")
+ Do While User.Progress < 0.9999
+ User.Progress += 0.0002
+ If User.Progress > 0.98 AndAlso User.Progress < 0.9999 Then Throw New Exception("对方未回应连接请求！")
+ Thread.Sleep(100)
+ Loop
+ Hint("已连接到 " & User.DisplayName & "！", HintType.Finish)
+ Catch ex As ThreadInterruptedException
+ Log("[IOI] 已中断主动发起的连接（" & User.DisplayName & "）")
+ Catch ex As InvalidOperationException
+ 'API 返回的错误
+ NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
+ User.Dispose()
+ If InitLoader.State = LoadState.Finished Then Log("与 " & DisplayName & " 建立连接失败：" & ex.Message, LogLevel.Msgbox)
+ Catch ex As Exception
+ '常规错误
+ NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
+ User.Dispose()
+ If ex.InnerException IsNot Nothing AndAlso TypeOf ex.InnerException Is ThreadInterruptedException Then Exit Sub
+ If InitLoader.State = LoadState.Finished Then Log(ex, "与 " & DisplayName & " 建立连接失败", LogLevel.Msgbox)
+ End Try
+ End Sub, "Link Create " & DisplayName)
+ End Sub
+ Private Shared Sub SendPortsubBack(User As LinkUserIoi, TargetVersion As Integer)
+ Try
+ SendPortsubRequest(User)
+ User.Progress = 0.9
+ If TargetVersion > RequestVersion Then
+ SendDisconnectRequest(User, "无法连接到 " & GetPlayerName() & "：对方的 PCL2 版本过低！", True)
+ Throw New InvalidOperationException("你的 PCL2 版本过低！")
+ ElseIf TargetVersion < RequestVersion Then
+ SendDisconnectRequest(User, "无法连接到 " & GetPlayerName() & "：你的 PCL2 版本过低！", True)
+ Throw New InvalidOperationException("对方的 PCL2 版本过低！")
+ Else
+ SendUpdateRequest(User, 1)
+ User.Progress = 1
+ Hint(User.DisplayName & " 已与你建立连接！")
+ End If
+ Catch ex As ThreadInterruptedException
+ Log("[IOI] 已中断被动建立的连接（" & User.DisplayName & "）")
+ Catch ex As InvalidOperationException
+ 'API 返回的错误
+ NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
+ User.Dispose()
+ If InitLoader.State = LoadState.Finished Then Log("与 " & User.DisplayName & " 建立连接失败：" & ex.Message, LogLevel.Hint)
+ Catch ex As Exception
+ '常规错误
+ NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
+ User.Dispose()
+ If InitLoader.State = LoadState.Finished Then Log(ex, "与 " & User.DisplayName & " 建立连接失败", LogLevel.Hint)
+ End Try
+ End Sub
+
+ '创建房间
+ Private Sub LinkCreate() Handles BtnCreate.Click
+ If MyMsgBox("请先进入 MC 并暂停游戏，在暂停页面选择对局域网开放，然后在下一个窗口输入 MC 显示的端口号。" & vbCrLf & "若使用服务端开服，则直接在下一个窗口输入服务器配置中的端口号即可。", "提示", "继续", "取消") = 2 Then Exit Sub
+ '获取端口号
+ Dim Port As String = MyMsgBoxInput("", New ObjectModel.Collection(Of Validate) From {
+ New ValidateInteger(0, 65535),
+ New ValidateExceptSame({"55555", "55557"}, "端口不能为 %！"),
+ New ValidateExceptSame(RoomListForMe.Select(AddressOf RoomEntry.SelectPort), "端口 % 已创建过房间，请在删除该房间后继续！")
+ }, "", "输入端口号", "确定", "取消")
+ If Port Is Nothing Then Exit Sub
+ '获取显示名称
+ Dim DisplayName As String = MyMsgBoxInput(GetPlayerName() & " 的房间 - " & Port, New ObjectModel.Collection(Of Validate) From {
+ New ValidateNullOrWhiteSpace(), New ValidateLength(1, 40), New ValidateFilter()
+ }, "", "输入房间名（建议包含游戏版本等信息）", "确定", "取消")
+ If DisplayName Is Nothing Then Exit Sub
+ DisplayName = DisplayName.Trim
+ '开始
+ RunInThread(Sub()
+ Try
+ '请求
+ Dim Result As JObject = GetJson(NetRequestOnce("http://127.0.0.1:55555/api/port?proto=tcp&port=" & Port & "&password=" & IoiPassword, "PUT", "", "", 100000))
+ If Result("msg") IsNot Nothing Then Throw New InvalidOperationException(Result("msg").ToString)
+ '成功
+ RoomListForMe.Add(New RoomEntry(Port, DisplayName))
+ Hint("房间 " & DisplayName & " 已创建！", HintType.Finish)
+ SendUpdateRequestToAllUsers()
+ Catch ex As InvalidOperationException
+ 'API 返回的错误
+ Log("创建房间失败：" & ex.Message, LogLevel.Msgbox)
+ Catch ex As Exception
+ '常规错误
+ Log(ex, "创建房间失败", LogLevel.Msgbox)
+ End Try
+ End Sub)
+ End Sub
+ Private Shared Sub SendUpdateRequestToAllUsers()
+ For i = 0 To UserList.Count - 1
+ If i > UserList.Count - 1 Then Exit For
+ Dim User = UserList.Values(i)
+ If User.Progress < 1 Then Continue For
+ Try
+ SendUpdateRequest(User, 1) '不需要使用多线程，发送实际会瞬间完成
+ Catch ex As Exception
+ Log(ex, "发送全局刷新请求失败（" & User.DisplayName & "）")
+ End Try
+ Next
+ End Sub
+ '修改房间名称
+ Private Shared Sub BtnRoomEdit_Click(sender As MyIconButton, e As EventArgs)
+ Dim Room As RoomEntry = sender.Tag
+ '获取房间名
+ Dim DisplayName As String = MyMsgBoxInput(Room.DisplayName, New ObjectModel.Collection(Of Validate) From {
+ New ValidateNullOrWhiteSpace(),
+ New ValidateLength(1, 40)
+ }, "", "输入房间名（建议包含游戏版本等信息）", "确定", "取消")
+ If DisplayName Is Nothing Then Exit Sub
+ DisplayName = DisplayName.Trim
+ '修改
+ Room.DisplayName = DisplayName
+ FrmLinkIoi.RefreshUi()
+ SendUpdateRequestToAllUsers()
+ End Sub
+ '加入房间
+ Private Shared Sub BtnRoom_Click(sender As MyListItem, e As EventArgs)
+ Dim Room As RoomEntry = sender.Tag
+ If MyMsgBox("请在多人游戏页面点击直接连接，输入 " & Room.Ip & " 以进入服务器！", "加入房间", "复制地址", "确定") = 1 Then
+ ClipboardSet(Room.Ip)
+ End If
+ End Sub
+ '关闭房间
+ Private Shared Sub BtnRoomClose_Click(sender As MyIconButton, e As EventArgs)
+ Dim Room As RoomEntry = sender.Tag
+ RunInThread(Sub()
+ Try
+ '远程移除
+ Dim Result As JObject = GetJson(NetRequestOnce("http://127.0.0.1:55555/api/port?proto=tcp&port=" & Room.Port & "&password=" & IoiPassword, "DELETE", "", "", 100000))
+ If Result("msg") IsNot Nothing Then Throw New InvalidOperationException(Result("msg").ToString)
+ '本地移除
+ RoomListForMe.Remove(Room)
+ '成功
+ RunInUi(Sub() FrmLinkIoi.RefreshUi())
+ SendUpdateRequestToAllUsers()
+ Catch ex As InvalidOperationException
+ 'API 返回的错误
+ If InitLoader.State = LoadState.Finished Then Log("移除房间失败：" & ex.Message, LogLevel.Msgbox)
+ Catch ex As Exception
+ '常规错误
+ If InitLoader.State = LoadState.Finished Then Log(ex, "移除房间失败", LogLevel.Msgbox)
+ End Try
+ End Sub)
+ End Sub
+
+ '获取数据包
+ Public Shared Sub ReceiveJson(JsonData As JObject, Optional NewSocket As Socket = Nothing)
+ '获取数据
+ Dim Id As String = JsonData("id"), Type As String = JsonData("type")
+ Select Case Type
+ Case "connect"
+ Dim DisplayName As String = JsonData("name")
+ Dim User As New LinkUserIoi(Id, DisplayName, NewSocket)
+ '如果发生了双向连接
+ If UserList.ContainsKey(Id) Then
+ If Id > IoiId Then
+ Log("[IOI] 双向连接，应当抛弃当前用户（" & DisplayName & "）")
+ For Each Pair In UserList(User.Id).Ports.ToList
+ DictionaryAdd(User.Ports, Pair.Key, Pair.Value)
+ Next
+ UserList(Id).Dispose()
+ Else
+ '应当保留当前用户
+ Log("[IOI] 双向连接，应当保留当前用户（" & DisplayName & "）")
+ NewSocket.Dispose()
+ Exit Sub
+ End If
+ End If
+ '加入列表
+ UserList.Add(Id, User)
+ '返回请求
+ User.RelativeThread = RunInNewThread(Sub()
+ SendPortsubBack(User, JsonData("version").ToObject(Of Integer))
+ End Sub, "Link Connect " & DisplayName)
+ '更新时间
+ User.LastReceive = Date.Now
+ Case "update"
+ If Not UserList.ContainsKey(Id) Then Throw New Exception("未在列表中的用户发送了更新请求：" & Id)
+ Dim User = UserList(Id)
+ '拉满进度（该请求也作为反向连接回应出现，用于向正向连接方传达连接已完成信号）
+ User.Progress = 1
+ '更新名称
+ Dim DisplayName As String = JsonData("name")
+ User.DisplayName = DisplayName
+ '更新房间列表
+ If JsonData("rooms") IsNot Nothing Then
+ User.Rooms = New List(Of RoomEntry)
+ For Each RoomObject In JsonData("rooms")
+ User.Rooms.Add(New RoomEntry(RoomObject("port"), RoomObject("name"), User))
+ Next
+ End If
+ '更新 Ping
+ Dim Stage As Integer = JsonData("stage"), Unique As Long = JsonData("unique")
+ If Stage > 1 Then
+ User.PingRecord.Enqueue((Date.Now - User.PingPending(Unique)).TotalMilliseconds / 2)
+ If User.PingRecord.Count > 5 Then User.PingRecord.Dequeue()
+ User.PingPending.Remove(Unique)
+ End If
+ '返回请求
+ If Stage > 0 AndAlso Stage < 3 Then RunInNewThread(Sub()
+ Try
+ SendUpdateRequest(User, Stage + 1, Unique)
+ Catch ex As Exception
+ Log(ex, "发送回程请求失败")
+ End Try
+ End Sub, "Link Update " & DisplayName)
+ '更新时间
+ User.LastReceive = Date.Now
+ Case "disconnect"
+ '断开连接
+ If Not UserList.ContainsKey(Id) Then Exit Sub
+ UserRemove(UserList(Id), ShowLeaveMessage:=JsonData("message") Is Nothing)
+ If JsonData("message") IsNot Nothing Then Hint(JsonData("message").ToString, If(JsonData("isError").ToObject(Of Boolean), HintType.Critical, HintType.Info))
+ Case Else
+ Throw New Exception("未知的操作种类：" & Type)
+ End Select
+ End Sub
+ '''
+ ''' 从用户列表中移除一位用户。提示信息视作该用户主动离开。
+ '''
+ Public Shared Sub UserRemove(User As LinkUserIoi, ShowLeaveMessage As Boolean)
+ If Not UserList.ContainsKey(User.Id) Then Exit Sub
+ If ShowLeaveMessage Then Hint(User.DisplayName & " 已离开！")
+ NetRequestOnce("http://127.0.0.1:55555/api/link?id=" & User.Id & "&password=" & IoiPassword, "DELETE", "", "", 500)
+ User.Dispose()
+ End Sub
+
+ '关闭联机模块按钮
+ Private Shared Sub ModuleStateChanged(Loader As LoaderBase, NewState As LoadState, OldState As LoadState) Handles InitLoader.OnStateChangedUi
+ If FrmLinkLeft IsNot Nothing Then CType(FrmLinkLeft.ItemIoi.Buttons(0), MyIconButton).Visibility = If(NewState = LoadState.Finished, Visibility.Visible, Visibility.Collapsed)
+ End Sub
+ Public Shared Sub ModuleStopManually()
+ IoiStop(False)
+ InitLoader.Error = New Exception("联机模块已关闭，点击以重新启动")
+ InitLoader.State = LoadState.Failed
+ IoiState = LoadState.Failed
+ End Sub
+
+End Class