X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/07cc384cf2e6e3589f2892026a9b8f9835c8eb2c..094877b11a71011cc7af7dc1b5a6b853b4985c6d:/src/main.sml diff --git a/src/main.sml b/src/main.sml index bcadb63..9f06c5b 100644 --- a/src/main.sml +++ b/src/main.sml @@ -20,43 +20,20 @@ structure Main :> MAIN = struct -open Ast Print +open Ast MsgTypes Print structure SM = StringMap -val dmy = ErrorMsg.dummyLoc - -fun init () = (F_OpenSSL_SML_add_all_algorithms.f' (); - F_OpenSSL_SML_load_error_strings.f' (); - F_OpenSSL_SML_load_BIO_strings.f' ()) - -val () = init () - -val defaultT : record ref = ref SM.empty -val defaultV : (unit -> exp) SM.map ref = ref SM.empty - -fun registerDefault (name, t, v) = - case SM.find (!defaultT, name) of - NONE => (defaultT := SM.insert (!defaultT, name, t); - defaultV := SM.insert (!defaultV, name, v)) - | SOME _ => raise Fail "Duplicate default environment variable" - -fun tInit () = (TAction ((CRoot, dmy), - !defaultT, - StringMap.empty), - dmy) - - +fun init () = Acl.read Config.aclFile fun check' G fname = let - (*val _ = print ("Check " ^ fname ^ "\n")*) val prog = Parse.parse fname in if !ErrorMsg.anyErrors then G else - Tycheck.checkFile G (tInit ()) prog + Tycheck.checkFile G (Defaults.tInit ()) prog end fun basis () = @@ -76,12 +53,14 @@ fun basis () = loop files val files = loop [] - val files = Order.order files + val (_, files) = Order.order files in if !ErrorMsg.anyErrors then Env.empty else - foldl (fn (fname, G) => check' G fname) Env.empty files + (Tycheck.allowExterns (); + foldl (fn (fname, G) => check' G fname) Env.empty files + before Tycheck.disallowExterns ()) end fun check fname = @@ -92,19 +71,23 @@ fun check fname = val b = basis () in if !ErrorMsg.anyErrors then - (b, NONE) + raise ErrorMsg.Error else let + val _ = Tycheck.disallowExterns () val _ = ErrorMsg.reset () val prog = Parse.parse fname in if !ErrorMsg.anyErrors then - (Env.empty, NONE) + raise ErrorMsg.Error else let - val G' = Tycheck.checkFile b (tInit ()) prog + val G' = Tycheck.checkFile b (Defaults.tInit ()) prog in - (G', #3 prog) + if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + (G', #3 prog) end end end @@ -134,116 +117,361 @@ fun eval fname = case reduce fname of (SOME body') => if !ErrorMsg.anyErrors then - () + raise ErrorMsg.Error else - Eval.exec (SM.map (fn f => f ()) (!defaultV)) body' - | NONE => () + Eval.exec (Defaults.eInit ()) body' + | NONE => raise ErrorMsg.Error -val dispatcher : C.rw ZString.zstring' = - ZString.dupML' (Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort) +val dispatcher = + Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort + +fun requestContext f = + 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 () = f () -val listenOn : C.rw ZString.zstring' = - ZString.dupML' ("localhost:" ^ Int.toString Config.dispatcherPort) + val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem", + Config.keyDir ^ "/" ^ user ^ "/key.pem", + Config.trustStore) + in + (user, context) + end -fun ssl_err s = +fun requestBio f = let - val err = F_OpenSSL_SML_get_error.f () + val (user, context) = requestContext f in - print s; - print "\nReason: "; - print (ZString.toML (F_OpenSSL_SML_lib_error_string.f err)); - print ":"; - print (ZString.toML (F_OpenSSL_SML_func_error_string.f err)); - print ":"; - print (ZString.toML (F_OpenSSL_SML_reason_error_string.f err)); - print "\n" + (user, OpenSSL.connect (context, dispatcher)) end -exception OpenSSL of string +fun request fname = + let + val (user, bio) = requestBio (fn () => ignore (check fname)) + + val inf = TextIO.openIn fname -val readBuf : (C.uchar, C.rw) C.obj C.ptr' = C.alloc' C.S.uchar (Word.fromInt Config.bufSize) -val bufSize = Int32.fromInt Config.bufSize + fun loop lines = + case TextIO.inputLine inf of + NONE => String.concat (List.rev lines) + | SOME line => loop (line :: lines) -fun readOne bio = + 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 requestGrant acl = let - val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize) + val (user, bio) = requestBio (fn () => ()) in - if r = 0 then - NONE - else if r < 0 then - raise OpenSSL "BIO_read failed" - else - SOME (CharVector.tabulate (Int32.toInt r, - fn i => chr (Word32.toInt (C.Get.uchar' - (C.Ptr.sub' C.S.uchar (readBuf, i)))))) + Msg.send (bio, MsgGrant acl); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Grant succeeded.\n" + | MsgError s => print ("Grant failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio end -fun writeAll (bio, s) = +fun requestRevoke acl = let - val buf = ZString.dupML' s + val (user, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRevoke acl); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Revoke succeeded.\n" + | MsgError s => print ("Revoke failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end - fun loop (buf, len) = - let - val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, len) - in - if r = len then - () - else if r <= 0 then - (C.free' buf; - raise OpenSSL "BIO_write failed") - else - loop (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), Int32.- (len, r)) - end +fun requestListPerms user = + let + val (_, bio) = requestBio (fn () => ()) in - loop (buf, Int32.fromInt (size s)); - C.free' buf + Msg.send (bio, MsgListPerms user); + (case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + NONE) + | SOME m => + case m of + MsgPerms perms => SOME perms + | MsgError s => (print ("Listing failed: " ^ s ^ "\n"); + NONE) + | _ => (print "Unexpected server reply.\n"; + NONE)) + before OpenSSL.close bio end -fun request fname = +fun requestWhoHas perm = let - val bio = F_OpenSSL_SML_new_connect.f' dispatcher + val (_, bio) = requestBio (fn () => ()) in - if C.Ptr.isNull' bio then - (ssl_err ("Error initializating connection to dispatcher at " ^ Config.dispatcher); - F_OpenSSL_SML_free_all.f' bio) - else if F_OpenSSL_SML_do_connect.f' bio <= 0 then - (ssl_err ("Error connecting to dispatcher at " ^ Config.dispatcher); - F_OpenSSL_SML_free_all.f' bio) - else let - val inf = TextIO.openIn fname - - fun loop () = - case TextIO.inputLine inf of - NONE => () - | SOME line => (writeAll (bio, line); - loop ()) - in - loop (); - TextIO.closeIn inf; - F_OpenSSL_SML_free_all.f' bio - end + Msg.send (bio, MsgWhoHas perm); + (case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + NONE) + | SOME m => + case m of + MsgWhoHasResponse users => SOME users + | MsgError s => (print ("whohas failed: " ^ s ^ "\n"); + NONE) + | _ => (print "Unexpected server reply.\n"; + NONE)) + before OpenSSL.close bio end -fun serviceOne () = +fun service () = let - val bio = F_OpenSSL_SML_new_accept.f' listenOn + 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 + + | MsgGrant acl => + if Acl.query {user = user, class = "group", value = "root"} then + ((Acl.grant acl; + Acl.write Config.aclFile; + Msg.send (bio, MsgOk); + print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during granting: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + else + ((Msg.send (bio, MsgError "Not authorized to grant privileges"); + print "Unauthorized user asked to grant a permission!\n"; + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgRevoke acl => + if Acl.query {user = user, class = "group", value = "root"} then + ((Acl.revoke acl; + Acl.write Config.aclFile; + Msg.send (bio, MsgOk); + print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during revocation: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + else + ((Msg.send (bio, MsgError "Not authorized to revoke privileges"); + print "Unauthorized user asked to revoke a permission!\n"; + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgListPerms user => + ((Msg.send (bio, MsgPerms (Acl.queryAll user)); + print ("Sent permission list for user " ^ user ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during permission listing: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgWhoHas perm => + ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm)); + print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n")) + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during whohas: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + + | _ => + (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 - if C.Ptr.isNull' bio then - (ssl_err "Error initializating listener"; - F_OpenSSL_SML_free_all.f' bio) - else if F_OpenSSL_SML_do_accept.f' bio <= 0 then - (ssl_err "Error accepting connection"; - F_OpenSSL_SML_free_all.f' bio) - else let - fun loop () = - case readOne bio of - NONE => () - | SOME line => (print line; - loop ()) - in - loop (); - F_OpenSSL_SML_free_all.f' bio - end + print "Listening for connections....\n"; + loop (); + OpenSSL.shutdown sock + end + +fun slave () = + let + val host = Slave.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 + loop files + + val files = loop [] + in + Autodoc.autodoc {outdir = outdir, infiles = files} end end