From 1ffc47a68def0e10e393ad4d8e62b7d6f7300c01 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sat, 17 Nov 2007 17:44:11 +0000
Subject: [PATCH] Back to server-slide describe

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

diff --git a/src/main-admin.sml b/src/main-admin.sml
index 1a9ceac..4ce4170 100644
--- a/src/main-admin.sml
+++ b/src/main-admin.sml
@@ -55,7 +55,7 @@ val _ =
        | ["tpe", node, uname] => OS.Process.exit (Main.requestTrustedPath {node = node, uname = uname})
        | ["sockperm", node, uname] => OS.Process.exit (Main.requestSocketPerm {node = node, uname = uname})
        | ["firewall", node, uname] => OS.Process.exit (Main.requestFirewall {node = node, uname = uname})
-       | ["describe", dom] => print (Domain.describe dom)
+       | ["describe", dom] => Main.requestDescribe dom
        | ["users"] =>
 	 (Acl.read Config.aclFile;
 	  app (fn s => (print s; print "\n")) (Acl.users ()))
diff --git a/src/main.sig b/src/main.sig
index 55ad560..53f019d 100644
--- a/src/main.sig
+++ b/src/main.sig
@@ -45,6 +45,7 @@ signature MAIN = sig
     val requestRegen : unit -> unit
     val requestRegenTc : unit -> unit
     val requestRmuser : string -> unit
+    val requestDescribe : string -> unit
 
     val requestSlavePing : unit -> OS.Process.status
     val requestSlaveShutdown : unit -> unit
diff --git a/src/main.sml b/src/main.sml
index 15a5853..8cc5a3a 100644
--- a/src/main.sml
+++ b/src/main.sml
@@ -873,6 +873,21 @@ fun requestFirewall {node, uname} =
 	before OpenSSL.close bio
     end
 
+fun requestDescribe dom =
+    let
+	val (_, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgDescribe dom);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgDescription s => print s
+	      | MsgError s => print ("Description failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
 fun regenerateEither tc checker context =
     let
 	fun ifReal f =
@@ -942,7 +957,8 @@ fun regenerateEither tc checker context =
 		    in
 			if !ErrorMsg.anyErrors then
 			    (ErrorMsg.reset ();
-			     print ("User " ^ user ^ "'s configuration has errors!\n"))
+			     print ("User " ^ user ^ "'s configuration has errors!\n");
+			     ok := false)
 			else
 			    app checker files
 		    end
@@ -1417,6 +1433,20 @@ fun service () =
 						      SOME "Script execution failed."))
 				      (fn () => ())
 
+			       | MsgDescribe dom =>
+				 doIt (fn () => if not (Domain.validDomain dom) then
+						    ("Requested description of invalid domain " ^ dom,
+						     SOME "Invalid domain name")
+						else if not (Domain.yourDomain dom
+							     orelse Acl.query {user = user, class = "priv", value = "all"}) then
+						    ("Requested description of " ^ dom ^ ", but not allowed access",
+						     SOME "Access denied")
+						else
+						    (Msg.send (bio, MsgDescription (Domain.describe dom));
+						     ("Sent description of domain " ^ dom,
+						      NONE)))
+				      (fn () => ())
+
 			       | _ =>
 				 doIt (fn () => ("Unexpected command",
 						 SOME "Unexpected command"))
diff --git a/src/msg.sml b/src/msg.sml
index 91cc78a..5940bbe 100644
--- a/src/msg.sml
+++ b/src/msg.sml
@@ -229,6 +229,10 @@ fun send (bio, m) =
 					OpenSSL.writeString (bio, dbtype);
 					OpenSSL.writeString (bio, dbname))
       | MsgMysqlFixperms => OpenSSL.writeInt (bio, 38)
+      | MsgDescribe dom => (OpenSSL.writeInt (bio, 39);
+			    OpenSSL.writeString (bio, dom))
+      | MsgDescription s => (OpenSSL.writeInt (bio, 40);
+			     OpenSSL.writeString (bio, s))
 
 fun checkIt v =
     case v of
@@ -339,6 +343,8 @@ fun recv bio =
 				SOME (MsgGrantDb {dbtype = dbtype, dbname = dbname})
 			      | _ => NONE)
 		   | 38 => SOME MsgMysqlFixperms
+		   | 39 => Option.map MsgDescribe (OpenSSL.readString bio)
+		   | 40 => Option.map MsgDescription (OpenSSL.readString bio)
 		   | _ => NONE)
 	 
 end
diff --git a/src/msgTypes.sml b/src/msgTypes.sml
index 25c3592..034e26a 100644
--- a/src/msgTypes.sml
+++ b/src/msgTypes.sml
@@ -120,5 +120,9 @@ datatype msg =
        (* Grant all allowed privileges on a DBMS database to the user *)
        | MsgMysqlFixperms
        (* Run the script to grant DROP privileges on MySQL tables to owning users *)
+       | MsgDescribe of string
+       (* Ask for a listing of all of a domain's real configuration *)
+       | MsgDescription of string
+       (* Reply to MsgDescribe *)
 
 end
-- 
2.20.1