X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/2bc5ed226e9a0cba24f9d689754e1d62bb883d86..d351d679283a797c98f5f65d18aa757c18e56305:/src/main.sml diff --git a/src/main.sml b/src/main.sml index f9b2c9f..05bce83 100644 --- a/src/main.sml +++ b/src/main.sml @@ -167,6 +167,9 @@ fun eval' fname = val dispatcher = Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort +val self = + "localhost:" ^ Int.toString Config.slavePort + fun requestContext f = let val uid = Posix.ProcEnv.getuid () @@ -191,6 +194,13 @@ fun requestBio f = (user, OpenSSL.connect (context, dispatcher)) end +fun requestSlaveBio () = + let + val (user, context) = requestContext (fn () => ()) + in + (user, OpenSSL.connect (context, self)) + end + fun request fname = let val (user, bio) = requestBio (fn () => ignore (check fname)) @@ -275,6 +285,54 @@ fun requestDir dname = end handle ErrorMsg.Error => () +fun requestPing () = + let + val (_, bio) = requestBio (fn () => ()) + in + OpenSSL.close bio; + OS.Process.success + end + handle _ => OS.Process.failure + +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 requestSlavePing () = + let + val (_, bio) = requestSlaveBio () + in + OpenSSL.close bio; + OS.Process.success + end + handle _ => OS.Process.failure + +fun requestSlaveShutdown () = + let + val (_, bio) = requestSlaveBio () + 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 () => ()) @@ -401,6 +459,21 @@ fun requestDbUser dbtype = OpenSSL.close bio end +fun requestDbPasswd rc = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgDbPasswd rc); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Your password has been changed.\n" + | MsgError s => print ("Password set failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun requestDbTable p = let val (user, bio) = requestBio (fn () => ()) @@ -531,6 +604,93 @@ fun requestSmtpLog domain = OpenSSL.close bio end +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 _ = Msg.send (bio, MsgQuery (QApt pkg)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "Package is installed.\n"; + OS.Process.success) + | MsgNo => (print "Package is not installed.\n"; + OS.Process.failure) + | MsgError s => (print ("APT query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + +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 _ = Msg.send (bio, MsgQuery (QCron uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "User has cron permissions.\n"; + OS.Process.success) + | MsgNo => (print "User does not have cron permissions.\n"; + OS.Process.failure) + | MsgError s => (print ("Cron query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + +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 _ = Msg.send (bio, MsgQuery (QFtp uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "User has FTP permissions.\n"; + OS.Process.success) + | MsgNo => (print "User does not have FTP permissions.\n"; + OS.Process.failure) + | MsgError s => (print ("FTP query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + fun regenerate context = let val b = basis () @@ -592,6 +752,7 @@ fun regenerate context = end handle IO.Io _ => () | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") + | ErrorMsg.Error => print ("User " ^ user ^ " had a compilation error.\n") in app contactNode Config.nodeIps; Env.pre (); @@ -611,6 +772,20 @@ fun rmuser user = Domain.rmdom doms end +fun now () = Date.toString (Date.fromTimeUniv (Time.now ())) + +fun answerQuery q = + case q of + QApt pkg => if Apt.installed pkg then MsgYes else MsgNo + | QCron user => if Cron.allowed user then MsgYes else MsgNo + | QFtp user => if Ftp.allowed user then MsgYes else MsgNo + +fun describeQuery q = + case q of + QApt pkg => "Requested installation status of package " ^ pkg + | QCron user => "Asked about cron permissions for user " ^ user + | QFtp user => "Asked about FTP permissions for user " ^ user + fun service () = let val () = Acl.read Config.aclFile @@ -628,7 +803,7 @@ fun service () = | SOME bio => let val user = OpenSSL.peerCN bio - val () = print ("\nConnection from " ^ user ^ "\n") + val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n") val () = Domain.setUser user fun doIt f cleanup = @@ -714,6 +889,16 @@ fun service () = MsgConfig code => doConfig [code] | MsgMultiConfig codes => doConfig codes + | MsgShutdown => + if Acl.query {user = user, class = "priv", value = "all"} + orelse Acl.query {user = user, class = "priv", value = "shutdown"} then + print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n") + else + (print "Unauthorized shutdown command!\n"; + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | MsgGrant acl => doIt (fn () => if Acl.query {user = user, class = "priv", value = "all"} then @@ -805,6 +990,20 @@ fun service () = SOME ("Error adding user: " ^ msg))) (fn () => ()) + | MsgDbPasswd {dbtype, passwd} => + doIt (fn () => + case Dbms.lookup dbtype of + NONE => ("Database passwd request with unknown datatype type " ^ dbtype, + SOME ("Unknown database type " ^ dbtype)) + | SOME handler => + case #passwd handler {user = user, passwd = passwd} of + NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".", + NONE) + | SOME msg => + ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg, + SOME ("Error adding user: " ^ msg))) + (fn () => ()) + | MsgCreateDbTable {dbtype, dbname} => doIt (fn () => if Dbms.validDbname dbname then @@ -930,6 +1129,12 @@ fun service () = NONE))) (fn () => ()) + | MsgQuery q => + doIt (fn () => (Msg.send (bio, answerQuery q); + (describeQuery q, + NONE))) + (fn () => ()) + | _ => doIt (fn () => ("Unexpected command", SOME "Unexpected command")) @@ -948,6 +1153,7 @@ fun service () = handle OpenSSL.OpenSSL _ => (); loop ()) in + print ("Domtool dispatcher starting up at " ^ now () ^ "\n"); print "Listening for connections....\n"; loop (); OpenSSL.shutdown sock @@ -963,19 +1169,17 @@ fun slave () = val sock = OpenSSL.listen (context, Config.slavePort) + val _ = print ("Slave server starting at " ^ now () ^ "\n") + fun loop () = case OpenSSL.accept sock of NONE => () | SOME bio => let val peer = OpenSSL.peerCN bio - val () = print ("\nConnection from " ^ peer ^ "\n") + val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n") in - if peer <> Config.dispatcherName then - (print "Not authorized!\n"; - OpenSSL.close bio; - loop ()) - else let + if peer = Config.dispatcherName then let fun loop' files = case Msg.recv bio of NONE => print "Dispatcher closed connection unexpectedly\n" @@ -994,6 +1198,21 @@ fun slave () = OpenSSL.close bio; loop () end + else if peer = "domtool" then + case Msg.recv bio of + SOME MsgShutdown => (OpenSSL.close bio; + print ("Shutting down at " ^ now () ^ "\n\n")) + | _ => (OpenSSL.close bio; + loop ()) + else + case Msg.recv bio of + SOME (MsgQuery q) => (print (describeQuery q ^ "\n"); + Msg.send (bio, answerQuery q); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio; + loop ()) + | _ => (OpenSSL.close bio; + loop ()) end handle OpenSSL.OpenSSL s => (print ("OpenSSL error: "^ s ^ "\n"); OpenSSL.close bio