X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/c9731b9b3ee43c4c8d82c31009a5870a01d3acfa..d22c1f00ed619c221dc9891c86c5ced202a9ee77:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 29d2b37..e106823 100644 --- a/src/main.sml +++ b/src/main.sml @@ -1,5 +1,5 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2006, Adam Chlipala + * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -170,19 +170,32 @@ val dispatcher = val self = "localhost:" ^ Int.toString Config.slavePort +fun context x = + (OpenSSL.context false x) + handle e as OpenSSL.OpenSSL _ => + (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n"; + raise e) + fun requestContext f = let - val uid = Posix.ProcEnv.getuid () - val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) + val user = + case Posix.ProcEnv.getenv "DOMTOOL_USER" of + NONE => + let + val uid = Posix.ProcEnv.getuid () + in + Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) + end + | SOME user => user val () = Acl.read Config.aclFile val () = Domain.setUser user val () = f () - val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem", - Config.keyDir ^ "/" ^ user ^ "/key.pem", - Config.trustStore) + val context = context (Config.certDir ^ "/" ^ user ^ ".pem", + Config.keyDir ^ "/" ^ user ^ "/key.pem", + Config.trustStore) in (user, context) end @@ -604,9 +617,189 @@ 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 requestSocketPerm {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 (QSocket uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgSocket p => (case p of + Any => print "Any\n" + | Client => print "Client\n" + | Server => print "Server\n" + | Nada => print "Nada\n"; + OS.Process.success) + | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + +fun requestFirewall {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 (QFirewall uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgFirewall ls => (app (fn s => (print s; print "\n")) ls; + OS.Process.success) + | MsgError s => (print ("Firewall 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 _ = ErrorMsg.reset () + val b = basis () + val _ = if Env.lookupType b "string" then + print "Still got it\n" + else + print "Don't got it\n" val () = Tycheck.disallowExterns () val () = Domain.resetGlobal () @@ -665,6 +858,8 @@ 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") + | _ => print "Unknown exception during regeneration!\n" in app contactNode Config.nodeIps; Env.pre (); @@ -686,13 +881,31 @@ fun rmuser user = 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 + | QSocket user => MsgSocket (SocketPerm.query user) + | QFirewall user => MsgFirewall (Firewall.query user) + +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 + | QSocket user => "Asked about socket permissions for user " ^ user + | QFirewall user => "Asked about firewall rules for user " ^ user + fun service () = let val () = Acl.read Config.aclFile - val context = OpenSSL.context (Config.serverCert, - Config.serverKey, - Config.trustStore) + val context = context (Config.serverCert, + Config.serverKey, + Config.trustStore) val _ = Domain.set_context context val sock = OpenSSL.listen (context, Config.dispatcherPort) @@ -1029,6 +1242,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")) @@ -1046,6 +1265,18 @@ fun service () = OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ()) + | IO.Io {name, function, cause} => + (print ("IO error: " ^ function ^ " for " ^ name ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | e => + (print "Unknown exception in main loop!\n"; + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) in print ("Domtool dispatcher starting up at " ^ now () ^ "\n"); print "Listening for connections....\n"; @@ -1057,9 +1288,9 @@ fun slave () = let val host = Slave.hostname () - val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem", - Config.keyDir ^ "/" ^ host ^ "/key.pem", - Config.trustStore) + val context = context (Config.certDir ^ "/" ^ host ^ ".pem", + Config.keyDir ^ "/" ^ host ^ "/key.pem", + Config.trustStore) val sock = OpenSSL.listen (context, Config.slavePort) @@ -1099,16 +1330,22 @@ fun slave () = | _ => (OpenSSL.close bio; loop ()) else - (print "Not authorized!\n"; - OpenSSL.close bio; - loop ()) + 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 handle OpenSSL.OpenSSL _ => (); loop ()) - | OS.SysErr (s, _) => - (print ("System error: "^ s ^ "\n"); + | e as OS.SysErr (s, _) => + (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e); + print ("System error: "^ s ^ "\n"); OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ())