From 8be753d995e728847df0fad81a01a1ad10180201 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 24 Feb 2008 20:36:46 +0000 Subject: [PATCH] Less noisy pinging and shutting down --- src/domain.sml | 8 ++--- src/main-admin.sml | 2 +- src/main.sml | 78 ++++++++++++++++++++++++---------------------- src/openssl.sig | 2 +- src/openssl.sml | 8 ++++- 5 files changed, 54 insertions(+), 44 deletions(-) diff --git a/src/domain.sml b/src/domain.sml index 8960bf9..d1046b7 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -699,10 +699,10 @@ fun handleSite (site, files) = if site = Config.defaultNode then Slave.handleChanges files else let - val bio = OpenSSL.connect (valOf (!ssl_context), - nodeIp site - ^ ":" - ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (valOf (!ssl_context), + nodeIp site + ^ ":" + ^ Int.toString Config.slavePort) in app (fn file => Msg.send (bio, MsgFile file)) files; Msg.send (bio, MsgDoFiles); diff --git a/src/main-admin.sml b/src/main-admin.sml index 0e404c6..183db60 100644 --- a/src/main-admin.sml +++ b/src/main-admin.sml @@ -61,6 +61,6 @@ val _ = app (fn s => (print s; print "\n")) (Acl.users ())) | _ => (print "Invalid command-line arguments\n"; - print "See the documentation: http://wiki2.hcoop.net/DomTool/AdminProcedures\n")) + print "See the documentation: http://wiki.hcoop.net/DomTool/AdminProcedures\n")) handle OpenSSL.OpenSSL s => (print ("OpenSSL exception: " ^ s ^ "\n"); OS.Process.exit OS.Process.failure) diff --git a/src/main.sml b/src/main.sml index b2f59b5..db1b52b 100644 --- a/src/main.sml +++ b/src/main.sml @@ -233,20 +233,24 @@ fun requestContext f = (user, context) end -fun requestBio f = +fun requestBio' printErr f = let val (user, context) = requestContext f in - (user, OpenSSL.connect (context, dispatcher)) + (user, OpenSSL.connect printErr (context, dispatcher)) end -fun requestSlaveBio () = +val requestBio = requestBio' true + +fun requestSlaveBio' printErr = let val (user, context) = requestContext (fn () => ()) in - (user, OpenSSL.connect (context, self)) + (user, OpenSSL.connect printErr (context, self)) end +fun requestSlaveBio () = requestSlaveBio' true + fun request fname = let val (user, bio) = requestBio (fn () => ignore (check (basis ()) fname)) @@ -341,7 +345,7 @@ fun requestDir dname = fun requestPing () = let - val (_, bio) = requestBio (fn () => ()) + val (_, bio) = requestBio' false (fn () => ()) in OpenSSL.close bio; OS.Process.success @@ -354,7 +358,7 @@ fun requestShutdown () = in Msg.send (bio, MsgShutdown); case Msg.recv bio of - NONE => print "Server closed connection unexpectedly.\n" + NONE => () | SOME m => case m of MsgOk => print "Shutdown begun.\n" @@ -365,7 +369,7 @@ fun requestShutdown () = fun requestSlavePing () = let - val (_, bio) = requestSlaveBio () + val (_, bio) = requestSlaveBio' false in OpenSSL.close bio; OS.Process.success @@ -378,7 +382,7 @@ fun requestSlaveShutdown () = in Msg.send (bio, MsgShutdown); case Msg.recv bio of - NONE => print "Server closed connection unexpectedly.\n" + NONE => () | SOME m => case m of MsgOk => print "Shutdown begun.\n" @@ -721,10 +725,10 @@ fun requestMysqlFixperms () = fun requestApt {node, pkg} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) val _ = Msg.send (bio, MsgQuery (QApt pkg)) @@ -750,10 +754,10 @@ fun requestApt {node, pkg} = fun requestCron {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) val _ = Msg.send (bio, MsgQuery (QCron uname)) @@ -779,10 +783,10 @@ fun requestCron {node, uname} = fun requestFtp {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) val _ = Msg.send (bio, MsgQuery (QFtp uname)) @@ -808,10 +812,10 @@ fun requestFtp {node, uname} = fun requestTrustedPath {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) val _ = Msg.send (bio, MsgQuery (QTrustedPath uname)) @@ -837,10 +841,10 @@ fun requestTrustedPath {node, uname} = fun requestSocketPerm {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) val _ = Msg.send (bio, MsgQuery (QSocket uname)) @@ -868,11 +872,11 @@ fun requestSocketPerm {node, uname} = fun requestFirewall {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) - + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val _ = Msg.send (bio, MsgQuery (QFirewall uname)) fun loop () = @@ -989,10 +993,10 @@ fun regenerateEither tc checker context = if node = Config.defaultNode then Domain.resetLocal () else let - val bio = OpenSSL.connect (context, - ip - ^ ":" - ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, + ip + ^ ":" + ^ Int.toString Config.slavePort) in Msg.send (bio, MsgRegenerate); case Msg.recv bio of diff --git a/src/openssl.sig b/src/openssl.sig index a3641a9..2e027b9 100644 --- a/src/openssl.sig +++ b/src/openssl.sig @@ -41,7 +41,7 @@ val writeString : bio * string -> unit val context : bool -> string * string * string -> context -val connect : context * string -> bio +val connect : bool -> context * string -> bio val close : bio -> unit val listen : context * int -> listener diff --git a/src/openssl.sml b/src/openssl.sml index aad3925..26001cc 100644 --- a/src/openssl.sml +++ b/src/openssl.sml @@ -266,9 +266,15 @@ fun context printErr (chain, key, root) = context end -fun connect (context, hostname) = +fun connect printErr (context, hostname) = let val bio = F_OpenSSL_SML_new_ssl_connect.f' context + + val ssl_err = + if printErr then + ssl_err + else + (fn _ => ()) in if C.Ptr.isNull' bio then (ssl_err ("Error initializating connection to " ^ hostname); -- 2.20.1