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 dispatcher = "localhost"
val dispatcherPort = 1234
+val slavePort = 1235
val queueSize = 5
val bufSize = 1024
val certDir = "/home/adamc/fake/certs"
val keyDir = "/home/adamc/fake/keys"
+val dispatcherName = "hcoop.net"
val dispatcher : string
val dispatcherPort : int
+val slavePort : int
val queueSize : int
val bufSize : int
val certDir : string
val keyDir : string
+
+val dispatcherName : string
BIO *OpenSSL_SML_next(BIO *b) {
return BIO_next(b);
}
+
+int OpenSSL_SML_puts(BIO *b, const char *buf) {
+ return BIO_puts(b, buf);
+}
BIO *OpenSSL_SML_pop(BIO *b);
BIO *OpenSSL_SML_next(BIO *b);
+
+int OpenSSL_SML_puts(BIO *b, const char *buf);
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
structure Domain :> DOMAIN = struct
+open MsgTypes
+
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
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 []
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)
-
-
end
defaults.sig
defaults.sml
+msgTypes.sml
+msg.sig
+msg.sml
+
domain.sig
domain.sml
val request : string -> unit
val service : unit -> unit
+ val slave : unit -> unit
end
structure Main :> MAIN = struct
-open Ast Print
+open Ast MsgTypes Print
structure SM = StringMap
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
- (Env.empty, NONE)
+ raise ErrorMsg.Error
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
case reduce fname of
(SOME body') =>
if !ErrorMsg.anyErrors then
- ()
+ raise ErrorMsg.Error
else
Eval.exec (Defaults.eInit ()) body'
- | NONE => ()
+ | NONE => raise ErrorMsg.Error
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 ()
val inf = TextIO.openIn fname
- fun loop () =
+ fun loop lines =
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
- loop ();
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 => ()
val context = OpenSSL.context (Config.serverCert,
Config.serverKey,
Config.trustStore)
+ val _ = Domain.set_context context
val sock = OpenSSL.listen (context, Config.dispatcherPort)
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
- (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 ();
--- /dev/null
+(* 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
--- /dev/null
+(* 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
--- /dev/null
+(* 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
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 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
- 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
-fun writeAll (bio, s) =
+fun readString bio =
+ case readInt bio of
+ NONE => NONE
+ | SOME len => readLen (bio, len)
+
+fun writeChar (bio, ch) =
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
- 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
- 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
- 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
- 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
+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' ())
domain : string,
dir : string,
file : string}
-
+
val fileHandler = ref (fn _ : file_status => ())
val preHandler = ref (fn () => ())
val postHandler = ref (fn () => ())
--- /dev/null
+domain "hcoop.net" with
+
+ vhost "www" where
+ WebNodes = ["kirillov"]
+ with
+ serverAlias "hcoop.net";
+ addDefaultCharset "mumbo-jumbo/incomprehensible"
+ end;
+end