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"
val mailNodes_all : string list
val mailNodes_admin : string list
+
+val domtoolDir : string -> string
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? *)
(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
signature EVAL = sig
val exec : Env.env_vars -> Ast.exp -> unit
+ val exec' : Env.env_vars -> Ast.exp -> Env.env_vars
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
- val (prim, args) = findPrimitive e1
+ val evs' = action (evs, args)
+ val evs'' = exec' evs e2
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
- | _ =>
- 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
app (fn user => print (" " ^ user)) users;
print "\n"))
| ["rmdom", dom] => Main.requestRmdom dom
+ | ["regen"] => Main.requestRegen ()
| _ => print "Invalid command-line arguments\n"
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 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 (_, 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;
- !ErrorMsg.anyErrors)
+ if !ErrorMsg.anyErrors then
+ raise ErrorMsg.Error
+ else
+ ())
end
fun reduce fname =
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
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 ()
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 => ()
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 () => ())
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
in
TextIO.output (outf, code);
TextIO.closeOut outf;
- eval outname
+ eval' outname
end
in
- (app doOne codes;
+ (Env.pre ();
+ app doOne codes;
+ Env.post ();
Msg.send (bio, MsgOk))
handle ErrorMsg.Error =>
(print "Compilation error\n";
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 ())
| _ =>
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
| 12 => Option.map MsgMultiConfig
(recvList OpenSSL.readString bio)
| 13 => Option.map MsgRmdom (OpenSSL.readString bio)
+ | 14 => SOME MsgRegenerate
| _ => NONE)
end
| 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