X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/08a04eb413e8ee58ee35affc5c4125b622ea75c4..c53e82e40cef407de986aa329d31457915ad0dbe:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 03d5877..3c0b728 100644 --- a/src/main.sml +++ b/src/main.sml @@ -53,7 +53,7 @@ fun basis () = loop files val files = loop [] - val (_, files) = Order.order files + val (_, files) = Order.order NONE files in if !ErrorMsg.anyErrors then Env.empty @@ -92,6 +92,36 @@ fun check fname = 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 @@ -175,6 +205,59 @@ fun request 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 () => ()) @@ -223,6 +306,24 @@ fun requestListPerms user = before OpenSSL.close bio end +fun requestWhoHas perm = + let + val (_, bio) = requestBio (fn () => ()) + in + 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 service () = let val () = Acl.read Config.aclFile @@ -243,6 +344,42 @@ fun service () = 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 @@ -250,38 +387,11 @@ fun service () = 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 = "group", value = "root"} then + if Acl.query {user = user, class = "priv", value = "all"} then ((Acl.grant acl; Acl.write Config.aclFile; Msg.send (bio, MsgOk); @@ -305,7 +415,7 @@ fun service () = loop ()) | MsgRevoke acl => - if Acl.query {user = user, class = "group", value = "root"} then + if Acl.query {user = user, class = "priv", value = "all"} then ((Acl.revoke acl; Acl.write Config.aclFile; Msg.send (bio, MsgOk); @@ -342,6 +452,20 @@ fun service () = 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 _ => ();