[MLton-commit] r6958
Vesa Karvonen
vesak at mlton.org
Sun Oct 19 16:13:22 PDT 2008
Changed to use labeled args via FRU. Also changed the client signature to
treat TCP as just one form of connection.
----------------------------------------------------------------------
U mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml
U mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml
U mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.sml
U mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.sml
U mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/client.sig
U mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/server.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml 2008-10-19 23:00:33 UTC (rev 6957)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml 2008-10-19 23:13:18 UTC (rev 6958)
@@ -31,31 +31,46 @@
fun close (IN {socket, ...}) =
Socket.close socket
+ end
- fun byName {host, port} =
- case INetSock.TCP.socket ()
- of socket =>
- (INetSock.TCP.setNODELAY (socket, true)
- ; Socket.connect
- (socket,
- INetSock.toAddr
- (NetHostDB.addr
- (valOf (NetHostDB.getByName host)),
- port))
- ; try (fn () =>
- run (Version.send Version.current >>= (fn () =>
- Version.recv >>= (fn version =>
- if version <> Version.current
- then error (ProtocolMismatch version)
- else return ())))
- socket,
- fn () =>
- IN {socket = socket,
- token = ref Token.zero,
- handlers = ResizableArray.new ()},
- fn e =>
- (Socket.close socket
- ; raise e)))
+ structure TCP = struct
+ type connect_args =
+ {host : String.t,
+ port : Int.t,
+ tcpNoDelay : Bool.t}
+ type 'a connect = ('a, connect_args) FRU.upd
+
+ val ~ = (fn {host=a, port=b, tcpNoDelay=c} => (a&b&c),
+ fn (a&b&c) => {host=a, port=b, tcpNoDelay=c})
+
+ fun connect ? =
+ let open FRU in args A A A $ ~ ~ end
+ {host = "127.0.0.1", port = 45678, tcpNoDelay = false}
+ (fn {host, port, tcpNoDelay} =>
+ case INetSock.TCP.socket ()
+ of socket =>
+ (INetSock.TCP.setNODELAY (socket, tcpNoDelay)
+ ; Socket.connect
+ (socket,
+ INetSock.toAddr
+ (NetHostDB.addr
+ (valOf (NetHostDB.getByName host)),
+ port))
+ ; try (fn () =>
+ run (Version.send Version.current >>= (fn () =>
+ Version.recv >>= (fn version =>
+ if version <> Version.current
+ then error (ProtocolMismatch version)
+ else return ())))
+ socket,
+ fn () =>
+ Conn.IN {socket = socket,
+ token = ref Token.zero,
+ handlers = ResizableArray.new ()},
+ fn e =>
+ (Socket.close socket
+ ; raise e))))
+ ?
end
structure Reply = struct
Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml 2008-10-19 23:00:33 UTC (rev 6957)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml 2008-10-19 23:13:18 UTC (rev 6958)
@@ -43,118 +43,30 @@
end
structure TCP = struct
- structure Opts = struct
- datatype t = IN
- of {name : String.t
- , port : Int.t
- , numAccepts : Int.t Option.t
- , tcpNoDelay : Bool.t
- , serverError : Exn.t Effect.t
- , closed : Unit.t Effect.t
- , accept : {addr : INetSock.sock_addr} UnPr.t
- , protocolMismatch :
- {addr : INetSock.sock_addr,
- version : Protocol.Version.t} Effect.t
- , connected : {addr : INetSock.sock_addr} Effect.t
- , unknownProc :
- {addr : INetSock.sock_addr,
- fingerprint : Protocol.Fingerprint.t} Effect.t
- , protocolError :
- {addr : INetSock.sock_addr,
- error : Exn.t} Effect.t
- , disconnected : {addr : INetSock.sock_addr} Effect.t}
+ type start_args =
+ {name : String.t,
+ port : Int.t,
+ numAccepts : Int.t Option.t,
+ tcpNoDelay : Bool.t,
+ serverError : Exn.t Effect.t,
+ closed : Unit.t Effect.t,
+ accept : {addr : INetSock.sock_addr} UnPr.t,
+ protocolMismatch :
+ {addr : INetSock.sock_addr,
+ version : Protocol.Version.t} Effect.t,
+ connected : {addr : INetSock.sock_addr} Effect.t,
+ unknownProc :
+ {addr : INetSock.sock_addr,
+ fingerprint : Protocol.Fingerprint.t} Effect.t,
+ protocolError :
+ {addr : INetSock.sock_addr, error : Exn.t} Effect.t,
+ disconnected : {addr : INetSock.sock_addr} Effect.t}
+ type 'a start = ('a, start_args) FRU.upd
- datatype 'a opt = OPT of {get : t -> 'a, set : 'a -> t UnOp.t}
-
- val default : t =
- IN {name = "127.0.0.1"
- , port = 45678
- , numAccepts = NONE
- , tcpNoDelay = false
- , serverError = ignore
- , closed = ignore
- , accept = const true
- , protocolMismatch = ignore
- , connected = ignore
- , unknownProc = ignore
- , protocolError = ignore
- , disconnected = ignore}
-
- fun mk get set =
- OPT {set = fn value =>
- fn IN {name
- , port
- , numAccepts
- , tcpNoDelay
- , serverError
- , closed
- , accept
- , protocolMismatch
- , connected
- , unknownProc
- , protocolError
- , disconnected} => let
- val opts =
- {name = ref name
- , port = ref port
- , numAccepts = ref numAccepts
- , tcpNoDelay = ref tcpNoDelay
- , serverError = ref serverError
- , closed = ref closed
- , accept = ref accept
- , protocolMismatch = ref protocolMismatch
- , connected = ref connected
- , unknownProc = ref unknownProc
- , protocolError = ref protocolError
- , disconnected = ref disconnected}
- fun get field = !(field opts)
- in
- set opts := value
- ; IN {name = get #name
- , port = get #port
- , numAccepts = get #numAccepts
- , tcpNoDelay = get #tcpNoDelay
- , serverError = get #serverError
- , closed = get #closed
- , accept = get #accept
- , protocolMismatch = get #protocolMismatch
- , connected = get #connected
- , unknownProc = get #unknownProc
- , protocolError = get #protocolError
- , disconnected = get #disconnected}
- end,
- get = fn IN r => get r}
-
- val name = mk #name #name
- val port = mk #port #port
- val numAccepts = mk #numAccepts #numAccepts
- val tcpNoDelay = mk #tcpNoDelay #tcpNoDelay
- val serverError = mk #serverError #serverError
- val closed = mk #closed #closed
- val accept = mk #accept #accept
- val protocolMismatch = mk #protocolMismatch #protocolMismatch
- val connected = mk #connected #connected
- val unknownProc = mk #unknownProc #unknownProc
- val protocolError = mk #protocolError #protocolError
- val disconnected = mk #disconnected #disconnected
-
- fun opts & (OPT {set, ...}, value) = set value opts
- val op := = id
- end
-
- fun start entries
- (Opts.IN {name
- , port
- , numAccepts
- , tcpNoDelay
- , serverError
- , closed
- , accept
- , protocolMismatch
- , connected
- , unknownProc
- , protocolError
- , disconnected}) = let
+ fun start' entries
+ ({name, port, numAccepts, tcpNoDelay, serverError, closed,
+ accept, protocolMismatch, connected, unknownProc,
+ protocolError, disconnected} : start_args) = let
fun serve addr =
Request.recv >>= (fn req =>
case req
@@ -218,6 +130,24 @@
| INR () => ()
; closed ()))
end
+
+ val ~ =
+ (fn {name=a, port=b, numAccepts=c, tcpNoDelay=d, serverError=e,
+ closed=f, accept=g, protocolMismatch=h, connected=i,
+ unknownProc=j, protocolError=k, disconnected=l} =>
+ (a&b&c&d&e&f&g&h&i&j&k&l),
+ fn (a&b&c&d&e&f&g&h&i&j&k&l) =>
+ {name=a, port=b, numAccepts=c, tcpNoDelay=d, serverError=e,
+ closed=f, accept=g, protocolMismatch=h, connected=i,
+ unknownProc=j, protocolError=k, disconnected=l})
+
+ fun start entries =
+ let open FRU in args A A A A A A A A A A A A $ ~ ~ end
+ {name = "127.0.0.1", port = 45678, numAccepts = NONE,
+ tcpNoDelay = false, serverError = ignore, closed = ignore,
+ accept = const true, protocolMismatch = ignore, connected = ignore,
+ unknownProc = ignore, protocolError = ignore, disconnected = ignore}
+ (start' entries)
end
fun run () = PollLoop.run Handler.runAll
Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.sml 2008-10-19 23:00:33 UTC (rev 6957)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.sml 2008-10-19 23:13:18 UTC (rev 6958)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-val conn = Client.Conn.byName {host = "127.0.0.1", port = 45678}
+val conn = Client.TCP.connect (U#tcpNoDelay true) $
local
fun mk s = verbose "client: " s (Client.Reply.sync o Client.declare s conn)
Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.sml 2008-10-19 23:00:33 UTC (rev 6957)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.sml 2008-10-19 23:13:18 UTC (rev 6958)
@@ -18,11 +18,6 @@
fun ` f s = ProcMap.add procMap s (verbose "server: " s f)
in
mkLib {bind = `bind, bindings = `bindings, find = `find} >| ignore
- ; TCP.start procMap let
- open TCP.Opts
- in
- default
- & numAccepts := SOME 1
- end
+ ; TCP.start procMap (U#numAccepts (SOME 1)) (U#tcpNoDelay true) $
; run ()
end
Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/client.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/client.sig 2008-10-19 23:00:33 UTC (rev 6957)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/client.sig 2008-10-19 23:13:18 UTC (rev 6958)
@@ -26,11 +26,23 @@
val close : t Effect.t
(** Explicitly closes the connection. *)
+ end
- val byName : {host : String.t, port : Int.t} -> t
+ structure TCP : sig
+ type connect_args
+ type 'a connect = ('a, connect_args) FRU.upd
+ val connect :
+ ((connect_args,
+ {host : String.t connect
+ (** default: {"127.0.0.1"} *)
+ , port : Int.t connect
+ (** default: {45678} *)
+ , tcpNoDelay : Bool.t connect
+ (** default: {false} *)
+ },
+ Conn.t) FRU.args,
+ 'k) CPS.t
(** Connects to the server on the specified host and port. *)
-
- (*val spawn : {exe : String.t, port : Int.t} -> t*)
end
structure Reply : sig
Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/server.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/server.sig 2008-10-19 23:00:33 UTC (rev 6957)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/server.sig 2008-10-19 23:13:18 UTC (rev 6958)
@@ -24,76 +24,43 @@
end
structure TCP : sig
- structure Opts : sig
- type t and 'a opt
-
- val default : t
- (** Default options. *)
-
- (** == Updating Options ==
- *
- * Example:
- *
- *> default & port := 4321
- *> & numAccepts := SOME 1
- *)
-
- val & : t * ('a opt * 'a) -> t
- val := : ('a opt * 'a) UnOp.t
-
- (** == Server Settings == *)
-
- val name : String.t opt
- (** default: {"127.0.0.1"} *)
-
- val port : Int.t opt
- (** default: {45678} *)
-
- val numAccepts : Int.t Option.t opt
- (**
- * Optional number of connections to accept after which the
- * listener port is closed automatically.
- *
- * default: {NONE}
- *)
-
- val tcpNoDelay : Bool.t opt
- (** default: {false} *)
-
- (** == Server Events == *)
-
- val serverError : Exn.t Effect.t opt
- (** default: {ignore} *)
-
- val closed : Unit.t Effect.t opt
- (** default: {ignore} *)
-
- val accept : {addr : INetSock.sock_addr} UnPr.t opt
- (** default: {const true} *)
-
- val protocolMismatch :
+ type start_args
+ type 'a start = ('a, start_args) FRU.upd
+ val start :
+ ProcMap.t ->
+ ((start_args,
+ {name : String.t start
+ (** default: {"127.0.0.1"} *)
+ , port : Int.t start
+ (** default: {45678} *)
+ , numAccepts : Int.t Option.t start
+ (** default: {45678} *)
+ , tcpNoDelay : Bool.t start
+ (** default: {false} *)
+ , serverError : Exn.t Effect.t start
+ (** default: {ignore} *)
+ , closed : Unit.t Effect.t start
+ (** default: {ignore} *)
+ , accept : {addr : INetSock.sock_addr} UnPr.t start
+ (** default: {const true} *)
+ , protocolMismatch :
{addr : INetSock.sock_addr,
- version : Protocol.Version.t} Effect.t opt
- (** default: {ignore} *)
-
- val connected : {addr : INetSock.sock_addr} Effect.t opt
- (** default: {ignore} *)
-
- val unknownProc :
+ version : Protocol.Version.t} Effect.t start
+ (** default: {ignore} *)
+ , connected : {addr : INetSock.sock_addr} Effect.t start
+ (** default: {ignore} *)
+ , unknownProc :
{addr : INetSock.sock_addr,
- fingerprint : Protocol.Fingerprint.t} Effect.t opt
- (** default: {ignore} *)
-
- val protocolError :
- {addr : INetSock.sock_addr,
- error : Exn.t} Effect.t opt
- (** default: {ignore} *)
-
- val disconnected : {addr : INetSock.sock_addr} Effect.t opt
- (** default: {ignore} *)
- end
-
- val start : ProcMap.t -> Opts.t Effect.t
+ fingerprint : Protocol.Fingerprint.t} Effect.t start
+ (** default: {ignore} *)
+ , protocolError :
+ {addr : INetSock.sock_addr, error : Exn.t} Effect.t start
+ (** default: {ignore} *)
+ , disconnected : {addr : INetSock.sock_addr} Effect.t start
+ (** default: {ignore} *)
+ },
+ Unit.t) FRU.args,
+ 'k) CPS.t
(**
* Starts an async server handler listening on the specified {name}d
* address and {port} for clients using the TCP protocol.
More information about the MLton-commit
mailing list