From 9f27d58f1ce0833bb5460d7ca612c74f378548a1 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 11 Feb 2007 22:12:07 +0000
Subject: [PATCH] Add shutdown command

---
 src/main-admin.sml |  3 ++-
 src/main.sig       |  1 +
 src/main.sml       | 26 +++++++++++++++++++++++++-
 src/msg.sml        |  2 ++
 src/msgTypes.sml   |  2 ++
 5 files changed, 32 insertions(+), 2 deletions(-)

diff --git a/src/main-admin.sml b/src/main-admin.sml
index e3dc67b..1eda532 100644
--- a/src/main-admin.sml
+++ b/src/main-admin.sml
@@ -30,7 +30,8 @@ fun requestPerms user =
 
 val _ =
     case CommandLine.arguments () of
-	["grant", user, class, value] => Main.requestGrant {user = user, class = class, value = value}
+	["shutdown"] => Main.requestShutdown ()
+      | ["grant", user, class, value] => Main.requestGrant {user = user, class = class, value = value}
       | ["revoke", user, class, value] => Main.requestRevoke {user = user, class = class, value = value}
       | ["perms", user] => requestPerms user
       | ["perms"] => requestPerms (Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid (Posix.ProcEnv.getuid ())))
diff --git a/src/main.sig b/src/main.sig
index ca699b8..87f3028 100644
--- a/src/main.sig
+++ b/src/main.sig
@@ -34,6 +34,7 @@ signature MAIN = sig
     val request : string -> unit
     val requestDir : string -> unit
 
+    val requestShutdown : unit -> unit
     val requestGrant : Acl.acl -> unit
     val requestRevoke : Acl.acl -> unit
     val requestListPerms : string -> (string * string list) list option
diff --git a/src/main.sml b/src/main.sml
index 7403743..8bb2d4e 100644
--- a/src/main.sml
+++ b/src/main.sml
@@ -275,6 +275,21 @@ fun requestDir dname =
     end
     handle ErrorMsg.Error => ()
 
+fun requestShutdown () =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgShutdown);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print "Shutdown begun.\n"
+	      | MsgError s => print ("Shutdown failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
 fun requestGrant acl =
     let
 	val (user, bio) = requestBio (fn () => ())
@@ -643,7 +658,7 @@ fun service () =
 	      | SOME bio =>
 		let
 		    val user = OpenSSL.peerCN bio
-		    val () = print ("\nConnection from " ^ user ^ "\n")
+		    val () = print ("\nConnection from " ^ user ^ " at " ^ Date.toString (Date.fromTimeUniv (Time.now ())) ^ "\n")
 		    val () = Domain.setUser user
 
 		    fun doIt f cleanup =
@@ -729,6 +744,14 @@ fun service () =
 				MsgConfig code => doConfig [code]
 			      | MsgMultiConfig codes => doConfig codes
 
+			      | MsgShutdown =>
+				if Acl.query {user = user, class = "priv", value = "shutdown"} then
+				    print ("Domtool dispatcher shutting down at " ^ Date.toString (Date.fromTimeUniv (Time.now ())) ^ "\n")
+				else
+				    (OpenSSL.close bio
+				     handle OpenSSL.OpenSSL _ => ();
+				     loop ())
+
 			      | MsgGrant acl =>
 				doIt (fn () =>
 					 if Acl.query {user = user, class = "priv", value = "all"} then
@@ -977,6 +1000,7 @@ fun service () =
 			    handle OpenSSL.OpenSSL _ => ();
 			    loop ())
     in
+	print ("Domtool dispatcher starting up at " ^ Date.toString (Date.fromTimeUniv (Time.now ())) ^ "\n");
 	print "Listening for connections....\n";
 	loop ();
 	OpenSSL.shutdown sock
diff --git a/src/msg.sml b/src/msg.sml
index a9063aa..f05d012 100644
--- a/src/msg.sml
+++ b/src/msg.sml
@@ -169,6 +169,7 @@ fun send (bio, m) =
       | MsgDbPasswd {dbtype, passwd} => (OpenSSL.writeInt (bio, 28);
 					 OpenSSL.writeString (bio, dbtype);
 					 OpenSSL.writeString (bio, passwd))
+      | MsgShutdown => OpenSSL.writeInt (bio, 29)
 
 fun checkIt v =
     case v of
@@ -263,6 +264,7 @@ fun recv bio =
 				(SOME dbtype, SOME passwd) =>
 				SOME (MsgDbPasswd {dbtype = dbtype, passwd = passwd})
 			      | _ => NONE)
+		   | 29 => SOME MsgShutdown
 		   | _ => NONE)
 	 
 end
diff --git a/src/msgTypes.sml b/src/msgTypes.sml
index 445f8af..3003a39 100644
--- a/src/msgTypes.sml
+++ b/src/msgTypes.sml
@@ -81,5 +81,7 @@ datatype msg =
        (* One line of a response to MsgSmtpLogReq *)
        | MsgDbPasswd of {dbtype : string, passwd : string}
        (* Change a DBMS user's password *)
+       | MsgShutdown
+       (* Halt the server *)
 
 end
-- 
2.20.1