make http non-blocking and add lockfile-kill-switch

src/Classes/FileInfo.cls

@@ -0,0 +1,60 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "FileInfo"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+Private m_fso
+Private m_path As String
+
+
+Private Sub Class_Initialize()
+    Set m_fso = CreateObject("Scripting.FileSystemObject")
+End Sub
+
+
+Public Sub Initialize(ByVal name As String)
+    m_path = name
+End Sub
+
+
+Public Property Get Exists()
+    Exists = m_fso.FileExists(m_path)
+End Property
+
+
+Public Sub Create()
+    Dim file
+    Set file = m_fso.CreateTextFile(m_path)
+
+    file.Close
+End Sub
+
+
+Public Sub WriteString(ByVal text As String)
+    If Not Exists Then
+        Create
+    End If
+
+    Dim file
+    Set file = m_fso.OpenTextFile(m_path, 2)
+
+    file.Write text
+    file.Close
+End Sub
+
+
+Public Function ReadString() As String
+    If Not Exists Then
+        Err.Raise StatusCode.ErrorFileNotFound
+    End If
+
+    Dim file
+    Set file = m_fso.OpenTextFile(m_path, 1)
+
+    ReadString = file.ReadAll
+    file.Close
+End Function

src/Classes/HttpServer.cls

@@ -16,35 +16,42 @@ End Sub
 
 
 Public Sub Serve(ByVal port As Long, Optional ByVal rootDirectory As String = ".")
+    Dim lockfile As FileInfo
+    Set lockfile = New FileInfo
+
+    lockfile.Initialize ActiveWorkbook.FullName & ".lock"
+    lockfile.Create
+
     m_tcpServer.BindTo port, 100
 
     Do While True
         Dim client As TcpClient
-        Set client = m_tcpServer.AcceptTcpClient()
-
-        Dim requestText As String
-        requestText = client.ReceiveString()
-
-        Dim request As HttpRequest
-        Set request = New HttpRequest
-        request.Parse requestText
-
-        Dim response As HttpResponse
-        Set response = ProcessRequest(request)
-
-        Dim responseText As String
-        responseText = ""
+        Set client = m_tcpServer.AcceptTcpClient(1000)
 
-        responseText = responseText & "HTTP/1.1 " & response.StatusCode & " Nobody Needs This Anyway" & vbCrLf
-        responseText = responseText & "Server: Microsoft Excel/" & Application.Version & vbCrLf
-        responseText = responseText & "Content-Length: " & Len(response.Body) & vbCrLf
-        responseText = responseText & "Connection: close" & vbCrLf
-        responseText = responseText & vbCrLf
-        responseText = responseText & response.Body
+        If Not client Is Nothing Then
+            Dim requestText As String
+            requestText = client.ReceiveString()
+
+            If requestText <> "" Then
+                Dim request As HttpRequest
+                Set request = New HttpRequest
+                request.Parse requestText
+
+                Dim response As HttpResponse
+                Set response = ProcessRequest(request)
+
+                Dim responseText As String
+                responseText = response.ToString()
+
+                client.SendString responseText
+            End If
+
+            client.Dispose
+        End If
 
-        client.SendString responseText
-        client.Dispose
-        Exit Do
+        If Not lockfile.Exists Then
+            Exit Do
+        End If
     Loop
 
     m_tcpServer.Dispose

src/Classes/TcpServer.cls

@@ -11,6 +11,7 @@ Option Explicit
 
 Private m_wsa As wsock32.WSADATA
 Private m_serverSocket As Long
+Private m_fdSet As wsock32.fd_set
 
 
 Private Sub Class_Initialize()
@@ -58,8 +59,24 @@ Public Sub BindTo(ByVal port As Long, Optional ByVal backlog As Integer = 10)
 End Sub
 
 
-Public Function AcceptTcpClient() As TcpClient
-    Dim client As TcpClient
+Public Function AcceptTcpClient(Optional ByVal timeoutMs As Long = 500) As TcpClient
+    wsock32.FD_ZERO_MACRO m_fdSet
+    wsock32.FD_SET_MACRO m_serverSocket, m_fdSet
+
+    Dim time As wsock32.timeval
+    time.tv_sec = timeoutMs / 1000
+    time.tv_usec = timeoutMs Mod 1000
+
+    Dim emptyFdSet As fd_set
+
+    Dim selectResult As Integer
+    selectResult = wsock32.select_(m_serverSocket, m_fdSet, emptyFdSet, emptyFdSet, time)
+
+    If selectResult = 0 Then
+        Set AcceptTcpClient = Nothing
+        Exit Function
+    End If
+
     Dim socket
     Dim socketAddress As wsock32.sockaddr
 
@@ -71,8 +88,10 @@ Public Function AcceptTcpClient() As TcpClient
         Exit Function
     End If
 
+    Dim client As TcpClient
     Set client = New TcpClient
-    client.Initialize (socket)
+
+    client.Initialize socket
 
     Set AcceptTcpClient = client
 End Function

src/Modules/wsock32.bas

@@ -30,6 +30,18 @@ Public Type sockaddr_in
     sin_zero As String * 8
 End Type
 
+Public Const FD_SETSIZE = 64
+
+Public Type fd_set
+    fd_count As Integer
+    fd_array(FD_SETSIZE) As Long
+End Type
+
+Public Type timeval
+    tv_sec As Long
+    tv_usec As Long
+End Type
+
 Public Type sockaddr
     sa_family As Integer
     sa_data As String * 14
@@ -44,7 +56,35 @@ Public Declare Function socket Lib "wsock32.dll" (ByVal addressFamily As Long, B
 Public Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
 Public Declare Function bind Lib "wsock32.dll" (ByVal socket As Long, name As sockaddr_in, ByVal nameLength As Integer) As Long
 Public Declare Function listen Lib "wsock32.dll" (ByVal socket As Long, ByVal backlog As Integer) As Long
+Public Declare Function select_ Lib "wsock32.dll" Alias "select" (ByVal nfds As Integer, readfds As fd_set, writefds As fd_set, exceptfds As fd_set, timeout As timeval) As Integer
 Public Declare Function accept Lib "wsock32.dll" (ByVal socket As Long, clientAddress As sockaddr, clientAddressLength As Integer) As Long
 Public Declare Function send Lib "wsock32.dll" (ByVal socket As Long, buffer As String, ByVal bufferLength As Long, ByVal flags As Long) As Long
 Public Declare Function recv Lib "wsock32.dll" (ByVal socket As Long, ByVal buffer As String, ByVal bufferLength As Long, ByVal flags As Long) As Long
 Public Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
+
+
+
+Public Sub FD_ZERO_MACRO(ByRef s As fd_set)
+    s.fd_count = 0
+End Sub
+
+
+Public Sub FD_SET_MACRO(ByVal fd As Long, ByRef s As fd_set)
+    Dim i As Integer
+    i = 0
+
+    Do While i < s.fd_count
+        If s.fd_array(i) = fd Then
+            Exit Do
+        End If
+
+        i = i + 1
+    Loop
+
+    If i = s.fd_count Then
+        If s.fd_count < FD_SETSIZE Then
+            s.fd_array(i) = fd
+            s.fd_count = s.fd_count + 1
+        End If
+    End If
+End Sub