[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