[MLton-commit] r6939

Vesa Karvonen vesak at mlton.org
Wed Oct 15 04:05:01 PDT 2008


Changed to support running multiple TCP listeners in a single server
process.  Added initial support for setting various TCP server options and
event notifications, but still needs tuning.

Changed the signature to make room for having other than TCP listeners,

----------------------------------------------------------------------

U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml
U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.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/lib-client.mlb
U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-client.use
U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb
U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.use
U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/client.sig
U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/export.sml
A   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/protocol.sig
U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/export.sml
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-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml	2008-10-15 11:04:48 UTC (rev 6939)
@@ -113,7 +113,7 @@
    end
 
    fun declare (signature' as (dom, cod, _)) = let
-      val fingerprint = Fingerprint.make signature'
+      val fingerprint = Fingerprint.fromSignature signature'
       val sendDom = send dom
       val recvCod = recv cod
    in

Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.sml	2008-10-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.sml	2008-10-15 11:04:48 UTC (rev 6939)
@@ -9,11 +9,16 @@
    val recv : 'a Rep.t -> ('a, Socket.active) SocketEvents.monad
    val send : 'a Rep.t -> 'a -> (Unit.t, Socket.active) SocketEvents.monad
 
+   structure Signature : sig
+      type ('d, 'c) t = 'd Rep.t * 'c Rep.t * String.t
+   end
+
    structure Fingerprint : sig
       eqtype t
       val t : t Rep.t
+      val toString : t -> String.t
       val toWord32 : t -> Word32.t
-      val make : 'd Rep.t * 'c Rep.t * String.t -> t
+      val fromSignature : ('d, 'c) Signature.t -> t
    end
 
    structure Token : sig
@@ -45,6 +50,7 @@
    structure Version : sig
       eqtype t
       val current : t
+      val toString : t -> String.t
       val recv : (t, Socket.active) SocketEvents.monad
       val send : t -> (Unit.t, Socket.active) SocketEvents.monad
    end
@@ -90,10 +96,14 @@
                        ; buffer)) >>= (fn () =>
                   SocketEvents.sendVec (Word8VectorSlice.full data))
 
+   structure Signature = struct
+      type ('d, 'c) t = 'd Rep.t * 'c Rep.t * String.t
+   end
+
    structure Fingerprint = struct
       open Word32
       val toWord32 = id
-      fun make (dom, cod, name) =
+      fun fromSignature (dom, cod, name) =
           Generic.typeHash dom +
           Generic.typeHash cod * 0w71 +
           Generic.hash String.t name

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-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml	2008-10-15 11:04:48 UTC (rev 6939)
@@ -7,93 +7,220 @@
 structure Server :> SERVER = struct
    open SocketEvents Async Protocol
 
-   val entries : (Fingerprint.t,
-                  Token.t -> (Unit.t, Socket.active) monad) HashMap.t =
-       HashMap.new {eq = op =, hash = Word32.toWord o Fingerprint.toWord32}
+   structure ProcMap = struct
+      type t = (Fingerprint.t,
+                Token.t -> (Unit.t, Socket.active) monad) HashMap.t
 
-   val sendExn = send Exn.t
+      fun new () =
+          HashMap.new
+           {eq = (op =),
+            hash = Word32.toWord o Fingerprint.toWord32}
 
-   fun define (signature' as (dom, cod, name)) = let
-      val fingerprint = Fingerprint.make signature'
-      val recvDom = recv dom
-      val sendCod = send cod
-      open Reply
-   in
-      fn f =>
-         case HashMap.find entries fingerprint
-          of SOME _ => fails ["fingerprint of ", name, " already in use"]
-           | NONE =>
-             (HashMap.insert entries)
-              (fingerprint,
-               fn token =>
-                  recvDom >>= (fn x =>
-                  try (fn () => f x,
-                       fn y =>
-                          send (RESULT token) >>= (fn () =>
-                          sendCod y),
-                       fn e =>
-                          send (EXN token) >>= (fn () =>
-                          sendExn e))))
+      val sendExn = send Exn.t
+
+      fun add entries (signature' as (dom, cod, name)) = let
+         val fingerprint = Fingerprint.fromSignature signature'
+         val recvDom = recv dom
+         val sendCod = send cod
+         open Reply
+      in
+         fn f =>
+            case HashMap.find entries fingerprint
+             of SOME _ => fails ["fingerprint of ", name, " already in use"]
+              | NONE =>
+                (HashMap.insert entries)
+                 (fingerprint,
+                  fn token =>
+                     recvDom >>= (fn x =>
+                     try (fn () => f x,
+                          fn y =>
+                             send (RESULT token) >>= (fn () =>
+                             sendCod y),
+                          fn e =>
+                             send (EXN token) >>= (fn () =>
+                             sendExn e))))
+      end
    end
 
-   fun serve () =
-       Request.recv >>= (fn req =>
-       case req
-        of Request.CALL {token, fingerprint} =>
-           case HashMap.find entries fingerprint
-            of NONE =>
-               skip >>= (fn () =>
-               Reply.send (Reply.UNKNOWN token) >>=
-               serve)
-             | SOME procedure =>
-               procedure token >>= serve)
+   structure TCP = struct
+      structure Opts = struct
+         datatype t = IN
+          of {name : String.t
+            , port : Int.t
+            , maxAccepts : Int.t Option.t
+            , tcpNoDelay : Bool.t
+            , serverError : Exn.t Effect.t
+            , closed : Unit.t Effect.t
+            , accept : {addr : INetSock.sock_addr} UnPr.t
+            , unknownProtocol :
+               {addr : INetSock.sock_addr,
+                version : Protocol.Version.t} Effect.t
+            , connected :
+               {addr : INetSock.sock_addr,
+                version : Protocol.Version.t} 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}
 
-   fun run {port, accept=filter} = let
-      fun negotiate addr =
-          if not (filter addr)
-          then error (Fail "addr")
-          else Version.recv >>= (fn version' =>
-               if version' <> Version.current
-               then error (Fail "version")
-               else Version.send version' >>= serve)
+         datatype 'a opt = OPT of {get : t -> 'a, set : 'a -> t UnOp.t}
 
-      fun accept ? =
-          (SocketEvents.sockEvt OS.IO.pollIn >>= (fn socket =>
-           case Socket.acceptNB socket
-            of NONE => error (Fail "NONE")
-             | SOME (socket, addr) =>
-               (INetSock.TCP.setNODELAY (socket, true)
-              ; (when (negotiate addr socket))
-                 (fn r =>
-                     (Socket.close socket
-                    ; case r
-                       of INR () => ()
-                        | INL e  =>
-                          case e
-                           of Closed => ()
-                            | e =>
-                              printlns
-                               ("unhandled exception: " ::
-                                Exn.message e ::
-                                List.intersperse
-                                 "\n"
-                                 (Exn.history e))))
-              ; accept))) ?
+         val default : t =
+             IN {name = "127.0.0.1"
+               , port = 45678
+               , maxAccepts = NONE
+               , tcpNoDelay = true
+               , serverError = ignore
+               , closed = ignore
+               , accept = const true
+               , unknownProtocol = ignore
+               , connected = ignore
+               , unknownProc = ignore
+               , protocolError = ignore
+               , disconnected = ignore}
 
-      val socket = INetSock.TCP.socket ()
-   in
-      (Socket.bind
-        (socket,
-         INetSock.toAddr
-          (valOf (NetHostDB.fromString "127.0.0.1"), port))
-     ; Socket.listen (socket, 16))
-      handle e => (Socket.close socket ; raise e)
-    ; (when (accept socket))
-       (fn r =>
-           (Socket.close socket
-          ; case r
-             of INL e  => println (Exn.message e)
-              | INR () => ()))
-    ; PollLoop.run Handler.runAll
+         fun mk get set =
+             OPT {set = fn value =>
+                           fn IN {name
+                                , port
+                                , maxAccepts
+                                , tcpNoDelay
+                                , serverError
+                                , closed
+                                , accept
+                                , unknownProtocol
+                                , connected
+                                , unknownProc
+                                , protocolError
+                                , disconnected} => let
+                                 val opts =
+                                     {name = ref name
+                                    , port = ref port
+                                    , maxAccepts = ref maxAccepts
+                                    , tcpNoDelay = ref tcpNoDelay
+                                    , serverError = ref serverError
+                                    , closed = ref closed
+                                    , accept = ref accept
+                                    , unknownProtocol = ref unknownProtocol
+                                    , 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
+                                   , maxAccepts = get #maxAccepts
+                                   , tcpNoDelay = get #tcpNoDelay
+                                   , serverError = get #serverError
+                                   , closed = get #closed
+                                   , accept = get #accept
+                                   , unknownProtocol = get #unknownProtocol
+                                   , 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 maxAccepts = mk #maxAccepts #maxAccepts
+         val tcpNoDelay = mk #tcpNoDelay #tcpNoDelay
+         val serverError = mk #serverError #serverError
+         val closed = mk #closed #closed
+         val accept = mk #accept #accept
+         val unknownProtocol = mk #unknownProtocol #unknownProtocol
+         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
+                        , maxAccepts
+                        , tcpNoDelay
+                        , serverError
+                        , closed
+                        , accept
+                        , unknownProtocol
+                        , connected
+                        , unknownProc
+                        , protocolError
+                        , disconnected}) = let
+         fun serve addr =
+             Request.recv >>= (fn req =>
+             case req
+              of Request.CALL {token, fingerprint} =>
+                 case HashMap.find entries fingerprint
+                  of NONE =>
+                     (unknownProc {addr = addr, fingerprint = fingerprint}
+                    ; skip >>= (fn () =>
+                      Reply.send (Reply.UNKNOWN token) >>= (fn () =>
+                      serve addr)))
+                   | SOME procedure =>
+                     procedure token >>= (fn () =>
+                     serve addr))
+
+         fun negotiate addr =
+             Version.recv >>= (fn version' =>
+             if version' <> Version.current
+             then (unknownProtocol {addr = addr, version = version'}
+                 ; return ())
+             else (connected {addr = addr, version = version'}
+                 ; Version.send version' >>= (fn () =>
+                   serve addr)))
+
+         fun listen maxAccepts =
+             if SOME 0 = maxAccepts
+             then return ()
+             else SocketEvents.sockEvt OS.IO.pollIn >>= (fn socket =>
+                  case Socket.acceptNB socket
+                   of NONE => error (Fail "acceptNB returned NONE")
+                    | SOME (socket, addr) =>
+                      (if not (accept {addr = addr})
+                       then (Socket.close socket
+                           ; listen maxAccepts)
+                       else (INetSock.TCP.setNODELAY (socket, tcpNoDelay)
+                           ; (when (negotiate addr socket))
+                              (fn r =>
+                                  (Socket.close socket
+                                 ; case r
+                                    of INR () => ()
+                                     | INL Closed => ()
+                                     | INL e =>
+                                       protocolError {addr = addr, error = e}
+                                 ; disconnected {addr = addr}))
+                           ; listen (Option.map (fn n => n-1) maxAccepts))))
+
+         val socket = INetSock.TCP.socket ()
+      in
+         (Socket.bind
+           (socket,
+            INetSock.toAddr
+             (NetHostDB.addr
+               (valOf (NetHostDB.getByName name)),
+              port))
+        ; Socket.listen (socket, 16))
+         handle e => (Socket.close socket ; raise e)
+       ; (when (listen maxAccepts socket))
+          (fn r =>
+              (Socket.close socket
+             ; case r
+                of INL e  => serverError e
+                 | INR () => ()
+             ; closed ()))
+      end
    end
+
+   fun run () = PollLoop.run Handler.runAll
 end

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-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.sml	2008-10-15 11:04:48 UTC (rev 6939)
@@ -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 = 4321}
+val conn = Client.Conn.byName {host = "127.0.0.1", port = 45678}
 
 local
    fun mk signature' 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-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.sml	2008-10-15 11:04:48 UTC (rev 6939)
@@ -12,10 +12,19 @@
    fun bindings () = !assoc
 end
 
-val () = Server.define (Pair.t (String.t, Int.t), Unit.t, "bind") bind
-val () = Server.define (String.t, Option.t Int.t, "find") find
-val () = Server.define
-          (Unit.t, List.t (Pair.t (String.t, Int.t)), "bindings")
-          bindings
-
-val () = Server.run {port = 4321, accept = const true}
+val () = let
+   open Server
+   val procMap = ProcMap.new ()
+   fun add ? = ProcMap.add procMap ?
+in
+   add (Pair.t (String.t, Int.t), Unit.t, "bind") bind
+ ; add (String.t, Option.t Int.t, "find") find
+ ; add (Unit.t, List.t (Pair.t (String.t, Int.t)), "bindings") bindings
+ ; TCP.start procMap let
+      open TCP.Opts
+   in
+      default
+       & maxAccepts := SOME 1
+   end
+ ; run ()
+end

Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-client.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-client.mlb	2008-10-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-client.mlb	2008-10-15 11:04:48 UTC (rev 6939)
@@ -20,6 +20,8 @@
       "warnUnused true"
    in
       local
+         public/protocol.sig
+
          public/client/client.sig
          detail/client.sml
       in

Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-client.use
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-client.use	2008-10-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-client.use	2008-10-15 11:04:48 UTC (rev 6939)
@@ -10,6 +10,7 @@
      "${MLTON_LIB}/com/ssh/async/unstable/example/poll-loop/lib.use",
      "${APPLICATION}/generic.use",
      "detail/protocol.use",
+     "public/protocol.sig",
      "public/client/client.sig",
      "detail/client.sml",
      "public/client/export.sml"] ;

Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb	2008-10-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb	2008-10-15 11:04:48 UTC (rev 6939)
@@ -21,6 +21,8 @@
       "warnUnused true"
    in
       local
+         public/protocol.sig
+
          public/server/server.sig
          detail/server.sml
       in

Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.use
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.use	2008-10-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.use	2008-10-15 11:04:48 UTC (rev 6939)
@@ -11,6 +11,7 @@
      "${MLTON_LIB}/org/mlton/vesak/ds/unstable/lib.use",
      "${APPLICATION}/generic.use",
      "detail/protocol.use",
+     "public/protocol.sig",
      "public/server/server.sig",
      "detail/server.sml",
      "public/server/export.sml"] ;

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-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/client.sig	2008-10-15 11:04:48 UTC (rev 6939)
@@ -41,9 +41,9 @@
       (** Waits for the asynchronous reply and returns it. *)
    end
 
-   val declare : 'd Rep.t * 'c Rep.t * String.t -> Conn.t -> 'd -> 'c Reply.t
+   val declare : ('d, 'c) Protocol.Signature.t -> Conn.t -> 'd -> 'c Reply.t
    (**
-    * Declares a procedure with the given signature {(dom, cod, name)} and
-    * allows it to be called through the given connection.
+    * Declares a procedure with the given signature and allows it to be
+    * called through the given connection.
     *)
 end

Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/export.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/export.sml	2008-10-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/export.sml	2008-10-15 11:04:48 UTC (rev 6939)
@@ -6,3 +6,6 @@
 
 signature CLIENT = CLIENT
 structure Client : CLIENT = Client
+
+signature PROTOCOL = PROTOCOL
+structure Protocol : PROTOCOL = Protocol

Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/protocol.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/protocol.sig	2008-10-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/protocol.sig	2008-10-15 11:04:48 UTC (rev 6939)
@@ -0,0 +1,23 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+signature PROTOCOL = sig
+   structure Signature : sig
+      type ('d, 'c) t = 'd Rep.t * 'c Rep.t * String.t
+   end
+
+   structure Fingerprint : sig
+      eqtype t
+      val toString : t -> String.t
+      val fromSignature : ('d, 'c) Signature.t -> t
+   end
+
+   structure Version : sig
+      eqtype t
+      val toString : t -> String.t
+      val current : t
+   end
+end


Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/protocol.sig
___________________________________________________________________
Name: svn:eol-style
   + native

Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/export.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/export.sml	2008-10-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/export.sml	2008-10-15 11:04:48 UTC (rev 6939)
@@ -6,3 +6,6 @@
 
 signature SERVER = SERVER
 structure Server : SERVER = Server
+
+signature PROTOCOL = PROTOCOL
+structure Protocol : PROTOCOL = Protocol

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-15 06:45:21 UTC (rev 6938)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/server.sig	2008-10-15 11:04:48 UTC (rev 6939)
@@ -8,15 +8,100 @@
  * Signature for the {Server} module for programming RPC servers.
 *)
 signature SERVER = sig
-   val define : 'd Rep.t * 'c Rep.t * String.t -> ('d -> 'c) Effect.t
-   (**
-    * Defines a procedure with the given signature {(dom, cod, name)} and
-    * implementation as callable via RPC.
-    *)
 
-   val run : {port : Int.t, accept : INetSock.sock_addr UnPr.t} Effect.t
+   structure ProcMap : sig
+      type t
+      (** Type of procedure maps. *)
+
+      val new : t Thunk.t
+      (** Creates a new procedure map. *)
+
+      val add : t -> ('d, 'c) Protocol.Signature.t -> ('d -> 'c) Effect.t
+      (**
+       * Adds a procedure with the given signature and implementation to
+       * the procedure map.
+       *)
+   end
+
+   structure TCP : sig
+      structure Opts : sig
+         type t and 'a opt
+
+         val default : t
+         (** Default options. *)
+
+         (** == Updating Options ==
+          *
+          * Example:
+          *
+          *> default & port := 4321
+          *>         & maxAccepts := 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 maxAccepts : Int.t Option.t opt
+         (** default: {NONE} *)
+
+         val tcpNoDelay : Bool.t opt
+         (** default: {true} *)
+
+         (** == 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 unknownProtocol :
+             {addr : INetSock.sock_addr,
+              version : Protocol.Version.t} Effect.t opt
+         (** default: {ignore} *)
+
+         val connected :
+             {addr : INetSock.sock_addr,
+              version : Protocol.Version.t} Effect.t opt
+         (** default: {ignore} *)
+
+         val 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
+      (**
+       * Starts an async server handler listening on the specified {name}d
+       * address and {port} for clients using the TCP protocol.
+       *)
+   end
+
+   val run : Unit.t Effect.t
    (**
-    * Starts the server process listening on the specified port for
-    * clients.
+    * Runs the started server(s).  Calling {run ()} is equivalent to
+    * executing:
+    *
+    *> PollLoop.run Handler.runAll
     *)
 end




More information about the MLton-commit mailing list