diff --git a/47-dotnet_Microsoft.VisualBasic.vbproj b/47-dotnet_Microsoft.VisualBasic.vbproj index 5fe1d55e..1766ff6b 100644 --- a/47-dotnet_Microsoft.VisualBasic.vbproj +++ b/47-dotnet_Microsoft.VisualBasic.vbproj @@ -1343,9 +1343,7 @@ - - @@ -1372,30 +1370,20 @@ - - - - - - - - - - diff --git a/ApplicationServices/Parallel/Threads/ParallelLoading.vb b/ApplicationServices/Parallel/Threads/ParallelLoading.vb deleted file mode 100644 index d4a9c1a2..00000000 --- a/ApplicationServices/Parallel/Threads/ParallelLoading.vb +++ /dev/null @@ -1,323 +0,0 @@ -#Region "Microsoft.VisualBasic::1fe2c3e9c08f62f177338a7aa8385ad6, Microsoft.VisualBasic.Core\ApplicationServices\Parallel\Threads\ParallelLoading.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Module ParallelLoading - ' - ' Function: __loadEntry, __loadTask, __parallelLoading, __subMain, DynamicsVBCTask - ' (+2 Overloads) Load, SendMessageAPI - ' Class LoadEntry - ' - ' Properties: LoadType, MethodEntryPoint - ' - ' Function: ToString - ' - ' Class LoadTaskInvoker - ' - ' Constructor: (+1 Overloads) Sub New - ' - ' Function: DataProcessor, Load - ' - ' Sub: FillData, GetSendData, StartProcess, WaitForTaskComplete - ' - ' Delegate Function - ' - ' - ' - ' - ' - ' /********************************************************************************/ - -#End Region - -Imports Microsoft.VisualBasic.ApplicationServices -Imports Microsoft.VisualBasic.Emit.CodeDOM_VBC -Imports Microsoft.VisualBasic.Language -Imports Microsoft.VisualBasic.Linq -Imports Microsoft.VisualBasic.Net.Http -Imports Microsoft.VisualBasic.Net.Protocols -Imports Microsoft.VisualBasic.Parallel.Tasks -Imports Microsoft.VisualBasic.Serialization.BinaryDumping - -Namespace Parallel - - ''' - ''' - ''' - Public Module ParallelLoading - - - Public Class LoadEntry : Inherits Attribute - - ''' - ''' 必须满足接口类型： Function(path As String) As T - ''' - ''' - Public Property MethodEntryPoint As System.Reflection.MethodInfo - - Public ReadOnly Property LoadType As Type - Get - Return MethodEntryPoint.DeclaringType - End Get - End Property - - Public Overrides Function ToString() As String - Return MethodEntryPoint.ToString - End Function - End Class - - ''' - ''' 当目标数据集非常的大的时候，在单个应用程序里面进行加载已经回非常缓慢了， - ''' 则这个时候可以使用这个函数将数据的加载任务分配到多个子进程之中以提高加载的时候的CPU的利用效率 - ''' - ''' - ''' - ''' - ''' 函数会自动从泛型类型之中解析出加载的函数 - Public Function Load(Of T)(sourceURL As Generic.IEnumerable(Of String), Optional TrimNull As Boolean = False) As KeyValuePair(Of String, T())() - Dim TypeEntry As Type = GetType(T) - Dim EntryPoint = Parallel.ParallelLoading.__loadEntry(TypeEntry) - - If EntryPoint Is Nothing Then - Throw New Exception($"Could not found any entry point for type:={TypeEntry.ToString}!") - End If - - Dim Process As String = DynamicsVBCTask(EntryPoint) '开始进行任务进程的动态编译 - Dim LQuery = (From source As String '进行并行化任务调度 - In sourceURL'这里不再使用并行化，因为启动Socket任务的需要为了避免端口占用的情况出现，任务不可以同时启动 - Select source, Task = Load(Of T)(url:=source, Process:=Process)).ToArray - Dim WaitTasks = (From mmfTask In LQuery.AsParallel '等待任务的结束然后返回数据集 - Let value As T() = mmfTask.Task.GetValue - Select New KeyValuePair(Of String, T())(mmfTask.source, value)).ToArray - - If TrimNull Then - WaitTasks = (From obj In WaitTasks.AsParallel Where Not obj.Value.IsNullOrEmpty Select obj).ToArray - End If - Return WaitTasks - End Function - - ''' - ''' 通过与并行进程进行内存共享来传输加载完毕的数据 - ''' - ''' - ''' - ''' - ''' - Private Function Load(Of T)(url As String, Process As String) As Task(Of String, T()) - Dim Task As New Task(Of String, T())(url, ParallelLoading.__loadTask(Of T)(Process)) - Return Task - End Function - - Private Function __loadTask(Of T)(process As String) As Func(Of String, T()) - Call Threading.Thread.Sleep(1000) - Return AddressOf New LoadTaskInvoker(Of T)(process).Load - End Function - - Private Class LoadTaskInvoker(Of T) - - ReadOnly Process As String - - Sub New(Process As String) - Me.Process = Process - End Sub - - Public Function Load(url As String) As T() - Dim Socket As New Microsoft.VisualBasic.Net.TcpSynchronizationServicesSocket(AddressOf DataProcessor, Net.GetFirstAvailablePort) - Call New Threading.Thread(AddressOf Socket.Run).Start() - Call StartProcess($"{url.CLIPath} { Socket.LocalPort}") - Call WaitForTaskComplete() - Return resultBuffer - End Function - - Private Sub StartProcess(argvs As String) - Dim ProcStart = New ProcessStartInfo(Process, arguments:=argvs) - Dim ProcInvoke As New Process With {.StartInfo = ProcStart} - - ProcStart.CreateNoWindow = True - ProcInvoke.Start() - End Sub - - Private Function DataProcessor(uid As Long, request As RequestStream, remote As System.Net.IPEndPoint) As RequestStream - Dim requestData As String = request.GetUTF8String - - If String.IsNullOrEmpty(requestData) Then - Return NetResponse.RFC_NO_CONTENT - End If - - If requestData.StartsWith(MMFProtocol.MMFSocket.MMF_PROTOCOL) Then - '进程开始向父进程返回数据了 - Dim host As String = Mid(requestData, Len(MMFProtocol.MMFSocket.MMF_PROTOCOL) + 1) - Call GetSendData(host) - End If - - Return NetResponse.RFC_OK - End Function - - Dim TaskComplete As Boolean = False - - Private Sub WaitForTaskComplete() - Do While Not TaskComplete - Call Threading.Thread.Sleep(100) - Loop - End Sub - - Dim resultBuffer As T() - Dim _client As MMFProtocol.MMFSocket - - Private Sub GetSendData(host As String) - _client = New MMFProtocol.MMFSocket(host, AddressOf FillData) - End Sub - - Private Sub FillData(byteBuffer As Byte()) - ' resultBuffer = byteBuffer.DeSerialize(Of T()) - TaskComplete = True - End Sub - End Class - - ''' - ''' 动态编译的加载进程的调用API来向主进程返回消息 - ''' - ''' - ''' - Public Function SendMessageAPI(Port As Integer) As String - Dim host As String = "Parallel-" & Process.GetCurrentProcess.Id - Dim Client As New Microsoft.VisualBasic.Net.AsynInvoke("127.0.0.1", Port) - Call Client.SendMessage($"{MMFProtocol.MMFSocket.MMF_PROTOCOL}{host}") - Return host - End Function - - - - ''' - ''' 动态编译 - ''' - ''' - ''' - Public Function DynamicsVBCTask(LoadEntry As LoadEntry) As String - Dim refList As String() = GetReferences(LoadEntry.LoadType) - Dim ns As New CodeDom.CodeNamespace(NameOf(Parallel.ParallelLoading)) - - Call ns.Types.Add(__subMain(LoadEntry)) - Call ns.GenerateCode.__DEBUG_ECHO - - Dim assembly As System.Reflection.Assembly = ns.Compile(refList, RunTimeDirectory, CodeDOMExtension.ExecutableProfile) - Dim Dir As String = FileIO.FileSystem.GetParentPath(assembly.Location) - For Each File As String In refList - Dim buffer = IO.File.ReadAllBytes(File) - Dim Saved As String = $"{Dir}/{FileIO.FileSystem.GetFileInfo(File).Name}" - Try - Call IO.File.WriteAllBytes(Saved, buffer) - Catch ex As Exception - Call ex.PrintException - End Try - Next - Return assembly.Location - End Function - - Private Function __subMain(loadEntry As LoadEntry) As CodeDom.CodeTypeDeclaration - Dim ProgramEntry As New CodeDom.CodeTypeDeclaration("Program") - Dim SubMain As New CodeDom.CodeMemberMethod() - - Call ProgramEntry.Members.Add(SubMain) - SubMain.Name = "Main" - SubMain.ReturnType = New CodeDom.CodeTypeReference(GetType(System.Void)) - SubMain.Parameters.Add(New CodeDom.CodeParameterDeclarationExpression(GetType(String()), SubMainArgv)) - SubMain.Attributes = CodeDom.MemberAttributes.Public Or CodeDom.MemberAttributes.Static - SubMain = __parallelLoading(invoke:=SubMain, loadEntry:=loadEntry) - - Return ProgramEntry - End Function - - Const SubMainArgv As String = "Argv" - Const LoadFile As String = "File" - Const LoadResult As String = "LoadResult" - Const Port As String = "Port" - Const Host As String = "host" - Const Socket As String = "Socket" - Const Buffer As String = "buffer" - - Private Function __parallelLoading(invoke As CodeDom.CodeMemberMethod, loadEntry As LoadEntry) As CodeDom.CodeMemberMethod - - ' Dim File As String = argv(Scan0) - Call invoke.Statements.Add(LocalsInit(LoadFile, GetType(String), CodeDOMExpressions.GetValue(New CodeDom.CodeArgumentReferenceExpression(SubMainArgv), Scan0))) - - Dim PortValue As CodeDom.CodeExpression = CodeDOMExpressions.GetValue(New CodeDom.CodeArgumentReferenceExpression(SubMainArgv), 1) - PortValue = [Call](GetType(Conversion), NameOf(Conversion.Val), {PortValue}) - PortValue = [CType](PortValue, GetType(Integer)) - - ' Dim Port As Integer = CInt(Val(argv(1))) - Call invoke.Statements.Add(LocalsInit(Port, GetType(Integer), PortValue)) - Call invoke.Statements.Add([Call](GetType(Extensions), NameOf(__DEBUG_ECHO), - { - [Call](GetType(String), NameOf(String.Format), {CodeDOMExpressions.Value("Load stream from url:={0}, port:={1}..."), LocalVariable(LoadFile), LocalVariable(Port)}) - })) - Call invoke.Statements.Add([Call](GetType(Extensions), NameOf(__DEBUG_ECHO), {"Start to loading data..."})) - ' Dim LoadResult = ParallelLoadingTest.Load(File) '数据加载 - Call invoke.Statements.Add(LocalsInit(LoadResult, loadEntry.LoadType.MakeArrayType, initExpression:=[Call](loadEntry.MethodEntryPoint, {LocalVariable(LoadFile)}))) - Call invoke.Statements.Add([Call](GetType(Extensions), NameOf(__DEBUG_ECHO), {"Data loading Job Done!"})) - - '得到结果之后进行序列化通过内存映射共享返回给主程序 - ' Dim host As String = Microsoft.VisualBasic.Parallel.ParallelLoading.SendMessageAPI(Port) '返回消息 - Call invoke.Statements.Add(LocalsInit(Host, GetType(String), [Call](GetType(ParallelLoading), NameOf(SendMessageAPI), {LocalVariable(Port)}))) - ' Dim Socket As New Microsoft.VisualBasic.MMFProtocol.MMFSocket(hostName:=host) '打开映射的端口 - Call invoke.Statements.Add(LocalsInit(Socket, GetType(MMFProtocol.MMFSocket), [New](GetType(MMFProtocol.MMFSocket), {LocalVariable(Host)}))) - Call invoke.Statements.Add([Call](GetType(Extensions), NameOf(__DEBUG_ECHO), {"Init transfer device job done, start to transferred data!"})) - ' Call Socket.SendMessage(LoadResult.GetSerializeBuffer) '返回内存数据 - Call invoke.Statements.Add(LocalsInit(Buffer, GetType(Byte()), [Call](GetType(StructSerializer), NameOf(StructureToByte), {LocalVariable(LoadResult)}))) - Call invoke.Statements.Add([Call](LocalVariable(Socket), NameOf(MMFProtocol.MMFSocket.SendMessage), {LocalVariable(Buffer)})) - Call invoke.Statements.Add([Call](GetType(Extensions), NameOf(__DEBUG_ECHO), {"Data transportation Job Done!"})) - - Return invoke - End Function - - Private Function __loadEntry(Type As Type) As LoadEntry - Dim Entries = Type.GetMethods(System.Reflection.BindingFlags.Public Or System.Reflection.BindingFlags.Static) - If Entries.IsNullOrEmpty Then - Return Nothing - End If - - Dim setValue = New SetValue(Of ParallelLoading.LoadEntry)() _ - .GetSet(NameOf(ParallelLoading.LoadEntry.MethodEntryPoint)) - Dim LQuery As LoadEntry = - LinqAPI.DefaultFirst(Of LoadEntry) <= From EntryPoint As System.Reflection.MethodInfo - In Entries.AsParallel - Let attrs As Object() = EntryPoint.GetCustomAttributes(attributeType:=GetType(LoadEntry), inherit:=True) - Where Not attrs.IsNullOrEmpty - Let LoadEntry = DirectCast(attrs.First, LoadEntry) - Select setValue(LoadEntry, EntryPoint) - Return LQuery - End Function - - Delegate Function ParallelLoad(Of T)(sourceUrl As String) As T() - - End Module -End Namespace diff --git a/ApplicationServices/Parallel/Threads/ServicesFolk.vb b/ApplicationServices/Parallel/Threads/ServicesFolk.vb deleted file mode 100644 index eef93009..00000000 --- a/ApplicationServices/Parallel/Threads/ServicesFolk.vb +++ /dev/null @@ -1,165 +0,0 @@ -#Region "Microsoft.VisualBasic::e1ba5a0dba6fb894a52bf987d07b8a33, Microsoft.VisualBasic.Core\ApplicationServices\Parallel\Threads\ServicesFolk.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Module ServicesFolk - ' - ' Function: Folk, ReturnPortal - ' Class __getChildPortal - ' - ' Function: HandleRequest, WaitForPortal - ' - ' - ' - ' - ' /********************************************************************************/ - -#End Region - -Imports System.Reflection -Imports Microsoft.VisualBasic.Net.Http -Imports Microsoft.VisualBasic.Net.Protocols -Imports Microsoft.VisualBasic.Win32 -Imports SetValueAction = Microsoft.VisualBasic.Linq.SetValue(Of Microsoft.VisualBasic.Net.TcpSynchronizationServicesSocket) - -Namespace Parallel - - ''' - ''' 主服务和子服务之间的相互作用的特点是子服务不会知道主服务节点的数据接口，所有的交互都是通过子服务上面的一个模块来监听主服务来实现的 - ''' 当主服务有数据需要向子服务更新的时候，会主动发送数据请求至子服务节点 - ''' - ''' 当前的用户规模还比较小这里仅仅是实现了本地的调用，后面考虑到业务吞吐量的问题，会将服务的调用分开到两台物理主机之上 - Public Module ServicesFolk - - ''' - ''' 函数返回子进程的交互数据通信的端口号 - ''' - ''' - ''' 命令行参数字符串，可以在这里加入一些其他的自定义数据 - ''' 函数返回子服务的交互端口 - Public Function Folk(assm As String, ByRef CLI As String, Optional ByRef folked As Process = Nothing) As Integer - Dim Portal As Integer - - '开通一个临时的端口用来和子服务交互 - Using TempListen As New Net.TcpSynchronizationServicesSocket( - Net.TCPExtensions.GetFirstAvailablePort, - Sub(ex) App.LogException(ex, MethodBase.GetCurrentMethod.GetFullName)) - - Dim __getChildPortal As New __getChildPortal - - Call SetValueAction.InvokeSet(Of Net.Abstract.DataRequestHandler)( - TempListen, - NameOf(TempListen.Responsehandler), - AddressOf __getChildPortal.HandleRequest) - - Call RunTask(AddressOf TempListen.Run) - Call TempListen.WaitForStart() - - Dim path As String = - If(assm.FileExists, FileIO.FileSystem.GetFileInfo(assm).FullName, $"{App.HOME}/{assm}") -#If DEBUG Then - Call $"Invoke start {path.ToFileURL} @{MethodBase.GetCurrentMethod.GetFullName}".__DEBUG_ECHO -#End If - Dim FolkSvr As Process = - Process.Start(path, $"{CLI} {ParentPortal} {TempListen.LocalPort}") - - __getChildPortal.PID = FolkSvr.Id - Portal = __getChildPortal.WaitForPortal - folked = FolkSvr - CLI = __getChildPortal.addArgs - End Using - - Dim msg As String = $"Get folked child services {assm} local_services:={Portal}" - - Call msg.__DEBUG_ECHO - - If WindowsServices.Initialized Then - Call ServicesLogs.WriteEntry(msg, EventLogEntryType.SuccessAudit) - End If - - Return Portal - End Function - - Private Class __getChildPortal - - Public PID As Integer - Public Portal As Integer = -100 - ''' - ''' 所返回来的额外的参数信息 - ''' - Public addArgs As String - - Public Function HandleRequest(uid As Long, request As RequestStream, remote As System.Net.IPEndPoint) As RequestStream - If uid <> PID Then - Return NetResponse.RFC_TOKEN_INVALID - End If - - Dim result As String = request.GetUTF8String - - Portal = Scripting.CTypeDynamic(Of Integer)(result) - addArgs = CommandLine.GetTokens(result).ElementAtOrDefault(1) - - Return NetResponse.RFC_OK - End Function - - Public Function WaitForPortal() As Integer - Do While Portal < 0 - Call Threading.Thread.Sleep(1) - Loop - - Return Portal - End Function - End Class - - Const ParentPortal As String = "--portal" - - ''' - ''' 子服务向服务主节点返回端口号数据，这个方法需要要在子服务上面的服务程序启动之后再调用 - ''' - ''' - ''' - ''' 额外返回的参数信息 - ''' - Public Function ReturnPortal(CLI As CommandLine.CommandLine, Port As Integer, Optional addArgs As String = "") As Boolean - Dim parentPortal As Integer = CLI.GetInt32(ServicesFolk.ParentPortal) - Dim Client As New Net.AsynInvoke("127.0.0.1", parentPortal) -#If DEBUG Then - Call $"{MethodBase.GetCurrentMethod.GetFullName} ==> ""{CLI}"" returns {Port}".__DEBUG_ECHO -#End If - Dim request As New RequestStream(Process.GetCurrentProcess.Id, 0, $"{CStr(Port)} ""{addArgs}""") With { - .uid = Process.GetCurrentProcess.Id - } - Dim response As RequestStream = Client.SendMessage(request) - Return response.Protocol = HTTP_RFC.RFC_OK - End Function - End Module -End Namespace diff --git a/ApplicationServices/Tools/Network/Abstract.vb b/ApplicationServices/Tools/Network/Abstract.vb index 88825071..71256687 100644 --- a/ApplicationServices/Tools/Network/Abstract.vb +++ b/ApplicationServices/Tools/Network/Abstract.vb @@ -76,7 +76,7 @@ Namespace Net.Abstract Public MustInherit Class IProtocolHandler MustOverride ReadOnly Property ProtocolEntry As Long - MustOverride Function HandleRequest(CA As Long, request As RequestStream, remoteDevcie As System.Net.IPEndPoint) As RequestStream + MustOverride Function HandleRequest(request As RequestStream, remoteDevcie As System.Net.IPEndPoint) As RequestStream End Class #Region "Delegate Abstract Interface" @@ -86,11 +86,10 @@ Namespace Net.Abstract ''' ''' ''' - ''' ''' ''' ''' - Public Delegate Function DataRequestHandler(CA As Long, request As RequestStream, RemoteAddress As System.Net.IPEndPoint) As RequestStream + Public Delegate Function DataRequestHandler(request As RequestStream, RemoteAddress As System.Net.IPEndPoint) As RequestStream ''' ''' 处理错误的工作逻辑的抽象接口 diff --git a/ApplicationServices/Tools/Network/Protocol/Reflection/AppMgr.vb b/ApplicationServices/Tools/Network/Protocol/Reflection/AppMgr.vb index b3dc366f..a4871c07 100644 --- a/ApplicationServices/Tools/Network/Protocol/Reflection/AppMgr.vb +++ b/ApplicationServices/Tools/Network/Protocol/Reflection/AppMgr.vb @@ -97,13 +97,13 @@ Namespace Net.Protocols.Reflection Return Register(DirectCast(App, Object), [overrides]) End Function - Public Overrides Function HandleRequest(CA As Long, request As RequestStream, remoteDevcie As System.Net.IPEndPoint) As RequestStream + Public Overrides Function HandleRequest(request As RequestStream, remoteDevcie As System.Net.IPEndPoint) As RequestStream If Not ProtocolApps.ContainsKey(request.ProtocolCategory) Then Return NetResponse.RFC_NOT_FOUND End If Dim Protocol As ProtocolHandler = ProtocolApps(request.ProtocolCategory) - Return Protocol.HandleRequest(CA, request, remoteDevcie) + Return Protocol.HandleRequest(request, remoteDevcie) End Function End Class End Namespace diff --git a/ApplicationServices/Tools/Network/Protocol/Reflection/Protocol.vb b/ApplicationServices/Tools/Network/Protocol/Reflection/Protocol.vb index e2e3b113..0770e71a 100644 --- a/ApplicationServices/Tools/Network/Protocol/Reflection/Protocol.vb +++ b/ApplicationServices/Tools/Network/Protocol/Reflection/Protocol.vb @@ -46,7 +46,8 @@ Namespace Net.Protocols.Reflection ''' - ''' This attribute indicates the entry point of the protocol processor definition location and the details of the protocol processor. + ''' This attribute indicates the entry point of the protocol processor definition location + ''' and the details of the protocol processor. ''' Public Class Protocol : Inherits Attribute @@ -66,18 +67,20 @@ Namespace Net.Protocols.Reflection ''' ''' Generates the protocol method entrypoint.(应用于服务器上面的协议处理方法) ''' - ''' - Sub New(EntryPoint As Long) - Me.EntryPoint = EntryPoint + ''' + Sub New(entryPoint As Long) + Me.EntryPoint = entryPoint End Sub ''' - ''' Generates the on the server side, this is using for initialize a protocol API entry point.(客户端上面的类型) + ''' Generates the on the server side, + ''' this is using for initialize a protocol API entry point. + ''' (客户端上面的类型) ''' - ''' 客户端上面的类型 - Sub New(Type As Type) - EntryPoint = SecurityString.MD5Hash.ToLong(Type.GUID.ToByteArray) - DeclaringType = Type + ''' 客户端上面的类型 + Sub New(type As Type) + EntryPoint = SecurityString.MD5Hash.ToLong(type.GUID.ToByteArray) + DeclaringType = type End Sub Public Overrides Function ToString() As String @@ -105,7 +108,8 @@ Namespace Net.Protocols.Reflection End Function ''' - ''' This method is usually using for generates a details protocol processor, example is calling the method interface: + ''' This method is usually using for generates a details protocol processor, example + ''' is calling the method interface: ''' Correspondent to the protocol entry property ''' ''' diff --git a/ApplicationServices/Tools/Network/Protocol/Reflection/ProtocolHandler.vb b/ApplicationServices/Tools/Network/Protocol/Reflection/ProtocolHandler.vb index 00400f22..0ccf69af 100644 --- a/ApplicationServices/Tools/Network/Protocol/Reflection/ProtocolHandler.vb +++ b/ApplicationServices/Tools/Network/Protocol/Reflection/ProtocolHandler.vb @@ -116,17 +116,16 @@ Namespace Net.Protocols.Reflection End Function Public Function HandlePush(uid As Long, request As RequestStream) As RequestStream - Return HandleRequest(uid, request, Nothing) + Return HandleRequest(request, Nothing) End Function ''' - ''' Handle the data request from the client for socket events: or + ''' Handle the data request from the client for socket events: . ''' - ''' ''' The request stream object which contains the commands from the client ''' The IPAddress of the target incoming client data request. ''' - Public Overrides Function HandleRequest(CA As Long, request As RequestStream, remoteDevcie As System.Net.IPEndPoint) As RequestStream + Public Overrides Function HandleRequest(request As RequestStream, remoteDevcie As System.Net.IPEndPoint) As RequestStream If request.ProtocolCategory <> Me.ProtocolEntry Then #If DEBUG Then Call $"Protocol_entry:={request.ProtocolCategory} was not found!".__DEBUG_ECHO @@ -142,7 +141,7 @@ Namespace Net.Protocols.Reflection End If Dim EntryPoint As DataRequestHandler = Me.Protocols(request.Protocol) - Dim value As RequestStream = EntryPoint(CA, request, remoteDevcie) + Dim value As RequestStream = EntryPoint(request, remoteDevcie) Return value End Function @@ -190,5 +189,9 @@ Namespace Net.Protocols.Reflection Return Nothing End Function + + Public Shared Narrowing Operator CType(handler As ProtocolHandler) As DataRequestHandler + Return AddressOf handler.HandleRequest + End Operator End Class End Namespace diff --git a/ApplicationServices/Tools/Network/Protocol/Reflection/ProtocolInvoker.vb b/ApplicationServices/Tools/Network/Protocol/Reflection/ProtocolInvoker.vb index ea6e240b..8eb7f9a7 100644 --- a/ApplicationServices/Tools/Network/Protocol/Reflection/ProtocolInvoker.vb +++ b/ApplicationServices/Tools/Network/Protocol/Reflection/ProtocolInvoker.vb @@ -56,20 +56,20 @@ Namespace Net.Protocols.Reflection Me.Method = Method End Sub - Public Function InvokeProtocol0(CA As Long, request As RequestStream, remoteDevice As System.Net.IPEndPoint) As RequestStream + Public Function InvokeProtocol0(request As RequestStream, remoteDevice As System.Net.IPEndPoint) As RequestStream Dim value = Method.Invoke(obj, Nothing) Dim data = DirectCast(value, RequestStream) Return data End Function - Public Function InvokeProtocol1(CA As Long, request As RequestStream, remoteDevice As System.Net.IPEndPoint) As RequestStream - Dim value = Method.Invoke(obj, {CA}) + Public Function InvokeProtocol1(request As RequestStream, remoteDevice As System.Net.IPEndPoint) As RequestStream + Dim value = Method.Invoke(obj, {}) Dim data = DirectCast(value, RequestStream) Return data End Function - Public Function InvokeProtocol2(CA As Long, request As RequestStream, remoteDevice As System.Net.IPEndPoint) As RequestStream - Dim value = Method.Invoke(obj, {CA, request}) + Public Function InvokeProtocol2(request As RequestStream, remoteDevice As System.Net.IPEndPoint) As RequestStream + Dim value = Method.Invoke(obj, {request}) Dim data = DirectCast(value, RequestStream) Return data End Function @@ -77,13 +77,12 @@ Namespace Net.Protocols.Reflection ''' ''' ''' - ''' ''' ''' ''' - Public Function InvokeProtocol3(CA As Long, request As RequestStream, remoteDevice As System.Net.IPEndPoint) As RequestStream + Public Function InvokeProtocol3(request As RequestStream, remoteDevice As System.Net.IPEndPoint) As RequestStream Try - Dim value = Method.Invoke(obj, {CA, request, remoteDevice}) + Dim value = Method.Invoke(obj, {request, remoteDevice}) Dim data = DirectCast(value, RequestStream) Return data Catch ex As Exception diff --git a/ApplicationServices/Tools/Network/SSL/Certificate.vb b/ApplicationServices/Tools/Network/SSL/Certificate.vb deleted file mode 100644 index 4d6bc865..00000000 --- a/ApplicationServices/Tools/Network/SSL/Certificate.vb +++ /dev/null @@ -1,278 +0,0 @@ -#Region "Microsoft.VisualBasic::dfc585cd43fad999d3346ae63aaaa225, Microsoft.VisualBasic.Core\ApplicationServices\Tools\Network\SSL\Certificate.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Class Certificate - ' - ' Properties: AppDomain, hash, IsPublicToken, PrivateKey, uid - ' - ' Constructor: (+4 Overloads) Sub New - ' Function: __decrypt, __load, (+2 Overloads) CopyFrom, (+2 Overloads) Decrypt, DecryptString - ' (+2 Overloads) Encrypt, EncryptData, (+2 Overloads) Install, InstallPublicToken, PublicEncrypt - ' ToString - ' - ' - ' /********************************************************************************/ - -#End Region - -Imports Microsoft.VisualBasic.Emit.CodeDOM_VBC -Imports Microsoft.VisualBasic.Net.Protocols -Imports Microsoft.VisualBasic.SecurityString - -Namespace Net.SSL - - ''' - ''' 应用程序的完整性验证和用户身份的验证 - ''' - Public Class Certificate : Implements SecurityString.SecurityStringModel.ISecurityStringModel - - Protected _SHA256 As SecurityString.SHA256 - - ''' - ''' 私有密匙 - ''' - ''' - Public Overridable ReadOnly Property PrivateKey As String - Get - Return _SHA256.strPassphrase - End Get - End Property - - ''' - ''' 计算出来的哈希值只能为负数，现在约定，当这个属性为0的时候就认为这个证书是公共密匙， - ''' 这个一般是使用用户的账号所计算出来的哈希值 - ''' - ''' - Public ReadOnly Property uid As Long - Get - Return _uid - End Get - End Property - - ''' - ''' 初始化继承类所需要的 - ''' - Protected _uid As Long - - Public ReadOnly Property IsPublicToken As Boolean - Get - Return uid = 0L - End Get - End Property - - ''' - ''' 与属性所不同的是，这个属性是的哈希值， - ''' 通常这个哈希值在请求resultful WebAPI的时候用来作为用户的唯一标识 - ''' - ''' - Public ReadOnly Property hash As Long - - Public Overrides Function ToString() As String - Return $"[{NameOf(Certificate)}] {uid} {_SHA256.Passphrase}" - End Function - - ''' - ''' 请注意这个构造方法会计算一遍密码的哈希值，假若需要直接进行初始化，请使用方法 - ''' - ''' 用户的私有密匙 - ''' 大小写无关的 - Sub New(hash As String, uid As String) - hash = SecurityString.MD5Hash.GetMd5Hash(hash) - _SHA256 = New SecurityString.SHA256(hash, SALT) - Me._uid = SecurityString.MD5Hash.ToLong(SecurityString.MD5Hash.GetMd5Hash(uid.ToLower)) - Me.hash = SecurityString.MD5Hash.ToLong(hash) - End Sub - - ''' - ''' - ''' - ''' 原始的密码，会在这个构造函数之中计算为哈希值产生新的密码。 - ''' 客户端所发送过来的使用哈希值计算出来的唯一标识符 - Sub New(hash As String, uid As Long) - hash = SecurityString.MD5Hash.GetMd5Hash(hash) - _SHA256 = New SecurityString.SHA256(hash, SALT) - Me._uid = uid - Me.hash = SecurityString.MD5Hash.ToLong(hash) - End Sub - - ''' - ''' 从服务器上面所返回来的握手数据 - ''' - ''' - Sub New(handshakeData As RequestStream) - Dim hash As String = SecurityString.MD5Hash.GetMd5Hash(handshakeData.GetUTF8String) - _SHA256 = New SHA256(hash, SALT) - Me._uid = handshakeData.uid - Me.hash = SecurityString.MD5Hash.ToLong(hash) - End Sub - - ''' - ''' 这个构造函数不再计算哈希值而是直接初始化 - ''' - ''' 必须是md5哈希值 - Protected Sub New(hash As String) - _SHA256 = New SHA256(hash, SALT) - Me.hash = SecurityString.MD5Hash.ToLong(hash) - End Sub - - Const SALT As String = "88888888" - - Public Shared Function CopyFrom(CA As SSL.Certificate, uid As String) As SSL.Certificate - Dim hashCode As String = SecurityString.MD5Hash.ToLong(SecurityString.MD5Hash.GetMd5Hash(uid.ToLower)) - Return New SSL.Certificate(CA._SHA256.Passphrase) With {._uid = hashCode} - End Function - - Public Shared Function CopyFrom(CA As SSL.Certificate, uid As Long) As SSL.Certificate - Return New SSL.Certificate(CA._SHA256.Passphrase) With {._uid = uid} - End Function - - ''' - ''' 不计算密匙哈希值而是直接安装 - ''' - ''' - ''' - ''' - Public Shared Function Install(privateKey As String, uid As Long) As SSL.Certificate - Return New SSL.Certificate(privateKey) With {._uid = uid} - End Function - - Public Shared Function InstallPublicToken(publicKey As String) As SSL.Certificate - Call $"Install public token ssl certificate.".__DEBUG_ECHO - Return New SSL.Certificate(publicKey) - End Function - - ''' - ''' 函数会根据uid的值来设定协议为私有密匙还是公共密匙 - ''' - ''' - ''' - Public Overridable Function Encrypt(request As RequestStream) As RequestStream - Dim byteData As Byte() = request.Serialize - Dim Protocol = If(IsPublicToken, RequestStream.Protocols.SSL_PublicToken, RequestStream.Protocols.SSL) - byteData = _SHA256.Encrypt(byteData) - request = New RequestStream(RequestStream.SYS_PROTOCOL, Protocol, byteData) With {.uid = uid} - - Return request - End Function - - ''' - ''' 强制将协议设定为公共密匙加密 - ''' - ''' - ''' - Public Overridable Function PublicEncrypt(request As RequestStream) As RequestStream - Dim byteData As Byte() = request.Serialize - byteData = _SHA256.Encrypt(byteData) - request = New RequestStream(RequestStream.SYS_PROTOCOL, RequestStream.Protocols.SSL_PublicToken, byteData) With {.uid = uid} - - Return request - End Function - - ''' - ''' - ''' - ''' - ''' - Public Overridable Function Decrypt(request As RequestStream) As RequestStream - Return __decrypt(request, _SHA256) - End Function - - Protected Shared Function __decrypt(request As RequestStream, sha256 As SecurityString.SHA256) As RequestStream - Dim byteData As Byte() = request.ChunkBuffer - byteData = sha256.Decrypt(byteData) - request = New RequestStream(byteData) - Return request - End Function - - ''' - ''' 检查应用程序的完整性 - ''' - ''' - Public Shared ReadOnly Property AppDomain As Certificate = Install(App.ExecutablePath, publicToken:=True) - - ''' - ''' - ''' - ''' 可执行程序的文件路径 - ''' - Public Shared Function Install(App As String, Optional publicToken As Boolean = False) As Certificate - Call Console.WriteLine() - Call Console.WriteLine() - Call $"**************************************************[ INSTALL {NameOf(Certificate)}: {App.ToFileURL}]****************************************************************".__DEBUG_ECHO - - Dim Modules = (From [module] As String - In __load(App).AsParallel - Select [module], hash = SecurityString.MD5Hash.GetFileHashString([module]) - Order By hash Ascending).ToArray '????已经排过序了，为什么顺序还是不一样 - For Each [module] In Modules - Call $" Installed Module ==> {[module].ToString}".__DEBUG_ECHO - Next - Dim caHashString As String = String.Join("+", (From [mod] In Modules Select [mod].hash).ToArray) - Dim CA As Certificate = If(publicToken, Certificate.InstallPublicToken(SecurityString.GetMd5Hash(caHashString)), New Certificate(caHashString, NameOf(App))) - - Call Console.WriteLine() - Call Console.WriteLine() - Call $"**************************************************[ END OF INSTALL {NameOf(Certificate)} ==> {CA.ToString}]****************************************************************".__DEBUG_ECHO - - Return CA - End Function - - Private Shared Function __load(path As String) As String() - Dim assembly As System.Reflection.Assembly - Try - assembly = System.Reflection.Assembly.LoadFile(FileIO.FileSystem.GetFileInfo(path).FullName) - Catch ex As Exception - Throw New Exception(path.ToFileURL, ex) - End Try - Dim refListBuffer = GetReferences(assembly:=assembly, removeSystem:=True) - - Return refListBuffer - End Function - - Public Overridable Function Decrypt(input() As Byte) As Byte() Implements SecurityStringModel.ISecurityStringModel.Decrypt - Return _SHA256.Decrypt(input) - End Function - - Public Overridable Function DecryptString(text As String) As String Implements SecurityStringModel.ISecurityStringModel.DecryptString - Return _SHA256.DecryptString(text) - End Function - - Public Overridable Function Encrypt(input() As Byte) As Byte() Implements SecurityStringModel.ISecurityStringModel.Encrypt - Return _SHA256.Encrypt(input) - End Function - - Public Overridable Function EncryptData(text As String) As String Implements SecurityStringModel.ISecurityStringModel.EncryptData - Return _SHA256.EncryptData(text) - End Function - End Class -End Namespace diff --git a/ApplicationServices/Tools/Network/SSL/Extensions.vb b/ApplicationServices/Tools/Network/SSL/Extensions.vb deleted file mode 100644 index da54d5b6..00000000 --- a/ApplicationServices/Tools/Network/SSL/Extensions.vb +++ /dev/null @@ -1,85 +0,0 @@ -#Region "Microsoft.VisualBasic::684b0b62a717929ca1123ca139351092, Microsoft.VisualBasic.Core\ApplicationServices\Tools\Network\SSL\Extensions.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Module CAExtensions - ' - ' Function: InstallCommon - ' - ' - ' /********************************************************************************/ - -#End Region - -Imports System.Reflection -Imports Microsoft.VisualBasic.Win32 - -Namespace Net.SSL - - Module CAExtensions - - Public Function InstallCommon(ByRef privateKeys As Dictionary(Of Long, Net.SSL.Certificate), - CA As Certificate, - [overrides] As Boolean, - trace As String, - invoke As MethodInfo) As Boolean - - If privateKeys.ContainsKey(CA.uid) Then - If WindowsServices.Initialized Then - Call ServicesLogs.WriteEntry({$"{invoke.DeclaringType.Name} private key dictionary contains a certificate which its uid: {CA.uid} is conflict with the new install certificate.", - If([overrides], "And the old conflicting certificates was overrides by the new one.", "The certificates operation was skipped!"), - $"Current: {privateKeys(CA.uid).ToString}", - $"Certificates_going_to_install: {CA.ToString}", - $"install_trace: {trace}"}, - invoke.FullName, - EventLogEntryType.SuccessAudit) - End If - - If [overrides] Then - Call privateKeys.Remove(CA.uid) - Else - Return False - End If - End If - - Call privateKeys.Add(CA.uid, CA) - - If WindowsServices.Initialized Then - Call ServicesLogs.WriteEntry({$"New certificates was installed on server!", CA.ToString}, - $"{trace} ==> {invoke.FullName}", - EventLogEntryType.SuccessAudit) - End If - - Return True - End Function - End Module -End Namespace diff --git a/ApplicationServices/Tools/Network/SSL/Protocol.vb b/ApplicationServices/Tools/Network/SSL/Protocol.vb deleted file mode 100644 index 0419ad73..00000000 --- a/ApplicationServices/Tools/Network/SSL/Protocol.vb +++ /dev/null @@ -1,271 +0,0 @@ -#Region "Microsoft.VisualBasic::c143a9b4ec352912719cad03404449ab, Microsoft.VisualBasic.Core\ApplicationServices\Tools\Network\SSL\Protocol.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Module SSLProtocols - ' - ' Function: (+3 Overloads) Handshaking - ' Interface ISSLServices - ' - ' Properties: CA, DeclaringModule, InstallCertificates, PrivateKeys, RaiseHandshakingEvent - ' RefuseHandshake, ResponseHandler - ' - ' Function: Install - ' - ' Delegate Sub - ' - ' - ' Delegate Function - ' - ' Function: __sslHandshake, SSLServicesResponseHandler - ' - ' - ' - ' - ' - ' /********************************************************************************/ - -#End Region - -Imports System.Reflection -Imports Microsoft.VisualBasic.Net.Http -Imports Microsoft.VisualBasic.Net.Protocols -Imports Microsoft.VisualBasic.Win32 - -Namespace Net.SSL - - Public Module SSLProtocols - - ''' - ''' 客户端与服务器之间初始化加密连接 - ''' - ''' 客户端的证书，这个是服务器来进行客户端程序的完整性验证的 - ''' - Public Function Handshaking(CA As SSL.Certificate, services As System.Net.IPEndPoint) As SSL.Certificate - Dim request As RequestStream = - New RequestStream(RequestStream.SYS_PROTOCOL, - RequestStream.Protocols.SSLHandshake, - New Byte() {}) With { - .uid = CA.uid - } - request = New Net.AsynInvoke(services).SendMessage(request, CA, isPublicToken:=True) '这个函数会把用户的账号和当前的客户端的数字证书发送给服务器 -#If DEBUG Then - Call $"[{MethodBase.GetCurrentMethod.GetFullName}] Handshaking {NameOf(CA)} hash:={CA.uid}".__DEBUG_ECHO -#End If - '服务器验证数字证书通过之后就会返回动态的客户端的私有密匙，一般是对随机数做MD5得到私有密匙 - Dim PrivateKey As New SSL.Certificate(request) -#If DEBUG Then - Call $"[{MethodBase.GetCurrentMethod.GetFullName}] Handshaking {NameOf(PrivateKey)} hash:={PrivateKey.uid}".__DEBUG_ECHO -#End If - Return PrivateKey - End Function - - Public Function Handshaking(PublicToken As SSL.Certificate, uid As String, services As System.Net.IPEndPoint) As SSL.Certificate - Dim CA = SSL.Certificate.CopyFrom(PublicToken, uid) -#If DEBUG Then - Call $"[{MethodBase.GetCurrentMethod.GetFullName}] Handshaking {NameOf(CA)} hash:={CA.uid}".__DEBUG_ECHO -#End If - Dim privateKey As SSL.Certificate = Handshaking(CA, services) -#If DEBUG Then - Call $"[{MethodBase.GetCurrentMethod.GetFullName}] Handshaking {NameOf(privateKey)} hash:={privateKey.uid}".__DEBUG_ECHO -#End If - Return privateKey - End Function - - Public Function Handshaking(CA As SSL.Certificate, services As System.Net.IPEndPoint, Install As InstallCertificates) As SSL.Certificate - Dim request As RequestStream = - New RequestStream(RequestStream.SYS_PROTOCOL, - RequestStream.Protocols.SSLHandshake, - New Byte() {}) With { - .uid = CA.uid - } - request = New Net.AsynInvoke(services).SendMessage(request, CA, isPublicToken:=True) '这个函数会把用户的账号和当前的客户端的数字证书发送给服务器 -#If DEBUG Then - Call $"[{MethodBase.GetCurrentMethod.GetFullName}] Handshaking {NameOf(CA)} hash:={CA.uid}".__DEBUG_ECHO -#End If - '服务器验证数字证书通过之后就会返回动态的客户端的私有密匙，一般是对随机数做MD5得到私有密匙 - Dim PrivateKey As SSL.Certificate = Install(request.GetUTF8String, CA.uid) -#If DEBUG Then - Call $"[{MethodBase.GetCurrentMethod.GetFullName}] Handshaking {NameOf(PrivateKey)} hash:={PrivateKey.uid}".__DEBUG_ECHO -#End If - Return PrivateKey - End Function - - ''' - ''' 抽象SSL服务器 - ''' - Public Interface ISSLServices - - ''' - ''' 告诉SSL层如何安装数字证书 - ''' - ''' - Property InstallCertificates As InstallCertificates - ''' - ''' 有新的客户端请求进行连接 - ''' - ''' - Property RaiseHandshakingEvent As HandshakingEvent - ''' - ''' 对于某些应用出于安全性的考虑，会将这里设置为False，则服务器就会全部拒绝后面的所有的握手请求，只接受来自于从外部导入的用户证书的数据请求 - ''' - ''' - Property RefuseHandshake As Boolean - - ''' - ''' 公共密匙 - ''' - ''' - ReadOnly Property CA As SSL.Certificate - ''' - ''' 客户端的私有密匙 - ''' - ''' - ReadOnly Property PrivateKeys As Dictionary(Of Long, SSL.Certificate) - ''' - ''' 处理私有密匙的数据请求 - ''' - ''' - ReadOnly Property ResponseHandler As Net.Abstract.DataRequestHandler - ReadOnly Property DeclaringModule As Object - - ''' - ''' - ''' - ''' - ''' 当证书的哈希值有冲突的时候，新安装的证书可不可以将旧的证书覆盖掉 - Function Install(CA As Certificate, [overrides] As Boolean, Optional trace As String = "") As Boolean - - End Interface - - Public Delegate Sub HandshakingEvent(uid As Long, CA As SSL.Certificate, remoteDev As System.Net.IPEndPoint) - Public Delegate Function InstallCertificates(privateKey As String, uid As Long) As Certificate - - ''' - ''' - ''' - ''' - ''' 解密使用的证书凭据，这个用来鉴别客户端身份是否被伪造 - ''' - ''' - ''' - ''' - Public Function SSLServicesResponseHandler(ssl As ISSLServices, CA As Long, - request As RequestStream, - remoteDev As System.Net.IPEndPoint, - InstallCertificates As InstallCertificates) As RequestStream - Dim uid As Long - - If request.IsSSL_PublicToken Then - uid = request.uid - request = ssl.CA.Decrypt(request) - End If - - If request.IsSSLHandshaking Then '客户端与服务器之间进行连接的初始化，服务器会在这里为客户端动态的生成一个密匙 - request = __sslHandshake(uid, ssl, request, remoteDev, InstallCertificates) - Return request - ElseIf request.IsSSLProtocol Then - uid = request.uid - - If Not ssl.PrivateKeys.ContainsKey(uid) Then ' 不存在的数字证书 - ' 记录进系统日志 - If WindowsServices.Initialized Then - Call ServicesLogs.WriteEntry({$"Remote socket {remoteDev.ToString} try send request with an not authorised certificates, and ssl server refused this request!", - $"{NameOf(CA)} (not_authorised) {CA}", - $"{NameOf(remoteDev)}: {remoteDev.ToString}"}, - $"{ssl.DeclaringModule.GetType.FullName} [{Scripting.ToString(ssl.DeclaringModule)}] ==> {MethodBase.GetCurrentMethod}", - EventLogEntryType.Warning) - End If - - Return New RequestStream(RequestStream.SYS_PROTOCOL, - RequestStream.Protocols.InvalidCertificates, - NameOf(RequestStream.Protocols.InvalidCertificates)) - End If - - Dim PrivateCertificate As SSL.Certificate = ssl.PrivateKeys(uid) - request = PrivateCertificate.Decrypt(request) '使用用户的私有密匙进行加密 - request = ssl.ResponseHandler(CA, request, remoteDev) ' CA应该是用户客户端的数字证书编号 - request = PrivateCertificate.Encrypt(request) - Return request - End If - - Return NetResponse.RFC_NO_CERT - End Function - - ''' - ''' 客户端与服务器之间进行连接的初始化，服务器会在这里为客户端动态的生成一个密匙 - ''' - ''' - Private Function __sslHandshake(uid As Long, ssl As ISSLServices, - request As RequestStream, - remoteDev As System.Net.IPEndPoint, - InstallCertificates As InstallCertificates) As RequestStream - If ssl.RefuseHandshake Then - Return New RequestStream(RequestStream.SYS_PROTOCOL, - RequestStream.Protocols.InvalidCertificates, - "Services Refused!") - End If - - Dim key As String = Guid.NewGuid.ToString - key = SecurityString.MD5Hash.GetMd5Hash(key) - - If uid <> request.uid Then - Return New RequestStream(RequestStream.SYS_PROTOCOL, - RequestStream.Protocols.InvalidCertificates, - NameOf(RequestStream.Protocols.InvalidCertificates)) - Else - request = New RequestStream(RequestStream.SYS_PROTOCOL, - RequestStream.Protocols.SSLHandshake, key) With { - .uid = uid - } - End If - - If ssl.PrivateKeys.ContainsKey(uid) Then ' 哈希函数设计不正确，有重复的哈希值，则当前的握手用户不能够使用这个哈希值，需要重新握手 - Call $"{NameOf(SSLServicesResponseHandler)} ==> {uid} was duplicated!".__DEBUG_ECHO - Return New RequestStream(RequestStream.SYS_PROTOCOL, RequestStream.Protocols.InvalidCertificates, "Duplicated hash value!") - End If - -#If DEBUG Then - Call $"[{MethodBase.GetCurrentMethod.GetFullName}] Handshaking hash:={uid}".__DEBUG_ECHO -#End If - - Dim PrivateKey As SSL.Certificate = InstallCertificates(key, uid) - Call ssl.PrivateKeys.Add(uid, PrivateKey) - Call ssl.RaiseHandshakingEvent()(uid, PrivateKey, remoteDev) - - request = Net.SSL.Certificate.CopyFrom(ssl.CA, uid).Encrypt(request) - - Return request - End Function - - End Module -End Namespace diff --git a/ApplicationServices/Tools/Network/SSL/SSL.pptx b/ApplicationServices/Tools/Network/SSL/SSL.pptx deleted file mode 100644 index e1561c14..00000000 Binary files a/ApplicationServices/Tools/Network/SSL/SSL.pptx and /dev/null differ diff --git a/ApplicationServices/Tools/Network/SSL/SSLSynchronizationServicesSocket.vb b/ApplicationServices/Tools/Network/SSL/SSLSynchronizationServicesSocket.vb deleted file mode 100644 index 3cb56abb..00000000 --- a/ApplicationServices/Tools/Network/SSL/SSLSynchronizationServicesSocket.vb +++ /dev/null @@ -1,258 +0,0 @@ -#Region "Microsoft.VisualBasic::5196cbf0510b65ca84c69fedf87bbb1a, Microsoft.VisualBasic.Core\ApplicationServices\Tools\Network\SSL\SSLSynchronizationServicesSocket.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Class SSLSynchronizationServicesSocket - ' - ' Properties: CA, DeclaringModule, IsRunning, IsShutdown, ISSLServices_InstallCertificates - ' LocalPort, PrivateKeys, RaiseHandshakingEvent, RefuseHandshake, Responsehandler - ' - ' Constructor: (+1 Overloads) Sub New - ' - ' Function: __responsehandler, Install, InstallCertificates, (+2 Overloads) Run, ToString - ' - ' Sub: (+2 Overloads) Dispose, HandShakingEventDoNothing, WaitForStart - ' - ' - ' /********************************************************************************/ - -#End Region - -Imports System.Reflection -Imports System.Runtime.CompilerServices -Imports Microsoft.VisualBasic.ComponentModel -Imports Microsoft.VisualBasic.Net.Abstract -Imports Microsoft.VisualBasic.Net.Protocols - -Namespace Net.SSL - - Public Class SSLSynchronizationServicesSocket - Implements IDisposable - Implements ITaskDriver - Implements IServicesSocket - Implements SSL.SSLProtocols.ISSLServices - - Dim _ServicesSocket As Net.TcpSynchronizationServicesSocket - - ''' - ''' 这个数字证书是当前版本下的服务器的客户端的数字签名，服务器会使用这个证书来验证客户端的文件是否被恶意破解，相当于公有密匙 - ''' - Public ReadOnly Property CA As Certificate Implements ISSLServices.CA - ''' - ''' A table stores the certificates of the current connected clients on this server. - ''' (连接上来的客户端的私有证书列表) - ''' - ''' - Public ReadOnly Property PrivateKeys As Dictionary(Of Long, Certificate) Implements ISSLServices.PrivateKeys - - ''' - ''' - ''' - ''' - ''' 服务器在部署的时候向对应版本您的客户端的数字签名 - ''' Public Delegate Sub (ex As ) - Sub New(LocalPort As Integer, - CA As SSL.Certificate, - container As Object, - Optional exHandler As Abstract.ExceptionHandler = Nothing) - - _DeclaringModule = container - _ServicesSocket = New TcpSynchronizationServicesSocket(LocalPort, exHandler) - _CA = CA - _PrivateKeys = New Dictionary(Of Long, Certificate) - End Sub - - Public ReadOnly Property IsShutdown As Boolean Implements IServicesSocket.IsShutdown - Get - If _ServicesSocket Is Nothing Then - Return True - End If - - Return _ServicesSocket.IsShutdown - End Get - End Property - - Public ReadOnly Property IsRunning As Boolean Implements IServicesSocket.IsRunning - Get - If _ServicesSocket Is Nothing Then - Return False - End If - - Return _ServicesSocket.Running - End Get - End Property - - ''' - ''' 底层工作socket所监听的端口号 - ''' - ''' - Public ReadOnly Property LocalPort As Integer Implements IServicesSocket.LocalPort - Get - Return _ServicesSocket.LocalPort - End Get - End Property - - Public Overrides Function ToString() As String - Return Me._ServicesSocket.ToString - End Function - -#Region "Responsehandler" - - ''' - ''' : - ''' Public Delegate Function (CA As , request As , - ''' RemoteAddress As ) As - ''' - ''' - Public Property Responsehandler As DataRequestHandler Implements IServicesSocket.Responsehandler, ISSLServices.ResponseHandler - Get - Return _responsehandler - End Get - Set(value As DataRequestHandler) - _ServicesSocket.Responsehandler = New DataRequestHandler(AddressOf __responsehandler) - _responsehandler = value - End Set - End Property - - ''' - ''' 生成证书的方法 - ''' - ''' - Public Property ISSLServices_InstallCertificates As InstallCertificates = - AddressOf InstallCertificates Implements ISSLServices.InstallCertificates - - ''' - ''' 客户端和服务器握手之后触发这个动作 - ''' - ''' - Public Property RaiseHandshakingEvent As HandshakingEvent = - AddressOf SSLSynchronizationServicesSocket.HandShakingEventDoNothing Implements ISSLServices.RaiseHandshakingEvent - - ''' - ''' Does this ssl server accepts the handshaking from the user client or just allow the client connect to this server from manual imports their certificates by using method - ''' - ''' - Public Property RefuseHandshake As Boolean Implements ISSLServices.RefuseHandshake - - Public ReadOnly Property DeclaringModule As Object Implements ISSLServices.DeclaringModule - - Dim _responsehandler As DataRequestHandler - - Private Function __responsehandler(CA As Long, request As RequestStream, remoteDev As System.Net.IPEndPoint) As RequestStream - Return SSL.SSLProtocols.SSLServicesResponseHandler(Me, CA, request, remoteDev, ISSLServices_InstallCertificates) - End Function -#End Region - - ''' - ''' 等待底层socket成功进入监听模式 - ''' - Public Sub WaitForStart() - Call _ServicesSocket.WaitForStart() - End Sub - - ''' - ''' This server waits for a connection and then uses asychronous operations to - ''' accept the connection, get data from the connected client, - ''' echo that data back to the connected client. - ''' It then disconnects from the client and waits for another client.(请注意，当服务器的代码运行到这里之后，代码将被阻塞在这里) - ''' - ''' - Public Function Run(localEndPoint As System.Net.IPEndPoint) As Integer Implements IServicesSocket.Run - Return _ServicesSocket.Run(localEndPoint) - End Function - - ''' - ''' This server waits for a connection and then uses asychronous operations to - ''' accept the connection, get data from the connected client, - ''' echo that data back to the connected client. - ''' It then disconnects from the client and waits for another client.(请注意，当服务器的代码运行到这里之后，代码将被阻塞在这里) - ''' - ''' - Public Function Run() As Integer Implements IServicesSocket.Run, ITaskDriver.Run - Return _ServicesSocket.Run - End Function - -#Region "IDisposable Support" - Private disposedValue As Boolean ' To detect redundant calls - - ' IDisposable - Protected Overridable Sub Dispose(disposing As Boolean) - If Not disposedValue Then - If disposing Then - ' TODO: dispose managed state (managed objects). - Call Me._ServicesSocket.Free - End If - - ' TODO: free unmanaged resources (unmanaged objects) and override Finalize() below. - ' TODO: set large fields to null. - End If - disposedValue = True - End Sub - - ' TODO: override Finalize() only if Dispose(disposing As Boolean) above has code to free unmanaged resources. - 'Protected Overrides Sub Finalize() - ' ' Do not change this code. Put cleanup code in Dispose(disposing As Boolean) above. - ' Dispose(False) - ' MyBase.Finalize() - 'End Sub - - ' This code added by Visual Basic to correctly implement the disposable pattern. - Public Sub Dispose() Implements IDisposable.Dispose - ' Do not change this code. Put cleanup code in Dispose(disposing As Boolean) above. - Dispose(True) - ' TODO: uncomment the following line if Finalize() is overridden above. - ' GC.SuppressFinalize(Me) - End Sub -#End Region - - Public Shared Function InstallCertificates(privateKey As String, uid As Long) As SSL.Certificate - Return New SSL.Certificate(privateKey, uid) - End Function - - Public Shared Sub HandShakingEventDoNothing(uid As Long, CA As SSL.Certificate, remote As System.Net.IPEndPoint) - ' DO NOTHING - End Sub - - ''' - ''' If the property of is set to TRUE, then no more new client can be connect to this server object. - ''' The only way to add new client on this server is using this function to imports the client's certificates direct manually. - ''' (假若ssl层关闭了握手协议，则不可能会再有新的客户端可以连接到这个服务器上面了，则这个时候就可以使用这个方法来手工的为新的客户端导入数字证书，从而可以只接受指定的客户端的连接操作 - ''' 假若是证书同步操作的话，则可以将app授权证书通过这个方法导入到服务器模块接收主节点的证书同步操作) - ''' - ''' - ''' - ''' - Public Function Install(CA As Certificate, [overrides] As Boolean, Optional trace As String = "") As Boolean Implements ISSLServices.Install - Return CAExtensions.InstallCommon(PrivateKeys, CA, [overrides], trace, MethodBase.GetCurrentMethod) - End Function - End Class -End Namespace diff --git a/ApplicationServices/Tools/Network/Tcp/AsynInvoke.vb b/ApplicationServices/Tools/Network/Tcp/AsynInvoke.vb index 8c6ee79d..3a590abc 100644 --- a/ApplicationServices/Tools/Network/Tcp/AsynInvoke.vb +++ b/ApplicationServices/Tools/Network/Tcp/AsynInvoke.vb @@ -1,62 +1,58 @@ #Region "Microsoft.VisualBasic::43478869161388f889b5f12a85a8f75e, Microsoft.VisualBasic.Core\ApplicationServices\Tools\Network\Tcp\AsynInvoke.vb" - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . +' Author: +' +' asuka (amethyst.asuka@gcmodeller.org) +' xie (genetics@smrucc.org) +' xieguigang (xie.guigang@live.com) +' +' Copyright (c) 2018 GPL3 Licensed +' +' +' GNU GENERAL PUBLIC LICENSE (GPL3) +' +' +' This program is free software: you can redistribute it and/or modify +' it under the terms of the GNU General Public License as published by +' the Free Software Foundation, either version 3 of the License, or +' (at your option) any later version. +' +' This program is distributed in the hope that it will be useful, +' but WITHOUT ANY WARRANTY; without even the implied warranty of +' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +' GNU General Public License for more details. +' +' You should have received a copy of the GNU General Public License +' along with this program. If not, see . - ' /********************************************************************************/ +' /********************************************************************************/ - ' Summaries: +' Summaries: - ' Class AsynInvoke - ' - ' Properties: LocalIPAddress - ' - ' Constructor: (+4 Overloads) Sub New - ' Function: LocalConnection, OperationTimeOut, SafelySendMessage, (+2 Overloads) SendMessage, ToString - ' Delegate Function - ' - ' Function: __decryptMessageCommon, (+6 Overloads) SendMessage - ' - ' Sub: __send, ConnectCallback, (+2 Overloads) Dispose, Receive, ReceiveCallback - ' SendCallback - ' - ' - ' - ' /********************************************************************************/ +' Class AsynInvoke +' +' Properties: LocalIPAddress +' +' Constructor: (+4 Overloads) Sub New +' Function: LocalConnection, OperationTimeOut, SafelySendMessage, (+2 Overloads) SendMessage, ToString +' Delegate Function +' +' Function: __decryptMessageCommon, (+6 Overloads) SendMessage +' +' Sub: __send, ConnectCallback, (+2 Overloads) Dispose, Receive, ReceiveCallback +' SendCallback +' +' +' +' /********************************************************************************/ #End Region -Imports System Imports System.Net Imports System.Net.Sockets -Imports System.Reflection -Imports System.Text Imports System.Threading -Imports Microsoft.VisualBasic.Net.Abstract Imports Microsoft.VisualBasic.Net.Http Imports Microsoft.VisualBasic.Net.Protocols @@ -233,27 +229,6 @@ Namespace Net End If End Function - Public Function SafelySendMessage(Message As RequestStream, - CA As SSL.Certificate, - Optional OperationTimeOut As Integer = 30 * 1000, - Optional OperationTimeoutHandler As Action = Nothing) As RequestStream - - Message = CA.Encrypt(Message) - Message = SendMessage(Message, OperationTimeOut, OperationTimeoutHandler) - - If Message.IsSSLProtocol OrElse Message.IsSSL_PublicToken Then - Message = CA.Decrypt(Message) - Else - Try - Message.ChunkBuffer = CA.Decrypt(Message.ChunkBuffer) - Catch ex As Exception - Return Message - End Try - End If - - Return Message - End Function - Public Delegate Function SendMessageInvoke(Message As String) As String Public Function SendMessage(Message As String, Callback As Action(Of String)) As IAsyncResult @@ -274,13 +249,6 @@ Namespace Net Return response End Function 'Main - Public Function SendMessage(Message As String, CA As SSL.Certificate) As String - Dim request = New RequestStream(0, 0, Message) - Dim byteData = CA.Encrypt(request).Serialize - byteData = SendMessage(byteData) - Return __decryptMessageCommon(byteData, CA).GetUTF8String - End Function - ''' ''' Send a request message to the remote server. ''' @@ -296,37 +264,6 @@ Namespace Net End If End Function - Private Function __decryptMessageCommon(retData As Byte(), CA As SSL.Certificate) As RequestStream - If Not RequestStream.IsAvaliableStream(retData) Then Return New RequestStream(0, 0, retData) - - Dim Message = New RequestStream(retData) - - If Message.IsSSLProtocol OrElse Message.IsSSL_PublicToken Then - Message = CA.Decrypt(Message) - Else - Try - Message.ChunkBuffer = CA.Decrypt(Message.ChunkBuffer) - Catch ex As Exception - Call App.LogException(ex, MethodBase.GetCurrentMethod.GetFullName) - End Try - End If - - Return Message - End Function - - ''' - ''' 发送一段使用证书对象进行数据加密操作的消息请求 - ''' - ''' - ''' - ''' - ''' - Public Function SendMessage(Message As RequestStream, CA As SSL.Certificate, Optional isPublicToken As Boolean = False) As RequestStream - Dim byteData = If(isPublicToken, CA.PublicEncrypt(Message), CA.Encrypt(Message)).Serialize - byteData = SendMessage(byteData) - Return __decryptMessageCommon(byteData, CA) - End Function - ''' ''' 最底层的消息发送函数 ''' diff --git a/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/Abstract.vb b/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/Abstract.vb deleted file mode 100644 index ddb751ec..00000000 --- a/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/Abstract.vb +++ /dev/null @@ -1,59 +0,0 @@ -#Region "Microsoft.VisualBasic::9df9f6c84fab11bf4cb9193eb5fa65be, Microsoft.VisualBasic.Core\ApplicationServices\Tools\Network\Tcp\Persistent\MessagePushServices\Abstract.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Delegate Sub - ' - ' - ' Delegate Function - ' - ' - ' - ' - ' - ' /********************************************************************************/ - -#End Region - -Imports Microsoft.VisualBasic.Net.Protocols - -Namespace Net.Persistent - - ''' - ''' 离线数据请求 - ''' - ''' - ''' - ''' - Public Delegate Sub OffLineMessageSendHandler(FromUSER_ID As Long, USER_ID As Long, Message As RequestStream) - Public Delegate Function PushMessage(USER_ID As Long, Message As RequestStream) As RequestStream -End Namespace diff --git a/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/MessagePushServer.vb b/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/MessagePushServer.vb deleted file mode 100644 index bc8361cb..00000000 --- a/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/MessagePushServer.vb +++ /dev/null @@ -1,412 +0,0 @@ -#Region "Microsoft.VisualBasic::4503a5e2e9f2543ee1661b0f2816f869, Microsoft.VisualBasic.Core\ApplicationServices\Tools\Network\Tcp\Persistent\MessagePushServices\MessagePushServer.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Class MessagePushServer - ' - ' Properties: LocalPort, ProtocolHandler, Responsehandler, SSLMode, UidMappings - ' UidMappingsBack - ' - ' Constructor: (+1 Overloads) Sub New - ' - ' Function: __broadcastMessage, __getMyIPAddress, __isGetSocketPortal, __isUserOnlineQuery, __Logon - ' __nonUidMappings, __requestHandlerInterface, (+2 Overloads) __sendMessage, __usrInvokeSend, GetEnumerator - ' IEnumerable_GetEnumerator, Run - ' - ' Sub: __socketCleanup, AcceptClient, DisconnectUser, Dispose, Install - ' RemoveFreeConnections, Run, SendMessage - ' - ' - ' /********************************************************************************/ - -#End Region - -Imports System.Reflection -Imports System.Threading -Imports Microsoft.VisualBasic.ComponentModel -Imports Microsoft.VisualBasic.Linq.Extensions -Imports Microsoft.VisualBasic.Net.Abstract -Imports Microsoft.VisualBasic.Net.Http -Imports Microsoft.VisualBasic.Net.Persistent.Application.Protocols -Imports Microsoft.VisualBasic.Net.Persistent.Socket -Imports Microsoft.VisualBasic.Net.Protocols -Imports Microsoft.VisualBasic.Net.Protocols.Reflection - -Namespace Net.Persistent.Application - - ''' - ''' 长连接模式的消息推送服务器 - ''' - - Public Class MessagePushServer : Inherits ServicesSocket - Implements IEnumerable(Of KeyValuePair(Of Long, WorkSocket)) - Implements ITaskDriver, IDataRequestHandler - - Public ReadOnly Property ProtocolHandler As ProtocolHandler - - Dim _socketList As New Dictionary(Of Long, WorkSocket) - ''' - ''' 客户端对这个服务器的端口号是自动配置的，只需要向客户端返回端口就可以了 - ''' - Dim _workSocket As TcpSynchronizationServicesSocket - Dim _offlineMessageSendHandler As OffLineMessageSendHandler - ''' - ''' 使用证书来加密发出去的消息 - ''' - Dim _sslLayer As SSL.ISSLServices - - Public ReadOnly Property SSLMode As Boolean - - Public Sub Install(ssl As SSL.ISSLServices) - _sslLayer = ssl - _SSLMode = Not ssl Is Nothing - End Sub - - ''' - ''' 从这个端口号进行登录（协同长连接的socket正常工作的socket的端口号，可以看作为UserAPI） - ''' - ''' - Public Overrides ReadOnly Property LocalPort As Integer - Get - Return Me._workSocket.LocalPort - End Get - End Property - - Dim _responsehandler As DataRequestHandler - - Friend Property Responsehandler As DataRequestHandler Implements IDataRequestHandler.Responsehandler - Get - Return _responsehandler - End Get - Set(value As DataRequestHandler) - _responsehandler = value - Me._workSocket.Responsehandler = AddressOf __requestHandlerInterface - End Set - End Property - - ''' - ''' 只要是为ssl服务设置的 - ''' - ''' - ''' - Private Function __requestHandlerInterface(CA As Long, - requestData As RequestStream, - remote As System.Net.IPEndPoint) As RequestStream - requestData = _responsehandler(CA, requestData, remote) - Return requestData - End Function - - ''' - ''' - ''' - ''' - ''' Public Delegate Sub (FromUSER_ID As , USER_ID As , Message As ) - ''' - Sub New(Optional LocalPort As Integer = 11000, - Optional OffLineMessageSendHandler As OffLineMessageSendHandler = Nothing, - Optional exHandler As Abstract.ExceptionHandler = Nothing) - - Call MyBase.New(GetFirstAvailablePort(5000), exHandler) - - Me._ProtocolHandler = New ProtocolHandler(Me) - Me.AcceptCallbackHandleInvoke = AddressOf AcceptClient - Me._workSocket = New TcpSynchronizationServicesSocket(AddressOf _ProtocolHandler.HandleRequest, LocalPort, Me.__exceptionHandle) - Me._offlineMessageSendHandler = If(OffLineMessageSendHandler Is Nothing, - Sub([from], USER_ID, MESSAGE) Call Console.WriteLine($" >>> [DEBUG {Now.ToString}, {from} => {USER_ID}] {MESSAGE}"), - OffLineMessageSendHandler) - End Sub - - Public Overrides Sub Run(localEndPoint As System.Net.IPEndPoint) - Call New Thread(AddressOf Me._workSocket.Run).Start() - Call Thread.Sleep(1000) - Call $"please logon server {Me.GetType.Name} at api_port={Me._workSocket.LocalPort}".__DEBUG_ECHO - Call MyBase.Run(localEndPoint) - End Sub - - Public Overrides Function Run() As Integer Implements ITaskDriver.Run - Return MyBase.Run() - End Function - - ''' - ''' Disconnect user persistent connection who have the specific from this server. - ''' (断开服务器与用户客户端的长连接) - ''' - ''' This user will be deleted from the server registry. - ''' 是否在删除socket句柄的时候还会删除相对应的ssl证书 - Public Sub DisconnectUser(USER_ID As Long, removeCA As Boolean) - If Me._socketList.ContainsKey(USER_ID) Then - Dim socket As WorkSocket = _socketList(USER_ID) - Call _socketList.Remove(USER_ID) - Call $"Clean up connection for user {USER_ID} previous connection.".__DEBUG_ECHO - Call socket.Free - End If - If removeCA AndAlso SSLMode Then - If _sslLayer.PrivateKeys.ContainsKey(USER_ID) Then - Call _sslLayer.PrivateKeys.Remove(USER_ID) - End If - End If - End Sub - - Protected Overrides Sub __socketCleanup(hash As Integer) - Dim LQuery = (From usr In _socketList Where hash = usr.Value.GetHashCode Select usr.Key).FirstOrDefault - Call DisconnectUser(LQuery, True) - End Sub - - ''' - ''' - ''' - ''' - ''' - ''' - Public Sub SendMessage(From As Long, USER_ID As Long, Message As RequestStream) - Dim request = ServicesProtocol.SendMessageRequest(From, USER_ID, Message) - Call __sendMessage(From, USER_ID, request) - End Sub - - ''' - ''' 发送出去的数据需要进行加密，假若是ssl模式的话 - ''' - ''' - ''' - ''' - ''' - Private Function __sendMessage(From As Long, USER_ID As Long, Message As RequestStream) As RequestStream -#If DEBUG Then - Call Console.Write($"{MethodBase.GetCurrentMethod.GetFullName} {NameOf(USER_ID)}:{USER_ID} mappings to ") -#End If - USER_ID = _UidMappings(USER_ID) -#If DEBUG Then - Call Console.WriteLine(USER_ID) '衔接着上一个输出语句 -#End If - If Me._socketList.ContainsKey(USER_ID) Then - Dim Socket As WorkSocket = Me._socketList(USER_ID) - Return __sendMessage(Socket, From, USER_ID, Message) - End If - -#If DEBUG Then - Call $"Unable to found user '{USER_ID}' on server...".__DEBUG_ECHO - Call $"Current users: {String.Join("; ", _socketList.Keys.Select(Function(id) CStr(id)).ToArray)}".__DEBUG_ECHO -#End If - Call Me._offlineMessageSendHandler(From, USER_ID, Message) - Return NetResponse.RFC_TEMP_REDIRECT - End Function - - ''' - ''' 将外部编号映射为内部的客户端句柄 - ''' 假若找不到，请返回-1 - ''' - ''' - Public Property UidMappings As Func(Of Long, Long) = AddressOf __nonUidMappings - Public Property UidMappingsBack As Func(Of Long, Long) = AddressOf __nonUidMappings - - Private Shared Function __nonUidMappings(USER_ID As Long) As Long - Return USER_ID - End Function - - ''' - ''' - ''' - ''' - ''' 这个是这一条消息的源头，可能需要进行映射 - ''' - ''' - ''' - Private Function __sendMessage(socket As WorkSocket, - From As Long, - USER_ID As Long, - Message As RequestStream) As RequestStream - - From = Me._UidMappingsBack(From) - - If socket Is Nothing OrElse socket.workSocket Is Nothing Then - Call _socketList.Remove(USER_ID) - Call Me._offlineMessageSendHandler(From, USER_ID, Message) - Return NetResponse.RFC_TEMP_REDIRECT - End If - -#If DEBUG Then - Call Console.WriteLine($"*Call {NameOf(__sendMessage)} ===> {Message}") -#End If - If SSLMode Then - Dim CA As SSL.Certificate = _sslLayer.PrivateKeys(USER_ID) - Dim post As New SendMessagePost(Message.ChunkBuffer) - post.Message = CA.Encrypt(post.Message) - post.FROM = From - Message = New RequestStream(ServicesProtocol.ProtocolEntry, - ServicesProtocol.Protocols.SendMessage, - post.Serialize) -#If DEBUG Then - Call $"Request encrypts from {CA.uid} job done!".__DEBUG_ECHO -#End If - End If - - Call socket.SendMessage(Message) '原封不动的进行数据转发 - Return NetResponse.RFC_OK - End Function - - ''' - ''' 用户客户端请求发送消息至指定编号的用户的终端之上 - ''' - ''' - ''' - ''' - ''' - - Private Function __usrInvokeSend(CA As Long, request As RequestStream, remote As System.Net.IPEndPoint) As RequestStream - Dim [From] As Long, USER_ID As Long -#If DEBUG Then - Call $"{NameOf(From)}:{From} invoke send to {NameOf(USER_ID)}:{USER_ID}".__DEBUG_ECHO -#End If - If ServicesProtocol.GetSendMessage(request, From, USER_ID) Then - Return Me.__sendMessage(From, USER_ID, request) - Else - Return NetResponse.RFC_TOKEN_INVALID - End If - End Function - - - Private Function __Logon(CA As Long, request As RequestStream, remote As System.Net.IPEndPoint) As RequestStream - Dim USER_ID As Long, remoteEp As String = "" - - If Not ServicesProtocol.GetLogOnUSER(request.GetUTF8String, USER_ID, remoteEp) Then - Return NetResponse.RFC_TOKEN_INVALID - End If - - Dim hash As Integer = CInt(Val(remoteEp)) - - If Not Me._Connections.ContainsKey(hash) Then - Call Console.WriteLine($"No connection could be made! {hash} for socket hash is not exists in the hash table!") - Return NetResponse.RFC_CONFLICT - End If - - Dim SocketClient As WorkSocket = Nothing - Call Me._Connections.TryGetValue(hash, SocketClient) - - If SocketClient Is Nothing Then - Call Console.WriteLine("No connection could be made!") - Return NetResponse.RFC_BAD_GATEWAY - Else - Call Console.WriteLine(" >> " & SocketClient.workSocket.RemoteEndPoint.ToString) - End If - - Call DisconnectUser(USER_ID, False) - Call _socketList.Add(USER_ID, SocketClient) - - Return NetResponse.RFC_OK - End Function - - - Private Function __broadcastMessage(CA As Long, request As RequestStream, remote As System.Net.IPEndPoint) As RequestStream - For Each cnn In Me.Connections - Call cnn.SendMessage(request) - Next - Return NetResponse.RFC_OK - End Function - - - Private Function __getMyIPAddress(CA As Long, request As RequestStream, remote As System.Net.IPEndPoint) As RequestStream - Return New RequestStream(0, HTTP_RFC.RFC_OK, remote.ToString.Split(":"c)(Scan0)) - End Function - - - Private Function __isGetSocketPortal(CA As Long, request As RequestStream, remote As System.Net.IPEndPoint) As RequestStream - Return New RequestStream(0, HTTP_RFC.RFC_OK, CStr(_LocalPort)) - End Function - - - Private Function __isUserOnlineQuery(CA As Long, request As RequestStream, remote As System.Net.IPEndPoint) As RequestStream - Dim USER_ID As Long = Scripting.CTypeDynamic(Of Long)(request.GetUTF8String) - Dim result As String = CStr(Me._socketList.ContainsKey(USER_ID)) - Return New RequestStream(0, HTTP_RFC.RFC_OK, result) - End Function - - Dim _freeCnnInfo As New List(Of String) - - ''' - ''' 哈希值不存在于现有的登录用户列表之中就是空闲连接 - ''' - Public Sub RemoveFreeConnections() - Dim LQuery = (From Guid As String In _freeCnnInfo.AsParallel '上一次刷新的时候的空闲连接 - Let LowCnn = (From cnn In Me.Connections.AsParallel - Where Guid.Equals(CStr(cnn.GetHashCode)) - Select cnn).FirstOrDefault - Where Not LowCnn Is Nothing AndAlso - (From cnn In Me._socketList - Where Guid.Equals(CStr(cnn.Value.GetHashCode)) - Select cnn).ToArray.IsNullOrEmpty '哈希值不存在的 - Select LowCnn).ToArray '对于上一次刷新的列表之中的连接而言，假若在这么长的一段时间间隔之中还是处于空闲状态，则服务器会将这些连接断开连接 - For Each cnn In LQuery - Call Me.ForceCloseHandle(cnn) - Call cnn.Free - Next - - Call $"Clean up {LQuery.Length } free connections.....".__DEBUG_ECHO - '获取新产生的空闲连接 - _freeCnnInfo = (From cnn In Me._Connections.AsParallel - Where (From item In Me._socketList Where item.Value.GetHashCode = cnn.GetHashCode Select 1).ToArray.IsNullOrEmpty - Select Guid = CStr(cnn.GetHashCode)).AsList - Call $"{_freeCnnInfo.Count} free connections pending for clean up....".__DEBUG_ECHO - - For Each usr In Me._socketList.ToArray - Call usr.Value.SendMessage(NetResponse.RFC_OK) - Next - End Sub - - ''' - ''' 建立一个新的连接 - ''' - ''' - Private Sub AcceptClient(Client As WorkSocket) - 'Do Nothing - Call $"{Client.workSocket.RemoteEndPoint.ToString} connection request accept!".__DEBUG_ECHO - End Sub - - Public Iterator Function GetEnumerator() As IEnumerator(Of KeyValuePair(Of Long, WorkSocket)) Implements IEnumerable(Of KeyValuePair(Of Long, WorkSocket)).GetEnumerator - For Each entry In Me._socketList.ToArray - Yield entry - Next - End Function - - Private Iterator Function IEnumerable_GetEnumerator() As IEnumerator Implements IEnumerable.GetEnumerator - Yield GetEnumerator() - End Function - - Protected Overrides Sub Dispose(disposing As Boolean) - If disposing Then - For Each cnn In Me._socketList.ToArray - Call DisconnectUser(cnn.Key, True) - Next - End If - Call MyBase.Dispose(disposing) - End Sub - End Class -End Namespace diff --git a/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/SSLClient.vb b/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/SSLClient.vb deleted file mode 100644 index 82f23bea..00000000 --- a/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/SSLClient.vb +++ /dev/null @@ -1,116 +0,0 @@ -#Region "Microsoft.VisualBasic::c3fcc9a39fc606f3958191507f70b593, Microsoft.VisualBasic.Core\ApplicationServices\Tools\Network\Tcp\Persistent\MessagePushServices\SSLClient.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Class SSLClient - ' - ' Properties: PrivateKey, PushUser - ' - ' Constructor: (+1 Overloads) Sub New - ' - ' Function: __sslRedirect, SendMessage - ' - ' Sub: Handshaking, Logon, SetDisconnectHandle - ' - ' - ' /********************************************************************************/ - -#End Region - -Imports System.Net -Imports System.Net.Sockets -Imports System.Threading -Imports Microsoft.VisualBasic.Net.Abstract -Imports Microsoft.VisualBasic.Net.Protocols -Imports Microsoft.VisualBasic.Net.Protocols.Reflection - -Namespace Net.Persistent.Application - - Public Class SSLClient - - Public ReadOnly Property PrivateKey As Net.SSL.Certificate - Public ReadOnly Property PushUser As Net.Persistent.Application.USER - - ReadOnly _DataRequestHandle As PushMessage - - ''' - ''' - ''' - ''' - ''' - ''' Public Delegate Function PushMessage(USER_ID As , Message As ) As - ''' - Sub New(services As System.Net.IPEndPoint, ID As Long, DataRequestHandle As PushMessage, Optional ExceptionHandler As Abstract.ExceptionHandler = Nothing) - _DataRequestHandle = DataRequestHandle - PushUser = New USER(services, ID, AddressOf __sslRedirect, ExceptionHandler) - End Sub - - Private Function __sslRedirect(USER_ID As Long, request As RequestStream) As RequestStream - request = PrivateKey.Decrypt(request) ' 解密之后在讲数据传递到实际的业务逻辑之上 - request = _DataRequestHandle(USER_ID, request) - Return request - End Function - - Public Sub Handshaking(PublicToken As Net.SSL.Certificate) - Dim Services = New System.Net.IPEndPoint(System.Net.IPAddress.Parse(PushUser.remoteHost), PushUser.remotePort) - _PrivateKey = Net.SSL.Certificate.CopyFrom(PublicToken, PushUser.USER_ID) - _PrivateKey = Net.SSL.SSLProtocols.Handshaking(PrivateKey, Services) - Call PushUser.BeginConnect(PrivateKey, _disconnectHandler) - End Sub - - ''' - ''' 使用已经拥有的用户证书登录服务器，这一步省略了握手步骤 - ''' - ''' - Public Sub Logon(UserToken As Net.SSL.Certificate) - _PrivateKey = UserToken - _PushUser.BeginConnect(UserToken, _disconnectHandler) - End Sub - - Dim _disconnectHandler As MethodInvoker - - Public Sub SetDisconnectHandle([handle] As MethodInvoker) - _disconnectHandler = handle - _PushUser.SetDisconnectHandle(handle) - End Sub - - ''' - ''' 消息在这个函数之中自动被加密处理 - ''' - ''' - ''' - ''' - Public Function SendMessage(USER_ID As Long, request As RequestStream) As Boolean - Return PushUser.SendMessage(USER_ID, request, PrivateKey) - End Function - End Class -End Namespace diff --git a/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/SSLPushServices.vb b/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/SSLPushServices.vb deleted file mode 100644 index a762553d..00000000 --- a/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/SSLPushServices.vb +++ /dev/null @@ -1,217 +0,0 @@ -#Region "Microsoft.VisualBasic::207dc029de94e511c91be0be3ac1991a, Microsoft.VisualBasic.Core\ApplicationServices\Tools\Network\Tcp\Persistent\MessagePushServices\SSLPushServices.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Class SSLPushServices - ' - ' Properties: CA, Connections, DeclaringModule, InstallCertificates, IsRunning - ' IsShutdown, LocalPort, PrivateKeys, PushServices, RaiseHandshakingEvent - ' RefuseHandshake, Responsehandler - ' - ' Constructor: (+1 Overloads) Sub New - ' - ' Function: __redirect, __responsehandler, Install, (+2 Overloads) Run - ' - ' Sub: (+2 Overloads) Dispose, Install, WaitForRunning - ' - ' - ' /********************************************************************************/ - -#End Region - -Imports System.Reflection -Imports System.Runtime.CompilerServices -Imports Microsoft.VisualBasic.ComponentModel -Imports Microsoft.VisualBasic.Net.Abstract -Imports Microsoft.VisualBasic.Net.Persistent.Socket -Imports Microsoft.VisualBasic.Net.Protocols -Imports Microsoft.VisualBasic.Net.SSL - -Namespace Net.Persistent.Application - - ''' - ''' 消息都是经过加密操作了的 - ''' - Public Class SSLPushServices : Implements Net.Abstract.IServicesSocket - Implements ISSLServices - - Public ReadOnly Property PushServices As Net.Persistent.Application.MessagePushServer - - ''' - ''' 共有密匙 - ''' - ''' - Public ReadOnly Property CA As Certificate Implements ISSLServices.CA - ''' - ''' 连接到当前的这个服务器上面的客户端的私有密匙列表 - ''' - ''' - Public ReadOnly Property PrivateKeys As Dictionary(Of Long, Certificate) Implements ISSLServices.PrivateKeys - - Public ReadOnly Property IsShutdown As Boolean Implements IServicesSocket.IsShutdown - Get - Return _PushServices.IsShutdown - End Get - End Property - - Public ReadOnly Property LocalPort As Integer Implements IServicesSocket.LocalPort - Get - Return _PushServices.LocalPort - End Get - End Property - - Dim _responsehandler As DataRequestHandler - - Private Property Responsehandler As DataRequestHandler Implements IDataRequestHandler.Responsehandler, ISSLServices.ResponseHandler - Get - Return _responsehandler - End Get - Set(value As DataRequestHandler) - _PushServices.Responsehandler = AddressOf __responsehandler - _responsehandler = value - End Set - End Property - - Private Function __responsehandler(CA As Long, request As RequestStream, remoteDev As System.Net.IPEndPoint) As RequestStream - Return SSL.SSLProtocols.SSLServicesResponseHandler(Me, CA, request, remoteDev, InstallCertificates) - End Function - - Public ReadOnly Property Connections As WorkSocket() - Get - Return _PushServices.Connections - End Get - End Property - - Public Property InstallCertificates As InstallCertificates = - AddressOf Net.SSL.SSLSynchronizationServicesSocket.InstallCertificates Implements ISSLServices.InstallCertificates - - Public Property RaiseHandshakingEvent As HandshakingEvent = - AddressOf SSL.SSLSynchronizationServicesSocket.HandShakingEventDoNothing Implements ISSLServices.RaiseHandshakingEvent - - Public Property RefuseHandshake As Boolean Implements ISSLServices.RefuseHandshake - - Public ReadOnly Property IsRunning As Boolean Implements IServicesSocket.IsRunning - Get - Return Me._PushServices.Running - End Get - End Property - - Public ReadOnly Property DeclaringModule As Object Implements ISSLServices.DeclaringModule - - ''' - ''' - ''' - ''' - ''' - ''' Public Delegate Sub (FromUSER_ID As , USER_ID As , Message As ) - ''' - ''' - Sub New(LocalPort As Integer, - container As Object, - Optional OffLineMessageSendHandler As OffLineMessageSendHandler = Nothing, - Optional exHandler As Abstract.ExceptionHandler = Nothing) - _PushServices = New MessagePushServer(LocalPort, OffLineMessageSendHandler, exHandler) - _DeclaringModule = container - Responsehandler = AddressOf __redirect - PrivateKeys = New Dictionary(Of Long, Certificate) - Call _PushServices.Install(Me) - End Sub - - Private Function __redirect(CA As Long, request As RequestStream, remote As System.Net.IPEndPoint) As RequestStream - request = _PushServices.ProtocolHandler.HandleRequest(CA, request, remote) - Return request - End Function - - ''' - ''' 安装新的公有密匙 - ''' - ''' - Public Sub Install(CA As SSL.Certificate) - _CA = CA - End Sub - - ''' - ''' 安装新的用户私有密匙 - ''' - ''' - ''' - ''' - Public Function Install(CA As Certificate, [overrides] As Boolean, Optional trace As String = "") As Boolean Implements ISSLServices.Install - Return CAExtensions.InstallCommon(PrivateKeys, CA, [overrides], trace, MethodBase.GetCurrentMethod) - End Function - - Public Sub WaitForRunning() - Call _PushServices.WaitForRunning() - End Sub - - Public Function Run() As Integer Implements IServicesSocket.Run, ITaskDriver.Run - Return _PushServices.Run - End Function - - Public Function Run(localEndPoint As System.Net.IPEndPoint) As Integer Implements IServicesSocket.Run - Call _PushServices.Run(localEndPoint) - Return 0 - End Function - -#Region "IDisposable Support" - Private disposedValue As Boolean ' To detect redundant calls - - ' IDisposable - Protected Overridable Sub Dispose(disposing As Boolean) - If Not disposedValue Then - If disposing Then - ' TODO: dispose managed state (managed objects). - End If - - ' TODO: free unmanaged resources (unmanaged objects) and override Finalize() below. - ' TODO: set large fields to null. - End If - disposedValue = True - End Sub - - ' TODO: override Finalize() only if Dispose(disposing As Boolean) above has code to free unmanaged resources. - 'Protected Overrides Sub Finalize() - ' ' Do not change this code. Put cleanup code in Dispose(disposing As Boolean) above. - ' Dispose(False) - ' MyBase.Finalize() - 'End Sub - - ' This code added by Visual Basic to correctly implement the disposable pattern. - Public Sub Dispose() Implements IDisposable.Dispose - ' Do not change this code. Put cleanup code in Dispose(disposing As Boolean) above. - Dispose(True) - ' TODO: uncomment the following line if Finalize() is overridden above. - ' GC.SuppressFinalize(Me) - End Sub -#End Region - End Class -End Namespace diff --git a/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/User.vb b/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/User.vb deleted file mode 100644 index 2894d549..00000000 --- a/ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/User.vb +++ /dev/null @@ -1,305 +0,0 @@ -#Region "Microsoft.VisualBasic::b3e9fc10f1f2408c56e6cb5242725b75, Microsoft.VisualBasic.Core\ApplicationServices\Tools\Network\Tcp\Persistent\MessagePushServices\User.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Class USER - ' - ' Properties: USER_ID - ' - ' Constructor: (+4 Overloads) Sub New - ' - ' Function: __receiveBroadcastMessage, (+3 Overloads) __sendMessage, __sendMessageToMe, IsUserOnLine, (+4 Overloads) SendMessage - ' ToString - ' - ' Sub: (+2 Overloads) BeginConnect, (+2 Overloads) BroadCastMessage, (+2 Overloads) Dispose, SetDisconnectHandle - ' - ' - ' /********************************************************************************/ - -#End Region - -Imports System.Text -Imports System.Threading -Imports Microsoft.VisualBasic.Net.Http -Imports Microsoft.VisualBasic.Net.Persistent.Application.Protocols -Imports Microsoft.VisualBasic.Net.Protocols -Imports Microsoft.VisualBasic.Net.Protocols.Reflection -Imports Microsoft.VisualBasic.Parallel - -Namespace Net.Persistent.Application - - ''' - ''' 服务器也相当于一个USER，只不过服务器的UID为0，即最高级的用户 - ''' - ''' - - Public Class USER : Implements System.IDisposable - - Public ReadOnly Property USER_ID As Long - - Friend remotePort As Integer, remoteHost As String - Dim __exceptionHandler As Abstract.ExceptionHandler - Dim _requestHandler As ProtocolHandler - - ''' - ''' - ''' - ''' - ''' - ''' - ''' 使用这个函数来获取外部发送过来的用户消息 - ''' - Sub New(HostName As String, - RemotePort As Integer, - ID As Long, - DataRequestHandle As PushMessage, - Optional ExceptionHandler As Abstract.ExceptionHandler = Nothing) - - Me.remoteHost = HostName - Me.USER_ID = ID - Me.remotePort = RemotePort - Me.__dataRequestHandle = DataRequestHandle - Me._requestHandler = New ProtocolHandler(Me) - End Sub - - Sub New(services As System.Net.IPEndPoint, ID As Long, DataRequestHandle As PushMessage, Optional ExceptionHandler As Abstract.ExceptionHandler = Nothing) - Call Me.New(New IPEndPoint(services), ID, DataRequestHandle, ExceptionHandler) - End Sub - - Sub New(services As IPEndPoint, ID As Long, DataRequestHandle As PushMessage, Optional ExceptionHandler As Abstract.ExceptionHandler = Nothing) - Call Me.New(services.IPAddress, services.Port, ID, DataRequestHandle, ExceptionHandler) - End Sub - - Sub New(post As UserId, DataRequestHandle As PushMessage, Optional ExceptionHandler As Abstract.ExceptionHandler = Nothing) - Call Me.New(post.Remote.IPAddress, post.Remote.Port, post.uid, DataRequestHandle, ExceptionHandler) - End Sub - - Dim __dataRequestHandle As PushMessage - Dim _pcnnSocket As Socket.PersistentClient - - Public Sub SetDisconnectHandle(handle As MethodInvoker) - Try - _pcnnSocket.RemoteServerShutdown = handle - Catch ex As Exception - ' 可能是在socket还没有启动的时候就设置句柄了，导致空引用，不过这个没有太多的影响，忽略这个错误 - End Try - End Sub - - ''' - ''' 请注意，线程会在这里阻塞 - ''' - ''' 远程主机强制关闭连接之后触发这个动作 - Public Sub BeginConnect(Optional ForceCloseConnection As MethodInvoker = Nothing, Optional CA As Net.SSL.Certificate = Nothing) - Dim remoteEp As System.Net.IPEndPoint = New System.Net.IPEndPoint(System.Net.IPAddress.Parse(Me.remoteHost), Me.remotePort) - Dim request As RequestStream = ServicesProtocol.GetServicesConnection - - Call $"Begin connect to {remoteEp.ToString}".__DEBUG_ECHO - If CA Is Nothing Then - request = New Net.AsynInvoke(remoteEp).SendMessage(request) - Else - request = New Net.AsynInvoke(remoteEp).SendMessage(request, CA) - End If - - Dim port As Integer = CInt(Val(request.GetUTF8String)) - - Me._pcnnSocket = New Socket.PersistentClient(Me.remoteHost, port, Me.__exceptionHandler) - Me._pcnnSocket.RemoteServerShutdown = ForceCloseConnection - Me._pcnnSocket.Responsehandler = AddressOf Me._requestHandler.HandleRequest - - Call RunTask(AddressOf Me._pcnnSocket.BeginConnect) - Call Me._pcnnSocket.WaitForConnected() - Call Thread.Sleep(1000) - Call Me._pcnnSocket.WaitForHash() - - request = ServicesProtocol.LogOnRequest(Me.USER_ID, Me._pcnnSocket.OnServerHashCode) - If CA Is Nothing Then - request = __sendMessage(request) - Else - request = CA.Encrypt(request) - request = __sendMessage(request) - request = CA.Decrypt(request) - End If - - If Not request.Protocol = HTTP_RFC.RFC_OK Then - '连接不成功 - Throw New Exception(NetResponse.RFC_BAD_REQUEST.GetUTF8String) - End If - - Do While Not Me.disposedValue - Call Thread.Sleep(1000) - Loop - End Sub - - ''' - ''' 不会发生阻塞 - ''' - ''' 远程主机强制关闭连接之后触发这个动作 - Public Sub BeginConnect(CA As Net.SSL.Certificate, Optional ForceCloseConnection As MethodInvoker = Nothing) - Call RunTask(Sub() Call BeginConnect(ForceCloseConnection, CA)) - End Sub - - ''' - ''' - ''' - ''' - ''' - ''' 由于数据都是通过中心服务器转发的，所以这个已经没有存在的意义了，但是为了和短连接的socket的数据处理接口保持兼容，所以还保留这个参数 - ''' - - Private Function __sendMessageToMe(CA As Long, request As RequestStream, remote As System.Net.IPEndPoint) As RequestStream - Dim post As New SendMessagePost(request.ChunkBuffer) - Return Me.__dataRequestHandle(post.FROM, post.Message) - End Function - - - Private Function __receiveBroadcastMessage(CA As Long, request As RequestStream, remote As System.Net.IPEndPoint) As RequestStream - Return Me.__dataRequestHandle(CA, request) - End Function - - Private Function __sendMessage(Message As String) As String -#If DEBUG Then - Call Console.WriteLine($" * >> {NameOf(__sendMessage)} {Message}") -#End If - Dim reply As String = New Net.AsynInvoke(Me.remoteHost, Me.remotePort, Me.__exceptionHandler).SendMessage(Message) - Return reply - End Function - - Private Function __sendMessage(Message As Byte()) As Byte() - Dim reply = New Net.AsynInvoke(Me.remoteHost, Me.remotePort, Me.__exceptionHandler).SendMessage(Message) - Return reply - End Function - - Private Function __sendMessage(request As RequestStream) As RequestStream - Return New RequestStream(__sendMessage(request.Serialize)) - End Function - - ''' - ''' True标识发送成功，False标识用户离线 - ''' - ''' - ''' 在发送之前请对消息进行加密处理 - ''' - Public Function SendMessage(USER_ID As Long, Message As RequestStream) As Boolean - Dim request = ServicesProtocol.SendMessageRequest(Me.USER_ID, USER_ID, Message) - Return SendMessage(request) - End Function - - Public Function SendMessage(USER_ID As Long, Message As RequestStream, CA As SSL.Certificate) As Boolean - Dim request = ServicesProtocol.SendMessageRequest(Me.USER_ID, USER_ID, Message) - request = CA.Encrypt(request) - Return SendMessage(request) - End Function - - Public Function SendMessage(Message As RequestStream) As Boolean - Dim bytesData = Message.Serialize - bytesData = __sendMessage(bytesData) - If RequestStream.IsAvaliableStream(bytesData) Then - Message = New RequestStream(bytesData) - Return Message.Protocol = HTTP_RFC.RFC_OK - Else - Return System.Text.Encoding.UTF8.GetString(bytesData).ParseBoolean - End If - End Function - - Public Function SendMessage(Message As RequestStream, CA As SSL.Certificate, Optional isPublicToken As Boolean = False) As Boolean - Dim byteData = If(isPublicToken, CA.PublicEncrypt(Message), CA.Encrypt(Message)).Serialize - byteData = __sendMessage(byteData) - If RequestStream.IsAvaliableStream(byteData) Then - Message = New RequestStream(byteData) - - If Message.IsSSLProtocol Then - Message = CA.Decrypt(Message) - Else - Return CA.DecryptString(Message.GetUTF8String).ParseBoolean - End If - - Return Message.GetUTF8String.ParseBoolean - Else - Return Encoding.UTF8.GetString(byteData).ParseBoolean - End If - End Function - - Public Sub BroadCastMessage(Message As RequestStream) - Dim request As RequestStream = ServicesProtocol.BroadcastMessage(Me.USER_ID, Message) - request = __sendMessage(request) - End Sub - - Public Sub BroadCastMessage(Message As RequestStream, CA As SSL.Certificate) - Dim request As RequestStream = ServicesProtocol.BroadcastMessage(Me.USER_ID, Message) - request = CA.Encrypt(request) - Call SendMessage(request) - End Sub - - Public Function IsUserOnLine(USER_ID As Long) As Boolean - Dim request As RequestStream = ServicesProtocol.IsUserOnlineRequest(USER_ID) - request = __sendMessage(request) - Return request.Protocol = HTTP_RFC.RFC_OK - End Function - - Public Overrides Function ToString() As String - Return USER_ID - End Function - -#Region "IDisposable Support" - Private disposedValue As Boolean ' To detect redundant calls - - ' IDisposable - Protected Overridable Sub Dispose(disposing As Boolean) - If Not disposedValue Then - If disposing Then - - ' TODO: dispose managed state (managed objects). - End If - - ' TODO: free unmanaged resources (unmanaged objects) and override Finalize() below. - ' TODO: set large fields to null. - End If - disposedValue = True - End Sub - - ' TODO: override Finalize() only if Dispose(disposing As Boolean) above has code to free unmanaged resources. - 'Protected Overrides Sub Finalize() - ' ' Do not change this code. Put cleanup code in Dispose(disposing As Boolean) above. - ' Dispose(False) - ' MyBase.Finalize() - 'End Sub - - ' This code added by Visual Basic to correctly implement the disposable pattern. - Public Sub Dispose() Implements IDisposable.Dispose - ' Do not change this code. Put cleanup code in Dispose(disposing As Boolean) above. - Dispose(True) - ' TODO: uncomment the following line if Finalize() is overridden above. - ' GC.SuppressFinalize(Me) - End Sub -#End Region - End Class -End Namespace diff --git a/ApplicationServices/Tools/Network/Tcp/Persistent/Protocols/UserId.vb b/ApplicationServices/Tools/Network/Tcp/Persistent/Protocols/UserId.vb deleted file mode 100644 index 6326cfe9..00000000 --- a/ApplicationServices/Tools/Network/Tcp/Persistent/Protocols/UserId.vb +++ /dev/null @@ -1,56 +0,0 @@ -#Region "Microsoft.VisualBasic::ecd0ffd91b41c2edf66248fea5772d55, Microsoft.VisualBasic.Core\ApplicationServices\Tools\Network\Tcp\Persistent\Protocols\UserId.vb" - - ' Author: - ' - ' asuka (amethyst.asuka@gcmodeller.org) - ' xie (genetics@smrucc.org) - ' xieguigang (xie.guigang@live.com) - ' - ' Copyright (c) 2018 GPL3 Licensed - ' - ' - ' GNU GENERAL PUBLIC LICENSE (GPL3) - ' - ' - ' This program is free software: you can redistribute it and/or modify - ' it under the terms of the GNU General Public License as published by - ' the Free Software Foundation, either version 3 of the License, or - ' (at your option) any later version. - ' - ' This program is distributed in the hope that it will be useful, - ' but WITHOUT ANY WARRANTY; without even the implied warranty of - ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ' GNU General Public License for more details. - ' - ' You should have received a copy of the GNU General Public License - ' along with this program. If not, see . - - - - ' /********************************************************************************/ - - ' Summaries: - - ' Class UserId - ' - ' Properties: Remote, uid - ' - ' Function: CreateApp - ' - ' - ' /********************************************************************************/ - -#End Region - -Namespace Net.Persistent.Application.Protocols - - Public Class UserId - - Public Property Remote As IPEndPoint - Public Property uid As Long - - Public Function CreateApp(protocols As PushMessage) As USER - Return New USER(Remote.IPAddress, Remote.Port, uid, protocols) - End Function - End Class -End Namespace diff --git a/ApplicationServices/Tools/Network/Tcp/Persistent/Socket/TcpClient.vb b/ApplicationServices/Tools/Network/Tcp/Persistent/Socket/TcpClient.vb index 98839d79..e33970b4 100644 --- a/ApplicationServices/Tools/Network/Tcp/Persistent/Socket/TcpClient.vb +++ b/ApplicationServices/Tools/Network/Tcp/Persistent/Socket/TcpClient.vb @@ -385,7 +385,7 @@ Namespace Net.Persistent.Socket If ServicesProtocol.Protocols.ServerHash = request.Protocol Then Me._OnServerHashCode = Scripting.CTypeDynamic(Of Integer)(request.GetUTF8String) Else - Call RunTask(Sub() Me.Responsehandler()(request.uid, request, Nothing)) + Call RunTask(Sub() Me.Responsehandler()(request, Nothing)) End If End Sub diff --git a/ApplicationServices/Tools/Network/Tcp/TCPExtensions.vb b/ApplicationServices/Tools/Network/Tcp/TCPExtensions.vb index 9d1c1e8e..3c67432a 100644 --- a/ApplicationServices/Tools/Network/Tcp/TCPExtensions.vb +++ b/ApplicationServices/Tools/Network/Tcp/TCPExtensions.vb @@ -44,12 +44,10 @@ Imports System.Net Imports System.Net.NetworkInformation Imports System.Net.Sockets -Imports System.Reflection Imports System.Runtime.CompilerServices Imports Microsoft.VisualBasic.Linq.Extensions Imports Microsoft.VisualBasic.Net.Http Imports Microsoft.VisualBasic.Net.Protocols -Imports Microsoft.VisualBasic.Serialization.JSON Namespace Net @@ -182,33 +180,5 @@ Namespace Net Return True End Function - -#Region "OAuth Arguments" - - Const hash As String = "hash" - Const uid As String = "uid" - - Public Function BuildOAuth(ca As Net.SSL.Certificate) As String - Dim array As KeyValuePair(Of String, String)() = { - New KeyValuePair(Of String, String)(hash, ca.PrivateKey), - New KeyValuePair(Of String, String)(uid, ca.uid) - } - Dim oauth As String = WebServiceUtils.BuildUrlData(array) - Return oauth - End Function - - Public Function GetCA(args As String) As Net.SSL.Certificate -#If DEBUG Then - Call $"{MethodBase.GetCurrentMethod.GetFullName} ==> {args}".__DEBUG_ECHO -#End If - Dim data = WebServiceUtils.QueryStringParameters(args, False) -#If DEBUG Then - Call data.AllKeys.Select(Function(k) data(k)).ToArray.GetJson.__DEBUG_ECHO -#End If - Dim privateKey As String = data(hash) - Dim uid As Long = Scripting.CTypeDynamic(Of Long)(data(TCPExtensions.uid)) - Return Net.SSL.Certificate.Install(privateKey, uid) - End Function -#End Region End Module End Namespace diff --git a/ApplicationServices/Tools/Network/Tcp/TcpSynchronizationServicesSocket.vb b/ApplicationServices/Tools/Network/Tcp/TcpSynchronizationServicesSocket.vb index 09b1fa94..b8ca3b98 100644 --- a/ApplicationServices/Tools/Network/Tcp/TcpSynchronizationServicesSocket.vb +++ b/ApplicationServices/Tools/Network/Tcp/TcpSynchronizationServicesSocket.vb @@ -105,7 +105,7 @@ Namespace Net ''' 监听的本地端口号，假若需要进行端口映射的话，则可以在方法之中设置映射的端口号 ''' Sub New(Optional LocalPort As Integer = 11000, - Optional exHandler As Abstract.ExceptionHandler = Nothing) + Optional exHandler As ExceptionHandler = Nothing) Me._LocalPort = LocalPort Me.__exceptionHandle = If(exHandler Is Nothing, AddressOf PrintException, exHandler) @@ -332,7 +332,7 @@ Namespace Net If requestData.IsPing Then requestData = NetResponse.RFC_OK Else - requestData = Me.Responsehandler()(requestData.uid, requestData, remoteEP) + requestData = Me.Responsehandler()(requestData, remoteEP) End If Call Send(handler, requestData) Catch ex As Exception diff --git a/Language/Value/DefaultValue/DefaultString.vb b/Language/Value/DefaultValue/DefaultString.vb index 46a05c87..156c964d 100644 --- a/Language/Value/DefaultValue/DefaultString.vb +++ b/Language/Value/DefaultValue/DefaultString.vb @@ -153,7 +153,8 @@ Namespace Language.Default End Operator ''' - ''' If is empty then returns , else returns itself. + ''' If is empty then returns , + ''' else returns itself. ''' ''' ''' @@ -166,6 +167,12 @@ Namespace Language.Default End If End Operator + ''' + ''' Get a value or using default value. + ''' + ''' + ''' + ''' Public Shared Operator Or(value As DefaultString, x%) As Integer Return CInt(value Or CDbl(x)) End Operator