X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/a3698041b3521c3cb17b3546ecdc08ba101c788a..976657583f419a6a204400ea90f9758d15243acb:/src/main.sml?ds=sidebyside diff --git a/src/main.sml b/src/main.sml index 7bc4599..490f66d 100644 --- a/src/main.sml +++ b/src/main.sml @@ -14,79 +14,318 @@ * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. -*) + *) (* Main interface *) structure Main :> MAIN = struct -open Ast Print +open Ast MsgTypes Print -val dmy = ErrorMsg.dummyLoc +structure SM = StringMap -val tInit = (TAction ((CRoot, dmy), - StringMap.empty, - StringMap.empty), - dmy) +fun init () = Acl.read Config.aclFile -fun check fname = +fun check' G fname = let val prog = Parse.parse fname in if !ErrorMsg.anyErrors then - () + G else - let - val G' = Tycheck.checkFile Env.empty tInit prog - in - () - end + Tycheck.checkFile G (Defaults.tInit ()) prog end -fun reduce fname = +fun basis () = let - val prog = Parse.parse fname + val dir = Posix.FileSys.opendir Config.libRoot + + fun loop files = + case Posix.FileSys.readdir dir of + NONE => (Posix.FileSys.closedir dir; + files) + | SOME fname => + if String.isSuffix ".dtl" fname then + loop (OS.Path.joinDirFile {dir = Config.libRoot, + file = fname} + :: files) + else + loop files + + val files = loop [] + val (_, files) = Order.order files in if !ErrorMsg.anyErrors then - () + Env.empty + else + foldl (fn (fname, G) => check' G fname) Env.empty files + end + +fun check fname = + let + val _ = ErrorMsg.reset () + val _ = Env.preTycheck () + + val b = basis () + in + if !ErrorMsg.anyErrors then + raise ErrorMsg.Error else let - val G' = Tycheck.checkFile Env.empty tInit prog + val _ = ErrorMsg.reset () + val prog = Parse.parse fname in if !ErrorMsg.anyErrors then - () + raise ErrorMsg.Error else - case prog of - (_, SOME body) => - let - val body' = Reduce.reduceExp G' body - in - printd (PD.hovBox (PD.PPS.Rel 0, - [PD.string "Result:", - PD.space 1, - p_exp body'])) - end - | _ => () + let + val G' = Tycheck.checkFile b (Defaults.tInit ()) prog + in + if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + (G', #3 prog) + end end end -fun eval fname = +fun reduce fname = let - val prog = Parse.parse fname + val (G, body) = check fname in if !ErrorMsg.anyErrors then - () + NONE else - let - val G' = Tycheck.checkFile Env.empty tInit prog - in - if !ErrorMsg.anyErrors then - () + case body of + SOME body => + let + val body' = Reduce.reduceExp G body + in + (*printd (PD.hovBox (PD.PPS.Rel 0, + [PD.string "Result:", + PD.space 1, + p_exp body']))*) + SOME 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 + +val dispatcher = + Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort + +fun hostname () = + let + val inf = TextIO.openIn "/etc/hostname" + in + case TextIO.inputLine inf of + NONE => (TextIO.closeIn inf; raise Fail "No line in /etc/hostname") + | SOME line => (TextIO.closeIn inf; String.substring (line, 0, size line - 1)) + end + +fun request fname = + let + val uid = Posix.ProcEnv.getuid () + val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) + + val () = Acl.read Config.aclFile + val () = Domain.setUser user + + val _ = check fname + + val uid = Posix.ProcEnv.getuid () + val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) + + val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem", + Config.keyDir ^ "/" ^ user ^ "/key.pem", + Config.trustStore) + + val bio = OpenSSL.connect (context, dispatcher) + + val inf = TextIO.openIn fname + + fun loop lines = + case TextIO.inputLine inf of + NONE => String.concat (List.rev lines) + | SOME line => loop (line :: lines) + + val code = loop [] + in + TextIO.closeIn inf; + Msg.send (bio, MsgConfig code); + 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 service () = + let + val () = Acl.read Config.aclFile + + val context = OpenSSL.context (Config.serverCert, + Config.serverKey, + Config.trustStore) + val _ = Domain.set_context context + + val sock = OpenSSL.listen (context, Config.dispatcherPort) + + fun loop () = + case OpenSSL.accept sock of + NONE => () + | SOME bio => + let + val user = OpenSSL.peerCN bio + val () = print ("\nConnection from " ^ user ^ "\n") + val () = Domain.setUser user + + fun cmdLoop () = + case Msg.recv bio of + NONE => (OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + 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 + | _ => + (Msg.send (bio, MsgError "Unexpected command") + handle OpenSSL.OpenSSL _ => (); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + in + cmdLoop () + end + handle OpenSSL.OpenSSL s => + (print ("OpenSSL error: " ^ s ^ "\n"); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | OS.SysErr (s, _) => + (print ("System error: " ^ s ^ "\n"); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + in + print "Listening for connections....\n"; + loop (); + OpenSSL.shutdown sock + end + +fun slave () = + let + val host = hostname () + + val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem", + Config.keyDir ^ "/" ^ host ^ "/key.pem", + Config.trustStore) + + val sock = OpenSSL.listen (context, Config.slavePort) + + fun loop () = + case OpenSSL.accept sock of + NONE => () + | SOME bio => + let + val peer = OpenSSL.peerCN bio + val () = print ("\nConnection from " ^ peer ^ "\n") + in + if peer <> Config.dispatcherName then + (print "Not authorized!\n"; + OpenSSL.close bio; + loop ()) + else let + fun loop' files = + case Msg.recv bio of + NONE => print "Dispatcher closed connection unexpectedly\n" + | SOME m => + case m of + MsgFile file => loop' (file :: files) + | MsgDoFiles => (Slave.handleChanges files; + Msg.send (bio, MsgOk)) + | _ => (print "Dispatcher sent unexpected command\n"; + Msg.send (bio, MsgError "Unexpected command")) + in + loop' []; + ignore (OpenSSL.readChar bio); + OpenSSL.close bio; + loop () + end + end handle OpenSSL.OpenSSL s => + (print ("OpenSSL error: "^ s ^ "\n"); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | OS.SysErr (s, _) => + (print ("System error: "^ s ^ "\n"); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + in + loop (); + OpenSSL.shutdown sock + end + +fun autodocBasis outdir = + let + val dir = Posix.FileSys.opendir Config.libRoot + + fun loop files = + case Posix.FileSys.readdir dir of + NONE => (Posix.FileSys.closedir dir; + files) + | SOME fname => + if String.isSuffix ".dtl" fname then + loop (OS.Path.joinDirFile {dir = Config.libRoot, + file = fname} + :: files) else - case prog of - (_, SOME body) => Eval.exec StringMap.empty body - | _ => () - end + loop files + + val files = loop [] + in + Autodoc.autodoc {outdir = outdir, infiles = files} end end