fun autodoc {outdir, infiles} =
let
- val (prov, infiles) = Order.order infiles
+ val (prov, infiles) = Order.order NONE infiles
val _ = HtmlPrint.setProviders prov
val G = foldl (fn (fname, G) => check' G fname) Env.empty infiles
(* Driver for server *)
+fun domtoolRoot () =
+ let
+ val uid = Posix.ProcEnv.getuid ()
+ val home = Posix.SysDB.Passwd.home (Posix.SysDB.getpwuid uid)
+ in
+ OS.Path.joinDirFile {dir = home,
+ file = "domtool"}
+ end
+
val _ =
case CommandLine.arguments () of
- [fname] => Main.request fname
+ [fname] =>
+ if Posix.FileSys.access (fname, []) then
+ Main.request fname
+ else
+ Main.request (OS.Path.joinDirFile {dir = domtoolRoot (),
+ file = fname})
+ | [] => Main.requestDir (domtoolRoot ())
| _ => 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 basis : unit -> Env.env
val eval : string -> unit
val request : string -> unit
+ val requestDir : string -> unit
+
val requestGrant : Acl.acl -> unit
val requestRevoke : Acl.acl -> unit
val requestListPerms : string -> (string * string list) list option
loop files
val files = loop []
- val (_, files) = Order.order files
+ val (_, files) = Order.order NONE files
in
if !ErrorMsg.anyErrors then
Env.empty
end
end
+val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-")
+
+fun checkDir dname =
+ let
+ val b = basis ()
+
+ 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
+ false
+ else
+ (foldl (fn (fname, G) => check' G fname) b files;
+ !ErrorMsg.anyErrors)
+ end
+
fun reduce fname =
let
val (G, body) = check fname
end
handle ErrorMsg.Error => ()
+fun requestDir dname =
+ let
+ val (user, bio) = requestBio (fn () => ignore (checkDir dname))
+
+ val b = basis ()
+
+ 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
+
+ val _ = if !ErrorMsg.anyErrors then
+ raise ErrorMsg.Error
+ else
+ ()
+
+ val codes = map (fn fname =>
+ let
+ val inf = TextIO.openIn fname
+
+ fun loop lines =
+ case TextIO.inputLine inf of
+ NONE => String.concat (rev lines)
+ | SOME line => loop (line :: lines)
+ in
+ loop []
+ 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
+ end
+ handle ErrorMsg.Error => ()
+
fun requestGrant acl =
let
val (user, bio) = requestBio (fn () => ())
val () = print ("\nConnection from " ^ user ^ "\n")
val () = Domain.setUser user
+ fun doConfig codes =
+ let
+ val _ = print "Configuration:\n"
+ val _ = app (fn s => (print s; print "\n")) codes
+ val _ = print "\n"
+
+ val outname = OS.FileSys.tmpName ()
+
+ fun doOne code =
+ let
+ val outf = TextIO.openOut outname
+ in
+ TextIO.output (outf, code);
+ TextIO.closeOut outf;
+ eval outname
+ end
+ in
+ (app doOne codes;
+ Msg.send (bio, MsgOk))
+ handle ErrorMsg.Error =>
+ (print "Compilation error\n";
+ Msg.send (bio,
+ MsgError "Error during configuration evaluation"))
+ | OpenSSL.OpenSSL s =>
+ (print "OpenSSL error\n";
+ Msg.send (bio,
+ MsgError
+ ("Error during configuration evaluation: "
+ ^ s)));
+ OS.FileSys.remove outname;
+ (ignore (OpenSSL.readChar bio);
+ OpenSSL.close bio)
+ handle OpenSSL.OpenSSL _ => ();
+ loop ()
+ end
+
fun cmdLoop () =
case Msg.recv bio of
NONE => (OpenSSL.close bio
loop ())
| SOME m =>
case m of
- MsgConfig code =>
- let
- val _ = print "Configuration:\n"
- val _ = print code
- val _ = print "\n"
-
- val outname = OS.FileSys.tmpName ()
- val outf = TextIO.openOut outname
- in
- TextIO.output (outf, code);
- TextIO.closeOut outf;
- (eval outname;
- Msg.send (bio, MsgOk))
- handle ErrorMsg.Error =>
- (print "Compilation error\n";
- Msg.send (bio,
- MsgError "Error during configuration evaluation"))
- | OpenSSL.OpenSSL s =>
- (print "OpenSSL error\n";
- Msg.send (bio,
- MsgError
- ("Error during configuration evaluation: "
- ^ s)));
- OS.FileSys.remove outname;
- (ignore (OpenSSL.readChar bio);
- OpenSSL.close bio)
- handle OpenSSL.OpenSSL _ => ();
- loop ()
- end
+ MsgConfig code => doConfig [code]
+ | MsgMultiConfig codes => doConfig codes
| MsgGrant acl =>
if Acl.query {user = user, class = "priv", value = "all"} then
(SOME user, SOME class, SOME value) => SOME {user = user, class = class, value = value}
| _ => NONE
+fun sendList f (bio, ls) =
+ (app (fn x =>
+ (OpenSSL.writeInt (bio, 1);
+ f (bio, x))) ls;
+ OpenSSL.writeInt (bio, 0))
+
+fun recvList f bio =
+ let
+ fun loop ls =
+ case OpenSSL.readInt bio of
+ SOME 0 => SOME (rev ls)
+ | SOME 1 =>
+ (case f bio of
+ SOME x => loop (x :: ls)
+ | NONE => NONE)
+ | _ => NONE
+ in
+ loop []
+ end
+
fun send (bio, m) =
case m of
MsgOk => OpenSSL.writeInt (bio, 1)
| MsgListPerms user => (OpenSSL.writeInt (bio, 8);
OpenSSL.writeString (bio, user))
| MsgPerms classes => (OpenSSL.writeInt (bio, 9);
- app (fn (class, values) =>
- (OpenSSL.writeInt (bio, 1);
- OpenSSL.writeString (bio, class);
- app (fn value =>
- (OpenSSL.writeInt (bio, 1);
- OpenSSL.writeString (bio, value))) values;
- OpenSSL.writeInt (bio, 0))) classes;
- OpenSSL.writeInt (bio, 0))
+ sendList (fn (bio, (class, values)) =>
+ (OpenSSL.writeString (bio, class);
+ sendList OpenSSL.writeString (bio, values)))
+ (bio, classes))
| MsgWhoHas {class, value} => (OpenSSL.writeInt (bio, 10);
OpenSSL.writeString (bio, class);
OpenSSL.writeString (bio, value))
| MsgWhoHasResponse users => (OpenSSL.writeInt (bio, 11);
- app (fn user =>
- (OpenSSL.writeInt (bio, 1);
- OpenSSL.writeString (bio, user))) users;
- OpenSSL.writeInt (bio, 0))
+ sendList OpenSSL.writeString (bio, users))
+ | MsgMultiConfig codes => (OpenSSL.writeInt (bio, 12);
+ sendList OpenSSL.writeString (bio, codes))
fun checkIt v =
case v of
| 8 => (case OpenSSL.readString bio of
SOME user => SOME (MsgListPerms user)
| _ => NONE)
- | 9 => let
- fun loop classes =
- case OpenSSL.readInt bio of
- SOME 0 => SOME (MsgPerms (rev classes))
- | SOME 1 =>
- (case OpenSSL.readString bio of
- SOME class =>
- let
- fun loop' values =
- case OpenSSL.readInt bio of
- SOME 0 => loop ((class, rev values) :: classes)
- | SOME 1 =>
- (case OpenSSL.readString bio of
- SOME value => loop' (value :: values)
- | NONE => NONE)
- | _ => NONE
- in
- loop' []
- end
- | NONE => NONE)
- | _ => NONE
- in
- loop []
- end
+ | 9 => Option.map MsgPerms
+ (recvList (fn bio =>
+ case (OpenSSL.readString bio,
+ recvList OpenSSL.readString bio) of
+ (SOME class, SOME values) => SOME (class, values)
+ | _ => NONE) bio)
| 10 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
(SOME class, SOME value) => SOME (MsgWhoHas {class = class, value = value})
| _ => NONE)
- | 11 => let
- fun loop users =
- case OpenSSL.readInt bio of
- SOME 0 => SOME (MsgWhoHasResponse (rev users))
- | SOME 1 =>
- (case OpenSSL.readString bio of
- SOME user => loop (user :: users)
- | NONE => NONE)
- | _ => NONE
- in
- loop []
- end
+ | 11 => Option.map MsgWhoHasResponse
+ (recvList OpenSSL.readString bio)
+ | 12 => Option.map MsgMultiConfig
+ (recvList OpenSSL.readString bio)
| _ => NONE)
end
(* Which users have this permission? *)
| MsgWhoHasResponse of string list
(* These are the users! *)
-
+ | MsgMultiConfig of string list
+ (* Multiple Domtool sources in dependency order *)
end
val providesValue : providers * string -> string option
(* Look up which file defines a symbol *)
- val order : string list -> providers * string list
+ val order : Env.env option -> string list -> providers * string list
+ (* The first argument gives an environment of known symbols *)
end
SM.insert (provide, name, fname)))
m1 m2
-fun order fnames =
+fun order basisOpt fnames =
let
fun doFile (fname, (provideC, provideT, provideV, require)) =
let
val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
let
- fun consider (kind, provide) =
+ fun consider (kind, provide, lastChance) =
SS.foldl (fn (name, need) =>
case SM.find (provide, name) of
- NONE => (ErrorMsg.error NONE
- ("File "
- ^ fname
- ^ " uses undefined "
- ^ kind
- ^ " "
- ^ name);
- need)
+ NONE =>
+ if lastChance name then
+ need
+ else
+ (ErrorMsg.error NONE
+ ("File "
+ ^ fname
+ ^ " uses undefined "
+ ^ kind
+ ^ " "
+ ^ name);
+ need)
| SOME fname' =>
SS.add (need, fname'))
- val need = consider ("context", provideC)
+ val need = consider ("context", provideC,
+ case basisOpt of
+ NONE => (fn _ => false)
+ | SOME b => Env.lookupContext b)
SS.empty rc
- val need = consider ("type", provideT)
+ val need = consider ("type", provideT,
+ case basisOpt of
+ NONE => (fn _ => false)
+ | SOME b => Env.lookupType b)
need rt
- val need = consider ("value", provideV)
+ val need = consider ("value", provideV,
+ case basisOpt of
+ NONE => (fn _ => false)
+ | SOME b => (fn name => Option.isSome (Env.lookupVal b name)))
need rv
in
need
HCoop / hcoop / domtool2.git / commitdiff