Saving environment variables across file executions

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

diff --git a/src/main.sml b/src/main.sml
index fc8df17..a0f402d 100644 (file)
--- a/src/main.sml
+++ b/src/main.sml
@@ -25,15 +25,29 @@ open Ast MsgTypes Print
 structure SM = StringMap
 
 fun init () = Acl.read Config.aclFile
-           
+
+fun isLib fname = OS.Path.file fname = "lib.dtl"
+
+fun wrapFile (fname, file) =
+    case (isLib fname, file) of
+       (true, (comment, ds, SOME e)) =>
+       let
+           val (_, loc) = e
+       in
+           (comment, ds, SOME (ELocal (e, (ESkip, loc)), loc))
+       end
+      | _ => file
+
 fun check' G fname =
     let
        val prog = Parse.parse fname
+       val prog = wrapFile (fname, prog)
     in
        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) prog)
     end
 
 fun basis () =
@@ -63,12 +77,12 @@ fun basis () =
             before Tycheck.disallowExterns ())
     end
 
-fun check fname =
+(* val b = basis () *)
+
+fun check G fname =
     let
        val _ = ErrorMsg.reset ()
        val _ = Env.preTycheck ()
-
-       val b = basis ()
     in
        if !ErrorMsg.anyErrors then
            raise ErrorMsg.Error
@@ -77,17 +91,19 @@ fun check fname =
                val _ = Tycheck.disallowExterns ()
                val _ = ErrorMsg.reset ()
                val prog = Parse.parse fname
+               val prog = wrapFile (fname, prog)
            in
                if !ErrorMsg.anyErrors then
                    raise ErrorMsg.Error
                else
                    let
-                       val G' = Tycheck.checkFile b (Defaults.tInit ()) prog
+                       val G' = Tycheck.checkFile G (Defaults.tInit prog) prog
                    in
                        if !ErrorMsg.anyErrors then
                            raise ErrorMsg.Error
                        else
-                           (G', #3 prog)
+                           (Option.app (Unused.check G) (#3 prog);
+                            (G', #3 prog))
                    end
            end
     end
@@ -148,9 +164,9 @@ fun checkDir dname =
     (setupUser ();
      checkDir' dname)
 
-fun reduce fname =
+fun reduce G fname =
     let
-       val (G, body) = check fname
+       val (G, body) = check G fname
     in
        if !ErrorMsg.anyErrors then
            NONE
@@ -164,28 +180,25 @@ fun reduce fname =
                                         [PD.string "Result:",
                                          PD.space 1,
                                          p_exp body']))*)
-                   SOME body'
+                   SOME (G, body')
                end
              | _ => NONE
     end
 
-fun eval fname =
-    case reduce fname of
-       (SOME body') =>
-       if !ErrorMsg.anyErrors then
-           raise ErrorMsg.Error
-       else
-           Eval.exec (Defaults.eInit ()) body'
-      | NONE => raise ErrorMsg.Error
+(*(Defaults.eInit ())*)
 
-fun eval' fname =
-    case reduce fname of
-       (SOME body') =>
+fun eval G evs fname =
+    case reduce G fname of
+       SOME (G, body') =>
        if !ErrorMsg.anyErrors then
            raise ErrorMsg.Error
        else
-           ignore (Eval.exec' (Defaults.eInit ()) body')
-      | NONE => raise ErrorMsg.Error
+           let
+               val evs' = Eval.exec' evs body'
+           in
+               (G, evs')
+           end
+      | NONE => (G, evs)
 
 val dispatcher =
     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
@@ -230,7 +243,7 @@ fun requestSlaveBio () =
 
 fun request fname =
     let
-       val (user, bio) = requestBio (fn () => ignore (check fname))
+       val (user, bio) = requestBio (fn () => ignore (check (basis ()) fname))
 
        val inf = TextIO.openIn fname
 
@@ -288,7 +301,7 @@ fun requestDir dname =
        val (_, files) = Order.order (SOME b) files
 
        val _ = if !ErrorMsg.anyErrors then
-                   raise ErrorMsg.Error
+                   (print "J\n";raise ErrorMsg.Error)
                else
                    ()
 
@@ -939,7 +952,13 @@ fun domainList dname =
 
 fun regenerateEither tc checker context =
     let
-       val domainsBefore = domainList Config.resultRoot
+       val () = print "Starting regeneration....\n"
+
+       val domainsBefore =
+           if tc then
+               SS.empty
+           else
+               domainList Config.resultRoot
 
        fun ifReal f =
            if tc then
@@ -1009,16 +1028,23 @@ fun regenerateEither tc checker context =
 
                        val files = loop []
                        val (_, files) = Order.order (SOME b) files
+
+                       fun checker' (file, (G, evs)) =
+                           checker G evs file
                    in
                        if !ErrorMsg.anyErrors then
                            (ErrorMsg.reset ();
                             print ("User " ^ user ^ "'s configuration has errors!\n");
                             ok := false)
                        else
-                           app checker files
+                           ();
+                       ignore (foldl checker' (basis (), Defaults.eInit ()) 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 {name, function, ...} =>
                   (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n");
@@ -1053,8 +1079,10 @@ fun regenerateEither tc checker context =
        !ok
     end
 
-val regenerate = regenerateEither false eval'
-val regenerateTc = regenerateEither true (ignore o check)
+val regenerate = regenerateEither false eval
+val regenerateTc = regenerateEither true
+                                   (fn G => fn evs => fn file =>
+                                                         (#1 (check G file), evs))
 
 fun rmuser user =
     let
@@ -1153,17 +1181,17 @@ fun service () =
 
                             val outname = OS.FileSys.tmpName ()
 
-                            fun doOne code =
+                            fun doOne (code, (G, evs)) =
                                 let
                                     val outf = TextIO.openOut outname
                                 in
                                     TextIO.output (outf, code);
                                     TextIO.closeOut outf;
-                                    eval' outname
+                                    eval G evs outname
                                 end
                         in
                             doIt (fn () => (Env.pre ();
-                                            app doOne codes;
+                                            ignore (foldl doOne (basis (), Defaults.eInit ()) codes);
                                             Env.post ();
                                             Msg.send (bio, MsgOk);
                                             ("Configuration complete.", NONE)))
@@ -1629,7 +1657,7 @@ fun slave () =
                          | _ => (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 ())
@@ -1639,6 +1667,17 @@ fun slave () =
                            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