X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/1824f573f7f8720514af1dc94d7cfb1de5b15fef..ae1479386628436613a664b6601f6ca833dd6b2d:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 715b486..5f2038d 100644 --- a/src/main.sml +++ b/src/main.sml @@ -371,10 +371,80 @@ fun requestRmdom dom = OpenSSL.close bio end -fun regenerate () = +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 requestDbUser dbtype = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgCreateDbUser dbtype); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Your user has been created.\n" + | MsgError s => print ("Creation failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestDbTable p = + let + val (user, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgCreateDbTable p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n") + | MsgError s => print ("Creation failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun regenerate context = let val b = basis () - val _ = Tycheck.disallowExterns () + 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 @@ -408,11 +478,24 @@ fun regenerate () = 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 @@ -557,12 +640,15 @@ fun service () = handle OpenSSL.OpenSSL _ => (); loop ()) - | MsgRmdom dom => + | MsgRmdom doms => if Acl.query {user = user, class = "priv", value = "all"} - orelse Acl.query {user = user, class = "domain", value = dom} then - ((Domain.rmdom dom; + 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 domain " ^ dom ^ ".\n")) + print ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".\n")) handle OpenSSL.OpenSSL s => (print "OpenSSL error\n"; Msg.send (bio, @@ -584,7 +670,7 @@ fun service () = | MsgRegenerate => if Acl.query {user = user, class = "priv", value = "regen"} orelse Acl.query {user = user, class = "priv", value = "all"} then - ((regenerate (); + ((regenerate context; Msg.send (bio, MsgOk); print "Regenerated all configuration.\n") handle OpenSSL.OpenSSL s => @@ -603,7 +689,99 @@ fun service () = ignore (OpenSSL.readChar bio); OpenSSL.close bio) handle OpenSSL.OpenSSL _ => (); - loop ()) + 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 ()) + + | MsgCreateDbUser dbtype => + (case Dbms.lookup dbtype of + NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype)); + print ("Database user creation request with unknown datatype type " ^ dbtype); + ignore (OpenSSL.readChar bio)) + handle OpenSSL.OpenSSL _ => (); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | SOME handler => + case #adduser handler user of + NONE => ((Msg.send (bio, MsgOk); + print ("Added " ^ dbtype ^ " user " ^ user ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during creation: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + | SOME msg => ((Msg.send (bio, MsgError ("Error adding user: " ^ msg)); + print ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg ^ "\n"); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ())) + + | MsgCreateDbTable {dbtype, dbname} => + if Dbms.validDbname dbname then + (case Dbms.lookup dbtype of + NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype)); + print ("Database creation request with unknown datatype type " ^ dbtype); + ignore (OpenSSL.readChar bio)) + handle OpenSSL.OpenSSL _ => (); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | SOME handler => + case #createdb handler {user = user, dbname = dbname} of + NONE => ((Msg.send (bio, MsgOk); + print ("Created database " ^ user ^ "_" ^ dbname ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during creation: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + | SOME msg => ((Msg.send (bio, MsgError ("Error creating database: " ^ msg)); + print ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg ^ "\n"); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ())) + else + ((Msg.send (bio, MsgError ("Invalid database name " ^ dbname)); + print ("Invalid database name " ^ user ^ "_" ^ dbname ^ "\n"); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) | _ => (Msg.send (bio, MsgError "Unexpected command") @@ -661,6 +839,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 @@ -684,7 +864,7 @@ fun slave () = OpenSSL.shutdown sock end -fun autodocBasis outdir = +fun listBasis () = let val dir = Posix.FileSys.opendir Config.libRoot @@ -699,10 +879,11 @@ fun autodocBasis outdir = :: files) else loop files - - val files = loop [] in - Autodoc.autodoc {outdir = outdir, infiles = files} + loop [] end +fun autodocBasis outdir = + Autodoc.autodoc {outdir = outdir, infiles = listBasis ()} + end