[MLton-commit] r5466
Vesa Karvonen
vesak at mlton.org
Sun Mar 25 23:24:43 PST 2007
Restructured and partly rewrote a simplistic smlbot for the async
programming library. Currently untested.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/poll-loop.sml
A mltonlib/trunk/com/ssh/async/unstable/example/smlbot/
A mltonlib/trunk/com/ssh/async/unstable/example/smlbot/Makefile
A mltonlib/trunk/com/ssh/async/unstable/example/smlbot/allowed-modules
A mltonlib/trunk/com/ssh/async/unstable/example/smlbot/main.sml
A mltonlib/trunk/com/ssh/async/unstable/example/smlbot/make-sandbox-prefix.sh
A mltonlib/trunk/com/ssh/async/unstable/example/smlbot/run-sandboxed-sml.sh
A mltonlib/trunk/com/ssh/async/unstable/example/smlbot/show-bindings.sml
A mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb
A mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.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-25 18:01:57 UTC (rev 5465)
+++ mltonlib/trunk/com/ssh/async/unstable/example/poll-loop/poll-loop.sml 2007-03-26 07:24:42 UTC (rev 5466)
@@ -35,7 +35,7 @@
recur ([] & !timeouts) (fn lp =>
fn fs & [] => here fs [(absTime, action)]
| fs & e::es => if Time.<= (#1e, absTime) then lp (e::fs & es)
- else here fs ((absTime, action)::es))
+ else here fs ((absTime, action)::es))
end
fun relTimeout (relTime, action) =
absTimeout (Time.+ (Time.now (), relTime), action)
Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/smlbot
___________________________________________________________________
Name: svn:ignore
+ generated
Added: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/Makefile
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/Makefile 2007-03-25 18:01:57 UTC (rev 5465)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/Makefile 2007-03-26 07:24:42 UTC (rev 5466)
@@ -0,0 +1,61 @@
+# 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.
+
+##########################################################################
+
+target-arch := $(shell mlton -show path-map | awk '/^TARGET_ARCH/ {print $$2}')
+target-os := $(shell mlton -show path-map | awk '/^TARGET_OS/ {print $$2}')
+target-id := $(target-arch)-$(target-os)
+
+gen-dir := generated/$(target-id)
+
+mlb-path-map := $(gen-dir)/mlb-path-map
+
+smlbot-exe := $(gen-dir)/smlbot
+
+ifeq ($(target-os),mingw)
+link-opt :=
+else
+link-opt := -link-opt -ldl
+endif
+
+##########################################################################
+
+.PHONY : all clean help
+
+help :
+ @echo "Targets:"
+ @echo " all Builds the SML bot"
+ @echo " clean Removes generated files"
+ @echo " help You are reading it"
+
+all : $(smlbot-exe)
+
+clean :
+ rm -rf $(gen-dir)
+
+##########################################################################
+
+$(mlb-path-map) : Makefile
+ mkdir -p $(@D)
+ echo 'MLTON_LIB $(shell cd ../../../../../.. && pwd)' > $@
+ echo 'SML_COMPILER mlton' >> $@
+
+$(smlbot-exe) : smlbot.mlb $(mlb-path-map)
+ mlton -stop f -mlb-path-map $(mlb-path-map) $< \
+ | sed $$'s#\r##g' \
+ | awk 'BEGIN { printf "$@ :" } { printf " " $$1 }' \
+ > $@.dep
+ mlton -mlb-path-map $(mlb-path-map) \
+ -prefer-abs-paths true \
+ -show-def-use $@.du \
+ -const 'Exn.keepHistory true' \
+ $(link-opt) \
+ -output $@ \
+ $<
+
+##########################################################################
+
+include $(wildcard $(gen-dir)/*.dep)
Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/Makefile
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/allowed-modules
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/allowed-modules 2007-03-25 18:01:57 UTC (rev 5465)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/allowed-modules 2007-03-26 07:24:42 UTC (rev 5466)
@@ -0,0 +1,59 @@
+structure Array
+structure Array2
+structure ArraySlice
+structure Bool
+structure Byte
+structure Char
+structure CharArray
+structure CharArraySlice
+structure CharMap
+structure CharVector
+structure CharVectorSlice
+structure Date
+structure FixedInt
+structure General
+structure IEEEReal
+structure Int
+structure Int31
+structure Int32
+structure Int64
+structure IntInf
+structure LargeInt
+structure LargeReal
+structure LargeWord
+structure List
+structure ListPair
+structure Math
+structure Option
+structure PackWord16Big
+structure PackWord16Little
+structure PackWord32Big
+structure PackWord32Little
+structure Position
+structure Real
+structure Real64
+structure Real64Array
+structure Real64ArraySlice
+structure Real64Vector
+structure Real64VectorSlice
+structure RealArray
+structure RealArraySlice
+structure RealVector
+structure RealVectorSlice
+structure String
+structure StringCvt
+structure Substring
+structure SysWord
+structure Text
+structure Time
+structure Vector
+structure VectorSlice
+structure Word
+structure Word31
+structure Word32
+structure Word64
+structure Word8
+structure Word8Array
+structure Word8ArraySlice
+structure Word8Vector
+structure Word8VectorSlice
Added: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/main.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/main.sml 2007-03-25 18:01:57 UTC (rev 5465)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/main.sml 2007-03-26 07:24:42 UTC (rev 5466)
@@ -0,0 +1,40 @@
+(* 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.
+ *)
+
+val () = let
+ val host = ref (SOME "127.0.0.1")
+ val port = ref (SOME "6667")
+ val pass = ref (SOME "smlbot")
+ val nick = ref (SOME "smlbot")
+ val channel = ref (SOME "#sml")
+ val get = valOf o !
+ fun set opt = opt <\ op := o SOME
+in
+ recur (CommandLine.arguments ()) (fn lp =>
+ fn [] =>
+ SMLBot.run {host = get host, port = get port,
+ pass = get pass, nick = get nick,
+ channel = get channel}
+ | "-help"::_ =>
+ print "Usage: smlbot [option ...]\n\
+ \\n\
+ \Options:\n\
+ \ -channel <channel>\n\
+ \ -host <host>\n\
+ \ -nick <nick>\n\
+ \ -pass <pass>\n\
+ \ -port <port>\n"
+ | opt::arg::rest =>
+ (set (case opt of
+ "-host" => host
+ | "-port" => port
+ | "-pass" => pass
+ | "-nick" => nick
+ | "-channel" => channel
+ | _ => fail ("Invalid option "^opt)) arg
+ ; lp rest)
+ | opt::_ => fail ("Invalid option "^opt))
+end
Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/main.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/make-sandbox-prefix.sh
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/make-sandbox-prefix.sh 2007-03-25 18:01:57 UTC (rev 5465)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/make-sandbox-prefix.sh 2007-03-26 07:24:42 UTC (rev 5466)
@@ -0,0 +1,24 @@
+#!/bin/bash
+
+# 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.
+
+set -e
+
+# Create sandbox
+echo 'val () = Control.Print.linewidth := 70
+fun print _ = raise Fail "IO not allowed"
+val use = print
+structure Poison = struct val IO_not_allowed = () end' \
+ > .sandbox-prefix.sml
+
+echo '' | \
+nice -n 19 sml show-bindings.sml | \
+grep -e 'structure' -e 'functor' | \
+grep -v -e 'structure _Core' | \
+eval grep -v `sed -e 's#^#-e "^#g' -e 's#$#$"#g' allowed-modules` | \
+sed -e 's#structure\(.*\)$#structure\1 = Poison#g' \
+ -e 's#functor\(.*\)$#functor\1 () = Poison#g' \
+ >> .sandbox-prefix.sml
Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/make-sandbox-prefix.sh
___________________________________________________________________
Name: svn:executable
+ *
Name: svn:eol-style
+ native
Added: 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-25 18:01:57 UTC (rev 5465)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/run-sandboxed-sml.sh 2007-03-26 07:24:42 UTC (rev 5466)
@@ -0,0 +1,21 @@
+#!/bin/bash
+
+# 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.
+
+set -e
+
+# Limit resource usage
+maxMem=1000000
+maxTime=30
+ulimit -v $maxMem -t $maxTime
+
+# Make sandbox-prefix if necessary
+if ! test -e .sandbox-prefix.sml ; then
+ ./make-sandbox-prefix.sh
+fi
+
+# Run the code from stdin
+exec nice -n 19 sml .sandbox-prefix.sml 2>&1
Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/run-sandboxed-sml.sh
___________________________________________________________________
Name: svn:executable
+ *
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/show-bindings.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/show-bindings.sml 2007-03-25 18:01:57 UTC (rev 5465)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/show-bindings.sml 2007-03-26 07:24:42 UTC (rev 5466)
@@ -0,0 +1,7 @@
+(* 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.
+ *)
+
+val () = CM.State.showBindings ()
Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/show-bindings.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb 2007-03-25 18:01:57 UTC (rev 5465)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb 2007-03-26 07:24:42 UTC (rev 5466)
@@ -0,0 +1,21 @@
+(* 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.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/misc-util/unstable/lib.mlb
+ ../../lib.mlb
+ ../poll-loop/lib.mlb
+
+ ann
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
+ smlbot.sml
+ main.sml
+ end
+in
+end
Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.mlb
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml
===================================================================
--- mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml 2007-03-25 18:01:57 UTC (rev 5465)
+++ mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml 2007-03-26 07:24:42 UTC (rev 5466)
@@ -0,0 +1,177 @@
+(* 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 SMLBot :> sig
+ val run : {host : String.t, port : String.t, pass : String.t,
+ nick : String.t, channel : String.t} Effect.t
+end = struct
+ structure W8V=Word8Vector and W8VS=Word8VectorSlice
+
+ open Async
+
+ fun when e f = Async.when (e, f)
+
+ fun relTimeout t = let
+ val v = IVar.new ()
+ in
+ PollLoop.relTimeout (t, IVar.fill v) ; IVar.read v
+ end
+
+ structure TextIO = struct
+ open TextIO
+ fun getReader i = #1 (TextIO.StreamIO.getReader (TextIO.getInstream i))
+ fun getIDesc i =
+ case getReader i of
+ TextPrimIO.RD {ioDesc = SOME d, ...} => d
+ | _ => fail "getIDesc"
+ fun readVecNB i =
+ case getReader i of
+ TextPrimIO.RD {chunkSize = n, readVecNB = SOME r, ...} => r n
+ | _ => fail "readVecNB"
+ end
+
+ local
+ fun mk toIODesc poll s = let
+ val ch = IVar.new ()
+ val pollDesc = poll (valOf (OS.IO.pollDesc (toIODesc s)))
+ in
+ PollLoop.addDesc
+ (pollDesc,
+ fn _ => (IVar.fill ch () ; PollLoop.remDesc pollDesc))
+ ; IVar.read ch
+ end
+ in
+ val sockEvt = mk Socket.ioDesc
+ val insEvt = mk TextIO.getIDesc OS.IO.pollIn
+ end
+
+ fun mkSender sock = let
+ val msgs = Mailbox.new ()
+ fun taking () =
+ (when (Mailbox.take msgs))
+ (fn msg => let
+ val v = String.toBytes (String.concatWith " " msg ^ "\r\n")
+ in
+ sending v (W8V.length v)
+ end)
+ and sending v =
+ fn 0 => waiting ()
+ | n => (when (sockEvt OS.IO.pollOut sock))
+ (fn () =>
+ (sending v)
+ (n-getOpt
+ (Socket.sendVecNB
+ (sock,
+ W8VS.slice (v, W8V.length v-n, NONE)),
+ 0)))
+ and waiting () =
+ (when (relTimeout (Time.fromSeconds 1)))
+ taking
+ in
+ taking () ; Mailbox.send msgs
+ end
+
+ fun mkRunner send = let
+ fun stripPrefix i s =
+ if #"-" = String.sub (s, i) andalso #" " = String.sub (s, i+1)
+ then String.extract (s, i+2, NONE)
+ else stripPrefix (i+1) s
+ val format =
+ List.filter (negate (String.isPrefix "[" orElse String.isPrefix "-"))
+ o String.tokens (eq #"\n") o stripPrefix 0
+ val jobs = Mailbox.new ()
+ fun taking () =
+ (when (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.closeOut outs
+ ; reading [] proc ins
+ end)
+ and reading ss proc ins =
+ (when (insEvt ins))
+ (fn () =>
+ case TextIO.readVecNB ins of
+ SOME "" => (TextIO.closeIn ins
+ ; ignore (Unix.reap proc)
+ ; send (format (concat (rev ss))) : Unit.t
+ ; taking ())
+ | SOME s => reading (s::ss) proc ins
+ | NONE => reading ss proc ins)
+ in
+ taking () ; Mailbox.send jobs
+ end
+
+ fun startReceiver sock send run = let
+ fun parse ss = let
+ open Substring
+ fun parseArgs args = let
+ val (mids, trail) = position " :" args
+ val mids = tokens (eq #" ") mids
+ val trail = if isEmpty trail then [] else [string (triml 2 trail)]
+ in
+ map string mids @ trail
+ end
+
+ fun parseCmd prefix rest = let
+ val (cmd, args) = splitl (notEq #" ") rest
+ in
+ {prefix = prefix, cmd = string cmd, args = parseArgs args}
+ end
+ in
+ if SOME #":" <> first ss then parseCmd NONE ss else let
+ val (prefix, rest) = splitl (notEq #" ") (triml 1 ss)
+ in
+ parseCmd (SOME (string prefix)) (triml 1 rest)
+ end
+ end
+
+ 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))
+
+ and dispatch {cmd, args, ...} =
+ (case String.toUpper cmd of
+ "PING" => send ["PONG", List.last args]
+ | "PRIVMSG" => let
+ val m = List.last args
+ in
+ if String.isPrefix "sml:" m
+ then run (String.extract (m, 4, NONE))
+ else ()
+ end
+ | _ => ()
+ ; receiving [])
+ in
+ receiving []
+ 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,
+ INetSock.toAddr
+ (NetHostDB.addr (valOf (NetHostDB.getByName host)),
+ valOf (Int.fromString port)))
+ ; app send [["PASS", pass],
+ ["NICK", nick],
+ ["USER", nick, "0", "*", nick],
+ ["JOIN", ch]]
+ ; startReceiver sock send run
+ ; PollLoop.run Handler.runAll
+ end)
+end
Property changes on: mltonlib/trunk/com/ssh/async/unstable/example/smlbot/smlbot.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list