Make 'domtool -tc' (no other arguments) work properly

[hcoop/domtool2.git] / src / main.sml

diff --git a/src/main.sml b/src/main.sml
index d57b867..f32fa2d 100644 (file)
--- a/src/main.sml
+++ b/src/main.sml
@@ -96,7 +96,24 @@ 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 =
+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 ()
 
@@ -127,6 +144,10 @@ fun checkDir dname =
                 ())
     end
 
+fun checkDir dname =
+    (setupUser ();
+     checkDir' dname)
+
 fun reduce fname =
     let
        val (G, body) = check fname
@@ -180,23 +201,6 @@ fun context x =
            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 ()
@@ -262,7 +266,7 @@ fun requestDir dname =
 
        val _ = ErrorMsg.reset ()
 
-       val (user, bio) = requestBio (fn () => checkDir dname)
+       val (user, bio) = requestBio (fn () => checkDir' dname)
 
        val b = basis ()
 
@@ -524,7 +528,7 @@ fun requestDbTable p =
     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 =>
@@ -576,7 +580,7 @@ fun requestListMailboxes domain =
             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
@@ -869,14 +873,20 @@ fun requestFirewall {node, uname} =
        before OpenSSL.close bio
     end
 
-fun regenerate context =
+fun regenerateEither tc checker context =
     let
+       fun ifReal f =
+           if tc then
+               ()
+           else
+               f ()
+
        val _ = ErrorMsg.reset ()
 
        val b = basis ()
        val () = Tycheck.disallowExterns ()
 
-       val () = Domain.resetGlobal ()
+       val () = ifReal Domain.resetGlobal
 
        val ok = ref true
  
@@ -934,83 +944,31 @@ fun regenerate context =
                            (ErrorMsg.reset ();
                             print ("User " ^ user ^ "'s configuration has errors!\n"))
                        else
-                           app eval' files
+                           app checker files
                    end
                else
                    ()
            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 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
+val regenerate = regenerateEither false eval'
+val regenerateTc = regenerateEither true (ignore o check)
 
 fun rmuser user =
     let
@@ -1283,7 +1241,7 @@ fun service () =
                                                   SOME ("Error adding user: " ^ msg)))
                                      (fn () => ())
 
-                              | MsgCreateDbTable {dbtype, dbname} =>
+                              | MsgCreateDb {dbtype, dbname} =>
                                 doIt (fn () =>
                                          if Dbms.validDbname dbname then
                                              case Dbms.lookup dbtype of
@@ -1361,7 +1319,8 @@ fun service () =
                                               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,