val homedirOf : string -> string
val homedir : unit -> string
+
+ type subject = {node : string, domain : string}
+
+ val registerDescriber : (subject -> string) -> unit
+ (* When a user runs [domtool-admin describe $DOM], every function passed to
+ * [registerDescriber] will be run on [$DOM]. *)
+ val describe : string -> string
+ (* Argument is domain to describe, over all nodes. *)
+
+ datatype description =
+ Filename of { filename : string, heading : string }
+ | Extension of { extension : string, heading : string -> string }
+
+ val considerAll : description list -> subject -> string
+ (* Find files in a domain directory matching some patterns and generate
+ * headings and contents listings for them. *)
end
fun homedir () = homedirOf (getUser ())
+type subject = {node : string, domain : string}
+
+val describers : (subject -> string) list ref = ref []
+
+fun registerDescriber f = describers := f :: !describers
+
+fun describeOne arg = String.concat (map (fn f => f arg) (!describers))
+
+val line = "-------------------------------\n"
+val dline = "===============================\n"
+
+fun describe dom =
+ String.concat (List.mapPartial
+ (fn node =>
+ case describeOne {node = node, domain = dom} of
+ "" => NONE
+ | s =>
+ SOME (String.concat [dline, "Node ", node, "\n", dline, "\n", s]))
+ nodes)
+
+datatype description =
+ Filename of { filename : string, heading : string}
+ | Extension of { extension : string, heading : string -> string }
+
+fun considerAll ds {node, domain} =
+ let
+ val ds = map (fn d => (d, ref [])) ds
+
+ val path = Config.resultRoot
+ val jdf = OS.Path.joinDirFile
+ val path = jdf {dir = path, file = node}
+ val path = foldr (fn (more, path) => jdf {dir = path, file = more})
+ path (String.tokens (fn ch => ch = #".") domain)
+ in
+ if Posix.FileSys.access (path, []) then
+ let
+ val dir = Posix.FileSys.opendir path
+
+ fun loop () =
+ case Posix.FileSys.readdir dir of
+ NONE => ()
+ | SOME fname =>
+ let
+ fun readFile entries =
+ let
+ val fname = OS.Path.joinDirFile {dir = path,
+ file = fname}
+
+ val inf = TextIO.openIn fname
+
+ fun loop entries =
+ case TextIO.inputLine inf of
+ NONE => entries
+ | SOME line => loop (line :: entries)
+ in
+ loop entries
+ before TextIO.closeIn inf
+ end
+ in
+ app (fn (d, entries) =>
+ case d of
+ Filename {filename, heading} =>
+ if fname = filename then
+ entries := "\n" :: readFile ("\n" :: line :: ":\n" :: heading :: line :: !entries)
+ else
+ ()
+ | Extension {extension, heading} =>
+ let
+ val {base, ext} = OS.Path.splitBaseExt fname
+ in
+ case ext of
+ NONE => ()
+ | SOME extension' =>
+ if extension' = extension then
+ entries := "\n" :: readFile ("\n" :: line :: ":\n" :: heading base :: line :: !entries)
+ else
+ ()
+ end) ds;
+ loop ()
+ end
+ in
+ loop ();
+ Posix.FileSys.closedir dir;
+ String.concat (List.concat (map (fn (_, entries) => rev (!entries)) ds))
+ end
+ else
+ ""
+ end
+
+val () = registerDescriber (considerAll [Filename {filename = "soa",
+ heading = "DNS SOA"}])
+
end
| ["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] => Main.requestDescribe dom
| _ => (print "Invalid command-line arguments\n";
print "See the documentation: http://wiki.hcoop.net/wiki/DomTool/AdminProcedures\n"))
handle OpenSSL.OpenSSL s => print ("OpenSSL exception: " ^ s ^ "\n")
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
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 ("Describe failed: " ^ s ^ "\n")
+ | _ => print "Unexpected server reply.\n";
+ OpenSSL.close bio
+ end
+
fun regenerateEither tc checker context =
let
fun ifReal f =
SOME "Script execution failed."))
(fn () => ())
+ | MsgDescribe dom =>
+ doIt (fn () => (if Domain.validDomain dom then
+ (Msg.send (bio, MsgDescription (Domain.describe dom));
+ ("Requested description of domain " ^ dom,
+ NONE))
+ else
+ ("Requested description of invalid domain " ^ dom,
+ SOME "Invalid domain name")))
+ (fn () => ())
+
| _ =>
doIt (fn () => ("Unexpected command",
SOME "Unexpected command"))
OpenSSL.close bio
handle OpenSSL.OpenSSL _ => ();
loop ())
+ | OS.Path.InvalidArc =>
+ (print "Invalid arc\n";
+ OpenSSL.close bio
+ handle OpenSSL.OpenSSL _ => ();
+ loop ())
| e =>
(print "Unknown exception in main loop!\n";
app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);
| MsgGrantDb {dbtype, dbname} => (OpenSSL.writeInt (bio, 37);
OpenSSL.writeString (bio, dbtype);
OpenSSL.writeString (bio, dbname))
- | MsqMysqlFixperms => OpenSSL.writeInt (bio, 38)
+ | 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
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
(* 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
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
- ()
+ if len = 0 then
+ SOME ""
+ else
+ let
+ val buf =
+ if len > Config.bufSize then
+ C.alloc' C.S.uchar (Word.fromInt len)
+ else
+ readBuf
- 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 (Compat.Char.toInt (C.Get.uchar'
- (C.Ptr.sub' C.S.uchar (buf, i))))))
+ fun cleanup () =
+ if len > Config.bufSize then
+ C.free' buf
else
- loop (C.Ptr.|+! C.S.uchar (buf', Int32.toInt r), needed - r)
- end
- in
- loop (buf, Int32.fromInt len)
- before cleanup ()
- end
+ ()
+
+ 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 (Compat.Char.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
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
+ if size s = 0 then
+ ()
+ else
+ 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);
HCoop / hcoop / domtool2.git / commitdiff