Add some more helpful network code in

This was from distributed-automation for the most part.

src/KeyManagement.cake

@@ -9,7 +9,7 @@
 ;; I had to do this for the crypto_box_* defines
 (c-import &with-decls "sodium.h")
 
-(c-import "<string.h>"
+(c-import "<string.h>" "<stdio.h>"
           &with-decls "<stdbool.h>")
 
 (var-global g-my-secret-key (array crypto_box_SECRETKEYBYTES (unsigned char)) (array 0))
@@ -40,10 +40,10 @@
         (and (generate-box-keys-to-file keys-filename)
              (load-box-keys-from-file keys-filename g-my-public-key g-my-secret-key))
       (return false)))
-  (da-log "My public key is:\n")
+  (fprintf stderr "My public key is:\n")
   (each-in-array g-my-public-key i
-    (da-log "0x%02x " (at i g-my-public-key)))
-  (da-log "\n")
+    (fprintf stderr "0x%02x " (at i g-my-public-key)))
+  (fprintf stderr "\n")
 
   (set g-my-machine-id (machine-id-from-public-key g-my-public-key))
 

src/Network.cake

@@ -1,5 +1,5 @@
 ;; Network.cake: Provide easy access to the sockets API
-(export
+(export-and-evaluate
  (comptime-cond
   ('Windows
    (c-import "<string.h>" "<winsock2.h>" "<stdio.h>"))
@@ -42,3 +42,109 @@
     (return true))
 
   (add-static-link-objects "Ws2_32.lib")))
+
+;;
+;; Helpers for my common client/server setup
+;;
+
+(c-import "<stdio.h>" "<fcntl.h>")
+
+(defmacro netlog (format string &optional &rest arguments any)
+  (if arguments
+      (scope
+       (tokenize-push output
+         (fprintf stderr (token-splice format) (token-splice-rest arguments tokens))))
+      (scope
+       (tokenize-push output
+         (fprintf stderr (token-splice format)))))
+  (return true))
+
+;; Not really sure what a good value is for this
+(var c-max-backlog-connections int 255)
+
+(defstruct network-server-state
+  server-socket socket-type
+  port int)
+
+;; Returns 0 on success
+(defun network-create-server (state (addr network-server-state)
+                              port int
+                              &return int)
+  (set (path state > port) port)
+  (set (path state > server-socket) (socket AF_INET SOCK_STREAM 0)) ;; TCP
+  (when (= (path state > server-socket) -1)
+    (netlog "Failed to initialize socket for TCP connections.\n")
+    (perror "Socket error: ")
+    (return 1))
+
+  (var server-address (struct sockaddr_in) (array 0))
+  (set (field server-address sin_family) AF_INET)
+  (set (field server-address sin_addr s_addr) INADDR_ANY)
+  (set (field server-address sin_port) (htons (path state > port)))
+  (when (< (bind (path state > server-socket) (type-cast (addr server-address)
+                                          (addr (const (struct sockaddr))))
+                 (sizeof server-address))
+           0)
+    (netlog "Failed to bind to port %d for TCP connections.\n" (path state > port))
+    (perror "Socket bind error")
+    (return 1))
+
+  (when (= (listen (path state > server-socket) c-max-backlog-connections) -1)
+    (netlog "Failed to listen on port %d for TCP connections.\n" (path state > port))
+    (perror "Socket listen error")
+    (return 1))
+  (netlog "Listening on port %d\n" (path state > port))
+
+  ;; This avoids a race condition where if the client breaks connection in between select and
+  ;; accept, the accept could block forever.
+  (comptime-cond
+   ('Windows
+    (var set-non-blocking (unsigned long) 1)
+    (ioctlsocket (path state > server-socket) FIONBIO (addr set-non-blocking)))
+   (true
+    (when (= -1 (fcntl (path state > server-socket) F_SETFL O_NONBLOCK))
+      (perror "Setting socket to not block")
+      (return 1))))
+  (return 0))
+
+(defun network-destroy-server (state (addr network-server-state))
+  (unless (= (path state > server-socket) -1)
+    (close (path state > server-socket))))
+
+;; Client
+(defstruct network-client-state
+  connection socket-type)
+
+(defun network-connect-client-to-server (state (addr network-client-state)
+                                         server-host-name (addr (const char))
+                                         server-port int
+                                         &return int)
+  (set (path state > connection) (socket AF_INET SOCK_STREAM 0)) ;; TCP
+  (when (= (path state > connection) -1)
+    (netlog "Failed to initialize socket for TCP connections.\n")
+    (perror "Socket error")
+    (return 1))
+
+  (var server-host (addr (struct hostent)) (gethostbyname server-host-name))
+  (unless server-host
+    (perror "Failed to find server host")
+    (return 1))
+
+  (var server-address (struct sockaddr_in) (array 0))
+  (set (field server-address sin_family) AF_INET)
+  (set (field server-address sin_port) (htons server-port))
+  (memcpy (addr (field server-address sin_addr s_addr))
+          (at 0 (path server-host > h_addr_list)) (path server-host > h_length))
+
+  (when (< (connect (path state > connection)
+                    (type-cast (addr server-address)
+                               (addr (struct sockaddr)))
+                    (sizeof server-address))
+           0)
+    (envlog "Failed to connect to server at port %d\n" server-port)
+    (perror "Socket error")
+    (return 1))
+  (return 0))
+
+(defun network-destroy-client-state (state (addr network-client-state))
+  (close (path state > connection)))

src/NetworkRemoteCommands.cake

@@ -0,0 +1,203 @@
+;; NetworkRemoteCommands.cake: Use Network.cake, Protocol.cake, and RemoteCommands.cake together
+;; to make a distributed command system.
+;; TODO: Add heartbeats and acks to make more reliable.
+(set-cakelisp-option cakelisp-src-dir "Dependencies/cakelisp/src")
+(add-cakelisp-search-directory "Dependencies/cakelisp/runtime")
+(import
+ ;; Cakelisp
+ "CHelpers.cake"
+ ;; GameLib
+ "Cryptography.cake" "Network.cake" "RemoteCommands.cake" "Protocol.cake" "DynamicArray.cake"
+ "KeyManagement.cake")
+
+(c-import
+ "<errno.h>" "<sys/select.h>"
+ &with-decls "<stdbool.h>" "<sodium.h>")
+
+(def-type-alias-global client-permissions (unsigned int))
+(var-global client-permission-receive-commands client-permissions (bit-shift-<< 1 1))
+(var-global client-permission-send-commands-to-server client-permissions (bit-shift-<< 1 2))
+
+(defstruct network-machine-data
+  name (addr (const char))
+  ;; public-key-hash (unsigned int)
+  permissions client-permissions
+  public-key (array crypto_box_PUBLICKEYBYTES (unsigned char)))
+
+(forward-declare (struct remote-command-queue)
+                 (struct network-server-state))
+
+(defstruct network-client-connection
+  id (unsigned int)
+  permissions client-permissions
+  name (addr (const char))
+  public-key (addr (unsigned char))
+  connection socket-type
+  send-to-socket bool
+  commands-to-send (addr remote-command-queue))
+
+(defun-local accept-new-connection
+    (state (addr network-server-state)
+     trusted-machines (addr network-machine-data)
+     num-trusted-machines int
+     ;; dynarray
+     active-connections (addr (addr network-client-connection))
+     &return bool)
+  (netlog "Accepting new connection\n")
+
+  ;; Receive new connection
+  (var client-address (struct sockaddr_in) (array 0))
+  (var client-address-length int (sizeof client-address))
+  (var client-socket socket-type
+    (comptime-cond
+     ('Windows ;; Grr...
+      (accept (path state > server-socket)
+              (type-cast (addr client-address) (addr (struct sockaddr)))
+              (addr client-address-length)))
+     (true
+      (accept (path state > server-socket)
+              (type-cast (addr client-address) (addr (struct sockaddr)))
+              (type-cast (addr client-address-length) (addr (unsigned int)))))))
+  (when (< client-socket 0)
+    ;; Server socket is non-blocking: we'll connect next time
+    (when (or (= errno EAGAIN)
+              (= errno EINPROGRESS))
+      (return 0))
+
+    (perror "Error accepting connection")
+    (return 1))
+
+  (var this-machine-id (unsigned int) (receive-cake-protocol-introduction client-socket))
+  (unless this-machine-id
+    (netlog "Error making initial handshake.\n")
+    (close client-socket)
+    (return 1))
+  (var client-machine (addr network-machine-data) null)
+  (each-in-range num-trusted-machines i
+    (var machine (addr network-machine-data) (addr (at i trusted-machines)))
+    (var machine-id (unsigned int)
+      (machine-id-from-public-key (path machine > public-key)))
+    (when (= this-machine-id machine-id)
+      (set client-machine machine)
+      (break)))
+  (unless client-machine
+    (netlog "A machine with ID %d attempted to connect, but it was not in the trusted machines list.
+ The connection will not proceed.\n" this-machine-id)
+    (close client-socket)
+    (return 1))
+
+  (var new-client network-client-connection (array 0))
+  (set-fields new-client
+    id this-machine-id
+    permissions (path client-machine > permissions)
+    name (path client-machine > name)
+    public-key (path client-machine > public-key)
+    connection client-socket)
+  (dynarray-push (deref active-connections) new-client)
+
+  (netlog "Successfully accepted connection with %s\n"
+          (field new-client name))
+  (return 0))
+
+(defun network-server-wait-or-receive-remote-commands
+    (state (addr network-server-state)
+     trusted-machines (addr network-machine-data)
+     num-trusted-machines int
+     ;; dynarray
+     active-connections (addr (addr network-client-connection))
+     &return int)
+  (var client-keys-data encryption-keys (array 0))
+  (memcpy (field client-keys-data my-secret-key) g-my-secret-key
+          (sizeof (field client-keys-data my-secret-key)))
+  ;; Don't copy the client key yet because we don't know it!
+  (var client-keys (addr encryption-keys) (addr client-keys-data))
+
+  ;; (netlog "Waiting for connection...\n")
+  (var read-connections fd_set)
+  (var write-connections fd_set)
+  (var exception-connections fd_set)
+  (scope
+   (var highest-file-descriptor int 0)
+   (FD_ZERO (addr read-connections))
+   (FD_ZERO (addr write-connections))
+   (FD_ZERO (addr exception-connections))
+   (FD_SET (path state > server-socket) (addr read-connections))
+   (when (> (path state > server-socket) highest-file-descriptor)
+     (set highest-file-descriptor (path state > server-socket)))
+   (each-item-addr-in-dynarray (deref active-connections) i connection (addr network-client-connection)
+     (when (bit-and (path connection > permissions) client-permission-send-commands-to-server)
+       (FD_SET (path connection > connection) (addr read-connections)))
+     (when (path connection > send-to-socket)
+       (FD_SET (path connection > connection) (addr write-connections)))
+     (FD_SET (path connection > connection) (addr exception-connections))
+     (when (> (path connection > connection) highest-file-descriptor)
+       (set highest-file-descriptor (path connection > connection))))
+   ;; Select with no timeout, because we have nothing else to do
+   (var select-result int
+     (select (+ 1 highest-file-descriptor)
+             (addr read-connections) (addr write-connections) (addr exception-connections)
+             null))
+   (cond
+     ((= 0 select-result)
+      (return 0))
+     ((= -1 select-result)
+      (perror "In select, waiting for connections")
+      (return 1))))
+
+  (when (FD_ISSET (path state > server-socket) (addr read-connections))
+    (accept-new-connection state trusted-machines num-trusted-machines active-connections))
+
+  (var incoming-commands (addr remote-command-queue) (create-remote-command-queue))
+  (defer (free-remote-command-queue incoming-commands))
+
+  ;; Iterate in reverse for safe erasing
+  (each-in-dynarray-reverse (deref active-connections) i
+    (var connection (addr network-client-connection) (addr (at i (deref active-connections))))
+    (var this-machine-permissions client-permissions (path connection > permissions))
+    (var client-socket socket-type (path connection > connection))
+
+    (when (FD_ISSET client-socket (addr exception-connections))
+      (netlog "Exception encountered; lost connection to %s\n" (path connection > name))
+      (dynarray-delete (deref active-connections) i)
+      (continue))
+
+    ;; Set their public key
+    ;; We re-use client-keys to not have to copy the master secret key all the time
+    (memcpy (path client-keys > their-public-key)
+            (path connection > public-key)
+            (sizeof (path client-keys > their-public-key)))
+
+    (clear-remote-command-queue incoming-commands)
+
+    ;; Receive
+    (when (FD_ISSET client-socket (addr read-connections))
+      (unless (bit-and this-machine-permissions client-permission-send-commands-to-server)
+        (netlog "Machine %s tried to send commands to the server, but it lacks permission to do so.
+ It will be disconnected.\n"
+                (path connection > name))
+        (close client-socket)
+        (dynarray-delete (deref active-connections) i)
+        (continue))
+      (unless (receive-command-queue incoming-commands client-socket client-keys)
+        (netlog "Lost connection to %s\n" (path connection > name))
+        (dynarray-delete (deref active-connections) i)
+        (continue))
+      (execute-requested-remote-commands incoming-commands null))
+
+    ;; Send
+    (when (and (path connection > send-to-socket)
+               (FD_ISSET client-socket (addr write-connections)))
+      (unless (bit-and this-machine-permissions client-permission-receive-commands)
+        (netlog "Server is trying to send commands to machine %s, but the machine lacks permission
+ to receive commands. It will be disconnected.\n"
+                (path connection > name))
+        (close client-socket)
+        (dynarray-delete (deref active-connections) i)
+        (continue))
+      (netlog "Server is sending commands to %s\n" (path connection > name))
+      (set (path connection > send-to-socket) false)
+      (unless (send-command-queue (path connection > commands-to-send) client-socket client-keys)
+        (netlog "Lost connection to %s\n" (path connection > name))
+        (dynarray-delete (deref active-connections) i)
+        (continue))))
+  (return 0))

src/Protocol.cake

@@ -11,7 +11,7 @@
 (forward-declare (struct remote-command-queue)
                  (struct encryption-keys))
 
-(c-import &with-decls "<stdbool.h>")
+(c-import "<stdio.h>" &with-decls "<stdbool.h>")
 
 (var-global g-protocol-verbose bool false)
 
@@ -82,16 +82,16 @@
   (unless (and (= num-read (array-size received-magic))
                (= 0 (memcmp received-magic c-protocol-introduction-magic (array-size received-magic))))
     (if num-read
-        (da-log "Received data which did not match cake protocol: the magic string did not match.\n")
+        (fprintf stderr "Received data which did not match cake protocol: the magic string did not match.\n")
         ;; Read size of 0 can indicate severed connection
-        (da-log "The connection has been closed unexpectedly.\n"))
+        (fprintf stderr "The connection has been closed unexpectedly.\n"))
     (return 0))
 
   ;; Identifier
   (var identifier-network (unsigned int) 0)
   (set num-read (proto-recv from-socket (addr identifier-network) (sizeof identifier-network)))
   (unless (= num-read (sizeof identifier-network))
-    (da-log "Received data which did not match cake protocol: the identifier was not the expected size.\n")
+    (fprintf stderr "Received data which did not match cake protocol: the identifier was not the expected size.\n")
     (return 0))
 
   (return (ntohl identifier-network)))
@@ -106,7 +106,7 @@
                            payload-size (unsigned int)
                            &return bool)
   (unless (and payload-size (< payload-size c-max-payload-size))
-    (da-log "Payload is size %d. Payload must not be empty, and must not be larger than %d bytes.\n"
+    (fprintf stderr "Payload is size %d. Payload must not be empty, and must not be larger than %d bytes.\n"
             payload-size c-max-payload-size)
     (return false))
 
@@ -118,7 +118,7 @@
                                 payload-size nonce
                                 (path keys > their-public-key)
                                 (path keys > my-secret-key)))
-    (da-log "Failed to encrypt payload\n")
+    (fprintf stderr "Failed to encrypt payload\n")
     (return false))
 
   ;; Magic
@@ -157,15 +157,15 @@
   (unless (and (= num-read (array-size received-magic))
                (= 0 (memcmp received-magic c-protocol-magic (array-size received-magic))))
     (if num-read
-        (da-log "Received data which did not match cake protocol: the magic string did not match.\n")
-        (da-log "The connection has been closed unexpectedly.\n"))
+        (fprintf stderr "Received data which did not match cake protocol: the magic string did not match.\n")
+        (fprintf stderr "The connection has been closed unexpectedly.\n"))
     (return -1))
 
   ;; Nonce
   (var nonce (array crypto_box_NONCEBYTES (unsigned char)))
   (set num-read (proto-recv from-socket nonce (array-size nonce)))
   (unless (= num-read (array-size nonce))
-    (da-log "Received data which did not match cake protocol: the nonce was not the expected size.\n")
+    (fprintf stderr "Received data which did not match cake protocol: the nonce was not the expected size.\n")
     (return -1))
 
   ;; Size (INCLUDES added crypto bytes)
@@ -175,18 +175,18 @@
    (var payload-size-network (unsigned int) 0)
    (unless (= (proto-recv from-socket (addr payload-size-network) (sizeof payload-size-network))
               (sizeof payload-size-network))
-     (da-log "Expected payload size, but it could not be read.\n")
+     (fprintf stderr "Expected payload size, but it could not be read.\n")
      (return -1))
    (set encrypted-payload-size (ntohl payload-size-network))
 
    (set payload-size (- encrypted-payload-size crypto_box_MACBYTES))
    (unless (and payload-size
                 (< payload-size c-max-payload-size))
-     (da-log "Payload is an invalid size %d. The max payload size is %d.\n"
+     (fprintf stderr "Payload is an invalid size %d. The max payload size is %d.\n"
              payload-size c-max-payload-size)
      (return -1))
    (unless (<= payload-size output-buffer-size)
-     (da-log "Payload is %d bytes, but the output buffer is only %d bytes.\n"
+     (fprintf stderr "Payload is %d bytes, but the output buffer is only %d bytes.\n"
              payload-size output-buffer-size)
      (return -1)))
 
@@ -199,7 +199,7 @@
                   (- encrypted-payload-size num-read)))
     (set num-read (+ num-read num-read-this-read)))
   (unless (= num-read encrypted-payload-size)
-    (da-log "Expected to read %d bytes, but only received %d bytes.\n"
+    (fprintf stderr "Expected to read %d bytes, but only received %d bytes.\n"
             encrypted-payload-size num-read)
     (return -1))
 
@@ -207,7 +207,7 @@
                                      encrypted-payload encrypted-payload-size nonce
                                      (path keys > their-public-key)
                                      (path keys > my-secret-key)))
-    (da-log "The message could not be decrypted.\n")
+    (fprintf stderr "The message could not be decrypted.\n")
     (return -1))
 
   (return payload-size))
@@ -229,12 +229,12 @@
   (cond
     ((> serialize-result 0)
      (when g-protocol-verbose
-       (da-log "Sending: \"%s\"\n" requested-commands-buffer))
+       (fprintf stderr "Sending: \"%s\"\n" requested-commands-buffer))
      (unless (send-cake-protocol to-socket keys
                                  requested-commands-buffer serialize-result)
        (return false)))
     ((= serialize-result -1)
-     (da-log "Failed to serialize requested command queue.\n")
+     (fprintf stderr "Failed to serialize requested command queue.\n")
      (return false)))
   (return true))
 
@@ -250,11 +250,11 @@
      (perror "Reading socket for commands")
      (return false))
     ((= num-read 0)
-     (da-log "No commands at this time.\n"))
+     (fprintf stderr "No commands at this time.\n"))
     ((> num-read 0)
      (if (clear-receive-requested-remote-commands
           command-queue received-commands num-read)
          (when g-protocol-verbose
-           (da-log "Commands received: \"%s\"\n" received-commands))
+           (fprintf stderr "Commands received: \"%s\"\n" received-commands))
          (return false))))
   (return true))

src/RemoteCommands.cake

@@ -235,7 +235,7 @@
                (token-splice-addr arguments-struct-metadata-name)
                (addr unpacked-arguments) packed-arguments
                malloc (addr characters-read))
-        (da-log "Failed to de-serialize command arguments\n")
+        (fprintf stderr "Failed to de-serialize command arguments\n")
         (return false))
       (call (token-splice name) (token-splice-array passing-arguments) userdata)
       (free-introspect-struct-fields (token-splice-addr arguments-struct-metadata-name)
@@ -279,7 +279,7 @@
          (queue-remote-command-internal (token-splice output-queue)
                                         (token-splice-addr hash-token)
                                         packed-arguments-buffer)
-         (da-log "Failed to serialize arguments.\n"))))
+         (fprintf stderr "Failed to serialize arguments.\n"))))
   (return true))
 
 ;; Returns -1 if failed to serialize. Otherwise, returns number of bytes written to buffer
@@ -310,7 +310,7 @@
   (unless (read-introspect-struct-s-expr remote-command-queue--metadata
                                          queue read-buffer
                                          malloc (addr characters-read))
-    (da-log "Failed to de-serialize requested remote commands\n")
+    (fprintf stderr "Failed to de-serialize requested remote commands\n")
     (return false))
   (return true))
 
@@ -327,13 +327,13 @@
         (continue))
       (set found true)
       (when g-remote-commands-verbose
-        (da-log "Execute %s\n" (path current-definition > name)))
+        (fprintf stderr "Execute %s\n" (path current-definition > name)))
       (unless (call (path current-definition > function) (path request > payload) userdata)
         (set is-successful false))
       (break))
     (unless found
-      (da-log "Error: Did not find command with hash %d\n" (path request > command-name-hash)))
+      (fprintf stderr "Error: Did not find command with hash %d\n" (path request > command-name-hash)))
     (unless is-successful
-      (da-log "Error: Remote command request could not be parsed. Queue execution aborted.\n")
+      (fprintf stderr "Error: Remote command request could not be parsed. Queue execution aborted.\n")
       (break)))
   (return is-successful))