Slave dispatching working

diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg
index 421db04..d237b52 100644 (file)
--- a/configDefault/domtool.cfg
+++ b/configDefault/domtool.cfg
@@ -14,7 +14,7 @@ val defaultRetry = 900
 val defaultExpiry = 1209600
 val defaultMinimum = 3600
 
 val defaultExpiry = 1209600
 val defaultMinimum = 3600
 

-val nodeIps = [("this", "1.2.3.4")]
+val nodeIps = [("this", "127.0.0.1"), ("kirillov", "127.0.0.1")]

 val defaultNode = "this"
 
 val aclFile = "/home/adamc/fake/acl"
 val defaultNode = "this"
 
 val aclFile = "/home/adamc/fake/acl"


@@ -25,6 +25,7 @@ val defaultDomain = "hcoop.net"
 
 val dispatcher = "localhost"
 val dispatcherPort = 1234
 
 val dispatcher = "localhost"
 val dispatcherPort = 1234

+val slavePort = 1235

 val queueSize = 5
 
 val bufSize = 1024
 val queueSize = 5
 
 val bufSize = 1024


@@ -36,3 +37,4 @@ val serverKey = "/home/adamc/fake/serverkey.pem"
 val certDir = "/home/adamc/fake/certs"
 val keyDir = "/home/adamc/fake/keys"
 
 val certDir = "/home/adamc/fake/certs"
 val keyDir = "/home/adamc/fake/keys"
 

+val dispatcherName = "hcoop.net"

diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs
index 2d3bc14..7ffc30d 100644 (file)
--- a/configDefault/domtool.cfs
+++ b/configDefault/domtool.cfs
@@ -34,6 +34,7 @@ val defaultDomain : string
 
 val dispatcher : string
 val dispatcherPort : int
 
 val dispatcher : string
 val dispatcherPort : int

+val slavePort : int

 val queueSize : int
 
 val bufSize : int
 val queueSize : int
 
 val bufSize : int


@@ -44,3 +45,5 @@ val serverKey : string
 
 val certDir : string
 val keyDir : string
 
 val certDir : string
 val keyDir : string

+
+val dispatcherName : string

diff --git a/openssl/openssl_sml.c b/openssl/openssl_sml.c
index c475c30..ee57282 100644 (file)
--- a/openssl/openssl_sml.c
+++ b/openssl/openssl_sml.c
@@ -244,3 +244,7 @@ BIO *OpenSSL_SML_pop(BIO *b) {
 BIO *OpenSSL_SML_next(BIO *b) {
   return BIO_next(b);
 }
 BIO *OpenSSL_SML_next(BIO *b) {
   return BIO_next(b);
 }

+
+int OpenSSL_SML_puts(BIO *b, const char *buf) {
+  return BIO_puts(b, buf);
+}

diff --git a/openssl/openssl_sml.h b/openssl/openssl_sml.h
index 6b02579..0568d29 100644 (file)
--- a/openssl/openssl_sml.h
+++ b/openssl/openssl_sml.h
@@ -58,3 +58,5 @@ BIO *OpenSSL_SML_new_accept(SSL_CTX *ctx, char *port);
 
 BIO *OpenSSL_SML_pop(BIO *b);
 BIO *OpenSSL_SML_next(BIO *b);
 
 BIO *OpenSSL_SML_pop(BIO *b);
 BIO *OpenSSL_SML_next(BIO *b);

+
+int OpenSSL_SML_puts(BIO *b, const char *buf);

diff --git a/src/domain.sig b/src/domain.sig
index 003dd2b..7ea6689 100644 (file)
--- a/src/domain.sig
+++ b/src/domain.sig
@@ -57,4 +57,6 @@ signature DOMAIN = sig
     val your_groups : unit -> DataStructures.StringSet.set
     val your_paths : unit -> DataStructures.StringSet.set
     (* UNIX users, groups, and paths the user may act with *)
     val your_groups : unit -> DataStructures.StringSet.set
     val your_paths : unit -> DataStructures.StringSet.set
     (* UNIX users, groups, and paths the user may act with *)

+
+    val set_context : OpenSSL.context -> unit

 end
 end

diff --git a/src/domain.sml b/src/domain.sml
index 2d566a3..38993a2 100644 (file)
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -20,9 +20,14 @@
 
 structure Domain :> DOMAIN = struct
 
 
 structure Domain :> DOMAIN = struct
 

+open MsgTypes
+

 structure SM = DataStructures.StringMap
 structure SS = DataStructures.StringSet
 
 structure SM = DataStructures.StringMap
 structure SS = DataStructures.StringSet
 

+val ssl_context = ref (NONE : OpenSSL.context option)
+fun set_context ctx = ssl_context := SOME ctx
+

 val nodes = map #1 Config.nodeIps
 val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
                    SM.empty Config.nodeIps
 val nodes = map #1 Config.nodeIps
 val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
                    SM.empty Config.nodeIps


@@ -408,8 +413,8 @@ fun findAllDiffs () =
                            before Posix.FileSys.closedir dir
                        end
                in
                            before Posix.FileSys.closedir dir
                        end
                in

-                   explore (OS.Path.joinDirFile {dir = Config.tmpDir,
-                                                 file = site}, diffs)
+                   exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
+                                                               file = site}, diffs))

                end
     in
        exploreSites []
                end
     in
        exploreSites []


@@ -545,12 +550,49 @@ val () = Env.registerPost (fn () =>
                              in
                                  if !ErrorMsg.anyErrors then
                                      ()
                              in
                                  if !ErrorMsg.anyErrors then
                                      ()

-                                 else
-                                     Slave.handleChanges (map #2 diffs);
+                                 else let
+                                         val changed = foldl (fn ((site, file), changed) =>
+                                                                 let
+                                                                     val ls = case SM.find (changed, site) of
+                                                                                  NONE => []
+                                                                                | SOME ls => ls
+                                                                 in
+                                                                     SM.insert (changed, site, file :: ls)
+                                                                 end) SM.empty diffs
+
+                                         fun handleSite (site, files) =
+                                             let
+                                                 
+                                             in
+                                                 print ("New configuration for node " ^ site ^ "\n");
+                                                 if site = Config.defaultNode then
+                                                     Slave.handleChanges files
+                                                 else let
+                                                         val bio = OpenSSL.connect (valOf (!ssl_context),
+                                                                                    nodeIp site
+                                                                                    ^ ":"
+                                                                                    ^ Int.toString Config.slavePort)
+                                                     in
+                                                         app (fn file => Msg.send (bio, MsgFile file)) files;
+                                                         Msg.send (bio, MsgDoFiles);
+                                                         case Msg.recv bio of
+                                                             NONE => print "Slave closed connection unexpectedly\n"
+                                                           | SOME m =>
+                                                             case m of
+                                                                 MsgOk => print ("Slave " ^ site ^ " finished\n")
+                                                               | MsgError s => print ("Slave " ^ site
+                                                                                      ^ " returned error: " ^
+                                                                                      s ^ "\n")
+                                                               | _ => print ("Slave " ^ site
+                                                                             ^ " returned unexpected command\n");
+                                                         OpenSSL.close bio
+                                                     end
+                                             end
+                                     in
+                                         SM.appi handleSite changed
+                                     end;

                                  ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
                                                     fn cl => "Temp file cleanup failed: " ^ cl))
                              end)
 
                                  ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
                                                     fn cl => "Temp file cleanup failed: " ^ cl))
                              end)
 

-
-

 end
 end

diff --git a/src/domtool.cm b/src/domtool.cm
index d1988c3..d10f96d 100644 (file)
--- a/src/domtool.cm
+++ b/src/domtool.cm
@@ -53,6 +53,10 @@ slave.sml
 defaults.sig
 defaults.sml
 
 defaults.sig
 defaults.sml
 

+msgTypes.sml
+msg.sig
+msg.sml
+

 domain.sig
 domain.sml
 
 domain.sig
 domain.sml
 

diff --git a/src/main.sig b/src/main.sig
index ef13569..69abb82 100644 (file)
--- a/src/main.sig
+++ b/src/main.sig
@@ -32,5 +32,6 @@ signature MAIN = sig
 
     val request : string -> unit
     val service : unit -> unit
 
     val request : string -> unit
     val service : unit -> unit

+    val slave : unit -> unit

 
 end
 
 end

diff --git a/src/main.sml b/src/main.sml
index e0beaf2..734b10a 100644 (file)
--- a/src/main.sml
+++ b/src/main.sml
@@ -20,7 +20,7 @@
 
 structure Main :> MAIN = struct
 
 
 structure Main :> MAIN = struct
 

-open Ast Print
+open Ast MsgTypes Print

 
 structure SM = StringMap
 
 
 structure SM = StringMap
 


@@ -69,19 +69,22 @@ fun check fname =
        val b = basis ()
     in
        if !ErrorMsg.anyErrors then
        val b = basis ()
     in
        if !ErrorMsg.anyErrors then

-           (b, NONE)
+           raise ErrorMsg.Error

        else
            let
                val _ = ErrorMsg.reset ()
                val prog = Parse.parse fname
            in
                if !ErrorMsg.anyErrors then
        else
            let
                val _ = ErrorMsg.reset ()
                val prog = Parse.parse fname
            in
                if !ErrorMsg.anyErrors then

-                   (Env.empty, NONE)
+                   raise ErrorMsg.Error

                else
                    let
                        val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
                    in
                else
                    let
                        val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
                    in

-                       (G', #3 prog)
+                       if !ErrorMsg.anyErrors then
+                           raise ErrorMsg.Error
+                       else
+                           (G', #3 prog)

                    end
            end
     end
                    end
            end
     end


@@ -111,14 +114,23 @@ fun eval fname =
     case reduce fname of
        (SOME body') =>
        if !ErrorMsg.anyErrors then
     case reduce fname of
        (SOME body') =>
        if !ErrorMsg.anyErrors then

-           ()
+           raise ErrorMsg.Error

        else
            Eval.exec (Defaults.eInit ()) body'
        else
            Eval.exec (Defaults.eInit ()) body'

-      | NONE => ()
+      | NONE => raise ErrorMsg.Error

 
 val dispatcher =
     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 
 
 val dispatcher =
     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 

+fun hostname () =
+    let
+       val inf = TextIO.openIn "/etc/hostname"
+    in
+       case TextIO.inputLine inf of
+           NONE => (TextIO.closeIn inf; raise Fail "No line in /etc/hostname")
+         | SOME line => (TextIO.closeIn inf; String.substring (line, 0, size line - 1))
+    end
+

 fun request fname =
     let
        val uid = Posix.ProcEnv.getuid ()
 fun request fname =
     let
        val uid = Posix.ProcEnv.getuid ()


@@ -136,14 +148,22 @@ fun request fname =
 
        val inf = TextIO.openIn fname
 
 
        val inf = TextIO.openIn fname
 

-       fun loop () =
+       fun loop lines =

            case TextIO.inputLine inf of
            case TextIO.inputLine inf of

-               NONE => ()
-             | SOME line => (OpenSSL.writeAll (bio, line);
-                             loop ())
+               NONE => String.concat (List.rev lines)
+             | SOME line => loop (line :: lines)
+
+       val code = loop []

     in
     in

-       loop ();

        TextIO.closeIn inf;
        TextIO.closeIn inf;

+       Msg.send (bio, MsgConfig code);
+       case Msg.recv bio of
+           NONE => print "Server closed connection unexpectedly.\n"
+         | SOME m =>
+           case m of
+               MsgOk => print "Configuration succeeded.\n"
+             | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
+             | _ => print "Unexpected server reply.\n";

        OpenSSL.close bio
     end
     handle ErrorMsg.Error => ()
        OpenSSL.close bio
     end
     handle ErrorMsg.Error => ()


@@ -155,6 +175,7 @@ fun service () =
        val context = OpenSSL.context (Config.serverCert,
                                       Config.serverKey,
                                       Config.trustStore)
        val context = OpenSSL.context (Config.serverCert,
                                       Config.serverKey,
                                       Config.trustStore)

+       val _ = Domain.set_context context

 
        val sock = OpenSSL.listen (context, Config.dispatcherPort)
 
 
        val sock = OpenSSL.listen (context, Config.dispatcherPort)
 


@@ -167,23 +188,95 @@ fun service () =
                    val () = print ("\nConnection from " ^ user ^ "\n")
                    val () = Domain.setUser user
 
                    val () = print ("\nConnection from " ^ user ^ "\n")
                    val () = Domain.setUser user
 

-                   val outname = OS.FileSys.tmpName ()
-                   val outf = TextIO.openOut outname
+                   fun cmdLoop () =
+                       case Msg.recv bio of
+                           NONE => (OpenSSL.close bio
+                                    handle OpenSSL.OpenSSL _ => ();
+                                    loop ())
+                         | SOME m =>
+                           case m of
+                               MsgConfig code =>
+                               let
+                                   val _ = print "Configuration:\n"
+                                   val _ = print code
+                                   val _ = print "\n"

 
 

-                   fun loop' () =
-                       case OpenSSL.readOne bio of
-                           NONE => ()
-                         | SOME line => (TextIO.output (outf, line);
-                                         loop' ())
+                                   val outname = OS.FileSys.tmpName ()
+                                   val outf = TextIO.openOut outname
+                               in
+                                   TextIO.output (outf, code);
+                                   TextIO.closeOut outf;
+                                   (eval outname;
+                                    Msg.send (bio, MsgOk))
+                                    handle ErrorMsg.Error =>
+                                           (print "Compilation error\n";
+                                            Msg.send (bio,
+                                                      MsgError "Error during configuration evaluation"))
+                                         | OpenSSL.OpenSSL s =>
+                                           (print "OpenSSL error\n";
+                                            Msg.send (bio,
+                                                      MsgError
+                                                          ("Error during configuration evaluation: "
+                                                           ^ s)));
+                                   OS.FileSys.remove outname;
+                                   (ignore (OpenSSL.readChar bio);
+                                    OpenSSL.close bio)
+                                   handle OpenSSL.OpenSSL _ => ();
+                                   loop ()
+                               end
+                             | _ =>
+                               (Msg.send (bio, MsgError "Unexpected command")
+                                handle OpenSSL.OpenSSL _ => ();
+                                OpenSSL.close bio
+                                handle OpenSSL.OpenSSL _ => ();
+                                loop ())
+               in
+                   cmdLoop ()
+               end
+    in
+       loop ();
+       OpenSSL.shutdown sock
+    end
+
+fun slave () =
+    let
+       val host = hostname ()
+
+       val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem",
+                                      Config.keyDir ^ "/" ^ host ^ ".pem",
+                                      Config.trustStore)
+
+       val sock = OpenSSL.listen (context, Config.slavePort)
+
+       fun loop () =
+           case OpenSSL.accept sock of
+               NONE => ()
+             | SOME bio =>
+               let
+                   val peer = OpenSSL.peerCN bio
+                   val () = print ("\nConnection from " ^ peer ^ "\n")

                in
                in

-                   (loop' ();
-                    TextIO.closeOut outf;
-                    eval outname
-                    handle ErrorMsg.Error => ();
-                    OS.FileSys.remove outname;
-                    OpenSSL.close bio)
-                   handle OpenSSL.OpenSSL _ => ();
-                   loop ()
+                   if peer <> Config.dispatcherName then
+                       (print "Not authorized!\n";
+                        OpenSSL.close bio;
+                        loop ())
+                   else let
+                           fun loop' files =
+                               case Msg.recv bio of
+                                   NONE => print "Dispatcher closed connection unexpectedly\n"
+                                 | SOME m =>
+                                   case m of
+                                       MsgFile file => loop' (file :: files)
+                                     | MsgDoFiles => (Slave.handleChanges files;
+                                                      Msg.send (bio, MsgOk))
+                                     | _ => (print "Dispatcher sent unexpected command\n";
+                                             Msg.send (bio, MsgError "Unexpected command"))
+                       in
+                           loop' [];
+                           ignore (OpenSSL.readChar bio);
+                           OpenSSL.close bio;
+                           loop ()
+                       end

                end
     in
        loop ();
                end
     in
        loop ();

diff --git a/src/msg.sig b/src/msg.sig
new file mode 100644 (file)
index 0000000..9b3ce1b
--- /dev/null
+++ b/src/msg.sig
@@ -0,0 +1,26 @@
+(* HCoop Domtool (http://hcoop.sourceforge.net/)
+ * Copyright (c) 2006, Adam Chlipala
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+ *)
+
+(* Network messages *)
+
+signature MSG = sig
+
+val send : OpenSSL.bio * MsgTypes.msg -> unit
+val recv : OpenSSL.bio -> MsgTypes.msg option
+
+end

diff --git a/src/msg.sml b/src/msg.sml
new file mode 100644 (file)
index 0000000..4dcc3ff
--- /dev/null
+++ b/src/msg.sml
@@ -0,0 +1,75 @@
+(* HCoop Domtool (http://hcoop.sourceforge.net/)
+ * Copyright (c) 2006, Adam Chlipala
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+ *)
+
+(* Network messages *)
+
+structure Msg :> MSG = struct
+
+open OpenSSL MsgTypes Slave
+
+val a2i = fn Add => 0
+          | Delete => 1
+          | Modify => 2
+
+val i2a = fn 0 => Add
+          | 1 => Delete
+          | 2 => Modify
+          | _ => raise OpenSSL.OpenSSL "Bad action number to deserialize"
+
+fun send (bio, m) =
+    case m of
+       MsgOk => OpenSSL.writeInt (bio, 1)
+      | MsgError s => (OpenSSL.writeInt (bio, 2);
+                      OpenSSL.writeString (bio, s))
+      | MsgConfig s => (OpenSSL.writeInt (bio, 3);
+                      OpenSSL.writeString (bio, s))
+      | MsgFile {action, domain, dir, file} =>
+       (OpenSSL.writeInt (bio, 4);
+        OpenSSL.writeInt (bio, a2i action);
+        OpenSSL.writeString (bio, domain);
+        OpenSSL.writeString (bio, dir);
+        OpenSSL.writeString (bio, file))
+      | MsgDoFiles => OpenSSL.writeInt (bio, 5)
+
+fun checkIt v =
+    case v of
+       NONE => raise OpenSSL.OpenSSL "Bad Msg format"
+      | _ => v
+
+fun recv bio =
+    case OpenSSL.readInt bio of
+       NONE => NONE
+      | SOME n =>
+       checkIt (case n of
+                    1 => SOME MsgOk
+                  | 2 => Option.map MsgError (OpenSSL.readString bio)
+                  | 3 => Option.map MsgConfig (OpenSSL.readString bio)
+                  | 4 => (case (OpenSSL.readInt bio,
+                                OpenSSL.readString bio,
+                                OpenSSL.readString bio,
+                                OpenSSL.readString bio) of
+                              (SOME action, SOME domain, SOME dir, SOME file) =>
+                              SOME (MsgFile {action = i2a action,
+                                             domain = domain,
+                                             dir = dir,
+                                             file = file})
+                            | _ => NONE)
+                  | 5 => SOME MsgDoFiles
+                  | _ => NONE)
+        
+end

diff --git a/src/msgTypes.sml b/src/msgTypes.sml
new file mode 100644 (file)
index 0000000..1dfe16e
--- /dev/null
+++ b/src/msgTypes.sml
@@ -0,0 +1,35 @@
+(* HCoop Domtool (http://hcoop.sourceforge.net/)
+ * Copyright (c) 2006, Adam Chlipala
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+ *)
+
+(* Network message data structures *)
+
+structure MsgTypes = struct
+
+datatype msg =
+        MsgOk
+       (* Your request was processed successfully. *)
+       | MsgError of string
+       (* Your request went wrong in some way. *)
+       | MsgConfig of string
+       (* Configuration source code *)
+       | MsgFile of Slave.file_status
+       (* The status of a configuration file has changed. *)
+       | MsgDoFiles
+       (* Perform the actions associated with the MsgFiles sent previously. *)
+
+end

diff --git a/src/openssl.sig b/src/openssl.sig
index 3179103..82cec65 100644 (file)
--- a/src/openssl.sig
+++ b/src/openssl.sig
@@ -28,8 +28,16 @@ type context
 type bio
 type listener
 
 type bio
 type listener
 

-val readOne : bio -> string option
-val writeAll : bio * string -> unit
+val readChar : bio -> char option
+val readInt : bio -> int option
+val readLen : bio * int -> string option
+val readChunk : bio -> string option
+val readString : bio -> string option
+
+val writeChar : bio * char -> unit
+val writeInt : bio * int -> unit
+val writeString' : bio * string -> unit
+val writeString : bio * string -> unit

 
 val context : string * string * string -> context
 
 
 val context : string * string * string -> context
 

diff --git a/src/openssl.sml b/src/openssl.sml
index dd9fa7d..7a062f1 100644 (file)
--- a/src/openssl.sml
+++ b/src/openssl.sml
@@ -59,42 +59,174 @@ fun ssl_err s =
 
 val readBuf : (C.uchar, C.rw) C.obj C.ptr' = C.alloc' C.S.uchar (Word.fromInt Config.bufSize)
 val bufSize = Int32.fromInt Config.bufSize
 
 val readBuf : (C.uchar, C.rw) C.obj C.ptr' = C.alloc' C.S.uchar (Word.fromInt Config.bufSize)
 val bufSize = Int32.fromInt Config.bufSize

+val one = Int32.fromInt 1
+val four = Int32.fromInt 4

 
 

-fun readOne bio =
+val eight = Word.fromInt 8
+val sixteen = Word.fromInt 16
+val twentyfour = Word.fromInt 24
+
+val mask1 = Word32.fromInt 255
+
+fun readChar bio =
+    let
+       val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, one)
+    in
+       if r = 0 then
+           NONE
+       else if r < 0 then
+           (ssl_err "BIO_read";
+            raise OpenSSL "BIO_read failed")
+       else
+           SOME (chr (Word32.toInt (C.Get.uchar'
+                                        (C.Ptr.sub' C.S.uchar (readBuf, 0)))))
+    end
+
+fun readInt bio =
+    let
+       val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, four)
+    in
+       if r = 0 then
+           NONE
+       else if r < 0 then
+           (ssl_err "BIO_read";
+            raise OpenSSL "BIO_read failed")
+       else
+           SOME (Word32.toInt
+                     (Word32.+
+                      (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0)),
+                       Word32.+
+                       (Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1)),
+                                   eight),
+                        Word32.+
+                        (Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2)),
+                                    sixteen),
+                         Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3)),
+                                    twentyfour))))))
+    end
+
+fun readLen (bio, len) =
+    let
+       val buf =
+           if len > Config.bufSize then
+               C.alloc' C.S.uchar (Word.fromInt len)
+           else
+               readBuf
+
+       fun cleanup () =
+           if len > Config.bufSize then
+               C.free' buf
+           else
+               ()
+
+       fun loop (buf', needed) =
+           let
+               val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' buf, Int32.fromInt len)
+           in
+               if r = 0 then
+                   (cleanup (); NONE)
+               else if r < 0 then
+                   (cleanup ();
+                    ssl_err "BIO_read";
+                    raise OpenSSL "BIO_read failed")
+               else if r = needed then
+                   SOME (CharVector.tabulate (Int32.toInt needed,
+                                           fn i => chr (Word32.toInt (C.Get.uchar'
+                                                                          (C.Ptr.sub' C.S.uchar (buf, i))))))
+               else
+                   loop (C.Ptr.|+! C.S.uchar (buf', Int32.toInt r), needed - r)
+           end
+    in
+       loop (buf, Int32.fromInt len)
+       before cleanup ()
+    end        
+
+fun readChunk bio =

     let
        val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize)
     in
        if r = 0 then
            NONE
        else if r < 0 then
     let
        val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize)
     in
        if r = 0 then
            NONE
        else if r < 0 then

-           raise OpenSSL "BIO_read failed"
+           (ssl_err "BIO_read";
+            raise OpenSSL "BIO_read failed")

        else
            SOME (CharVector.tabulate (Int32.toInt r,
                                    fn i => chr (Word32.toInt (C.Get.uchar'
                                                                   (C.Ptr.sub' C.S.uchar (readBuf, i))))))
     end
 
        else
            SOME (CharVector.tabulate (Int32.toInt r,
                                    fn i => chr (Word32.toInt (C.Get.uchar'
                                                                   (C.Ptr.sub' C.S.uchar (readBuf, i))))))
     end
 

-fun writeAll (bio, s) =
+fun readString bio =
+    case readInt bio of
+       NONE => NONE
+      | SOME len => readLen (bio, len)
+
+fun writeChar (bio, ch) =

     let
     let

-       val buf = ZString.dupML' s
+       val _ = C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
+                             Word32.fromInt (ord ch))
+
+       fun trier () =
+           let
+               val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' readBuf, one)
+           in
+               if r = 0 then
+                   trier ()
+               else if r < 0 then
+                   (ssl_err "BIO_write";
+                    raise OpenSSL "BIO_write")
+               else
+                   ()
+           end
+    in
+       trier ()
+    end
+
+fun writeInt (bio, n) =
+    let
+       val w = Word32.fromInt n
+
+       val _ = (C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
+                              Word32.andb (w, mask1));
+                C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1),
+                              Word32.andb (Word32.>> (w, eight), mask1));
+                C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2),
+                              Word32.andb (Word32.>> (w, sixteen), mask1));
+                C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3),
+                              Word32.andb (Word32.>> (w, twentyfour), mask1)))

 
 

-       fun loop (buf, len) =
+       fun trier (buf, count) =

            let
            let

-               val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, len)
+               val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, count)

            in
            in

-               if r = len then
+               if r < 0 then
+                   (ssl_err "BIO_write";
+                    raise OpenSSL "BIO_write")
+               else if r = count then

                    ()
                    ()

-               else if r <= 0 then
-                   (C.free' buf;
-                    raise OpenSSL "BIO_write failed")

                else
                else

-                   loop (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), Int32.- (len, r))
+                   trier (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), count - r)

            end
     in
            end
     in

-       loop (buf, Int32.fromInt (size s));
-       C.free' buf
+       trier (readBuf, 4)
+    end        
+
+fun writeString' (bio, s) =
+    let
+       val buf = ZString.dupML' s
+    in
+       if F_OpenSSL_SML_puts.f' (bio, buf) <= 0 then
+           (C.free' buf;
+            ssl_err "BIO_puts";
+            raise OpenSSL "BIO_puts")
+       else
+           C.free' buf

     end
 
     end
 

+fun writeString (bio, s) =
+    (writeInt (bio, size s);
+     writeString' (bio, s))
+

 fun context (chain, key, root) =
     let
        val context = F_OpenSSL_SML_CTX_new.f' (F_OpenSSL_SML_SSLv23_method.f' ())
 fun context (chain, key, root) =
     let
        val context = F_OpenSSL_SML_CTX_new.f' (F_OpenSSL_SML_SSLv23_method.f' ())

diff --git a/src/slave.sml b/src/slave.sml
index 4e44a8b..b1303b8 100644 (file)
--- a/src/slave.sml
+++ b/src/slave.sml
@@ -29,7 +29,7 @@ type file_status = {action : file_action,
                    domain : string,
                    dir : string,
                    file : string}
                    domain : string,
                    dir : string,
                    file : string}

-                  
+

 val fileHandler = ref (fn _ : file_status => ())
 val preHandler = ref (fn () => ())
 val postHandler = ref (fn () => ())
 val fileHandler = ref (fn _ : file_status => ())
 val preHandler = ref (fn () => ())
 val postHandler = ref (fn () => ())

diff --git a/tests/testApacheMulti.dtl b/tests/testApacheMulti.dtl
new file mode 100644 (file)
index 0000000..161d176
--- /dev/null
+++ b/tests/testApacheMulti.dtl
@@ -0,0 +1,9 @@
+domain "hcoop.net" with
+
+       vhost "www" where
+               WebNodes = ["kirillov"]
+       with
+               serverAlias "hcoop.net";
+               addDefaultCharset "mumbo-jumbo/incomprehensible"
+       end;
+end