X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/51be7da6b88fb5c93db9b03dc7f5abc710590be2..e69e60ccf1aa77a40cd5b15c4361f378ce332a42:/src/main.sml diff --git a/src/main.sml b/src/main.sml index afd0ce9..997713d 100644 --- a/src/main.sml +++ b/src/main.sml @@ -53,22 +53,18 @@ fun basis () = loop files val files = loop [] - val (_, files) = Order.order files + val (_, files) = Order.order NONE files in if !ErrorMsg.anyErrors then Env.empty else - foldl (fn (fname, G) => check' G fname) Env.empty files + (Tycheck.allowExterns (); + foldl (fn (fname, G) => check' G fname) Env.empty files + before Tycheck.disallowExterns ()) end fun check fname = let - (*val uid = Posix.ProcEnv.getuid () - val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) - - val () = Acl.read Config.aclFile - val () = Domain.setUser user*) - val _ = ErrorMsg.reset () val _ = Env.preTycheck () @@ -78,6 +74,7 @@ fun check fname = raise ErrorMsg.Error else let + val _ = Tycheck.disallowExterns () val _ = ErrorMsg.reset () val prog = Parse.parse fname in @@ -95,6 +92,39 @@ fun check fname = end end +val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") + +fun checkDir dname = + let + val b = basis () + + val dir = Posix.FileSys.opendir dname + + fun loop files = + case Posix.FileSys.readdir dir of + NONE => (Posix.FileSys.closedir dir; + files) + | SOME fname => + if notTmp fname then + loop (OS.Path.joinDirFile {dir = dname, + file = fname} + :: files) + else + loop files + + val files = loop [] + val (_, files) = Order.order (SOME b) files + in + if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + (foldl (fn (fname, G) => check' G fname) b files; + if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + ()) + end + fun reduce fname = let val (G, body) = check fname @@ -125,30 +155,45 @@ fun eval fname = Eval.exec (Defaults.eInit ()) body' | NONE => raise ErrorMsg.Error +fun eval' fname = + case reduce fname of + (SOME body') => + if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + ignore (Eval.exec' (Defaults.eInit ()) body') + | NONE => raise ErrorMsg.Error + val dispatcher = Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort -fun hostname () = - let - val inf = TextIO.openIn "/etc/hostname" - in - case TextIO.inputLine inf of - NONE => (TextIO.closeIn inf; raise Fail "No line in /etc/hostname") - | SOME line => (TextIO.closeIn inf; String.substring (line, 0, size line - 1)) - end - -fun request fname = +fun requestContext f = let - val _ = check fname - val uid = Posix.ProcEnv.getuid () val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) + + 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) + in + (user, context) + end - val bio = OpenSSL.connect (context, dispatcher) +fun requestBio f = + let + val (user, context) = requestContext f + in + (user, OpenSSL.connect (context, dispatcher)) + end + +fun request fname = + let + val (user, bio) = requestBio (fn () => ignore (check fname)) val inf = TextIO.openIn fname @@ -172,6 +217,255 @@ fun request fname = end handle ErrorMsg.Error => () +fun requestDir dname = + let + val _ = ErrorMsg.reset () + + val (user, bio) = requestBio (fn () => checkDir dname) + + val b = basis () + + val dir = Posix.FileSys.opendir dname + + fun loop files = + case Posix.FileSys.readdir dir of + NONE => (Posix.FileSys.closedir dir; + files) + | SOME fname => + if notTmp fname then + loop (OS.Path.joinDirFile {dir = dname, + file = fname} + :: files) + else + loop files + + val files = loop [] + val (_, files) = Order.order (SOME b) files + + val _ = if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + () + + val codes = map (fn fname => + let + val inf = TextIO.openIn fname + + fun loop lines = + case TextIO.inputLine inf of + NONE => String.concat (rev lines) + | SOME line => loop (line :: lines) + in + loop [] + before TextIO.closeIn inf + end) files + in + if !ErrorMsg.anyErrors then + () + else + (Msg.send (bio, MsgMultiConfig codes); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Configuration succeeded.\n" + | MsgError s => print ("Configuration failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio) + end + handle ErrorMsg.Error => () + +fun requestGrant acl = + let + val (user, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgGrant acl); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Grant succeeded.\n" + | MsgError s => print ("Grant failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestRevoke acl = + let + val (user, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRevoke acl); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Revoke succeeded.\n" + | MsgError s => print ("Revoke failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestListPerms user = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgListPerms user); + (case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + NONE) + | SOME m => + case m of + MsgPerms perms => SOME perms + | MsgError s => (print ("Listing failed: " ^ s ^ "\n"); + NONE) + | _ => (print "Unexpected server reply.\n"; + NONE)) + before OpenSSL.close bio + end + +fun requestWhoHas perm = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgWhoHas perm); + (case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + NONE) + | SOME m => + case m of + MsgWhoHasResponse users => SOME users + | MsgError s => (print ("whohas failed: " ^ s ^ "\n"); + NONE) + | _ => (print "Unexpected server reply.\n"; + NONE)) + before OpenSSL.close bio + end + +fun requestRegen () = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRegenerate); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Regeneration succeeded.\n" + | MsgError s => print ("Regeneration failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestRmdom dom = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRmdom dom); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Removal succeeded.\n" + | MsgError s => print ("Removal failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestRmuser user = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRmuser user); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Removal succeeded.\n" + | MsgError s => print ("Removal failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun regenerate context = + let + val b = basis () + val () = Tycheck.disallowExterns () + + val () = Domain.resetGlobal () + + fun contactNode (node, ip) = + if node = Config.defaultNode then + Domain.resetLocal () + else let + val bio = OpenSSL.connect (context, + ip + ^ ":" + ^ Int.toString Config.slavePort) + in + Msg.send (bio, MsgRegenerate); + case Msg.recv bio of + NONE => print "Slave closed connection unexpectedly\n" + | SOME m => + case m of + MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n") + | MsgError s => print ("Slave " ^ node + ^ " returned error: " ^ + s ^ "\n") + | _ => print ("Slave " ^ node + ^ " returned unexpected command\n"); + OpenSSL.close bio + end + + fun doUser user = + let + val _ = Domain.setUser user + val _ = ErrorMsg.reset () + + val dname = Config.domtoolDir user + + val dir = Posix.FileSys.opendir dname + + fun loop files = + case Posix.FileSys.readdir dir of + NONE => (Posix.FileSys.closedir dir; + files) + | SOME fname => + if notTmp fname then + loop (OS.Path.joinDirFile {dir = dname, + file = fname} + :: files) + else + loop files + + val files = loop [] + val (_, files) = Order.order (SOME b) files + in + if !ErrorMsg.anyErrors then + print ("User " ^ user ^ "'s configuration has errors!\n") + else + app eval' files + end + handle IO.Io _ => () + | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") + in + app contactNode Config.nodeIps; + Env.pre (); + app doUser (Acl.users ()); + Env.post () + end + +fun rmuser user = + let + val doms = Acl.class {user = user, class = "domain"} + val doms = List.filter (fn dom => + case Acl.whoHas {class = "domain", value = dom} of + [_] => true + | _ => false) (StringSet.listItems doms) + in + Acl.rmuser user; + Domain.rmdom doms + end + fun service () = let val () = Acl.read Config.aclFile @@ -192,6 +486,44 @@ fun service () = val () = print ("\nConnection from " ^ user ^ "\n") val () = Domain.setUser user + fun doConfig codes = + let + val _ = print "Configuration:\n" + val _ = app (fn s => (print s; print "\n")) codes + val _ = print "\n" + + val outname = OS.FileSys.tmpName () + + fun doOne code = + let + val outf = TextIO.openOut outname + in + TextIO.output (outf, code); + TextIO.closeOut outf; + eval' outname + end + in + (Env.pre (); + app doOne codes; + Env.post (); + Msg.send (bio, MsgOk)) + handle ErrorMsg.Error => + (print "Compilation error\n"; + Msg.send (bio, + MsgError "Error during configuration evaluation")) + | OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during configuration evaluation: " + ^ s))); + OS.FileSys.remove outname; + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop () + end + fun cmdLoop () = case Msg.recv bio of NONE => (OpenSSL.close bio @@ -199,35 +531,160 @@ fun service () = loop ()) | SOME m => case m of - MsgConfig code => - let - val _ = print "Configuration:\n" - val _ = print code - val _ = print "\n" + MsgConfig code => doConfig [code] + | MsgMultiConfig codes => doConfig codes + + | MsgGrant acl => + if Acl.query {user = user, class = "priv", value = "all"} then + ((Acl.grant acl; + Acl.write Config.aclFile; + Msg.send (bio, MsgOk); + print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during granting: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + else + ((Msg.send (bio, MsgError "Not authorized to grant privileges"); + print "Unauthorized user asked to grant a permission!\n"; + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) - val outname = OS.FileSys.tmpName () - val outf = TextIO.openOut outname - in - TextIO.output (outf, code); - TextIO.closeOut outf; - (eval outname; - Msg.send (bio, MsgOk)) - handle ErrorMsg.Error => - (print "Compilation error\n"; + | MsgRevoke acl => + if Acl.query {user = user, class = "priv", value = "all"} then + ((Acl.revoke acl; + Acl.write Config.aclFile; + Msg.send (bio, MsgOk); + print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; Msg.send (bio, - MsgError "Error during configuration evaluation")) - | OpenSSL.OpenSSL s => + MsgError + ("Error during revocation: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + else + ((Msg.send (bio, MsgError "Not authorized to revoke privileges"); + print "Unauthorized user asked to revoke a permission!\n"; + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgListPerms user => + ((Msg.send (bio, MsgPerms (Acl.queryAll user)); + print ("Sent permission list for user " ^ user ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during permission listing: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgWhoHas perm => + ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm)); + print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during whohas: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgRmdom doms => + if Acl.query {user = user, class = "priv", value = "all"} + orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then + ((Domain.rmdom doms; + app (fn dom => + Acl.revokeFromAll {class = "domain", value = dom}) doms; + Acl.write Config.aclFile; + Msg.send (bio, MsgOk); + print ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".\n")) + handle OpenSSL.OpenSSL s => (print "OpenSSL error\n"; Msg.send (bio, MsgError - ("Error during configuration evaluation: " + ("Error during revocation: " ^ s))); - OS.FileSys.remove outname; (ignore (OpenSSL.readChar bio); OpenSSL.close bio) handle OpenSSL.OpenSSL _ => (); - loop () - end + loop ()) + else + ((Msg.send (bio, MsgError "Not authorized to remove that domain"); + print "Unauthorized user asked to remove a domain!\n"; + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgRegenerate => + if Acl.query {user = user, class = "priv", value = "regen"} + orelse Acl.query {user = user, class = "priv", value = "all"} then + ((regenerate context; + Msg.send (bio, MsgOk); + print "Regenerated all configuration.\n") + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during regeneration: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + else + ((Msg.send (bio, MsgError "Not authorized to regeneration"); + print "Unauthorized user asked to regenerate!\n"; + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgRmuser user => + if Acl.query {user = user, class = "priv", value = "all"} then + ((rmuser user; + Acl.write Config.aclFile; + Msg.send (bio, MsgOk); + print ("Removed user " ^ user ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during revocation: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + else + ((Msg.send (bio, MsgError "Not authorized to remove users"); + print "Unauthorized user asked to remove a user!\n"; + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + | _ => (Msg.send (bio, MsgError "Unexpected command") handle OpenSSL.OpenSSL _ => (); @@ -237,6 +694,16 @@ fun service () = in cmdLoop () 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"); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) in print "Listening for connections....\n"; loop (); @@ -245,7 +712,7 @@ fun service () = fun slave () = let - val host = hostname () + val host = Slave.hostname () val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem", Config.keyDir ^ "/" ^ host ^ "/key.pem", @@ -274,6 +741,8 @@ fun slave () = MsgFile file => loop' (file :: files) | MsgDoFiles => (Slave.handleChanges files; Msg.send (bio, MsgOk)) + | MsgRegenerate => (Domain.resetLocal (); + Msg.send (bio, MsgOk)) | _ => (print "Dispatcher sent unexpected command\n"; Msg.send (bio, MsgError "Unexpected command")) in @@ -287,6 +756,11 @@ fun slave () = OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ()) + | OS.SysErr (s, _) => + (print ("System error: "^ s ^ "\n"); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) in loop (); OpenSSL.shutdown sock