X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/41c58dafe735d17b7d3241bf248ca8806a355926..06bd821502f57dcb4ef89295b221fc2b9a4f1ae3:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 15a5853..381badb 100644 --- a/src/main.sml +++ b/src/main.sml @@ -25,15 +25,32 @@ 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 + (if isLib fname then + () + else + Option.app (Unused.check G) (#3 prog); + Tycheck.checkFile G (Defaults.tInit prog) prog) end fun basis () = @@ -63,12 +80,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 +94,22 @@ 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) + (if isLib fname then + () + else + Option.app (Unused.check G) (#3 prog); + (G', #3 prog)) end end end @@ -148,12 +170,12 @@ 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 + (G, NONE) else case body of SOME body => @@ -164,28 +186,25 @@ fun reduce fname = [PD.string "Result:", PD.space 1, p_exp body']))*) - SOME body' + (G, SOME body') end - | _ => NONE + | _ => (G, 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 + (G, SOME 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 + | (G, NONE) => (G, evs) val dispatcher = Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort @@ -214,23 +233,27 @@ fun requestContext f = (user, context) end -fun requestBio f = +fun requestBio' printErr f = let val (user, context) = requestContext f in - (user, OpenSSL.connect (context, dispatcher)) + (user, OpenSSL.connect printErr (context, dispatcher)) end -fun requestSlaveBio () = +val requestBio = requestBio' true + +fun requestSlaveBio' printErr = let val (user, context) = requestContext (fn () => ()) in - (user, OpenSSL.connect (context, self)) + (user, OpenSSL.connect printErr (context, self)) end +fun requestSlaveBio () = requestSlaveBio' true + 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 +311,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 () @@ -322,7 +345,7 @@ fun requestDir dname = fun requestPing () = let - val (_, bio) = requestBio (fn () => ()) + val (_, bio) = requestBio' false (fn () => ()) in OpenSSL.close bio; OS.Process.success @@ -335,7 +358,7 @@ fun requestShutdown () = in Msg.send (bio, MsgShutdown); case Msg.recv bio of - NONE => print "Server closed connection unexpectedly.\n" + NONE => () | SOME m => case m of MsgOk => print "Shutdown begun.\n" @@ -346,7 +369,7 @@ fun requestShutdown () = fun requestSlavePing () = let - val (_, bio) = requestSlaveBio () + val (_, bio) = requestSlaveBio' false in OpenSSL.close bio; OS.Process.success @@ -359,7 +382,7 @@ fun requestSlaveShutdown () = in Msg.send (bio, MsgShutdown); case Msg.recv bio of - NONE => print "Server closed connection unexpectedly.\n" + NONE => () | SOME m => case m of MsgOk => print "Shutdown begun.\n" @@ -702,10 +725,10 @@ fun requestMysqlFixperms () = fun requestApt {node, pkg} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) val _ = Msg.send (bio, MsgQuery (QApt pkg)) @@ -731,10 +754,10 @@ fun requestApt {node, pkg} = fun requestCron {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) val _ = Msg.send (bio, MsgQuery (QCron uname)) @@ -760,10 +783,10 @@ fun requestCron {node, uname} = fun requestFtp {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) val _ = Msg.send (bio, MsgQuery (QFtp uname)) @@ -789,10 +812,10 @@ fun requestFtp {node, uname} = fun requestTrustedPath {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) val _ = Msg.send (bio, MsgQuery (QTrustedPath uname)) @@ -818,10 +841,10 @@ fun requestTrustedPath {node, uname} = fun requestSocketPerm {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) val _ = Msg.send (bio, MsgQuery (QSocket uname)) @@ -849,11 +872,11 @@ fun requestSocketPerm {node, uname} = fun requestFirewall {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) - + val bio = OpenSSL.connect true (context, if node = Config.masterNode then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + val _ = Msg.send (bio, MsgQuery (QFirewall uname)) fun loop () = @@ -873,8 +896,80 @@ fun requestFirewall {node, uname} = before OpenSSL.close bio end +fun requestDescribe dom = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgDescribe dom); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgDescription s => print s + | MsgError s => print ("Description failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +structure SS = StringSet + +fun domainList dname = + let + val dir = Posix.FileSys.opendir dname + + fun visitNode dset = + case Posix.FileSys.readdir dir of + NONE => dset + | SOME node => + let + val path = OS.Path.joinDirFile {dir = dname, + file = node} + + fun visitDomains (path, bfor, dset) = + let + val dir = Posix.FileSys.opendir path + + fun loop dset = + case Posix.FileSys.readdir dir of + NONE => dset + | SOME dname => + let + val path = OS.Path.joinDirFile {dir = path, + file = dname} + in + if Posix.FileSys.ST.isDir (Posix.FileSys.stat path) then + let + val bfor = dname :: bfor + in + loop (visitDomains (path, bfor, + SS.add (dset, + String.concatWith "." bfor))) + end + else + loop dset + end + in + loop dset + before Posix.FileSys.closedir dir + end + in + visitNode (visitDomains (path, [], dset)) + end + in + visitNode SS.empty + before Posix.FileSys.closedir dir + end + fun regenerateEither tc checker context = let + val () = print "Starting regeneration....\n" + + val domainsBefore = + if tc then + SS.empty + else + domainList Config.resultRoot + fun ifReal f = if tc then () @@ -886,7 +981,11 @@ fun regenerateEither tc checker context = val b = basis () val () = Tycheck.disallowExterns () - val () = ifReal Domain.resetGlobal + val () = ifReal (fn () => + (ignore (OS.Process.system ("rm -rf " ^ Config.oldResultRoot ^ "/*")); + ignore (OS.Process.system ("cp -r " ^ Config.resultRoot + ^ "/* " ^ Config.oldResultRoot ^ "/")); + Domain.resetGlobal ())) val ok = ref true @@ -894,10 +993,10 @@ fun regenerateEither tc checker context = if node = Config.defaultNode then Domain.resetLocal () else let - val bio = OpenSSL.connect (context, - ip - ^ ":" - ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, + ip + ^ ":" + ^ Int.toString Config.slavePort) in Msg.send (bio, MsgRegenerate); case Msg.recv bio of @@ -939,15 +1038,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")) + 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"); @@ -963,12 +1070,29 @@ fun regenerateEither tc checker context = ifReal (fn () => (app contactNode Config.nodeIps; Env.pre ())); app doUser (Acl.users ()); - ifReal Env.post; + ifReal (fn () => + let + val domainsAfter = domainList Config.resultRoot + val domainsGone = SS.difference (domainsBefore, domainsAfter) + in + if SS.isEmpty domainsGone then + () + else + (print "Domains to kill:"; + SS.app (fn s => (print " "; print s)) domainsGone; + print "\n"; + + Domain.rmdom' Config.oldResultRoot (SS.listItems domainsGone)); + + Env.post () + end); !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 @@ -1067,17 +1191,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))) @@ -1417,6 +1541,20 @@ fun service () = SOME "Script execution failed.")) (fn () => ()) + | MsgDescribe dom => + doIt (fn () => if not (Domain.validDomain dom) then + ("Requested description of invalid domain " ^ dom, + SOME "Invalid domain name") + else if not (Domain.yourDomain dom + orelse Acl.query {user = user, class = "priv", value = "all"}) then + ("Requested description of " ^ dom ^ ", but not allowed access", + SOME "Access denied") + else + (Msg.send (bio, MsgDescription (Domain.describe dom)); + ("Sent description of domain " ^ dom, + NONE))) + (fn () => ()) + | _ => doIt (fn () => ("Unexpected command", SOME "Unexpected command")) @@ -1529,7 +1667,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 ()) @@ -1539,6 +1677,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