X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/d22c1f00ed619c221dc9891c86c5ced202a9ee77..0c85f25e773621daeb1b4ecff989dfbb602a8918:/src/main.sml diff --git a/src/main.sml b/src/main.sml index e106823..f3bedc2 100644 --- a/src/main.sml +++ b/src/main.sml @@ -92,7 +92,9 @@ fun check fname = end end -val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") +fun notTmp s = + String.sub (s, 0) <> #"." + andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") s fun checkDir dname = let @@ -172,11 +174,12 @@ val self = fun context x = (OpenSSL.context false x) - handle e as OpenSSL.OpenSSL _ => + handle e as OpenSSL.OpenSSL s => (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n"; + print ("Additional information: " ^ s ^ "\n"); raise e) -fun requestContext f = +fun setupUser () = let val user = case Posix.ProcEnv.getenv "DOMTOOL_USER" of @@ -187,9 +190,15 @@ fun requestContext f = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) end | SOME user => user - - val () = Acl.read Config.aclFile - val () = Domain.setUser user + in + Acl.read Config.aclFile; + Domain.setUser user; + user + end + +fun requestContext f = + let + val user = setupUser () val () = f () @@ -242,6 +251,14 @@ fun request fname = fun requestDir dname = let + val _ = if Posix.FileSys.access (dname, []) then + () + else + (print ("Can't access " ^ dname ^ ".\n"); + print "Did you mean to run domtool on a specific file, instead of asking for all\n"; + print "files in your ~/domtool directory?\n"; + OS.Process.exit OS.Process.failure) + val _ = ErrorMsg.reset () val (user, bio) = requestBio (fn () => checkDir dname) @@ -427,6 +444,21 @@ fun requestRegen () = OpenSSL.close bio end +fun requestRegenTc () = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRegenerateTc); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "All configuration validated.\n" + | MsgError s => print ("Configuration validation failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun requestRmdom dom = let val (_, bio) = requestBio (fn () => ()) @@ -796,14 +828,12 @@ fun regenerate context = 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 () + val ok = ref true + fun contactNode (node, ip) = if node = Config.defaultNode then Domain.resetLocal () @@ -825,7 +855,8 @@ fun regenerate context = | _ => print ("Slave " ^ node ^ " returned unexpected command\n"); OpenSSL.close bio - end + end + handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n") fun doUser user = let @@ -833,38 +864,106 @@ fun regenerate context = val _ = ErrorMsg.reset () val dname = Config.domtoolDir user + in + if Posix.FileSys.access (dname, []) then + let + 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 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) + val files = loop [] + val (_, files) = Order.order (SOME b) files + in + if !ErrorMsg.anyErrors then + (ErrorMsg.reset (); + print ("User " ^ user ^ "'s configuration has errors!\n")) 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") + app eval' files + end else - app eval' files + () 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" + handle IO.Io _ => () + | OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n"); + ok := false) + | ErrorMsg.Error => (ErrorMsg.reset (); + print ("User " ^ user ^ " had a compilation error.\n"); + ok := false) + | _ => (print "Unknown exception during regeneration!\n"; + ok := false) in app contactNode Config.nodeIps; Env.pre (); app doUser (Acl.users ()); - Env.post () + Env.post (); + !ok + end + +fun regenerateTc context = + let + val _ = ErrorMsg.reset () + + val b = basis () + val () = Tycheck.disallowExterns () + + val () = Domain.resetGlobal () + + val ok = ref true + + fun doUser user = + let + val _ = Domain.setUser user + val _ = ErrorMsg.reset () + + val dname = Config.domtoolDir user + in + if Posix.FileSys.access (dname, []) then + let + 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 + (ErrorMsg.reset (); + print ("User " ^ user ^ "'s configuration has errors!\n"); + ok := false) + else + app (ignore o check) files + end + else + () + end + handle IO.Io _ => () + | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") + | ErrorMsg.Error => (ErrorMsg.reset (); + print ("User " ^ user ^ " had a compilation error.\n")) + | _ => print "Unknown exception during -tc regeneration!\n" + in + app doUser (Acl.users ()); + !ok end fun rmuser user = @@ -929,8 +1028,11 @@ fun service () = (print msgLocal; print "\n"; Msg.send (bio, MsgOk))) - handle OpenSSL.OpenSSL _ => - print "OpenSSL error\n" + handle e as (OpenSSL.OpenSSL s) => + (print ("OpenSSL error: " ^ s ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + Msg.send (bio, MsgError ("OpenSSL error: " ^ s)) + handle OpenSSL.OpenSSL _ => ()) | OS.SysErr (s, _) => (print "System error: "; print s; @@ -1069,14 +1171,32 @@ fun service () = doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"} orelse Acl.query {user = user, class = "priv", value = "all"} then - (regenerate context; - ("Regenerated all configuration.", - NONE)) + (if regenerate context then + ("Regenerated all configuration.", + NONE) + else + ("Error regenerating configuration!", + SOME "Error regenerating configuration! Consult /var/log/domtool.log.")) else ("Unauthorized user asked to regenerate!", SOME "Not authorized to regenerate")) (fn () => ()) + | MsgRegenerateTc => + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "regen"} + orelse Acl.query {user = user, class = "priv", value = "all"} then + (if regenerateTc context then + ("Checked all configuration.", + NONE) + else + ("Found a compilation error!", + SOME "Found a compilation error! Consult /var/log/domtool.log.")) + else + ("Unauthorized user asked to regenerate -tc!", + SOME "Not authorized to regenerate -tc")) + (fn () => ()) + | MsgRmuser user' => doIt (fn () => if Acl.query {user = user, class = "priv", value = "all"} then @@ -1255,8 +1375,9 @@ fun service () = in cmdLoop () end - handle OpenSSL.OpenSSL s => + handle e as (OpenSSL.OpenSSL s) => (print ("OpenSSL error: " ^ s ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ())