[MLton-commit] r5491
Vesa Karvonen
vesak at mlton.org
Sun Apr 1 21:03:08 PDT 2007
Towards session mode.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/poll-loop.sml
U mltonlib/trunk/com/ssh/async/unstable/example/smlbot/run-sandboxed-sml.sh
U mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb
U mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml
A mltonlib/trunk/com/ssh/async/unstable/example/smlbot/text-io.sml
A mltonlib/trunk/com/ssh/async/unstable/example/smlbot/text-prim-io.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/poll-loop.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/poll-loop.sml 2007-03-30 02:45:44 UTC (rev 5490)
+++ mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/poll-loop.sml 2007-04-02 04:03:07 UTC (rev 5491)
@@ -43,14 +43,17 @@
fun run ef =
(ef () : Unit.t
; if null (!descs) orelse !doStop then doStop := false else let
- val ds = map #1 (!descs)
- fun doPoll timeout = OS.IO.poll (ds, timeout)
- fun noTimeout ids =
- (app (fn id =>
- findDesc (OS.IO.infoToPollDesc id)
- (fn (_, (_, action), _) =>
- action id)) ids
- ; run ef)
+ val descs = (!descs)
+ fun doPoll timeout = OS.IO.poll (map #1 descs, timeout)
+ fun noTimeout is =
+ recur (is & descs) (fn lp =>
+ fn [] & _ => run ef
+ | _ & [] => fail "run"
+ | i::is & (da as (d, action))::das =>
+ if OS.IO.infoToPollDesc i = d then
+ (action i ; lp (is & da::das))
+ else
+ lp (i::is & das))
in
case List.pop timeouts of
NONE => noTimeout (doPoll NONE)
Modified: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/run-sandboxed-sml.sh
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/run-sandboxed-sml.sh 2007-03-30 02:45:44 UTC (rev 5490)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/run-sandboxed-sml.sh 2007-04-02 04:03:07 UTC (rev 5491)
@@ -7,23 +7,24 @@
set -e
-# Limit resource usage
-maxMem=1000000
-maxTime=30
-ulimit -v $maxMem -t $maxTime
+# Limit memory usage
+maxMem=10000000
+ulimit -v $maxMem
-# Make sandbox-prefix if necessary
-if ! test -e .sandbox-prefix.sml ; then
- ./make-sandbox-prefix.sh
-fi
+#maxTime=30
+#ulimit -t $maxTime
# Run the code from stdin
if test -d .hamlet-succ ; then
- # Using HaMLet successor with modified Basis
- cd .hamlet-succ
- exec nice -n 19 ./hamlet 2>&1
+ # Using HaMLet-S with modified Basis
+ exec nice -n 19 .hamlet-succ/hamlet 2>&1
else
+ # Make sandbox-prefix if necessary
+ if ! test -e .sandbox-prefix.sml ; then
+ ./make-sandbox-prefix.sh
+ fi
+
# Using sml/nj with the sandbox prefix
exec nice -n 19 sml .sandbox-prefix.sml 2>&1
fi
Modified: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb 2007-03-30 02:45:44 UTC (rev 5490)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb 2007-04-02 04:03:07 UTC (rev 5491)
@@ -11,9 +11,18 @@
../poll-loop/lib.mlb
ann
+ "forceUsed"
"sequenceNonUnit warn"
"warnUnused true"
in
+ text-io.sml
+ text-prim-io.sml
+ end
+
+ ann
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
smlbot.sml
main.sml
end
Modified: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml 2007-03-30 02:45:44 UTC (rev 5490)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml 2007-04-02 04:03:07 UTC (rev 5491)
@@ -32,6 +32,7 @@
end
in
val sockEvt = mk Socket.ioDesc
+ val iodEvt = mk id
end
fun mkSender sock = let
@@ -62,39 +63,64 @@
taking () ; Mailbox.send msgs
end
- val maxLines = 10
+ fun startSession send = let
+ open TextPrimIO Substring
+ val proc = Unix.execute ("./run-sandboxed-sml.sh", [])
+ val (ins, outs) = Unix.streamsOf proc
+ val (rd, inp) = TextIO.getReader ins
- fun mkRunner send = let
- fun stripPrefix i s =
- if #"\n" = String.sub (s, i) andalso
- #"-" = String.sub (s, i+1) andalso
- #" " = String.sub (s, i+2)
- then String.extract (s, i+3, NONE)
- else stripPrefix (i+1) s
- val format =
- (fn l => if length l <= maxLines then l else
- List.take (l, maxLines-1) @ ["..."]) o
- List.filter (negate (String.isPrefix "[" orElse String.isPrefix "-"))
- o String.tokens (eq #"\n") o stripPrefix 0
- val jobs = Mailbox.new ()
- fun taking () =
- (every (Mailbox.take jobs))
- (fn code => let
- val proc = Unix.execute ("./run-sandboxed-sml.sh", [])
- val (ins, outs) = Unix.streamsOf proc
- in
- TextIO.output (outs, code)
- ; TextIO.output1 (outs, #";")
- ; TextIO.closeOut outs
- ; send (format (TextIO.inputAll ins)) : Unit.t
- ; TextIO.closeIn ins
- ; ignore (Unix.reap proc)
- end)
+ val die = IVar.new ()
+
+ val rdDesc = RD.ioDesc rd
+ fun reading prefix =
+ (println "reading"
+ ; any [IVar.read die,
+ on (iodEvt OS.IO.pollIn rdDesc)
+ (fn () =>
+ case RD.readVecNB rd (RD.chunkSize rd) of
+ NONE => reading prefix
+ | SOME suffix =>
+ if "" = suffix then IVar.fill die () else
+ processLines (full (prefix ^ suffix)))])
+ and processLines inp = let
+ val (line, rest) = splitl (notEq #"\n") inp
+ in
+ if isEmpty rest then
+ reading (string inp)
+ else
+ (send (string line) : Unit.t ; processLines (triml 1 rest))
+ end
+
+ val wr = #1 (TextIO.getWriter outs)
+ val wrDesc = WR.ioDesc wr
+ val lines = Mailbox.new ()
+ fun waitingLines () =
+ (println "waitingLines"
+ ; any [IVar.read die,
+ on (Mailbox.take lines)
+ (fn line =>
+ writingLine (full (line ^ "\n")))])
+ and writingLine line =
+ (println "writingLine"
+ ; if isEmpty line then waitingLines () else
+ any [IVar.read die,
+ on (iodEvt OS.IO.pollOut wrDesc)
+ (fn () =>
+ case WR.writeVecNB wr line of
+ NONE => writingLine line
+ | SOME n => writingLine (triml n line))])
in
- taking () ; Mailbox.send jobs
+ when (IVar.read die)
+ (fn () => (print "Closing session... "
+ ; WR.close wr
+ ; RD.close rd
+ ; ignore (Unix.reap proc)
+ ; println "done"))
+ ; waitingLines () ; processLines (full inp)
+ ; {die = die, run = Mailbox.send lines}
end
- fun startReceiver sock send nick run = let
+ fun startReceiver sock send nick ch = let
fun parse ss = let
open Substring
fun parseArgs args = let
@@ -119,37 +145,53 @@
end
val prefix = nick ^ ":"
+ val reset = prefix ^ " (*) reset"
- fun receiving ("\n"::"\r"::ss) =
- dispatch (parse (Substring.full (concat (rev ss))))
- | receiving ss =
- (when (sockEvt OS.IO.pollIn sock))
- (fn () =>
- case Socket.recvVecNB (sock, 1) of
- NONE => receiving ss
- | SOME bs => receiving (String.fromBytes bs :: ss))
+ fun start () = startSession (fn l => send ["NOTICE", ch, ":" ^ l])
- and dispatch {cmd, args, ...} =
- (case String.toUpper cmd of
- "PING" => send ["PONG", List.last args]
+ fun receiving (session as {die, ...}) =
+ fn "\n"::"\r"::ss =>
+ dispatch session (parse (Substring.full (concat (rev ss))))
+ | ss =>
+ (println "receiving"
+ ; any [on (IVar.read die)
+ (fn () =>
+ receiving (start ()) ss),
+ on (sockEvt OS.IO.pollIn sock)
+ (fn () =>
+ case Socket.recvVecNB (sock, 1) of
+ NONE => receiving session ss
+ | SOME bs =>
+ if 0 = W8V.length bs then
+ IVar.fill die ()
+ else
+ receiving session (String.fromBytes bs :: ss))])
+
+ and dispatch (session as {run, die}) {cmd, args, ...} =
+ (println "dispatch"
+ ; case String.toUpper cmd of
+ "PING" => (send ["PONG", List.last args] ; receiving session [])
| "PRIVMSG" => let
val m = List.last args
in
- if String.isPrefix prefix m
- then run (String.extract (m, size prefix, NONE))
- else ()
+ if reset = m then
+ (IVar.fill die ()
+ ; receiving (start ()) [])
+ else if String.isPrefix prefix m then
+ (run (String.extract (m, size prefix, NONE))
+ ; receiving session [])
+ else
+ receiving session []
end
- | _ => ()
- ; receiving [])
+ | _ => receiving session [])
in
- receiving []
+ receiving (start ()) []
end
fun run {host, port, pass, nick, channel = ch} =
(With.for (With.around INetSock.TCP.socket Socket.close))
(fn sock => let
val send = mkSender sock
- val run = mkRunner (app (fn l => send ["NOTICE", ch, ":" ^ l]))
in
Socket.connect
(sock,
@@ -164,7 +206,7 @@
["NOTICE", ch,
":Hello, I'm "^nick^". Try writing \""^nick^
": <code>\"."]]
- ; startReceiver sock send nick run
+ ; startReceiver sock send nick ch
; PollLoop.run Handler.runAll
end)
end
Added: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/text-io.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/text-io.sml 2007-03-30 02:45:44 UTC (rev 5490)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/text-io.sml 2007-04-02 04:03:07 UTC (rev 5491)
@@ -0,0 +1,11 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure TextIO = struct
+ open TextIO
+ val getReader = StreamIO.getReader o getInstream
+ val getWriter = StreamIO.getWriter o getOutstream
+end
Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/text-io.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/text-prim-io.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/text-prim-io.sml 2007-03-30 02:45:44 UTC (rev 5490)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/text-prim-io.sml 2007-04-02 04:03:07 UTC (rev 5491)
@@ -0,0 +1,56 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure TextPrimIO = struct
+ open TextPrimIO
+
+ structure RD = struct
+ datatype t = datatype reader
+ local
+ fun S s (RD r) = s r
+ fun O s r a = valOf (S s r) a
+ in
+ val name = S#name
+ val chunkSize = S#chunkSize
+ val readVec = O#readVec
+ val readArr = O#readArr
+ val readVecNB = O#readVecNB
+ val readArrNB = O#readArrNB
+ val block = O#block
+ val canInput = O#canInput
+ val avail = pass () o S#avail
+ val getPos = O#getPos
+ val setPos = O#setPos
+ val endPos = O#endPos
+ val verifyPos = O#verifyPos
+ val close = pass () o S#close
+ val ioDesc = valOf o S#ioDesc
+ end
+ end
+
+ structure WR = struct
+ datatype t = datatype writer
+ local
+ fun S s (WR r) = s r
+ fun O s r a = valOf (S s r) a
+ in
+ val name = S#name
+ val chunkSize = S#chunkSize
+ val writeVec = O#writeVec
+ val writeArr = O#writeArr
+ val writeVecNB = O#writeVecNB
+ val writeArrNB = O#writeArrNB
+ val block = O#block
+ val canOutput = O#canOutput
+ val getPos = O#getPos
+ val setPos = O#setPos
+ val endPos = O#endPos
+ val verifyPos = O#verifyPos
+ val close = pass () o S#close
+ val ioDesc = valOf o S#ioDesc
+ end
+ end
+end
Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/text-prim-io.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list