From 314ce7bdcb5f54a7d1763e8b6d405dc66cb65d2b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 17 Nov 2007 15:17:42 +0000 Subject: [PATCH] Adding domain description --- src/domain.sig | 16 ++++++++ src/domain.sml | 92 ++++++++++++++++++++++++++++++++++++++++++++++ src/main-admin.sml | 1 + src/main.sig | 1 + src/main.sml | 30 +++++++++++++++ src/msg.sml | 8 +++- src/msgTypes.sml | 4 ++ src/openssl.sml | 90 ++++++++++++++++++++++++--------------------- 8 files changed, 199 insertions(+), 43 deletions(-) diff --git a/src/domain.sig b/src/domain.sig index b3c06ce..bdf92de 100644 --- a/src/domain.sig +++ b/src/domain.sig @@ -95,4 +95,20 @@ signature DOMAIN = sig 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 diff --git a/src/domain.sml b/src/domain.sml index 4944a34..67ff449 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -790,4 +790,96 @@ fun homedirOf uname = 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 diff --git a/src/main-admin.sml b/src/main-admin.sml index 201456e..459db6d 100644 --- a/src/main-admin.sml +++ b/src/main-admin.sml @@ -55,6 +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] => 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") 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 f32fa2d..ec795e3 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 ("Describe failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun regenerateEither tc checker context = let fun ifReal f = @@ -1417,6 +1432,16 @@ fun service () = 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")) @@ -1441,6 +1466,11 @@ fun service () = 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); diff --git a/src/msg.sml b/src/msg.sml index 61fa4bc..5940bbe 100644 --- a/src/msg.sml +++ b/src/msg.sml @@ -228,7 +228,11 @@ fun send (bio, m) = | 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 @@ -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 diff --git a/src/openssl.sml b/src/openssl.sml index d309a61..aad3925 100644 --- a/src/openssl.sml +++ b/src/openssl.sml @@ -108,40 +108,43 @@ fun readInt bio = 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 @@ -216,16 +219,19 @@ fun writeInt (bio, n) = 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); -- 2.20.1