xieguigang
/
microsoft-visualbasic-runtime
0
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge branch 'master' of https://github.com/xieguigang/sciBASIC.Core

This commit is contained in:
xieguigang 2018-10-05 03:57:13 +08:00
parent e8d822851b 21c844350a
commit ae7b392005
24 changed files with 86 additions and 2724 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
47-dotnet_Microsoft.VisualBasic.vbproj
View File

@ -1343,9 +1343,7 @@
<Compile Include="ApplicationServices\Tools\MMFProtocol\MapStream\MSWriter.vb" />
<Compile Include="ApplicationServices\Tools\MMFProtocol\MapStream\MSReader.vb" />
<Compile Include="ApplicationServices\Parallel\Tasks\AsyncHandle.vb" />
<Compile Include="ApplicationServices\Parallel\Threads\ServicesFolk.vb" />
<Compile Include="ApplicationServices\Parallel\Tasks\UpdateThread.vb" />
<Compile Include="ApplicationServices\Parallel\Threads\ParallelLoading.vb" />
<Compile Include="ApplicationServices\Parallel\Threads\ParallelExtension.vb" />
<Compile Include="Scripting\Runtime\CType\Casting.vb" />
<Compile Include="Scripting\InputHandler.vb" />
@ -1372,30 +1370,20 @@
<Compile Include="ApplicationServices\Tools\Network\Protocol\Streams\Array.vb" />
<Compile Include="ApplicationServices\Tools\Network\Protocol\Streams\ArrayBase.vb" />
<Compile Include="ApplicationServices\Tools\Network\Protocol\Streams\String.vb" />
<Compile Include="ApplicationServices\Tools\Network\SSL\Certificate.vb" />
<Compile Include="ApplicationServices\Tools\Network\Protocol\IVerifySession.vb" />
<Compile Include="ApplicationServices\Tools\Network\Protocol\Reflection\AppMgr.vb" />
<Compile Include="ApplicationServices\Tools\Network\Protocol\Reflection\ProtocolInvoker.vb" />
<Compile Include="ApplicationServices\Tools\Network\Protocol\Reflection\Protocol.vb" />
<Compile Include="ApplicationServices\Tools\Network\Protocol\Reflection\ProtocolHandler.vb" />
<Compile Include="ApplicationServices\Tools\Network\SSL\Extensions.vb" />
<Compile Include="ApplicationServices\Tools\Network\SSL\Protocol.vb" />
<Compile Include="ApplicationServices\Tools\Network\SSL\SSLSynchronizationServicesSocket.vb" />
<Compile Include="ApplicationServices\Tools\Network\Protocol\RequestStream.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\Persistent\Protocols\UserId.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\Persistent\Protocols\POST.vb" />
<Compile Include="ApplicationServices\Tools\Network\wGetTools.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\StateObject.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\IPTools\IPEndPoint.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\IPTools\LAN.vb" />
<Compile Include="ApplicationServices\Tools\Network\DomainParser.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\Persistent\MessagePushServices\SSLClient.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\Persistent\MessagePushServices\SSLPushServices.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\Persistent\MessagePushServices\Abstract.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\Persistent\Socket\WorkSocket.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\Persistent\Protocols\Protocol.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\Persistent\MessagePushServices\User.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\Persistent\MessagePushServices\MessagePushServer.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\Persistent\Socket\TcpClient.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\Persistent\Socket\ServicesSocket.vb" />
<Compile Include="ApplicationServices\Tools\Network\Tcp\PingUtility.vb" />

323
ApplicationServices/Parallel/Threads/ParallelLoading.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' 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
''' <summary>
'''
''' </summary>
Public Module ParallelLoading
<AttributeUsage(AttributeTargets.Method, AllowMultiple:=False, Inherited:=True)>
Public Class LoadEntry : Inherits Attribute
''' <summary>
''' 必须满足接口类型： Function(path As String) As T
''' </summary>
''' <returns></returns>
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
''' <summary>
''' 当目标数据集非常的大的时候，在单个应用程序里面进行加载已经回非常缓慢了，
''' 则这个时候可以使用这个函数将数据的加载任务分配到多个子进程之中以提高加载的时候的CPU的利用效率
''' </summary>
''' <typeparam name="T"></typeparam>
''' <param name="sourceURL"></param>
''' <returns></returns>
''' <remarks>函数会自动从<typeparamref name="T"/></remarks>泛型类型之中解析出加载的函数
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
''' <summary>
''' 通过与并行进程进行内存共享来传输加载完毕的数据
''' </summary>
''' <typeparam name="T"></typeparam>
''' <param name="url"></param>
''' <param name="Process"></param>
''' <returns></returns>
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
''' <summary>
''' 动态编译的加载进程的调用API来向主进程返回消息
''' </summary>
''' <param name="Port"></param>
''' <returns></returns>
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
''' <summary>
''' 动态编译
''' </summary>
''' <param name="LoadEntry"></param>
''' <returns></returns>
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

165
ApplicationServices/Parallel/Threads/ServicesFolk.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' 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
''' <summary>
''' 主服务和子服务之间的相互作用的特点是子服务不会知道主服务节点的数据接口，所有的交互都是通过子服务上面的一个模块来监听主服务来实现的
''' 当主服务有数据需要向子服务更新的时候，会主动发送数据请求至子服务节点
''' </summary>
''' <remarks>当前的用户规模还比较小这里仅仅是实现了本地的调用，后面考虑到业务吞吐量的问题，会将服务的调用分开到两台物理主机之上</remarks>
Public Module ServicesFolk
''' <summary>
''' 函数返回子进程的交互数据通信的端口号
''' </summary>
''' <param name="assm"></param>
''' <param name="CLI">命令行参数字符串，可以在这里加入一些其他的自定义数据</param>
''' <returns>函数返回子服务的交互端口</returns>
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
''' <summary>
''' 所返回来的额外的参数信息
''' </summary>
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"
''' <summary>
''' 子服务向服务主节点返回端口号数据，这个方法需要要在子服务上面的服务程序启动之后再调用
''' </summary>
''' <param name="CLI"></param>
''' <param name="Port"></param>
''' <param name="addArgs">额外返回的参数信息</param>
''' <returns></returns>
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

5
ApplicationServices/Tools/Network/Abstract.vb
View File

@ -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
''' <summary>
'''
''' </summary>
''' <param name="CA"><see cref="SSL.Certificate.uid"/></param>
''' <param name="request"></param>
''' <param name="RemoteAddress"></param>
''' <returns></returns>
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
''' <summary>
''' 处理错误的工作逻辑的抽象接口

4
ApplicationServices/Tools/Network/Protocol/Reflection/AppMgr.vb
View File

@ -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

24
ApplicationServices/Tools/Network/Protocol/Reflection/Protocol.vb
View File

@ -46,7 +46,8 @@
Namespace Net.Protocols.Reflection
''' <summary>
''' 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.
''' </summary>
<AttributeUsage(AttributeTargets.Class Or AttributeTargets.Method, AllowMultiple:=True, Inherited:=True)>
Public Class Protocol : Inherits Attribute
@ -66,18 +67,20 @@ Namespace Net.Protocols.Reflection
''' <summary>
''' Generates the protocol method entrypoint.(应用于服务器上面的协议处理方法)
''' </summary>
''' <param name="EntryPoint"></param>
Sub New(EntryPoint As Long)
Me.EntryPoint = EntryPoint
''' <param name="entryPoint"></param>
Sub New(entryPoint As Long)
Me.EntryPoint = entryPoint
End Sub
''' <summary>
''' Generates the <see cref="ProtocolHandler"/> on the server side, this is using for initialize a protocol API entry point.(客户端上面的类型)
''' Generates the <see cref="ProtocolHandler"/> on the server side,
''' this is using for initialize a protocol API entry point.
''' (客户端上面的类型)
''' </summary>
''' <param name="Type">客户端上面的类型</param>
Sub New(Type As Type)
EntryPoint = SecurityString.MD5Hash.ToLong(Type.GUID.ToByteArray)
DeclaringType = Type
''' <param name="type">客户端上面的类型</param>
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
''' <summary>
''' This method is usually using for generates a details protocol processor, example is calling the method interface: <see cref="Net.Abstract.DataRequestHandler"/>
''' This method is usually using for generates a details protocol processor, example
''' is calling the method interface: <see cref="Net.Abstract.DataRequestHandler"/>
''' Correspondent to the protocol entry property <see cref="RequestStream.Protocol"/>
''' </summary>
''' <param name="Method"></param>

13
ApplicationServices/Tools/Network/Protocol/Reflection/ProtocolHandler.vb
View File

@ -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
''' <summary>
''' Handle the data request from the client for socket events: <see cref="Net.TcpSynchronizationServicesSocket.Responsehandler"/> or <see cref="Net.SSL.SSLSynchronizationServicesSocket.Responsehandler"/>
''' Handle the data request from the client for socket events: <see cref="Net.TcpSynchronizationServicesSocket.Responsehandler"/>.
''' </summary>
''' <param name="CA"></param>
''' <param name="request">The request stream object which contains the commands from the client</param>
''' <param name="remoteDevcie">The IPAddress of the target incoming client data request.</param>
''' <returns></returns>
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

15
ApplicationServices/Tools/Network/Protocol/Reflection/ProtocolInvoker.vb
View File

@ -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
''' <summary>
'''
''' </summary>
''' <param name="CA"><see cref="SSL.Certificate.uid"/></param>
''' <param name="request"></param>
''' <param name="remoteDevice"></param>
''' <returns></returns>
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

278
ApplicationServices/Tools/Network/SSL/Certificate.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' 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
''' <summary>
''' 应用程序的完整性验证和用户身份的验证
''' </summary>
Public Class Certificate : Implements SecurityString.SecurityStringModel.ISecurityStringModel
Protected _SHA256 As SecurityString.SHA256
''' <summary>
''' 私有密匙
''' </summary>
''' <returns></returns>
Public Overridable ReadOnly Property PrivateKey As String
Get
Return _SHA256.strPassphrase
End Get
End Property
''' <summary>
''' <see cref="Guid"/>计算出来的哈希值只能为负数，现在约定，当这个属性为0的时候就认为这个证书是公共密匙，
''' 这个一般是使用用户的账号所计算出来的哈希值
''' </summary>
''' <returns></returns>
Public ReadOnly Property uid As Long
Get
Return _uid
End Get
End Property
''' <summary>
''' 初始化继承类所需要的
''' </summary>
Protected _uid As Long
Public ReadOnly Property IsPublicToken As Boolean
Get
Return uid = 0L
End Get
End Property
''' <summary>
''' 与<see cref="uid"/>属性所不同的是，这个属性是<see cref="privatekey"/>的哈希值，
''' 通常这个哈希值在请求resultful WebAPI的时候用来作为用户的唯一标识
''' </summary>
''' <returns></returns>
Public ReadOnly Property hash As Long
Public Overrides Function ToString() As String
Return $"[{NameOf(Certificate)}] {uid} {_SHA256.Passphrase}"
End Function
''' <summary>
''' 请注意这个构造方法会计算一遍密码的哈希值，假若需要直接进行初始化，请使用<see cref="Install"/>方法
''' </summary>
''' <param name="hash">用户的私有密匙</param>
''' <param name="uid">大小写无关的</param>
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
''' <summary>
'''
''' </summary>
''' <param name="hash">原始的密码，会在这个构造函数之中计算为哈希值产生新的密码。</param>
''' <param name="uid">客户端所发送过来的使用哈希值计算出来的唯一标识符</param>
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
''' <summary>
''' 从服务器上面所返回来的握手数据
''' </summary>
''' <param name="handshakeData"></param>
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
''' <summary>
''' 这个构造函数不再计算哈希值而是直接初始化
''' </summary>
''' <param name="hash">必须是md5哈希值</param>
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
''' <summary>
''' 不计算密匙<paramref name="privateKey"/>哈希值而是直接安装
''' </summary>
''' <param name="privateKey"></param>
''' <param name="uid"></param>
''' <returns></returns>
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
''' <summary>
''' 函数会根据uid的值来设定协议为私有密匙还是公共密匙
''' </summary>
''' <param name="request"></param>
''' <returns></returns>
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
''' <summary>
''' 强制将协议设定为公共密匙加密
''' </summary>
''' <param name="request"></param>
''' <returns></returns>
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
''' <summary>
''' <see cref="Decrypt(Byte())"/> <see cref="RequestStream.ChunkBuffer"/>
''' </summary>
''' <param name="request"></param>
''' <returns></returns>
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
''' <summary>
''' 检查应用程序的完整性
''' </summary>
''' <returns></returns>
Public Shared ReadOnly Property AppDomain As Certificate = Install(App.ExecutablePath, publicToken:=True)
''' <summary>
'''
''' </summary>
''' <param name="App">可执行程序的文件路径</param>
''' <returns></returns>
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

85
ApplicationServices/Tools/Network/SSL/Extensions.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' 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

271
ApplicationServices/Tools/Network/SSL/Protocol.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' 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
''' <summary>
''' 客户端与服务器之间初始化加密连接
''' </summary>
''' <param name="CA">客户端的证书，这个是服务器来进行客户端程序的完整性验证的</param>
''' <returns></returns>
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
''' <summary>
''' 抽象SSL服务器
''' </summary>
Public Interface ISSLServices
''' <summary>
''' 告诉SSL层如何安装数字证书
''' </summary>
''' <returns></returns>
Property InstallCertificates As InstallCertificates
''' <summary>
''' 有新的客户端请求进行连接
''' </summary>
''' <returns></returns>
Property RaiseHandshakingEvent As HandshakingEvent
''' <summary>
''' 对于某些应用出于安全性的考虑，会将这里设置为False，则服务器就会全部拒绝后面的所有的握手请求，只接受来自于从外部导入的用户证书的数据请求
''' </summary>
''' <returns></returns>
Property RefuseHandshake As Boolean
''' <summary>
''' 公共密匙
''' </summary>
''' <returns></returns>
ReadOnly Property CA As SSL.Certificate
''' <summary>
''' 客户端的私有密匙
''' </summary>
''' <returns></returns>
ReadOnly Property PrivateKeys As Dictionary(Of Long, SSL.Certificate)
''' <summary>
''' 处理私有密匙的数据请求
''' </summary>
''' <returns></returns>
ReadOnly Property ResponseHandler As Net.Abstract.DataRequestHandler
ReadOnly Property DeclaringModule As Object
''' <summary>
'''
''' </summary>
''' <param name="CA"></param>
''' <param name="[overrides]">当证书的哈希值有冲突的时候，新安装的证书<paramref name="ca"/>可不可以将旧的证书覆盖掉</param>
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
''' <summary>
'''
''' </summary>
''' <param name="ssl"></param>
''' <param name="CA">解密使用的证书凭据，这个用来鉴别客户端身份是否被伪造</param>
''' <param name="request"></param>
''' <param name="remoteDev"></param>
''' <param name="InstallCertificates"></param>
''' <returns></returns>
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
''' <summary>
''' 客户端与服务器之间进行连接的初始化，服务器会在这里为客户端动态的生成一个密匙
''' </summary>
''' <returns></returns>
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

BIN
ApplicationServices/Tools/Network/SSL/SSL.pptx
View File

Binary file not shown.

258
ApplicationServices/Tools/Network/SSL/SSLSynchronizationServicesSocket.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' 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
''' <summary>
''' 这个数字证书是当前版本下的服务器的客户端的数字签名，服务器会使用这个证书来验证客户端的文件是否被恶意破解，相当于公有密匙
''' </summary>
Public ReadOnly Property CA As Certificate Implements ISSLServices.CA
''' <summary>
''' A table stores the certificates of the current connected clients on this server.
''' (连接上来的客户端的私有证书列表)
''' </summary>
''' <returns></returns>
Public ReadOnly Property PrivateKeys As Dictionary(Of Long, Certificate) Implements ISSLServices.PrivateKeys
''' <summary>
'''
''' </summary>
''' <param name="LocalPort"></param>
''' <param name="CA">服务器在部署的时候向对应版本您的客户端的数字签名</param>
''' <param name="exHandler">Public Delegate Sub <see cref="Abstract.ExceptionHandler"/>(ex As <see cref="Exception"/>)</param>
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
''' <summary>
''' 底层工作socket所监听的端口号
''' </summary>
''' <returns></returns>
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"
''' <summary>
''' <see cref="DataRequestHandler"/>:
''' Public Delegate Function <see cref="DataRequestHandler"/>(CA As <see cref="System.int64"/>, request As <see cref="RequestStream"/>,
''' RemoteAddress As <see cref="System.Net.IPEndPoint"/>) As <see cref="System.Net.IPEndPoint"/>
''' </summary>
''' <returns></returns>
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
''' <summary>
''' 生成证书的方法
''' </summary>
''' <returns></returns>
Public Property ISSLServices_InstallCertificates As InstallCertificates =
AddressOf InstallCertificates Implements ISSLServices.InstallCertificates
''' <summary>
''' 客户端和服务器握手之后触发这个动作
''' </summary>
''' <returns></returns>
Public Property RaiseHandshakingEvent As HandshakingEvent =
AddressOf SSLSynchronizationServicesSocket.HandShakingEventDoNothing Implements ISSLServices.RaiseHandshakingEvent
''' <summary>
''' 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 <see cref="Install(Certificate, Boolean, String)"/>
''' </summary>
''' <returns></returns>
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
''' <summary>
''' 等待底层socket成功进入监听模式
''' </summary>
Public Sub WaitForStart()
Call _ServicesSocket.WaitForStart()
End Sub
''' <summary>
''' 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.(请注意，当服务器的代码运行到这里之后，代码将被阻塞在这里)
''' </summary>
''' <remarks></remarks>
Public Function Run(localEndPoint As System.Net.IPEndPoint) As Integer Implements IServicesSocket.Run
Return _ServicesSocket.Run(localEndPoint)
End Function
''' <summary>
''' 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.(请注意，当服务器的代码运行到这里之后，代码将被阻塞在这里)
''' </summary>
''' <remarks></remarks>
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
''' <summary>
''' If the property of <see cref="SSLSynchronizationServicesSocket.RefuseHandshake"/> 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授权证书通过这个方法导入到服务器模块接收主节点的证书同步操作)
''' </summary>
''' <param name="CA"></param>
''' <param name="[overrides]"></param>
''' <returns></returns>
Public Function Install(CA As Certificate, [overrides] As Boolean, <CallerMemberName> Optional trace As String = "") As Boolean Implements ISSLServices.Install
Return CAExtensions.InstallCommon(PrivateKeys, CA, [overrides], trace, MethodBase.GetCurrentMethod)
End Function
End Class
End Namespace

147
ApplicationServices/Tools/Network/Tcp/AsynInvoke.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' 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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' /********************************************************************************/
' 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
''' <summary>
''' Send a request message to the remote server.
''' </summary>
@ -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
''' <summary>
''' 发送一段使用证书对象<paramref name="CA"/>进行数据加密操作的消息请求<paramref name="Message"/>
''' </summary>
''' <param name="Message"></param>
''' <param name="CA"></param>
''' <param name="isPublicToken"></param>
''' <returns></returns>
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
''' <summary>
''' 最底层的消息发送函数
''' </summary>

59
ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/Abstract.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' Summaries:
' Delegate Sub
'
'
' Delegate Function
'
'
'
'
'
' /********************************************************************************/
#End Region
Imports Microsoft.VisualBasic.Net.Protocols
Namespace Net.Persistent
''' <summary>
''' 离线数据请求
''' </summary>
''' <param name="FromUSER_ID"></param>
''' <param name="USER_ID"></param>
''' <param name="Message"></param>
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

412
ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/MessagePushServer.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' 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
''' <summary>
''' 长连接模式的消息推送服务器
''' </summary>
<Protocol(GetType(ServicesProtocol.Protocols))>
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)
''' <summary>
''' 客户端对这个服务器的端口号是自动配置的，只需要向客户端返回<see cref="_LocalPort"/>端口就可以了
''' </summary>
Dim _workSocket As TcpSynchronizationServicesSocket
Dim _offlineMessageSendHandler As OffLineMessageSendHandler
''' <summary>
''' 使用证书来加密发出去的消息
''' </summary>
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
''' <summary>
''' 从这个端口号进行登录（协同长连接的socket正常工作的socket的端口号，可以看作为UserAPI）
''' </summary>
''' <returns></returns>
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
''' <summary>
''' 只要是为ssl服务设置的
''' </summary>
''' <param name="remote"></param>
''' <returns></returns>
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
''' <summary>
'''
''' </summary>
''' <param name="LocalPort"></param>
''' <param name="OffLineMessageSendHandler">Public Delegate Sub <see cref="OffLineMessageSendHandler"/>(FromUSER_ID As <see cref="Long"/>, USER_ID As <see cref="Long"/>, Message As <see cref="RequestStream"/>)</param>
''' <param name="exHandler"></param>
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
''' <summary>
''' Disconnect user persistent connection who have the specific <paramref name="user_id"/> from this server.
''' (断开服务器与用户客户端的长连接)
''' </summary>
''' <param name="USER_ID">This user will be deleted from the server registry.</param>
''' <param name="removeCA">是否在删除socket句柄的时候还会删除相对应的ssl证书</param>
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
''' <summary>
'''
''' </summary>
''' <param name="From"></param>
''' <param name="USER_ID"></param>
''' <param name="Message"></param>
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
''' <summary>
''' 发送出去的数据需要进行加密，假若是ssl模式的话
''' </summary>
''' <param name="From"></param>
''' <param name="USER_ID"></param>
''' <param name="Message"></param>
''' <returns></returns>
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
''' <summary>
''' 将外部编号映射为内部的客户端句柄
''' 假若找不到，请返回-1
''' </summary>
''' <returns></returns>
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
''' <summary>
'''
''' </summary>
''' <param name="socket"></param>
''' <param name="From">这个是这一条消息的源头，可能需要进行映射</param>
''' <param name="USER_ID"></param>
''' <param name="Message"></param>
''' <returns></returns>
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
''' <summary>
''' 用户客户端请求发送消息至指定编号的用户的终端之上
''' </summary>
''' <param name="CA"></param>
''' <param name="request"></param>
''' <param name="remote"></param>
''' <returns></returns>
<Protocol(ServicesProtocol.Protocols.SendMessage)>
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
<Protocol(ServicesProtocol.Protocols.Logon)>
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
<Protocol(ServicesProtocol.Protocols.Broadcast)>
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
<Protocol(ServicesProtocol.Protocols.GetMyIPAddress)>
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
<Protocol(ServicesProtocol.Protocols.ConfigConnection)>
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
<Protocol(ServicesProtocol.Protocols.IsUserOnline)>
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)
''' <summary>
''' 哈希值不存在于现有的登录用户列表之中就是空闲连接
''' </summary>
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
''' <summary>
''' 建立一个新的连接
''' </summary>
''' <param name="Client"></param>
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

116
ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/SSLClient.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' 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
''' <summary>
'''
''' </summary>
''' <param name="services"></param>
''' <param name="ID"></param>
''' <param name="DataRequestHandle">Public Delegate Function PushMessage(USER_ID As <see cref="Long"/>, Message As <see cref="RequestStream"/>) As <see cref="RequestStream"/></param>
''' <param name="ExceptionHandler"></param>
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
''' <summary>
''' 使用已经拥有的用户证书登录服务器，这一步省略了握手步骤
''' </summary>
''' <param name="UserToken"></param>
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
''' <summary>
''' 消息在这个函数之中自动被加密处理
''' </summary>
''' <param name="USER_ID"></param>
''' <param name="request"></param>
''' <returns></returns>
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

217
ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/SSLPushServices.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' 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
''' <summary>
''' 消息都是经过加密操作了的
''' </summary>
Public Class SSLPushServices : Implements Net.Abstract.IServicesSocket
Implements ISSLServices
Public ReadOnly Property PushServices As Net.Persistent.Application.MessagePushServer
''' <summary>
''' 共有密匙
''' </summary>
''' <returns></returns>
Public ReadOnly Property CA As Certificate Implements ISSLServices.CA
''' <summary>
''' 连接到当前的这个服务器上面的客户端的私有密匙列表
''' </summary>
''' <returns></returns>
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
''' <summary>
'''
''' </summary>
''' <param name="LocalPort"></param>
''' <param name="OffLineMessageSendHandler">
''' Public Delegate Sub <see cref="OffLineMessageSendHandler"/>(FromUSER_ID As <see cref="Long"/>, USER_ID As <see cref="Long"/>, Message As <see cref="RequestStream"/>)
''' </param>
''' <param name="exHandler"></param>
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
''' <summary>
''' 安装新的公有密匙
''' </summary>
''' <param name="CA"></param>
Public Sub Install(CA As SSL.Certificate)
_CA = CA
End Sub
''' <summary>
''' 安装新的用户私有密匙
''' </summary>
''' <param name="CA"></param>
''' <param name="[overrides]"></param>
''' <returns></returns>
Public Function Install(CA As Certificate, [overrides] As Boolean, <CallerMemberName> 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

305
ApplicationServices/Tools/Network/Tcp/Persistent/MessagePushServices/User.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' 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
''' <summary>
''' 服务器也相当于一个USER，只不过服务器的UID为0，即最高级的用户
''' </summary>
'''
<Protocol(GetType(ServicesProtocol.Protocols))>
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
''' <summary>
'''
''' </summary>
''' <param name="HostName"></param>
''' <param name="RemotePort"></param>
''' <param name="ID"></param>
''' <param name="DataRequestHandle">使用这个函数来获取外部发送过来的用户消息</param>
''' <param name="ExceptionHandler"></param>
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
''' <summary>
''' 请注意，线程会在这里阻塞
''' </summary>
''' <param name="ForceCloseConnection">远程主机强制关闭连接之后触发这个动作</param>
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
''' <summary>
''' 不会发生阻塞
''' </summary>
''' <param name="ForceCloseConnection">远程主机强制关闭连接之后触发这个动作</param>
Public Sub BeginConnect(CA As Net.SSL.Certificate, Optional ForceCloseConnection As MethodInvoker = Nothing)
Call RunTask(Sub() Call BeginConnect(ForceCloseConnection, CA))
End Sub
''' <summary>
'''
''' </summary>
''' <param name="CA"></param>
''' <param name="request"></param>
''' <param name="remote">由于数据都是通过中心服务器转发的，所以这个已经没有存在的意义了，但是为了和短连接的socket的数据处理接口保持兼容，所以还保留这个参数</param>
''' <returns></returns>
<Protocol(ServicesProtocol.Protocols.SendMessage)>
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
<Protocol(ServicesProtocol.Protocols.Broadcast)>
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
''' <summary>
''' True标识发送成功，False标识用户离线
''' </summary>
''' <param name="USER_ID"></param>
''' <param name="Message">在发送之前请对消息进行加密处理</param>
''' <returns></returns>
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

56
ApplicationServices/Tools/Network/Tcp/Persistent/Protocols/UserId.vb
View File

@ -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 <http://www.gnu.org/licenses/>.
' /********************************************************************************/
' 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

2
ApplicationServices/Tools/Network/Tcp/Persistent/Socket/TcpClient.vb
View File

@ -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

30
ApplicationServices/Tools/Network/Tcp/TCPExtensions.vb
View File

@ -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"
<Extension> 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
<Extension> 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

4
ApplicationServices/Tools/Network/Tcp/TcpSynchronizationServicesSocket.vb
View File

@ -105,7 +105,7 @@ Namespace Net
''' <param name="LocalPort">监听的本地端口号，假若需要进行端口映射的话，则可以在<see cref="Run"></see>方法之中设置映射的端口号</param>
''' <remarks></remarks>
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

9
Language/Value/DefaultValue/DefaultString.vb
View File

@ -153,7 +153,8 @@ Namespace Language.Default
End Operator
''' <summary>
''' If <paramref name="value"/> is empty then returns <paramref name="default"/>, else returns <paramref name="value"/> itself.
''' If <paramref name="value"/> is empty then returns <paramref name="default"/>,
''' else returns <paramref name="value"/> itself.
''' </summary>
''' <param name="value"></param>
''' <param name="default$"></param>
@ -166,6 +167,12 @@ Namespace Language.Default
End If
End Operator
''' <summary>
''' Get a <see cref="Integer"/> value or using default <see cref="Integer"/> value.
''' </summary>
''' <param name="value"></param>
''' <param name="x%"></param>
''' <returns></returns>
Public Shared Operator Or(value As DefaultString, x%) As Integer
Return CInt(value Or CDbl(x))
End Operator