diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 58f7d5c4..96b4fed7 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -3264,6 +3264,86 @@ let () = Nil | _ -> raise (Eval_error "channel-set-blocking!: (channel bool)")); + (* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *) + let resolve_inet_addr host = + if host = "" || host = "0.0.0.0" then Unix.inet_addr_any + else if host = "localhost" then Unix.inet_addr_loopback + else + try Unix.inet_addr_of_string host + with _ -> + try + let entry = Unix.gethostbyname host in + if Array.length entry.Unix.h_addr_list = 0 then + raise (Eval_error ("socket: cannot resolve " ^ host)) + else entry.Unix.h_addr_list.(0) + with Not_found -> raise (Eval_error ("socket: cannot resolve " ^ host)) + in + let port_of v = match v with + | Integer n -> n + | Number n -> int_of_float n + | _ -> raise (Eval_error "socket: port must be a number") + in + let alloc_chan_name () = + let id = !channel_next_id in + incr channel_next_id; + Printf.sprintf "sock%d" id + in + + register "socket-connect" (fun args -> + match args with + | [String host; port_v] -> + let port = port_of port_v in + let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in + let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + (try Unix.connect sock addr + with Unix.Unix_error (e, _, _) -> + (try Unix.close sock with _ -> ()); + raise (Eval_error ("socket-connect: " ^ Unix.error_message e))); + let name = alloc_chan_name () in + Hashtbl.replace channel_table name (sock, "rw", ref false, ref true); + String name + | _ -> raise (Eval_error "socket-connect: (host port)")); + + register "socket-server" (fun args -> + let (host, port) = match args with + | [port_v] -> ("", port_of port_v) + | [String h; port_v] -> (h, port_of port_v) + | _ -> raise (Eval_error "socket-server: (port) or (host port)") + in + let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in + let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Unix.setsockopt sock Unix.SO_REUSEADDR true; + (try Unix.bind sock addr + with Unix.Unix_error (e, _, _) -> + (try Unix.close sock with _ -> ()); + raise (Eval_error ("socket-server: bind: " ^ Unix.error_message e))); + Unix.listen sock 8; + let name = alloc_chan_name () in + Hashtbl.replace channel_table name (sock, "server", ref false, ref true); + String name); + + register "socket-accept" (fun args -> + match args with + | [String name] -> + let (sock, _, _, _) = chan_get name in + let (client_sock, client_addr) = + try Unix.accept sock + with Unix.Unix_error (e, _, _) -> + raise (Eval_error ("socket-accept: " ^ Unix.error_message e)) + in + let (host_str, port) = match client_addr with + | Unix.ADDR_INET (addr, p) -> (Unix.string_of_inet_addr addr, p) + | Unix.ADDR_UNIX path -> (path, 0) + in + let client_name = alloc_chan_name () in + Hashtbl.replace channel_table client_name (client_sock, "rw", ref false, ref true); + let d = Hashtbl.create 3 in + Hashtbl.replace d "channel" (String client_name); + Hashtbl.replace d "host" (String host_str); + Hashtbl.replace d "port" (Integer port); + Dict d + | _ -> raise (Eval_error "socket-accept: (server-channel)")); + (* io-select-channels: (read-list write-list timeout-ms) → {:readable [...] :writable [...]} timeout-ms < 0 → block indefinitely; 0 → poll. Returns ready channel names. *) register "io-select-channels" (fun args -> diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index 4457dc55..727a94b2 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -362,8 +362,13 @@ (is-chan (and (not (nil? maybe-chan)) - (>= (len maybe-chan) 4) - (equal? (slice maybe-chan 0 4) "file")))) + (or + (and + (>= (len maybe-chan) 4) + (equal? (slice maybe-chan 0 4) "file")) + (and + (>= (len maybe-chan) 4) + (equal? (slice maybe-chan 0 4) "sock")))))) (if is-chan (let @@ -3199,6 +3204,61 @@ (interp args) (assoc (tcl-event-step interp 0) :result ""))) +; ============================================================ +; Socket: TCP client and server (Phase 5c) +; ============================================================ + +; Internal command invoked by the auto-registered fileevent on a server +; channel. Args: (server-chan callback-word ...). Accepts one client and +; calls the user callback with (client-chan peer-host peer-port). +(define + tcl-cmd-_sock-do-accept + (fn + (interp args) + (let + ((server-chan (first args)) (cb-parts (rest args))) + (let + ((info (socket-accept server-chan))) + (let + ((client-chan (get info :channel)) + (peer-host (get info :host)) + (peer-port (str (get info :port)))) + (let + ((cmd + (join + " " + (append + cb-parts + (list client-chan peer-host peer-port))))) + (assoc (tcl-eval-string interp cmd) :result ""))))))) + +; socket host port — TCP client; returns "sockN" +; socket -server cb port — TCP server; auto-fires cb on each accept +(define + tcl-cmd-socket + (fn + (interp args) + (cond + ((= 0 (len args)) (error "socket: wrong # args")) + ((equal? (first args) "-server") + (if + (< (len args) 3) + (error "socket: usage: socket -server cb port") + (let + ((cb (nth args 1)) (port (parse-int (nth args 2)))) + (let + ((server-chan (socket-server port))) + (let + ((handler (str "_sock-do-accept " server-chan " " cb))) + (assoc + (tcl-fileevent-set interp server-chan "readable" handler) + :result server-chan)))))) + ((= 2 (len args)) + (let + ((host (first args)) (port (parse-int (nth args 1)))) + (assoc interp :result (socket-connect host port)))) + (else (error "socket: wrong # args"))))) + (define tcl-cmd-array @@ -3689,6 +3749,10 @@ ((i (tcl-register i "vwait" tcl-cmd-vwait))) (let ((i (tcl-register i "update" tcl-cmd-update))) + (let + ((i (tcl-register i "socket" tcl-cmd-socket))) + (let + ((i (tcl-register i "_sock-do-accept" tcl-cmd-_sock-do-accept))) (let ((i (tcl-register i "file" tcl-cmd-file))) (let @@ -3700,4 +3764,4 @@ (tcl-register i "array" - tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) diff --git a/lib/tcl/tests/idioms.sx b/lib/tcl/tests/idioms.sx index 17738dc9..a49866e2 100644 --- a/lib/tcl/tests/idioms.sx +++ b/lib/tcl/tests/idioms.sx @@ -274,6 +274,35 @@ :result) "1") + ; 38-41. Phase 5c sockets: TCP client + server + (ok "socket-server-fires-callback" + (get + (run + "proc h {sock host port} { global got; set got hit; close $sock }\nset srv [socket -server h 18901]\nset cli [socket localhost 18901]\nvwait got\nclose $srv\nclose $cli\nset got") + :result) + "hit") + + (ok "socket-client-server-roundtrip" + (get + (run + "proc h {sock host port} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server h 18902]\nset cli [socket localhost 18902]\nputs $cli ping\nflush $cli\nvwait received\nclose $srv\nclose $cli\nset received") + :result) + "ping") + + (ok "socket-server-peer-host" + (get + (run + "proc h {sock host port} { global peer; set peer $host; close $sock }\nset srv [socket -server h 18903]\nset cli [socket 127.0.0.1 18903]\nvwait peer\nclose $srv\nclose $cli\nset peer") + :result) + "127.0.0.1") + + (ok "socket-multiple-connections" + (get + (run + "proc h {sock host port} { global count; incr count; close $sock }\nset count 0\nset srv [socket -server h 18904]\nset c1 [socket localhost 18904]\nset c2 [socket localhost 18904]\nset c3 [socket localhost 18904]\nwhile {$count < 3} { update; after 5 }\nclose $srv\nclose $c1\nclose $c2\nclose $c3\nset count") + :result) + "3") + (dict "passed" tcl-idiom-pass