Michael Ober
2009-12-12 22:16:20 UTC
The code below appears to work, but it eventually freezes and I have to
reboot the server. Killing and restarting the program itself doesn't work
as the listener socket is still bound. I have put debugging statements in
to verify that the ThreadPool threads are being released and the most thread
pool threads that this code used was 3, even under heavy load. The problem
appears to be when there are no clients for an extended period and then a
client attempts to connect. At that point, the application freezes. I have
left out the BankInfo object which contains the bank name, address, phone
number, and routing number as well as Library Routines such as WriteLog and
SMTPMail.<method>. The library routines have been in use in other
applications for several years now and are thoroughly debugged.
The server code itself is a MustInherit (virtual) class that the inheriter
must provide the business logic to handle the individual commands from the
client. The server and its associated client class handles the buffering,
blocking, and deblocking of inbound and outbound communications. This is a
Windows Forms application and the lbClients item is a standard ListBox.
''''''''' Start of code.
Option Compare Text
Option Strict On
Option Explicit On
Option Infer Off
Imports System.Net.Sockets
Imports System.Net
Imports System.Threading
Imports System.Text.ASCIIEncoding
Imports System.IO
Public Module Data
Public RoutingNumbers As New BankTable
Public UpdatedRoutingNumbers As New BankTable
End Module
Public Class BankTable
Inherits Dictionary(Of String, BankInfo)
End Class
Public Class frmBankRoutingNumbers
Public WithEvents Clients As ClientConnections
Private Sub frmBankRoutingNumbers_FormClosing(ByVal sender As Object,
ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
On Error Resume Next
Clients.Dispose()
End Sub
Private Sub frmBankRoutingNumbers_Load(ByVal sender As System.Object,
ByVal e As System.EventArgs) Handles MyBase.Load
Me.Text = AppName()
Me.Show()
Dim bi As BankInfo
Dim lastpercent As String = ""
Dim currentpercent As String = ""
''' Initialize server data structures clipped out.
WriteLog("Starting Listener")
Me.Text = AppName("Starting Listener")
Me.lbClients.Items.Clear()
Clients = New ClientConnections()
Me.Text = AppName("Listening")
End Sub
#Region "IP Server Connection Display Interface"
Delegate Sub AddClientCallBack(ByVal connection As
IPServer.ConnectionInformation)
Delegate Sub RemoveClientCallBack(ByVal connection As
IPServer.ConnectionInformation)
Private Sub AddClient(ByVal connection As
IPServer.ConnectionInformation)
On Error Resume Next
Me.lbClients.Items.Add(connection.ToString())
Me.Text = AppName(Me.lbClients.Items.Count)
End Sub
Private Sub RemoveClient(ByVal connection As
IPServer.ConnectionInformation)
On Error Resume Next
Me.lbClients.Items.Remove(connection.ToString())
Me.Text = AppName(Me.lbClients.Items.Count)
End Sub
Private Sub Clients_NewConnection(ByRef connection As
IPServer.ConnectionInformation, ByVal Count As Integer) Handles
Clients.NewConnection
Dim UpdateClientList As New AddClientCallBack(AddressOf AddClient)
Me.Invoke(UpdateClientList, connection)
End Sub
Private Sub Clients_ConnectionClosed(ByRef connection As
IPServer.ConnectionInformation, ByVal Count As Integer) Handles
Clients.ConnectionClosed
Dim UpdateClientList As New RemoveClientCallBack(AddressOf
RemoveClient)
Me.Invoke(UpdateClientList, connection)
End Sub
#End Region
End Class
Public Class ClientConnections
Inherits IPServer.IPSocketHandler
Private so As New ReaderWriterLockSlim
Public Sub New()
MyBase.New(OSInterface.iniWrapper.ReadInt("ABADatabase", "Port",
"wakefield.ini"), _
New TimeSpan(0,
OSInterface.iniWrapper.ReadInt("ABADatabase", "ClientTTL", "wakefield.ini",
15), 0))
End Sub
Public Overrides Function ProcessMessage(ByVal message As String) As
String
Try
Dim cmd As String = ""
Dim i As Integer = InStr(message, ":")
If i > 0 Then
cmd = Left$(message, i - 1)
message = Mid$(message, i + 1)
End If
Select Case
CType([Enum].Parse(GetType(BankInfo.ClientServerCommandStrings), cmd),
BankInfo.ClientServerCommandStrings)
Case BankInfo.ClientServerCommandStrings.GetRoutingNumber
Try
so.EnterReadLock()
Return RoutingNumbers(message).ToString()
Catch ex As Exception
Dim bi As New BankInfo(message)
bi.ExceptionMessage = "Unknown Routing Number"
Return bi.ToString()
End Try
Case BankInfo.ClientServerCommandStrings.UpdateBankInfo
Try
Dim bi As New BankInfo(New csvLine(message,
BankInfo.CSVHeader))
bi.HasBeenUpdated = True ' Just in case this is a
new bank
so.EnterWriteLock()
bi = RoutingNumbers.Add(bi)
If bi.HasBeenUpdated Then
UpdatedRoutingNumbers.Add(bi)
Using fOut As New StreamWriter(ABAUpdates, False,
System.Text.Encoding.ASCII)
fOut.WriteLine(BankInfo.strHeader)
For Each bi In From ChangedBankInfo As BankInfo
In UpdatedRoutingNumbers.Values Order By ChangedBankInfo.BankName
WriteLog(bi.ToString())
fOut.WriteLine(bi.ToString())
Next
End Using
Return bi.ToString()
Catch ex As Exception
WriteLog(ex)
Return ""
End Try
Case Else
Dim bi As New BankInfo()
bi.ExceptionMessage = "Unknown Request"
Return bi.ToString()
End Select
Catch ex As Exception
WriteLog(ex)
SMTPMail.SendMessage("mis", AppName() & " - Client Handler
Crash", ex.ToString())
Return ""
Finally
Do While so.IsReadLockHeld
so.ExitReadLock()
Loop
Do While so.IsWriteLockHeld
so.ExitWriteLock()
Loop
End Try
End Function
End Class
Namespace IPServer
Module ClientCollection
Public Clients As New ClientList
End Module
Public Class ClientList
Inherits SynchronizedCollection(Of ConnectionInformation)
Public Overrides Function ToString() As String
Dim aCI() As ConnectionInformation = MyBase.ToArray()
Dim s As String = "Connections: " & aCI.Count.ToString("#,##0")
Try
For Each ci As ConnectionInformation In aCI
s &= vbNewLine & ci.ToString()
Next
Catch ex As Exception
End Try
Return s
End Function
End Class
Public Class ConnectionInformation
Implements IDisposable
Public MessageIn As String = ""
' Who's talking to me?
Private _ClientName As String = ""
Private _ClientPort As Integer = 0
' Private structures and storage for sending and receiving data
Private _sock As Socket = Nothing
Private Const _bufSize As Integer = 1500
Private _bufIn(_bufSize) As Byte
Private _ReceiveResults As IAsyncResult = Nothing
Private _SendResults As IAsyncResult = Nothing
Private _bufOut() As Byte
' TimeOut support; Async sockets don't directly support timeouts
Private _InactivityTimer As Timer = Nothing
Private _Activity As Boolean = True ' All socket activity must
set this value to True
Public Sub New(ByVal sock As Socket, ByVal SocketTimeout As
TimeSpan)
Me.New(SocketTimeout)
Me.sock = sock
End Sub
Public Sub New(ByVal SocketTimeout As TimeSpan)
If SocketTimeout <> Nothing Then _InactivityTimer = New
Timer(AddressOf TimeOutHandler, Me, SocketTimeout, SocketTimeout)
Clients.Add(Me)
End Sub
Private Sub TimeOutHandler(ByVal objConnectionInformation As Object)
Dim ci As ConnectionInformation =
CType(objConnectionInformation, ConnectionInformation)
If ci._Activity Then
ci._Activity = False
Else
WriteLog(ci.ToString() & " Socket Timeout")
ci.Close()
End If
End Sub
Public Function BeginReceive(ByVal callback As AsyncCallback) As
IAsyncResult
_ReceiveResults = _sock.BeginReceive(_bufIn, 0, _bufSize,
SocketFlags.None, callback, Me)
_Activity = True
Return _ReceiveResults
End Function
Public Function EndReceive(ByVal asyncResult As IAsyncResult) As
Integer
Dim ci As ConnectionInformation = CType(asyncResult.AsyncState,
ConnectionInformation)
Try
If ci._sock Is Nothing Then Return 0
ci._Activity = True
Dim bytesReceived As Integer =
ci._sock.EndReceive(asyncResult)
ci.MessageIn &= ASCII.GetString(ci._bufIn, 0, bytesReceived)
Return bytesReceived
Catch exSock As SocketException
Dim sockErr As SocketError = exSock.SocketErrorCode
Dim msg As String = [Enum].GetName(GetType(SocketError),
sockErr)
WriteLog("Socket Exception: " & msg, exSock)
Return 0
Catch ex As Exception
WriteLog(ex)
Return 0
Finally
ci._Activity = True
End Try
Return 0 ' Forces the socket to close elsewhere in code
End Function
Public Sub Send(ByVal MessageOut As String)
Try
_Activity = True
Do Until _SendResults Is Nothing OrElse _bufOut.Length = 0
_SendResults.AsyncWaitHandle.WaitOne()
Loop
_bufOut = System.Text.Encoding.ASCII.GetBytes(MessageOut)
_SendResults = _sock.BeginSend(_bufOut, 0, _bufOut.Length,
SocketFlags.None, AddressOf OnSend, Me)
Catch ex As Exception
WriteLog(ex)
Finally
_Activity = True
End Try
End Sub
Private Sub OnSend(ByVal ar As IAsyncResult)
Dim ci As ConnectionInformation = CType(ar.AsyncState,
ConnectionInformation)
ci._Activity = True
Try
Dim bytesSent As Integer = ci._sock.EndSend(ar)
' Did we send the entire buffer?
If bytesSent >= _bufOut.Length Then
Array.Resize(_bufOut, 0)
Else
' No; reset the buffer to contain only the bytes needed
to be sent
Dim tBuf(_bufOut.Length - bytesSent - 1) As Byte
Array.Copy(_bufOut, bytesSent, tBuf, 0, tBuf.Length)
_bufOut = tBuf
' Send them
_SendResults = ci._sock.BeginSend(_bufOut, 0,
_bufOut.Length, SocketFlags.None, AddressOf OnSend, ci)
End If
ci._Activity = True
Catch ex As Exception
WriteLog(ci.ToString() & vbNewLine & ex.Message, True)
Finally
ci._Activity = True
End Try
End Sub
Public WriteOnly Property sock() As Socket
Set(ByVal value As Socket)
_sock = value
If _sock Is Nothing Then
_ClientName = ""
_ClientPort = 0
_Activity = False
Else
Dim ClientEndPoint As IPEndPoint =
CType(_sock.RemoteEndPoint, IPEndPoint)
_ClientName =
Dns.GetHostEntry(ClientEndPoint.Address.ToString()).HostName
_ClientPort = ClientEndPoint.Port
_Activity = True
End If
End Set
End Property
Public ReadOnly Property ClientName() As String
Get
Return _ClientName
End Get
End Property
Public ReadOnly Property ClientPort() As Integer
Get
Return _ClientPort
End Get
End Property
Public Shadows Function ToString() As String
Return _ClientName & ":" & _ClientPort.ToString()
End Function
Public ReadOnly Property ClientCount() As Integer
Get
Return Clients.Count
End Get
End Property
Public Function Close() As Integer
On Error Resume Next
_InactivityTimer.Dispose()
WriteLog("Closing Client Connection: " & Me.ToString())
If _sock IsNot Nothing Then
_sock.Shutdown(SocketShutdown.Both)
_sock.Close()
_sock = Nothing
End If
Clients.Remove(Me)
Return Clients.Count
End Function
#Region " IDisposable Support "
' This code added by Visual Basic to correctly implement the
disposable pattern.
Protected Overridable Sub Dispose(ByVal disposing As Boolean)
Close()
End Sub
Public Sub Dispose() Implements IDisposable.Dispose
' Do not change this code. Put cleanup code in Dispose(ByVal
disposing As Boolean) above.
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
#End Region
End Class
Public MustInherit Class IPSocketHandler
Implements IDisposable
Public Event NewConnection(ByRef connection As
ConnectionInformation, ByVal Count As Integer)
Public Event ConnectionClosed(ByRef connection As
ConnectionInformation, ByVal Count As Integer)
Public MustOverride Function ProcessMessage(ByVal message As String)
As String
Private _tcpServer As Socket = Nothing
Private ReadOnly _CommandTermination As String = BEL
Protected ReadOnly _SocketTimeout As TimeSpan
Public Sub New(ByVal Port As Integer)
Me.New(Port, BEL, Nothing)
End Sub
Public Sub New(ByVal Port As Integer, ByVal SocketTimeout As
TimeSpan)
Me.New(Port, BEL, SocketTimeout)
End Sub
Public Sub New(ByVal Port As Integer, ByVal CommandTermination As
String)
Me.New(Port, CommandTermination, Nothing)
End Sub
Public Sub New(ByVal Port As Integer, ByVal CommandTermination As
String, ByVal SocketTimeout As TimeSpan)
' save the termination and TTL before doing anything else to
avoid threading issues
_CommandTermination = CommandTermination
_SocketTimeout = SocketTimeout
Try
Dim myAddr As IPAddress =
Dns.GetHostEntry(My.Computer.Name).AddressList(0)
Dim sEndPoint As String = My.Computer.Name & "(" &
myAddr.ToString() & "):" & Port.ToString()
WriteLog("Configure Listener on " & sEndPoint)
_tcpServer = New Socket(AddressFamily.InterNetwork,
SocketType.Stream, ProtocolType.Tcp)
Dim LocalEP As IPEndPoint = New IPEndPoint(myAddr, Port)
_tcpServer.Bind(LocalEP)
_tcpServer.Listen(5) ' 5 is the standard backlog
value
_tcpServer.BeginAccept(AddressOf OnAccept, Nothing)
WriteLog("Listening for connections on " & sEndPoint)
Catch ex As Exception
WriteLog(ex)
SMTPMail.SendMessage("mis", AppName() & ": Unable to create
Listener", ex.Message())
Throw ex
End Try
End Sub
'Handle connection requests
Private Sub OnAccept(ByVal ar As System.IAsyncResult)
Dim ci As New ConnectionInformation(_SocketTimeout)
Try
ci.sock = _tcpServer.EndAccept(ar)
' Start listening for the next connection
_tcpServer.BeginAccept(AddressOf OnAccept, Nothing)
' Wait for data
ci.BeginReceive(AddressOf OnReceive)
RaiseEvent NewConnection(ci, ci.ClientCount)
Catch ex As Exception
WriteLog(ci.ToString(), ex)
RaiseEvent ConnectionClosed(ci, ci.Close())
Finally
WriteLog(Clients.ToString(), True)
End Try
End Sub
Private Sub OnReceive(ByVal ar As IAsyncResult)
Dim ci As ConnectionInformation = CType(ar.AsyncState,
ConnectionInformation)
Try
Dim bytesReceived As Integer = ci.EndReceive(ar)
Select Case bytesReceived
Case 0
RaiseEvent ConnectionClosed(ci, ci.Close())
WriteLog(Clients.ToString())
Case Else
Dim i As Integer = InStr(ci.MessageIn,
_CommandTermination)
Do While i > 0
' Process msg
Dim msg As String = Left$(ci.MessageIn, i - 1)
WriteLog(ci.ToString() & " => " & msg)
Dim msgOut As String = ProcessMessage(msg)
If msgOut <> "" Then
ci.Send(msgOut & _CommandTermination)
WriteLog(ci.ToString() & " <= " & msgOut)
End If
ci.MessageIn = Mid$(ci.MessageIn, i +
_CommandTermination.Length)
i = InStr(ci.MessageIn, _CommandTermination)
Loop
' Finally, read the next chunk of data
ci.BeginReceive(AddressOf OnReceive)
End Select
Catch ex As Exception
WriteLog(ex)
RaiseEvent ConnectionClosed(ci, ci.Close())
WriteLog(Clients.ToString())
End Try
End Sub
Public Sub Close()
On Error Resume Next
WriteLog("Server Shutdown Starting")
' Close the listener
WriteLog("Listener being closed")
_tcpServer.Close()
_tcpServer = Nothing
' Stop the clients; Don't use "for each" as closing a connection
removes it from clients
' Closing a client connection has the side effect of removing
the connection from the clients collection
WriteLog("Closing Clients: " & Clients.ToString())
Do While Clients.Count > 0
Clients(0).Close()
Loop
End Sub
#Region " IDisposable Support "
' This code added by Visual Basic to correctly implement the
disposable pattern.
Protected Overridable Sub Dispose(ByVal disposing As Boolean)
Close()
End Sub
Public Sub Dispose() Implements IDisposable.Dispose
' Do not change this code. Put cleanup code in Dispose(ByVal
disposing As Boolean) above.
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
#End Region
End Class
End Namespace
'''' I added the following, but these events don't appear to getting
executed.
Namespace My
' The following events are available for MyApplication:
'
' Startup: Raised when the application starts, before the startup form
is created.
' Shutdown: Raised after all application forms are closed. This event
is not raised if the application terminates abnormally.
' UnhandledException: Raised if the application encounters an unhandled
exception.
' StartupNextInstance: Raised when launching a single-instance
application and the application is already active.
' NetworkAvailabilityChanged: Raised when the network connection is
connected or disconnected.
Partial Friend Class MyApplication
Private Sub MyApplication_Shutdown(ByVal sender As Object, ByVal e
As System.EventArgs) Handles Me.Shutdown
On Error Resume Next
frmBankRoutingNumbers.Clients.Dispose()
End Sub
Private Sub MyApplication_UnhandledException(ByVal sender As Object,
ByVal e As
Microsoft.VisualBasic.ApplicationServices.UnhandledExceptionEventArgs)
Handles Me.UnhandledException
On Error Resume Next
SMTPMail.SendMessage("mis", My.Application.Info.AssemblyName &
" - CRASH", e.ToString())
frmBankRoutingNumbers.Clients.Dispose()
logs.WriteLog(e.ToString())
End Sub
End Class
End Namespace
reboot the server. Killing and restarting the program itself doesn't work
as the listener socket is still bound. I have put debugging statements in
to verify that the ThreadPool threads are being released and the most thread
pool threads that this code used was 3, even under heavy load. The problem
appears to be when there are no clients for an extended period and then a
client attempts to connect. At that point, the application freezes. I have
left out the BankInfo object which contains the bank name, address, phone
number, and routing number as well as Library Routines such as WriteLog and
SMTPMail.<method>. The library routines have been in use in other
applications for several years now and are thoroughly debugged.
The server code itself is a MustInherit (virtual) class that the inheriter
must provide the business logic to handle the individual commands from the
client. The server and its associated client class handles the buffering,
blocking, and deblocking of inbound and outbound communications. This is a
Windows Forms application and the lbClients item is a standard ListBox.
''''''''' Start of code.
Option Compare Text
Option Strict On
Option Explicit On
Option Infer Off
Imports System.Net.Sockets
Imports System.Net
Imports System.Threading
Imports System.Text.ASCIIEncoding
Imports System.IO
Public Module Data
Public RoutingNumbers As New BankTable
Public UpdatedRoutingNumbers As New BankTable
End Module
Public Class BankTable
Inherits Dictionary(Of String, BankInfo)
End Class
Public Class frmBankRoutingNumbers
Public WithEvents Clients As ClientConnections
Private Sub frmBankRoutingNumbers_FormClosing(ByVal sender As Object,
ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
On Error Resume Next
Clients.Dispose()
End Sub
Private Sub frmBankRoutingNumbers_Load(ByVal sender As System.Object,
ByVal e As System.EventArgs) Handles MyBase.Load
Me.Text = AppName()
Me.Show()
Dim bi As BankInfo
Dim lastpercent As String = ""
Dim currentpercent As String = ""
''' Initialize server data structures clipped out.
WriteLog("Starting Listener")
Me.Text = AppName("Starting Listener")
Me.lbClients.Items.Clear()
Clients = New ClientConnections()
Me.Text = AppName("Listening")
End Sub
#Region "IP Server Connection Display Interface"
Delegate Sub AddClientCallBack(ByVal connection As
IPServer.ConnectionInformation)
Delegate Sub RemoveClientCallBack(ByVal connection As
IPServer.ConnectionInformation)
Private Sub AddClient(ByVal connection As
IPServer.ConnectionInformation)
On Error Resume Next
Me.lbClients.Items.Add(connection.ToString())
Me.Text = AppName(Me.lbClients.Items.Count)
End Sub
Private Sub RemoveClient(ByVal connection As
IPServer.ConnectionInformation)
On Error Resume Next
Me.lbClients.Items.Remove(connection.ToString())
Me.Text = AppName(Me.lbClients.Items.Count)
End Sub
Private Sub Clients_NewConnection(ByRef connection As
IPServer.ConnectionInformation, ByVal Count As Integer) Handles
Clients.NewConnection
Dim UpdateClientList As New AddClientCallBack(AddressOf AddClient)
Me.Invoke(UpdateClientList, connection)
End Sub
Private Sub Clients_ConnectionClosed(ByRef connection As
IPServer.ConnectionInformation, ByVal Count As Integer) Handles
Clients.ConnectionClosed
Dim UpdateClientList As New RemoveClientCallBack(AddressOf
RemoveClient)
Me.Invoke(UpdateClientList, connection)
End Sub
#End Region
End Class
Public Class ClientConnections
Inherits IPServer.IPSocketHandler
Private so As New ReaderWriterLockSlim
Public Sub New()
MyBase.New(OSInterface.iniWrapper.ReadInt("ABADatabase", "Port",
"wakefield.ini"), _
New TimeSpan(0,
OSInterface.iniWrapper.ReadInt("ABADatabase", "ClientTTL", "wakefield.ini",
15), 0))
End Sub
Public Overrides Function ProcessMessage(ByVal message As String) As
String
Try
Dim cmd As String = ""
Dim i As Integer = InStr(message, ":")
If i > 0 Then
cmd = Left$(message, i - 1)
message = Mid$(message, i + 1)
End If
Select Case
CType([Enum].Parse(GetType(BankInfo.ClientServerCommandStrings), cmd),
BankInfo.ClientServerCommandStrings)
Case BankInfo.ClientServerCommandStrings.GetRoutingNumber
Try
so.EnterReadLock()
Return RoutingNumbers(message).ToString()
Catch ex As Exception
Dim bi As New BankInfo(message)
bi.ExceptionMessage = "Unknown Routing Number"
Return bi.ToString()
End Try
Case BankInfo.ClientServerCommandStrings.UpdateBankInfo
Try
Dim bi As New BankInfo(New csvLine(message,
BankInfo.CSVHeader))
bi.HasBeenUpdated = True ' Just in case this is a
new bank
so.EnterWriteLock()
bi = RoutingNumbers.Add(bi)
If bi.HasBeenUpdated Then
UpdatedRoutingNumbers.Add(bi)
Using fOut As New StreamWriter(ABAUpdates, False,
System.Text.Encoding.ASCII)
fOut.WriteLine(BankInfo.strHeader)
For Each bi In From ChangedBankInfo As BankInfo
In UpdatedRoutingNumbers.Values Order By ChangedBankInfo.BankName
WriteLog(bi.ToString())
fOut.WriteLine(bi.ToString())
Next
End Using
Return bi.ToString()
Catch ex As Exception
WriteLog(ex)
Return ""
End Try
Case Else
Dim bi As New BankInfo()
bi.ExceptionMessage = "Unknown Request"
Return bi.ToString()
End Select
Catch ex As Exception
WriteLog(ex)
SMTPMail.SendMessage("mis", AppName() & " - Client Handler
Crash", ex.ToString())
Return ""
Finally
Do While so.IsReadLockHeld
so.ExitReadLock()
Loop
Do While so.IsWriteLockHeld
so.ExitWriteLock()
Loop
End Try
End Function
End Class
Namespace IPServer
Module ClientCollection
Public Clients As New ClientList
End Module
Public Class ClientList
Inherits SynchronizedCollection(Of ConnectionInformation)
Public Overrides Function ToString() As String
Dim aCI() As ConnectionInformation = MyBase.ToArray()
Dim s As String = "Connections: " & aCI.Count.ToString("#,##0")
Try
For Each ci As ConnectionInformation In aCI
s &= vbNewLine & ci.ToString()
Next
Catch ex As Exception
End Try
Return s
End Function
End Class
Public Class ConnectionInformation
Implements IDisposable
Public MessageIn As String = ""
' Who's talking to me?
Private _ClientName As String = ""
Private _ClientPort As Integer = 0
' Private structures and storage for sending and receiving data
Private _sock As Socket = Nothing
Private Const _bufSize As Integer = 1500
Private _bufIn(_bufSize) As Byte
Private _ReceiveResults As IAsyncResult = Nothing
Private _SendResults As IAsyncResult = Nothing
Private _bufOut() As Byte
' TimeOut support; Async sockets don't directly support timeouts
Private _InactivityTimer As Timer = Nothing
Private _Activity As Boolean = True ' All socket activity must
set this value to True
Public Sub New(ByVal sock As Socket, ByVal SocketTimeout As
TimeSpan)
Me.New(SocketTimeout)
Me.sock = sock
End Sub
Public Sub New(ByVal SocketTimeout As TimeSpan)
If SocketTimeout <> Nothing Then _InactivityTimer = New
Timer(AddressOf TimeOutHandler, Me, SocketTimeout, SocketTimeout)
Clients.Add(Me)
End Sub
Private Sub TimeOutHandler(ByVal objConnectionInformation As Object)
Dim ci As ConnectionInformation =
CType(objConnectionInformation, ConnectionInformation)
If ci._Activity Then
ci._Activity = False
Else
WriteLog(ci.ToString() & " Socket Timeout")
ci.Close()
End If
End Sub
Public Function BeginReceive(ByVal callback As AsyncCallback) As
IAsyncResult
_ReceiveResults = _sock.BeginReceive(_bufIn, 0, _bufSize,
SocketFlags.None, callback, Me)
_Activity = True
Return _ReceiveResults
End Function
Public Function EndReceive(ByVal asyncResult As IAsyncResult) As
Integer
Dim ci As ConnectionInformation = CType(asyncResult.AsyncState,
ConnectionInformation)
Try
If ci._sock Is Nothing Then Return 0
ci._Activity = True
Dim bytesReceived As Integer =
ci._sock.EndReceive(asyncResult)
ci.MessageIn &= ASCII.GetString(ci._bufIn, 0, bytesReceived)
Return bytesReceived
Catch exSock As SocketException
Dim sockErr As SocketError = exSock.SocketErrorCode
Dim msg As String = [Enum].GetName(GetType(SocketError),
sockErr)
WriteLog("Socket Exception: " & msg, exSock)
Return 0
Catch ex As Exception
WriteLog(ex)
Return 0
Finally
ci._Activity = True
End Try
Return 0 ' Forces the socket to close elsewhere in code
End Function
Public Sub Send(ByVal MessageOut As String)
Try
_Activity = True
Do Until _SendResults Is Nothing OrElse _bufOut.Length = 0
_SendResults.AsyncWaitHandle.WaitOne()
Loop
_bufOut = System.Text.Encoding.ASCII.GetBytes(MessageOut)
_SendResults = _sock.BeginSend(_bufOut, 0, _bufOut.Length,
SocketFlags.None, AddressOf OnSend, Me)
Catch ex As Exception
WriteLog(ex)
Finally
_Activity = True
End Try
End Sub
Private Sub OnSend(ByVal ar As IAsyncResult)
Dim ci As ConnectionInformation = CType(ar.AsyncState,
ConnectionInformation)
ci._Activity = True
Try
Dim bytesSent As Integer = ci._sock.EndSend(ar)
' Did we send the entire buffer?
If bytesSent >= _bufOut.Length Then
Array.Resize(_bufOut, 0)
Else
' No; reset the buffer to contain only the bytes needed
to be sent
Dim tBuf(_bufOut.Length - bytesSent - 1) As Byte
Array.Copy(_bufOut, bytesSent, tBuf, 0, tBuf.Length)
_bufOut = tBuf
' Send them
_SendResults = ci._sock.BeginSend(_bufOut, 0,
_bufOut.Length, SocketFlags.None, AddressOf OnSend, ci)
End If
ci._Activity = True
Catch ex As Exception
WriteLog(ci.ToString() & vbNewLine & ex.Message, True)
Finally
ci._Activity = True
End Try
End Sub
Public WriteOnly Property sock() As Socket
Set(ByVal value As Socket)
_sock = value
If _sock Is Nothing Then
_ClientName = ""
_ClientPort = 0
_Activity = False
Else
Dim ClientEndPoint As IPEndPoint =
CType(_sock.RemoteEndPoint, IPEndPoint)
_ClientName =
Dns.GetHostEntry(ClientEndPoint.Address.ToString()).HostName
_ClientPort = ClientEndPoint.Port
_Activity = True
End If
End Set
End Property
Public ReadOnly Property ClientName() As String
Get
Return _ClientName
End Get
End Property
Public ReadOnly Property ClientPort() As Integer
Get
Return _ClientPort
End Get
End Property
Public Shadows Function ToString() As String
Return _ClientName & ":" & _ClientPort.ToString()
End Function
Public ReadOnly Property ClientCount() As Integer
Get
Return Clients.Count
End Get
End Property
Public Function Close() As Integer
On Error Resume Next
_InactivityTimer.Dispose()
WriteLog("Closing Client Connection: " & Me.ToString())
If _sock IsNot Nothing Then
_sock.Shutdown(SocketShutdown.Both)
_sock.Close()
_sock = Nothing
End If
Clients.Remove(Me)
Return Clients.Count
End Function
#Region " IDisposable Support "
' This code added by Visual Basic to correctly implement the
disposable pattern.
Protected Overridable Sub Dispose(ByVal disposing As Boolean)
Close()
End Sub
Public Sub Dispose() Implements IDisposable.Dispose
' Do not change this code. Put cleanup code in Dispose(ByVal
disposing As Boolean) above.
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
#End Region
End Class
Public MustInherit Class IPSocketHandler
Implements IDisposable
Public Event NewConnection(ByRef connection As
ConnectionInformation, ByVal Count As Integer)
Public Event ConnectionClosed(ByRef connection As
ConnectionInformation, ByVal Count As Integer)
Public MustOverride Function ProcessMessage(ByVal message As String)
As String
Private _tcpServer As Socket = Nothing
Private ReadOnly _CommandTermination As String = BEL
Protected ReadOnly _SocketTimeout As TimeSpan
Public Sub New(ByVal Port As Integer)
Me.New(Port, BEL, Nothing)
End Sub
Public Sub New(ByVal Port As Integer, ByVal SocketTimeout As
TimeSpan)
Me.New(Port, BEL, SocketTimeout)
End Sub
Public Sub New(ByVal Port As Integer, ByVal CommandTermination As
String)
Me.New(Port, CommandTermination, Nothing)
End Sub
Public Sub New(ByVal Port As Integer, ByVal CommandTermination As
String, ByVal SocketTimeout As TimeSpan)
' save the termination and TTL before doing anything else to
avoid threading issues
_CommandTermination = CommandTermination
_SocketTimeout = SocketTimeout
Try
Dim myAddr As IPAddress =
Dns.GetHostEntry(My.Computer.Name).AddressList(0)
Dim sEndPoint As String = My.Computer.Name & "(" &
myAddr.ToString() & "):" & Port.ToString()
WriteLog("Configure Listener on " & sEndPoint)
_tcpServer = New Socket(AddressFamily.InterNetwork,
SocketType.Stream, ProtocolType.Tcp)
Dim LocalEP As IPEndPoint = New IPEndPoint(myAddr, Port)
_tcpServer.Bind(LocalEP)
_tcpServer.Listen(5) ' 5 is the standard backlog
value
_tcpServer.BeginAccept(AddressOf OnAccept, Nothing)
WriteLog("Listening for connections on " & sEndPoint)
Catch ex As Exception
WriteLog(ex)
SMTPMail.SendMessage("mis", AppName() & ": Unable to create
Listener", ex.Message())
Throw ex
End Try
End Sub
'Handle connection requests
Private Sub OnAccept(ByVal ar As System.IAsyncResult)
Dim ci As New ConnectionInformation(_SocketTimeout)
Try
ci.sock = _tcpServer.EndAccept(ar)
' Start listening for the next connection
_tcpServer.BeginAccept(AddressOf OnAccept, Nothing)
' Wait for data
ci.BeginReceive(AddressOf OnReceive)
RaiseEvent NewConnection(ci, ci.ClientCount)
Catch ex As Exception
WriteLog(ci.ToString(), ex)
RaiseEvent ConnectionClosed(ci, ci.Close())
Finally
WriteLog(Clients.ToString(), True)
End Try
End Sub
Private Sub OnReceive(ByVal ar As IAsyncResult)
Dim ci As ConnectionInformation = CType(ar.AsyncState,
ConnectionInformation)
Try
Dim bytesReceived As Integer = ci.EndReceive(ar)
Select Case bytesReceived
Case 0
RaiseEvent ConnectionClosed(ci, ci.Close())
WriteLog(Clients.ToString())
Case Else
Dim i As Integer = InStr(ci.MessageIn,
_CommandTermination)
Do While i > 0
' Process msg
Dim msg As String = Left$(ci.MessageIn, i - 1)
WriteLog(ci.ToString() & " => " & msg)
Dim msgOut As String = ProcessMessage(msg)
If msgOut <> "" Then
ci.Send(msgOut & _CommandTermination)
WriteLog(ci.ToString() & " <= " & msgOut)
End If
ci.MessageIn = Mid$(ci.MessageIn, i +
_CommandTermination.Length)
i = InStr(ci.MessageIn, _CommandTermination)
Loop
' Finally, read the next chunk of data
ci.BeginReceive(AddressOf OnReceive)
End Select
Catch ex As Exception
WriteLog(ex)
RaiseEvent ConnectionClosed(ci, ci.Close())
WriteLog(Clients.ToString())
End Try
End Sub
Public Sub Close()
On Error Resume Next
WriteLog("Server Shutdown Starting")
' Close the listener
WriteLog("Listener being closed")
_tcpServer.Close()
_tcpServer = Nothing
' Stop the clients; Don't use "for each" as closing a connection
removes it from clients
' Closing a client connection has the side effect of removing
the connection from the clients collection
WriteLog("Closing Clients: " & Clients.ToString())
Do While Clients.Count > 0
Clients(0).Close()
Loop
End Sub
#Region " IDisposable Support "
' This code added by Visual Basic to correctly implement the
disposable pattern.
Protected Overridable Sub Dispose(ByVal disposing As Boolean)
Close()
End Sub
Public Sub Dispose() Implements IDisposable.Dispose
' Do not change this code. Put cleanup code in Dispose(ByVal
disposing As Boolean) above.
Dispose(True)
GC.SuppressFinalize(Me)
End Sub
#End Region
End Class
End Namespace
'''' I added the following, but these events don't appear to getting
executed.
Namespace My
' The following events are available for MyApplication:
'
' Startup: Raised when the application starts, before the startup form
is created.
' Shutdown: Raised after all application forms are closed. This event
is not raised if the application terminates abnormally.
' UnhandledException: Raised if the application encounters an unhandled
exception.
' StartupNextInstance: Raised when launching a single-instance
application and the application is already active.
' NetworkAvailabilityChanged: Raised when the network connection is
connected or disconnected.
Partial Friend Class MyApplication
Private Sub MyApplication_Shutdown(ByVal sender As Object, ByVal e
As System.EventArgs) Handles Me.Shutdown
On Error Resume Next
frmBankRoutingNumbers.Clients.Dispose()
End Sub
Private Sub MyApplication_UnhandledException(ByVal sender As Object,
ByVal e As
Microsoft.VisualBasic.ApplicationServices.UnhandledExceptionEventArgs)
Handles Me.UnhandledException
On Error Resume Next
SMTPMail.SendMessage("mis", My.Application.Info.AssemblyName &
" - CRASH", e.ToString())
frmBankRoutingNumbers.Clients.Dispose()
logs.WriteLog(e.ToString())
End Sub
End Class
End Namespace