[MLton-commit] r6922
Vesa Karvonen
vesak at mlton.org
Mon Oct 13 01:12:43 PDT 2008
Initial commit of a RPC (Remote Procedure Call) library.
----------------------------------------------------------------------
A mltonlib/trunk/org/mlton/vesak/rpc-lib/
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/LICENSE
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/README
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.mlb
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.sml
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/socket-events.sml
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/Build.bgb
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/Build.sh
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/app/
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/app/generic.mlb
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.mlb
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.sml
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.mlb
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.sml
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-client.mlb
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/client.sig
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/export.sml
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/export.sml
A mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/server.sig
----------------------------------------------------------------------
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable
___________________________________________________________________
Name: svn:ignore
+ generated
Copied: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/LICENSE (from rev 6898, mltonlib/trunk/org/mlton/vesak/LICENSE)
===================================================================
--- mltonlib/trunk/org/mlton/vesak/LICENSE 2008-10-01 11:59:28 UTC (rev 6898)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/LICENSE 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,20 @@
+COPYRIGHT NOTICE, LICENSE AND DISCLAIMER.
+
+Copyright (C) 2008 Vesa Karvonen
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both the copyright notice and this permission notice and warranty
+disclaimer appear in supporting documentation, and that the name of
+the above copyright holders, or their entities, not be used in
+advertising or publicity pertaining to distribution of the software
+without specific, written prior permission.
+
+The above copyright holders disclaim all warranties with regard to
+this software, including all implied warranties of merchantability and
+fitness. In no event shall the above copyright holders be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether in an
+action of contract, negligence or other tortious action, arising out
+of or in connection with the use or performance of this software.
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/LICENSE
___________________________________________________________________
Name: svn:mergeinfo
+
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/README
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/README 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/README 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,77 @@
+RPC (Remote Procedure Call) Library
+-----------------------------------
+
+ This library implements a simple RPC mechanism. One can conveniently
+ define a server that allows a client to call a set of procedures
+ defined on the server via TCP sockets. A custom binary protocol based
+ on generic serialization is used for communication.
+
+
+Info
+----
+
+ License: MLton license (a BSD-style license)
+ Portability: portable
+ Ported to: MLton
+ Stability: experimental
+ Maintainer: Vesa Karvonen <vesa.a.j.k at gmail.com>
+
+
+About Library Organization
+--------------------------
+
+ example/
+
+ This directory contains examples of using the RPC library.
+
+ public/{client/,server/,}
+
+ These directories contain the documented signature definitions
+ (*.sig) and listings of all top-level bindings exported by this
+ library (export.sml). There are actually two libraries: one for
+ clients and another for servers. The contents of these directories
+ should ideally provide sufficient documentation to use the library.
+
+ lib-{client,server}.mlb
+
+ Build files for the client and server sides of the RPC library.
+
+ detail/
+
+ Implementation details of the library.
+
+
+Motivation
+----------
+
+ The motivation for an easy-to-use RPC mechanism should be fairly clear.
+ However, one of the motivations for building this library was actually
+ the idea that one could use an RPC like mechanism to implement
+ separately compiled libraries in SML. Using this library one can
+ fairly easily define a separately compiled server program that can be
+ used about as conveniently as a separately compiled library. Such a
+ library program could also be compiled with a particular SML
+ implementation and used from a program running on a different SML
+ implementation.
+
+
+Contributions
+-------------
+
+ The signatures and structures defined by this library are not meant to
+ be cast in stone! We welcome contributions including new functionality,
+ bug fixes, and ports to new compilers. The recommended submit method
+ for small contributions to this library is to send a message with a
+ brief description of the proposed contribution as well as a patch
+ containing full code and documentation (signature comments) to either
+ the MLton-user list
+
+ mlton-user at mlton.org
+
+ or the MLton list
+
+ mlton at mlton.org .
+
+ For larger extensions or changes we recommend that you first contact
+ the active maintainer(s) of this library. The preferred contact method
+ is through the above mailing lists.
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,140 @@
+(* 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.
+ *)
+
+structure Client :> CLIENT = struct
+ open SocketEvents Async Protocol
+
+ exception Unknown
+ exception ProtocolMismatch
+
+ fun run xM socket =
+ case ref (INL (Fail "impossible"))
+ of result =>
+ ((when (xM socket))
+ (fn x => result := x)
+ ; PollLoop.run Handler.runAll
+ ; Exn.reflect (!result))
+
+ structure Conn = struct
+ datatype t =
+ IN of {socket : socket,
+ token : Token.t Ref.t,
+ live : {token : Token.t,
+ setExn : Exn.t Effect.t,
+ recvCod : Unit.t monad} ResizableArray.t}
+
+ fun close (IN {socket, ...}) =
+ Socket.close socket
+
+ 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
+ else return ())))
+ socket,
+ fn () =>
+ IN {socket = socket,
+ token = ref Token.zero,
+ live = ResizableArray.new ()},
+ fn e =>
+ (Socket.close socket
+ ; raise e)))
+ end
+
+ structure Reply = struct
+ datatype 'a t =
+ IN of (Conn.t, (Exn.t, 'a) Sum.t) Sum.t Ref.t
+
+ fun drop live token' = let
+ fun lp i =
+ if i < ResizableArray.length live
+ then case ResizableArray.sub (live, i)
+ of handler as {token, ...} =>
+ if token = token'
+ then (ResizableArray.update
+ (live,
+ i,
+ ResizableArray.sub
+ (live,
+ ResizableArray.length live - 1))
+ ; ignore (ResizableArray.pop live)
+ ; SOME handler)
+ else lp (i+1)
+ else NONE
+ in
+ lp 0
+ end
+
+ val recvExn = recv Exn.t
+
+ fun sync (reply as IN result) =
+ case !result
+ of INR result => Exn.reflect result
+ | INL (Conn.IN {socket, live, ...}) =>
+ (run (Reply.recv >>= (fn reply =>
+ case drop
+ live
+ (case reply
+ of Reply.UNKNOWN token => token
+ | Reply.EXN token => token
+ | Reply.RESULT token => token)
+ of NONE =>
+ (case reply
+ of Reply.UNKNOWN _ => return ()
+ | Reply.EXN _ => skip
+ | Reply.RESULT _ => skip)
+ | SOME {setExn, recvCod, ...} =>
+ (case reply
+ of Reply.RESULT _ => recvCod
+ | Reply.EXN _ =>
+ recvExn >>= (fn e =>
+ (setExn e
+ ; return ()))
+ | Reply.UNKNOWN _ =>
+ (setExn Unknown
+ ; return ()))))
+ socket
+ ; sync reply)
+ end
+
+ fun declare (signature' as (dom, cod, _)) = let
+ val fingerprint = Fingerprint.make signature'
+ val sendDom = send dom
+ val recvCod = recv cod
+ in
+ fn conn as Conn.IN {socket, live, token, ...} => fn value => let
+ val token' = Token.next (!token)
+ val result = ref (INL conn)
+ in
+ token := token'
+ ; run (Request.send
+ (Request.CALL
+ {token = token',
+ fingerprint = fingerprint}) >>= (fn () =>
+ sendDom value))
+ socket
+ ; ResizableArray.push
+ live
+ {token = token',
+ setExn = fn e => result := INR (INL e),
+ recvCod = recvCod >>= (fn v =>
+ (result := INR (INR v)
+ ; return ()))}
+ ; Reply.IN result
+ end
+ end
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/client.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.mlb 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.mlb 2008-10-13 08:11:10 UTC (rev 6922)
@@ -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.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
+ $(MLTON_LIB)/com/ssh/async/unstable/lib.mlb
+ $(MLTON_LIB)/com/ssh/async/unstable/example/poll-loop/lib.mlb
+
+ $(APPLICATION)/generic.mlb
+in
+ ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
+ socket-events.sml
+ protocol.sml
+ end
+end
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.sml 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.sml 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,151 @@
+(* 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.
+ *)
+
+structure Protocol :> sig
+ val skip : Unit.t SocketEvents.monad
+ val recv : 'a Rep.t -> 'a SocketEvents.monad
+ val send : 'a Rep.t -> 'a -> Unit.t SocketEvents.monad
+
+ structure Fingerprint : sig
+ eqtype t
+ val t : t Rep.t
+ val toWord32 : t -> Word32.t
+ val make : 'd Rep.t * 'c Rep.t * String.t -> t
+ end
+
+ structure Token : sig
+ eqtype t
+ val t : t Rep.t
+ val zero : t
+ val next : t UnOp.t
+ end
+
+ structure Request : sig
+ datatype t =
+ CALL of {token : Token.t,
+ fingerprint : Fingerprint.t} (* value *)
+ val t : t Rep.t
+ val recv : t SocketEvents.monad
+ val send : t -> Unit.t SocketEvents.monad
+ end
+
+ structure Reply : sig
+ datatype t =
+ UNKNOWN of Token.t
+ | RESULT of Token.t (* value *)
+ | EXN of Token.t (* value *)
+ val t : t Rep.t
+ val recv : t SocketEvents.monad
+ val send : t -> Unit.t SocketEvents.monad
+ end
+
+ structure Version : sig
+ eqtype t
+ val current : t
+ val recv : t SocketEvents.monad
+ val send : t -> Unit.t SocketEvents.monad
+ end
+end = struct
+ open SocketEvents
+
+ fun buffer n = Word8ArraySlice.full (Word8Array.array (n, 0w0))
+
+ val recv1 =
+ SocketEvents.recv (buffer Word32.numBytes) >>= (fn data =>
+ SocketEvents.recv
+ (buffer
+ (LargeWord.toInt
+ (PackWord32Little.subArr
+ (#1 (Word8ArraySlice.base data), 0)))))
+
+ fun recv t =
+ case #1 o Generic.unpickler
+ t
+ (IOSMonad.fromReader Word8ArraySlice.getItem)
+ of unpickle =>
+ recv1 >>= (fn data =>
+ try (fn () => unpickle data,
+ return,
+ error))
+
+ val skip = recv1 >>= (fn _ => return ())
+
+ fun send t =
+ case Generic.pickle t
+ of pickle =>
+ fn value =>
+ case pickle value
+ of data =>
+ SocketEvents.sendArr
+ (case buffer Word32.numBytes
+ of buffer =>
+ (PackWord32Little.update
+ (#1 (Word8ArraySlice.base buffer),
+ 0,
+ LargeWord.fromInt (Word8Vector.length data))
+ ; buffer)) >>= (fn () =>
+ SocketEvents.sendVec (Word8VectorSlice.full data))
+
+ structure Fingerprint = struct
+ open Word32
+ val toWord32 = id
+ fun make (dom, cod, name) =
+ Generic.typeHash dom +
+ Generic.typeHash cod +
+ Generic.hash String.t name
+ end
+
+ structure Token = struct
+ open Word32
+ val zero = 0w0
+ fun next w : t = w+0w1
+ end
+
+ structure Request = struct
+ datatype t =
+ CALL of {token : Token.t,
+ fingerprint : Fingerprint.t} (* value *)
+
+ val t : t Rep.t =
+ data' (C1'"CALL"
+ (record (R'"token" Token.t
+ *` R'"fingerprint" Fingerprint.t)))
+ (fn CALL {token=t, fingerprint=f} => t & f,
+ fn t & f => CALL {token=t, fingerprint=f})
+
+ val recv = recv t
+ val send = send t
+ end
+
+ structure Reply = struct
+ datatype t =
+ UNKNOWN of Token.t
+ | RESULT of Token.t (* value *)
+ | EXN of Token.t (* value *)
+
+ val t : t Rep.t =
+ data' (C1'"UNKNOWN" Token.t
+ +` C1'"RESULT" Token.t
+ +` C1'"EXN" Token.t)
+ (fn UNKNOWN t => INL (INL t)
+ | RESULT t => INL (INR t)
+ | EXN t => INR t,
+ fn INL (INL t) => UNKNOWN t
+ | INL (INR t) => RESULT t
+ | INR t => EXN t)
+
+ val recv = recv t
+ val send = send t
+ end
+
+ structure Version = struct
+ open Word32
+ val current =
+ Generic.typeHash Request.t + Generic.typeHash Reply.t
+ val recv = recv t
+ val send = send t
+ end
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/protocol.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,99 @@
+(* 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.
+ *)
+
+structure Server :> SERVER = struct
+ open SocketEvents Async Protocol
+
+ val entries :
+ {fingerprint : Fingerprint.t,
+ procedure : Token.t -> Unit.t monad} List.t Ref.t =
+ ref []
+
+ fun find fingerprint =
+ List.find (eq fingerprint o #fingerprint) (!entries)
+
+ val sendExn = send Exn.t
+
+ fun define (signature' as (dom, cod, _)) = let
+ val recvDom = recv dom
+ val sendCod = send cod
+ open Reply
+ in
+ fn f =>
+ (push entries)
+ {fingerprint = Fingerprint.make signature',
+ procedure = 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
+
+ fun serve () =
+ Request.recv >>= (fn req =>
+ case req
+ of Request.CALL {token = token, fingerprint = fingerprint} =>
+ case find fingerprint
+ of NONE =>
+ skip >>= (fn () =>
+ Reply.send (Reply.UNKNOWN token) >>=
+ serve)
+ | SOME {procedure, ...} =>
+ procedure token >>= serve)
+
+ 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)
+
+ 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 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
+ end
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/socket-events.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/socket-events.sml 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/socket-events.sml 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,92 @@
+(* 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.
+ *)
+
+structure SocketEvents :> sig
+ exception Closed
+
+ type socket = Socket.active INetSock.stream_sock
+
+ include MONAD_CORE
+ where type 'a monad = socket -> (Exn.t, 'a) Sum.t Async.Event.t
+
+ val error : Exn.t -> 'a monad
+
+ val sockEvt : OS.IO.poll_desc UnOp.t -> socket monad
+
+ val recv : Word8ArraySlice.t -> Word8ArraySlice.t monad
+
+ val sendArr : Word8ArraySlice.t -> Unit.t monad
+ val sendVec : Word8VectorSlice.t -> Unit.t monad
+end = struct
+ open PollLoop Async
+
+ exception Closed
+
+ type socket = Socket.active INetSock.stream_sock
+
+ type 'a monad = socket -> (Exn.t, 'a) Sum.t Async.Event.t
+ fun error e _ =
+ case IVar.new ()
+ of result => (IVar.fill result (INL e) ; IVar.read result)
+ fun return x _ =
+ case IVar.new ()
+ of result => (IVar.fill result (INR x) ; IVar.read result)
+ fun (xM >>= x2yM) socket =
+ case IVar.new ()
+ of result =>
+ ((when (xM socket))
+ (fn INL e => IVar.fill result (INL e)
+ | INR x =>
+ (when (x2yM x socket))
+ (IVar.fill result))
+ ; IVar.read result)
+
+ local
+ fun mk toIODesc poll s = let
+ val ch = IVar.new ()
+ val pollDesc = poll (valOf (OS.IO.pollDesc (toIODesc s)))
+ in
+ addDesc
+ (pollDesc, fn _ => (IVar.fill ch (INR s) ; remDesc pollDesc))
+ ; IVar.read ch
+ end
+ in
+ fun sockEvt ? = mk Socket.ioDesc ?
+ (*fun iodEvt ? = mk id ?*)
+ end
+
+ fun recv fullSlice =
+ recur fullSlice (fn lp =>
+ fn slice =>
+ if Word8ArraySlice.isEmpty slice
+ then return fullSlice
+ else sockEvt OS.IO.pollIn >>= (fn socket =>
+ case Socket.recvArrNB (socket, slice)
+ of NONE => error (Fail "impossible")
+ | SOME 0 => error Closed
+ | SOME n =>
+ lp (Word8ArraySlice.subslice (slice, n, NONE))))
+
+ local
+ fun mk isEmpty subslice sendNB slice =
+ recur slice (fn lp =>
+ fn slice =>
+ if isEmpty slice
+ then return ()
+ else sockEvt OS.IO.pollOut >>= (fn socket =>
+ case sendNB (socket, slice)
+ of NONE => error (Fail "impossible")
+ | SOME 0 => error Closed
+ | SOME n =>
+ lp (subslice (slice, n, NONE))))
+ in
+ val sendArr =
+ mk Word8ArraySlice.isEmpty Word8ArraySlice.subslice Socket.sendArrNB
+
+ val sendVec =
+ mk Word8VectorSlice.isEmpty Word8VectorSlice.subslice Socket.sendVecNB
+ end
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/socket-events.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example
___________________________________________________________________
Name: svn:ignore
+ generated
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/Build.bgb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/Build.bgb 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/Build.bgb 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,8 @@
+;; 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.
+
+(bg-build
+ :name "RPC-lib example"
+ :shell "nice -n5 ./Build.sh")
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/Build.sh
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/Build.sh 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/Build.sh 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,26 @@
+#!/bin/bash
+
+# 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.
+
+set -e
+set -x
+
+mkdir -p generated
+
+function Compile {
+ mlton -mlb-path-var "MLTON_LIB $(cd ../../../../../.. && pwd)" \
+ -mlb-path-var "SML_COMPILER mlton" \
+ -mlb-path-var "APPLICATION $(pwd)/app" \
+ -prefer-abs-paths true \
+ -show-def-use "generated/$1.du" \
+ -output "generated/$1" \
+ "$1.mlb"
+ strip "generated/$1"
+ ls -l "generated/$1"
+}
+
+Compile server
+Compile client
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/Build.sh
___________________________________________________________________
Name: svn:executable
+ *
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/app/generic.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/app/generic.mlb 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/app/generic.mlb 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,24 @@
+(* 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.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
+in
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/generic.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/type-info.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/type-hash.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/hash.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/pretty.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/eq.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/some.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/pickle.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/read.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/close-pretty-with-extra.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/reg-basis-exns.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/types.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/types-$(SML_COMPILER).sml
+end
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.mlb 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.mlb 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,21 @@
+(* 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.
+ *)
+
+$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+../lib-client.mlb
+
+$(APPLICATION)/generic.mlb
+
+ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+in
+ local
+ client.sml
+ in
+ end
+end
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.sml 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.sml 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,31 @@
+(* 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.
+ *)
+
+val conn = Client.Conn.byName {host = "127.0.0.1", port = 4321}
+
+local
+ fun mk signature' conn =
+ Client.Reply.sync o Client.declare signature' conn
+in
+ val bind = mk (Pair.t (String.t, Int.t), Unit.t, "bind") conn
+ val find = mk (String.t, Option.t Int.t, "find") conn
+ val bindings =
+ mk (Unit.t, List.t (Pair.t (String.t, Int.t)), "bindings") conn
+end
+
+fun tell x =
+ printlns [x, " => ",
+ case find x
+ of NONE => "undefined"
+ | SOME x => Int.toString x]
+
+val () =
+ (tell "x"
+ ; bind ("x", 1234)
+ ; tell "x"
+ ; println (Generic.show (List.t (Pair.t (String.t, Int.t))) (bindings ())))
+
+val () = Client.Conn.close conn
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/client.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.mlb 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.mlb 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,21 @@
+(* 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.
+ *)
+
+$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+../lib-server.mlb
+
+$(APPLICATION)/generic.mlb
+
+ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+in
+ local
+ server.sml
+ in
+ end
+end
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.sml 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.sml 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,21 @@
+(* 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.
+ *)
+
+local
+ val assoc : (String.t * Int.t) List.t Ref.t = ref []
+in
+ fun bind (k, v) = assoc := (k, v) :: List.filter (notEq k o #1) (!assoc)
+ fun find k = Option.map #2 (List.find (eq k o #1) (!assoc))
+ 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}
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/example/server.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-client.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-client.mlb 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-client.mlb 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,29 @@
+(* 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.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
+ $(MLTON_LIB)/com/ssh/async/unstable/lib.mlb
+ $(MLTON_LIB)/com/ssh/async/unstable/example/poll-loop/lib.mlb
+
+ $(APPLICATION)/generic.mlb
+
+ detail/protocol.mlb
+in
+ ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
+ local
+ public/client/client.sig
+ detail/client.sml
+ in
+ public/client/export.sml
+ end
+ end
+end
Added: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb 2008-10-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,29 @@
+(* 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.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
+ $(MLTON_LIB)/com/ssh/async/unstable/lib.mlb
+ $(MLTON_LIB)/com/ssh/async/unstable/example/poll-loop/lib.mlb
+
+ $(APPLICATION)/generic.mlb
+
+ detail/protocol.mlb
+in
+ ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
+ local
+ public/server/server.sig
+ detail/server.sml
+ in
+ public/server/export.sml
+ end
+ end
+end
Added: 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-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/client.sig 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,24 @@
+(* 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 CLIENT = sig
+ exception Unknown
+ exception ProtocolMismatch
+
+ structure Conn : sig
+ type t
+ val close : t Effect.t
+ val byName : {host : String.t, port : Int.t} -> t
+ (*val spawn : {exe : String.t, port : Int.t} -> t*)
+ end
+
+ structure Reply : sig
+ type 'a t
+ val sync : 'a t -> 'a
+ end
+
+ val declare : 'd Rep.t * 'c Rep.t * String.t -> Conn.t -> 'd -> 'c Reply.t
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/client.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: 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-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/export.sml 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,8 @@
+(* 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 CLIENT = CLIENT
+structure Client : CLIENT = Client
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/client/export.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: 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-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/export.sml 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,8 @@
+(* 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 SERVER = SERVER
+structure Server : SERVER = Server
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/export.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: 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-13 01:09:19 UTC (rev 6921)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/server.sig 2008-10-13 08:11:10 UTC (rev 6922)
@@ -0,0 +1,11 @@
+(* 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 SERVER = sig
+ val run : {port : Int.t,
+ accept : INetSock.sock_addr UnPr.t} Effect.t
+ val define : 'd Rep.t * 'c Rep.t * String.t -> ('d -> 'c) Effect.t
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/public/server/server.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list