Preliminary regeneration support

diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg
index 6d1c7e1..e1d427a 100644 (file)
--- a/configDefault/domtool.cfg
+++ b/configDefault/domtool.cfg
@@ -51,3 +51,8 @@ val serialDir = "/afs/hcoop.net/common/etc/domtool/serials"
 val dispatcherName = "deleuze.hcoop.net"
 
 val homeBase = "/afs/hcoop.net/usr"
 val dispatcherName = "deleuze.hcoop.net"
 
 val homeBase = "/afs/hcoop.net/usr"

+
+fun domtoolDir user =
+    case user of
+       "domtool" => "/afs/hcoop.net/common/etc/domtool/domtool"
+      | _ => "/afs/hcoop.net/usr/" ^ user ^ "/domtool"

diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs
index b27b48a..61375b1 100644 (file)
--- a/configDefault/domtool.cfs
+++ b/configDefault/domtool.cfs
@@ -60,3 +60,5 @@ val dnsNodes_admin : string list
 
 val mailNodes_all : string list
 val mailNodes_admin : string list
 
 val mailNodes_all : string list
 val mailNodes_admin : string list

+
+val domtoolDir : string -> string

diff --git a/src/acl.sig b/src/acl.sig
index 2ac1f19..10abcde 100644 (file)
--- a/src/acl.sig
+++ b/src/acl.sig
@@ -30,6 +30,9 @@ signature ACL = sig
     val queryAll : string -> (string * string list) list
     (* What are all of a user's permissions, by class? *)
 
     val queryAll : string -> (string * string list) list
     (* What are all of a user's permissions, by class? *)
 

+    val users : unit -> string list
+    (* Which users have been granted privileges? *)
+

     val whoHas : {class : string, value : string} -> string list
     (* Which users have a permission? *)
 
     val whoHas : {class : string, value : string} -> string list
     (* Which users have a permission? *)
 

diff --git a/src/acl.sml b/src/acl.sml
index 6634f91..be30fdf 100644 (file)
--- a/src/acl.sml
+++ b/src/acl.sml
@@ -44,6 +44,8 @@ fun queryAll user =
                                      (class, SS.foldr (op::) [] values) :: out)
                                  [] classes
 
                                      (class, SS.foldr (op::) [] values) :: out)
                                  [] classes
 

+fun users () = SM.foldri (fn (user, _, ls) => user :: ls) [] (!acl)
+

 fun whoHas {class, value} =
     SM.foldri (fn (user, classes, users) =>
                  case SM.find (classes, class) of
 fun whoHas {class, value} =
     SM.foldri (fn (user, classes, users) =>
                  case SM.find (classes, class) of

diff --git a/src/eval.sig b/src/eval.sig
index e9cd6aa..3d05210 100644 (file)
--- a/src/eval.sig
+++ b/src/eval.sig
@@ -21,5 +21,6 @@
 signature EVAL = sig
 
     val exec : Env.env_vars -> Ast.exp -> unit
 signature EVAL = sig
 
     val exec : Env.env_vars -> Ast.exp -> unit

+    val exec' : Env.env_vars -> Ast.exp -> Env.env_vars

     
 end
     
 end

diff --git a/src/eval.sml b/src/eval.sml
index 7aa8053..6cbeca7 100644 (file)
--- a/src/eval.sml
+++ b/src/eval.sml
@@ -56,58 +56,58 @@ fun findPrimitive e =
        (name, rev args)
     end
 
        (name, rev args)
     end
 

-fun exec evs e =
-    let
-       fun exec' evs (eAll as (e, _)) =
-           case e of
-               ESkip => SM.empty
-             | ESet (ev, e) => SM.insert (SM.empty, ev, e)
-             | EGet (x, ev, e) => exec' evs (Reduce.subst x (lookup (evs, ev)) e)
-             | ESeq es =>
-               let
-                   val (new, _) =
-                       foldl (fn (e, (new, keep)) =>
-                                 let
-                                     val new' = exec' keep e
-                                 in
-                                     (conjoin (new, new'),
-                                      conjoin (keep, new'))
-                                 end) (SM.empty, evs) es
-               in
-                   new
-               end
-             | ELocal (e1, e2) =>
-               let
-                   val evs' = exec' evs e1
-                   val evs'' = exec' (conjoin (evs, evs')) e2
-               in
-                   conjoin (evs, evs'')
-               end
-             | EWith (e1, e2) =>
+fun exec' evs (eAll as (e, _)) =
+    case e of
+       ESkip => SM.empty
+      | ESet (ev, e) => SM.insert (SM.empty, ev, e)
+      | EGet (x, ev, e) => exec' evs (Reduce.subst x (lookup (evs, ev)) e)
+      | ESeq es =>
+       let
+           val (new, _) =
+               foldl (fn (e, (new, keep)) =>
+                         let
+                             val new' = exec' keep e
+                         in
+                             (conjoin (new, new'),
+                              conjoin (keep, new'))
+                         end) (SM.empty, evs) es
+       in
+           new
+       end
+      | ELocal (e1, e2) =>
+       let
+           val evs' = exec' evs e1
+           val evs'' = exec' (conjoin (evs, evs')) e2
+       in
+           conjoin (evs, evs'')
+       end
+      | EWith (e1, e2) =>
+       let
+           val (prim, args) = findPrimitive e1
+       in
+           case Env.container prim of
+               NONE => raise Fail "Unbound primitive container"
+             | SOME (action, cleanup) =>

                let
                let

-                   val (prim, args) = findPrimitive e1
+                   val evs' = action (evs, args)
+                   val evs'' = exec' evs e2

                in
                in

-                   case Env.container prim of
-                       NONE => raise Fail "Unbound primitive container"
-                     | SOME (action, cleanup) =>
-                       let
-                           val evs' = action (evs, args)
-                           val evs'' = exec' evs e2
-                       in
-                           cleanup ();
-                           evs'
-                       end
+                   cleanup ();
+                   evs'

                end
                end

+       end

 
 

-             | _ =>
-               let
-                   val (prim, args) = findPrimitive eAll
-               in
-                   case Env.action prim of
-                       NONE => raise Fail "Unbound primitive action"
-                     | SOME action => action (evs, args)
-               end
+      | _ =>
+       let
+           val (prim, args) = findPrimitive eAll
+       in
+           case Env.action prim of
+               NONE => raise Fail "Unbound primitive action"
+             | SOME action => action (evs, args)
+       end

 
 

+fun exec evs e =
+    let

        val _ = Env.pre ()
        val evs' = exec' evs e
     in
        val _ = Env.pre ()
        val evs' = exec' evs e
     in

diff --git a/src/main-admin.sml b/src/main-admin.sml
index e0081b4..2931ae6 100644 (file)
--- a/src/main-admin.sml
+++ b/src/main-admin.sml
@@ -42,4 +42,5 @@ val _ =
              app (fn user => print (" " ^ user)) users;
              print "\n"))
       | ["rmdom", dom] => Main.requestRmdom dom
              app (fn user => print (" " ^ user)) users;
              print "\n"))
       | ["rmdom", dom] => Main.requestRmdom dom

+      | ["regen"] => Main.requestRegen ()

       | _ => print "Invalid command-line arguments\n"
       | _ => print "Invalid command-line arguments\n"

diff --git a/src/main.sig b/src/main.sig
index 941b704..c086bd5 100644 (file)
--- a/src/main.sig
+++ b/src/main.sig
@@ -24,7 +24,7 @@ signature MAIN = sig
 
     val check : string -> Env.env * Ast.exp option
     val check' : Env.env -> string -> Env.env
 
     val check : string -> Env.env * Ast.exp option
     val check' : Env.env -> string -> Env.env

-    val checkDir : string -> bool
+    val checkDir : string -> unit

 
     val basis : unit -> Env.env
 
 
     val basis : unit -> Env.env
 


@@ -39,6 +39,7 @@ signature MAIN = sig
     val requestListPerms : string -> (string * string list) list option
     val requestWhoHas : {class : string, value : string} -> string list option
     val requestRmdom : string -> unit
     val requestListPerms : string -> (string * string list) list option
     val requestWhoHas : {class : string, value : string} -> string list option
     val requestRmdom : string -> unit

+    val requestRegen : unit -> unit

 
     val service : unit -> unit
     val slave : unit -> unit
 
     val service : unit -> unit
     val slave : unit -> unit

diff --git a/src/main.sml b/src/main.sml
index 0f65362..715b486 100644 (file)
--- a/src/main.sml
+++ b/src/main.sml
@@ -116,10 +116,13 @@ fun checkDir dname =
        val (_, files) = Order.order (SOME b) files
     in
        if !ErrorMsg.anyErrors then
        val (_, files) = Order.order (SOME b) files
     in
        if !ErrorMsg.anyErrors then

-           false
+           raise ErrorMsg.Error

        else
            (foldl (fn (fname, G) => check' G fname) b files;
        else
            (foldl (fn (fname, G) => check' G fname) b files;

-            !ErrorMsg.anyErrors)
+            if !ErrorMsg.anyErrors then
+                raise ErrorMsg.Error
+            else
+                ())

     end
 
 fun reduce fname =
     end
 
 fun reduce fname =


@@ -152,6 +155,15 @@ fun eval fname =
            Eval.exec (Defaults.eInit ()) body'
       | NONE => raise ErrorMsg.Error
 
            Eval.exec (Defaults.eInit ()) body'
       | NONE => raise ErrorMsg.Error
 

+fun eval' fname =
+    case reduce fname of
+       (SOME body') =>
+       if !ErrorMsg.anyErrors then
+           raise ErrorMsg.Error
+       else
+           ignore (Eval.exec' (Defaults.eInit ()) body')
+      | NONE => raise ErrorMsg.Error
+

 val dispatcher =
     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 
 val dispatcher =
     Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
 


@@ -207,7 +219,9 @@ fun request fname =
 
 fun requestDir dname =
     let
 
 fun requestDir dname =
     let

-       val (user, bio) = requestBio (fn () => ignore (checkDir dname))
+       val _ = ErrorMsg.reset ()
+
+       val (user, bio) = requestBio (fn () => checkDir dname)

 
        val b = basis ()
 
 
        val b = basis ()
 


@@ -246,15 +260,18 @@ fun requestDir dname =
                                before TextIO.closeIn inf
                            end) files
     in
                                before TextIO.closeIn inf
                            end) files
     in

-       Msg.send (bio, MsgMultiConfig codes);
-       case Msg.recv bio of
-           NONE => print "Server closed connection unexpectedly.\n"
-         | SOME m =>
-           case m of
-               MsgOk => print "Configuration succeeded.\n"
-             | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
-             | _ => print "Unexpected server reply.\n";
-       OpenSSL.close bio
+       if !ErrorMsg.anyErrors then
+           ()
+       else
+           (Msg.send (bio, MsgMultiConfig codes);
+            case Msg.recv bio of
+                NONE => print "Server closed connection unexpectedly.\n"
+              | SOME m =>
+                case m of
+                    MsgOk => print "Configuration succeeded.\n"
+                  | MsgError s => print ("Configuration failed: " ^ s ^ "\n")
+                  | _ => print "Unexpected server reply.\n";
+            OpenSSL.close bio)

     end
     handle ErrorMsg.Error => ()
 
     end
     handle ErrorMsg.Error => ()
 


@@ -324,6 +341,21 @@ fun requestWhoHas perm =
        before OpenSSL.close bio
     end
 
        before OpenSSL.close bio
     end
 

+fun requestRegen () =
+    let
+       val (_, bio) = requestBio (fn () => ())
+    in
+       Msg.send (bio, MsgRegenerate);
+       case Msg.recv bio of
+           NONE => print "Server closed connection unexpectedly.\n"
+         | SOME m =>
+           case m of
+               MsgOk => print "Regeneration succeeded.\n"
+             | MsgError s => print ("Regeneration failed: " ^ s ^ "\n")
+             | _ => print "Unexpected server reply.\n";
+       OpenSSL.close bio
+    end
+

 fun requestRmdom dom =
     let
        val (_, bio) = requestBio (fn () => ())
 fun requestRmdom dom =
     let
        val (_, bio) = requestBio (fn () => ())


@@ -339,6 +371,48 @@ fun requestRmdom dom =
        OpenSSL.close bio
     end
 
        OpenSSL.close bio
     end
 

+fun regenerate () =
+    let
+       val b = basis ()
+       val _ = Tycheck.disallowExterns ()
+
+       fun doUser user =
+           let
+               val _ = Domain.setUser user
+               val _ = ErrorMsg.reset ()
+
+               val dname = Config.domtoolDir user
+
+               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
+                   print ("User " ^ user ^ "'s configuration has errors!\n")
+               else
+                   app eval' files
+           end
+               handle IO.Io _ => ()
+                    | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n")
+    in
+       Env.pre ();
+       app doUser (Acl.users ());
+       Env.post ()
+    end
+

 fun service () =
     let
        val () = Acl.read Config.aclFile
 fun service () =
     let
        val () = Acl.read Config.aclFile


@@ -373,10 +447,12 @@ fun service () =
                                in
                                    TextIO.output (outf, code);
                                    TextIO.closeOut outf;
                                in
                                    TextIO.output (outf, code);
                                    TextIO.closeOut outf;

-                                   eval outname
+                                   eval' outname

                                end
                        in
                                end
                        in

-                           (app doOne codes;
+                           (Env.pre ();
+                            app doOne codes;
+                            Env.post ();

                             Msg.send (bio, MsgOk))
                            handle ErrorMsg.Error =>
                                   (print "Compilation error\n";
                             Msg.send (bio, MsgOk))
                            handle ErrorMsg.Error =>
                                   (print "Compilation error\n";


@@ -503,6 +579,30 @@ fun service () =
                                      ignore (OpenSSL.readChar bio);
                                      OpenSSL.close bio)
                                     handle OpenSSL.OpenSSL _ => ();
                                      ignore (OpenSSL.readChar bio);
                                      OpenSSL.close bio)
                                     handle OpenSSL.OpenSSL _ => ();

+                                    loop ())
+
+                             | MsgRegenerate =>
+                               if Acl.query {user = user, class = "priv", value = "regen"}
+                                  orelse Acl.query {user = user, class = "priv", value = "all"} then
+                                   ((regenerate ();
+                                     Msg.send (bio, MsgOk);
+                                     print "Regenerated all configuration.\n")
+                                    handle OpenSSL.OpenSSL s =>
+                                           (print "OpenSSL error\n";
+                                            Msg.send (bio,
+                                                      MsgError
+                                                          ("Error during regeneration: "
+                                                           ^ s)));
+                                   (ignore (OpenSSL.readChar bio);
+                                    OpenSSL.close bio)
+                                   handle OpenSSL.OpenSSL _ => ();
+                                   loop ())
+                               else
+                                   ((Msg.send (bio, MsgError "Not authorized to regeneration");
+                                     print "Unauthorized user asked to regenerate!\n";
+                                     ignore (OpenSSL.readChar bio);
+                                     OpenSSL.close bio)
+                                    handle OpenSSL.OpenSSL _ => ();

                                     loop ())                           
 
                              | _ =>
                                     loop ())                           
 
                              | _ =>

diff --git a/src/msg.sml b/src/msg.sml
index aa5cf35..bb6a2b1 100644 (file)
--- a/src/msg.sml
+++ b/src/msg.sml
@@ -95,6 +95,7 @@ fun send (bio, m) =
                                 sendList OpenSSL.writeString (bio, codes))
       | MsgRmdom dom => (OpenSSL.writeInt (bio, 13);
                         OpenSSL.writeString (bio, dom))
                                 sendList OpenSSL.writeString (bio, codes))
       | MsgRmdom dom => (OpenSSL.writeInt (bio, 13);
                         OpenSSL.writeString (bio, dom))

+      | MsgRegenerate => OpenSSL.writeInt (bio, 14)

 
 fun checkIt v =
     case v of
 
 fun checkIt v =
     case v of


@@ -143,6 +144,7 @@ fun recv bio =
                   | 12 => Option.map MsgMultiConfig
                           (recvList OpenSSL.readString bio)
                   | 13 => Option.map MsgRmdom (OpenSSL.readString bio)
                   | 12 => Option.map MsgMultiConfig
                           (recvList OpenSSL.readString bio)
                   | 13 => Option.map MsgRmdom (OpenSSL.readString bio)

+                  | 14 => SOME MsgRegenerate

                   | _ => NONE)
         
 end
                   | _ => NONE)
         
 end

diff --git a/src/msgTypes.sml b/src/msgTypes.sml
index bf74086..89ab255 100644 (file)
--- a/src/msgTypes.sml
+++ b/src/msgTypes.sml
@@ -49,5 +49,7 @@ datatype msg =
        | MsgRmdom of string
        (* Remove all configuration associated with a domain and revoke rights
        * to that domain from all users. *)
        | MsgRmdom of string
        (* Remove all configuration associated with a domain and revoke rights
        * to that domain from all users. *)

+       | MsgRegenerate
+       (* Make a clean slate of it and reprocess all configuration from scratch. *)

 
 end
 
 end