X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/9f27d58f1ce0833bb5460d7ca612c74f378548a1..4d5126e168a9671d01a0b57efcecd08ad68dcfbe:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 8bb2d4e..90a5e94 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,15 @@ 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 () => ()) @@ -290,6 +309,30 @@ fun requestShutdown () = 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 () => ()) @@ -561,6 +604,122 @@ 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 requestTrustedPath {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 (QTrustedPath 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 trusted path restriction.\n"; + OS.Process.success) + | MsgNo => (print "User does not have trusted path restriction.\n"; + OS.Process.failure) + | MsgError s => (print ("Trusted path 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 () @@ -622,6 +781,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 (); @@ -641,6 +801,22 @@ 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 + | QTrustedPath user => if TrustedPath.query 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 + | QTrustedPath user => "Asked about trusted path settings for user " ^ user + fun service () = let val () = Acl.read Config.aclFile @@ -658,7 +834,7 @@ fun service () = | SOME bio => let val user = OpenSSL.peerCN bio - val () = print ("\nConnection from " ^ user ^ " at " ^ Date.toString (Date.fromTimeUniv (Time.now ())) ^ "\n") + val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n") val () = Domain.setUser user fun doIt f cleanup = @@ -745,10 +921,12 @@ fun service () = | 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") + 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 - (OpenSSL.close bio + (print "Unauthorized shutdown command!\n"; + OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ()) @@ -982,6 +1160,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")) @@ -1000,7 +1184,7 @@ fun service () = handle OpenSSL.OpenSSL _ => (); loop ()) in - print ("Domtool dispatcher starting up at " ^ Date.toString (Date.fromTimeUniv (Time.now ())) ^ "\n"); + print ("Domtool dispatcher starting up at " ^ now () ^ "\n"); print "Listening for connections....\n"; loop (); OpenSSL.shutdown sock @@ -1016,19 +1200,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" @@ -1047,6 +1229,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