[MLton-commit] r6944

Vesa Karvonen vesak at mlton.org
Thu Oct 16 14:17:50 PDT 2008


Changed the protocol mismatch and unknown procedure exceptions to include
the version and fingerprint, respectively, for diagnostic purposes.

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

U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml
U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/client.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-16 21:14:40 UTC (rev 6943)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml	2008-10-16 21:17:49 UTC (rev 6944)
@@ -7,8 +7,8 @@
 structure Client :> CLIENT = struct
    open SocketEvents Async Protocol
 
-   exception Unknown
-   exception ProtocolMismatch
+   exception UnknownProcedure of Fingerprint.t
+   exception ProtocolMismatch of Version.t
 
    fun run xM socket =
        case ref (INL (Fail "impossible"))
@@ -19,13 +19,15 @@
           ; Exn.reflect (!result))
 
    structure Conn = struct
+      datatype handler =
+         HANDLER of {token : Token.t,
+                     fingerprint : Fingerprint.t,
+                     setExn : Exn.t Effect.t,
+                     recvCod : (Unit.t, Socket.active) monad}
       datatype t =
          IN of {socket : Socket.active socket,
                 token : Token.t Ref.t,
-                live : {token : Token.t,
-                        setExn : Exn.t Effect.t,
-                        recvCod : (Unit.t, Socket.active) monad}
-                        ResizableArray.t}
+                handlers : handler ResizableArray.t}
 
       fun close (IN {socket, ...}) =
           Socket.close socket
@@ -44,13 +46,13 @@
                        run (Version.send Version.current >>= (fn () =>
                             Version.recv >>= (fn version =>
                             if version <> Version.current
-                            then error ProtocolMismatch
+                            then error (ProtocolMismatch version)
                             else return ())))
                            socket,
                     fn () =>
                        IN {socket = socket,
                            token = ref Token.zero,
-                           live = ResizableArray.new ()},
+                           handlers = ResizableArray.new ()},
                     fn e =>
                        (Socket.close socket
                       ; raise e)))
@@ -60,19 +62,19 @@
       datatype 'a t =
          IN of (Conn.t, (Exn.t, 'a) Sum.t) Sum.t Ref.t
 
-      fun drop live token' = let
+      fun drop handlers token' = let
          fun lp i =
-             if i < ResizableArray.length live
-             then case ResizableArray.sub (live, i)
-                   of handler as {token, setExn=_, recvCod=_} =>
+             if i < ResizableArray.length handlers
+             then case ResizableArray.sub (handlers, i)
+                   of handler as Conn.HANDLER {token, ...} =>
                       if token = token'
                       then (ResizableArray.update
-                             (live,
+                             (handlers,
                               i,
                               ResizableArray.sub
-                               (live,
-                                ResizableArray.length live - 1))
-                          ; ignore (ResizableArray.pop live)
+                               (handlers,
+                                ResizableArray.length handlers - 1))
+                          ; ignore (ResizableArray.pop handlers)
                           ; SOME handler)
                       else lp (i+1)
              else NONE
@@ -85,10 +87,10 @@
       fun sync (reply as IN result) =
           case !result
            of INR result => Exn.reflect result
-            | INL (Conn.IN {socket, live, ...}) =>
+            | INL (Conn.IN {socket, handlers, ...}) =>
               (run (Reply.recv >>= (fn reply =>
                     case drop
-                          live
+                          handlers
                           (case reply
                             of Reply.UNKNOWN token => token
                              | Reply.EXN token => token
@@ -98,7 +100,8 @@
                           of Reply.UNKNOWN _ => return ()
                            | Reply.EXN _ => skip
                            | Reply.RESULT _ => skip)
-                      | SOME {setExn, recvCod, ...} =>
+                      | SOME
+                         (Conn.HANDLER {setExn, recvCod, fingerprint, ...}) =>
                         (case reply
                           of Reply.RESULT _ => recvCod
                            | Reply.EXN _ =>
@@ -106,7 +109,7 @@
                              (setExn e
                             ; return ()))
                            | Reply.UNKNOWN _ =>
-                             (setExn Unknown
+                             (setExn (UnknownProcedure fingerprint)
                             ; return ()))))
                    socket
              ; sync reply)
@@ -117,7 +120,7 @@
       val sendDom = send dom
       val recvCod = recv cod
    in
-      fn conn as Conn.IN {socket, live, token, ...} => fn value => let
+      fn conn as Conn.IN {socket, handlers, token, ...} => fn value => let
             val token' = Token.next (!token)
             val result = ref (INL conn)
          in
@@ -129,12 +132,14 @@
                  sendDom value))
                 socket
           ; ResizableArray.push
-             live
-             {token = token',
-              setExn = fn e => result := INR (INL e),
-              recvCod = recvCod >>= (fn v =>
-                        (result := INR (INR v)
-                       ; return ()))}
+             handlers
+             (Conn.HANDLER
+               {token = token',
+                fingerprint = fingerprint,
+                setExn = fn e => result := INR (INL e),
+                recvCod = recvCod >>= (fn v =>
+                          (result := INR (INR v)
+                         ; return ()))})
           ; Reply.IN result
          end
    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-16 21:14:40 UTC (rev 6943)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/client.sig	2008-10-16 21:17:49 UTC (rev 6944)
@@ -8,13 +8,13 @@
  * Signature for the {Client} module for programming RPC clients.
  *)
 signature CLIENT = sig
-   exception Unknown
+   exception UnknownProcedure of Protocol.Fingerprint.t
    (**
     * Raised when an attempt is made to call a declared procedure that is
     * not defined on the server.
     *)
 
-   exception ProtocolMismatch
+   exception ProtocolMismatch of Protocol.Version.t
    (**
     * Raised during the connection process if the server doesn't support
     * the protocol of the client.




More information about the MLton-commit mailing list