if !ErrorMsg.anyErrors then
G
else
- Tycheck.checkFile G (Defaults.tInit ()) prog
+ (Option.app (Unused.check G) (#3 prog);
+ Tycheck.checkFile G (Defaults.tInit ()) prog)
end
fun basis () =
if !ErrorMsg.anyErrors then
raise ErrorMsg.Error
else
- (G', #3 prog)
+ (Option.app (Unused.check b) (#3 prog);
+ (G', #3 prog))
end
end
end
String.sub (s, 0) <> #"."
andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") s
-fun checkDir dname =
+fun setupUser () =
+ let
+ 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
+ in
+ Acl.read Config.aclFile;
+ Domain.setUser user;
+ user
+ end
+
+fun checkDir' dname =
let
val b = basis ()
())
end
+fun checkDir dname =
+ (setupUser ();
+ checkDir' dname)
+
fun reduce fname =
let
val (G, body) = check fname
raise ErrorMsg.Error
else
Eval.exec (Defaults.eInit ()) body'
- | NONE => raise ErrorMsg.Error
+ | NONE => ()
fun eval' fname =
case reduce fname of
raise ErrorMsg.Error
else
ignore (Eval.exec' (Defaults.eInit ()) body')
- | NONE => raise ErrorMsg.Error
+ | NONE => ()
val dispatcher =
Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
print ("Additional information: " ^ s ^ "\n");
raise e)
-fun setupUser () =
- let
- 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
- in
- Acl.read Config.aclFile;
- Domain.setUser user;
- user
- end
-
fun requestContext f =
let
val user = setupUser ()
val _ = ErrorMsg.reset ()
- val (user, bio) = requestBio (fn () => checkDir dname)
+ val (user, bio) = requestBio (fn () => checkDir' dname)
val b = basis ()
val (_, files) = Order.order (SOME b) files
val _ = if !ErrorMsg.anyErrors then
- raise ErrorMsg.Error
+ (print "J\n";raise ErrorMsg.Error)
else
()
let
val (user, bio) = requestBio (fn () => ())
in
- Msg.send (bio, MsgCreateDbTable p);
+ Msg.send (bio, MsgCreateDb p);
case Msg.recv bio of
NONE => print "Server closed connection unexpectedly.\n"
| SOME m =>
case m of
MsgMailboxes users => (Msg.send (bio, MsgOk);
Vmail.Listing users)
- | MsgError s => Vmail.Error ("Creation failed: " ^ s)
+ | MsgError s => Vmail.Error ("Listing failed: " ^ s)
| _ => Vmail.Error "Unexpected server reply.")
before OpenSSL.close bio
end
before OpenSSL.close bio
end
-fun regenerate context =
+fun requestDescribe dom =
+ let
+ val (_, bio) = requestBio (fn () => ())
+ in
+ Msg.send (bio, MsgDescribe dom);
+ case Msg.recv bio of
+ NONE => print "Server closed connection unexpectedly.\n"
+ | SOME m =>
+ case m of
+ MsgDescription s => print s
+ | MsgError s => print ("Description failed: " ^ s ^ "\n")
+ | _ => print "Unexpected server reply.\n";
+ OpenSSL.close bio
+ end
+
+structure SS = StringSet
+
+fun domainList dname =
+ let
+ val dir = Posix.FileSys.opendir dname
+
+ fun visitNode dset =
+ case Posix.FileSys.readdir dir of
+ NONE => dset
+ | SOME node =>
+ let
+ val path = OS.Path.joinDirFile {dir = dname,
+ file = node}
+
+ fun visitDomains (path, bfor, dset) =
+ let
+ val dir = Posix.FileSys.opendir path
+
+ fun loop dset =
+ case Posix.FileSys.readdir dir of
+ NONE => dset
+ | SOME dname =>
+ let
+ val path = OS.Path.joinDirFile {dir = path,
+ file = dname}
+ in
+ if Posix.FileSys.ST.isDir (Posix.FileSys.stat path) then
+ let
+ val bfor = dname :: bfor
+ in
+ loop (visitDomains (path, bfor,
+ SS.add (dset,
+ String.concatWith "." bfor)))
+ end
+ else
+ loop dset
+ end
+ in
+ loop dset
+ before Posix.FileSys.closedir dir
+ end
+ in
+ visitNode (visitDomains (path, [], dset))
+ end
+ in
+ visitNode SS.empty
+ before Posix.FileSys.closedir dir
+ end
+
+fun regenerateEither tc checker context =
let
+ val () = print "Starting regeneration....\n"
+
+ val domainsBefore =
+ if tc then
+ SS.empty
+ else
+ domainList Config.resultRoot
+
+ fun ifReal f =
+ if tc then
+ ()
+ else
+ f ()
+
val _ = ErrorMsg.reset ()
val b = basis ()
val () = Tycheck.disallowExterns ()
- val () = Domain.resetGlobal ()
+ val () = ifReal (fn () =>
+ (ignore (OS.Process.system ("rm -rf " ^ Config.oldResultRoot ^ "/*"));
+ ignore (OS.Process.system ("cp -r " ^ Config.resultRoot
+ ^ "/* " ^ Config.oldResultRoot ^ "/"));
+ Domain.resetGlobal ()))
val ok = ref true
in
if !ErrorMsg.anyErrors then
(ErrorMsg.reset ();
- print ("User " ^ user ^ "'s configuration has errors!\n"))
+ print ("User " ^ user ^ "'s configuration has errors!\n");
+ ok := false)
else
- app eval' files
+ ();
+ app checker files
end
+ else if String.isSuffix "_admin" user then
+ ()
else
- ()
+ (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n");
+ ok := false)
end
- handle IO.Io _ => ()
- | OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n");
- ok := false)
+ handle IO.Io {name, function, ...} =>
+ (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
+ ok := false)
+ | exn as 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 ();
+ ifReal (fn () => (app contactNode Config.nodeIps;
+ Env.pre ()));
app doUser (Acl.users ());
- Env.post ();
+ ifReal (fn () =>
+ let
+ val domainsAfter = domainList Config.resultRoot
+ val domainsGone = SS.difference (domainsBefore, domainsAfter)
+ in
+ if SS.isEmpty domainsGone then
+ ()
+ else
+ (print "Domains to kill:";
+ SS.app (fn s => (print " "; print s)) domainsGone;
+ print "\n";
+
+ Domain.rmdom' Config.oldResultRoot (SS.listItems domainsGone));
+
+ Env.post ()
+ end);
!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
+val regenerate = regenerateEither false eval'
+val regenerateTc = regenerateEither true (ignore o check)
fun rmuser user =
let
SOME ("Error adding user: " ^ msg)))
(fn () => ())
- | MsgCreateDbTable {dbtype, dbname} =>
+ | MsgCreateDb {dbtype, dbname} =>
doIt (fn () =>
if Dbms.validDbname dbname then
case Dbms.lookup dbtype of
SOME "Invalid password; may only contain printable, non-space characters")
else if not (Domain.yourPath mailbox) then
("User wasn't authorized to add a mailbox at " ^ mailbox,
- SOME "You're not authorized to use that mailbox location.")
+ SOME ("You're not authorized to use that mailbox location. ("
+ ^ mailbox ^ ")"))
else
case Vmail.add {requester = user,
domain = domain, user = emailUser,
SOME "Script execution failed."))
(fn () => ())
+ | MsgDescribe dom =>
+ doIt (fn () => if not (Domain.validDomain dom) then
+ ("Requested description of invalid domain " ^ dom,
+ SOME "Invalid domain name")
+ else if not (Domain.yourDomain dom
+ orelse Acl.query {user = user, class = "priv", value = "all"}) then
+ ("Requested description of " ^ dom ^ ", but not allowed access",
+ SOME "Access denied")
+ else
+ (Msg.send (bio, MsgDescription (Domain.describe dom));
+ ("Sent description of domain " ^ dom,
+ NONE)))
+ (fn () => ())
+
| _ =>
doIt (fn () => ("Unexpected command",
SOME "Unexpected command"))
OpenSSL.close bio
handle OpenSSL.OpenSSL _ => ();
loop ())
+ | OS.Path.InvalidArc =>
+ (print "Invalid arc\n";
+ 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;
loop ())
end handle OpenSSL.OpenSSL s =>
- (print ("OpenSSL error: "^ s ^ "\n");
+ (print ("OpenSSL error: " ^ s ^ "\n");
OpenSSL.close bio
handle OpenSSL.OpenSSL _ => ();
loop ())
OpenSSL.close bio
handle OpenSSL.OpenSSL _ => ();
loop ())
+ | IO.Io {function, name, ...} =>
+ (print ("IO error: " ^ function ^ ": " ^ name ^ "\n");
+ OpenSSL.close bio
+ handle OpenSSL.OpenSSL _ => ();
+ loop ())
+ | e =>
+ (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e);
+ print "Uncaught exception!\n";
+ OpenSSL.close bio
+ handle OpenSSL.OpenSSL _ => ();
+ loop ())
in
loop ();
OpenSSL.shutdown sock
HCoop / hcoop / domtool2.git / blobdiff