X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/284f3883a04dae06a49b39b4cbf2665c4acef159..563e77927eb5faaae4571bd2b0811de590368581:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 9530bcd..ac9207d 100644 --- a/src/main.sml +++ b/src/main.sml @@ -1,5 +1,5 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2006-2007, Adam Chlipala + * Copyright (c) 2006-2009, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -251,21 +251,37 @@ fun requestSlaveBio' printErr = fun requestSlaveBio () = requestSlaveBio' true -fun request fname = +fun request (fname, libOpt) = let - val (user, bio) = requestBio (fn () => ignore (check (basis ()) fname)) - - val inf = TextIO.openIn fname + val (user, bio) = requestBio (fn () => + let + val env = basis () + val env = case libOpt of + NONE => env + | SOME lib => #1 (check env lib) + in + ignore (check env fname) + end) + + fun readFile fname = + let + val inf = TextIO.openIn fname - fun loop lines = - case TextIO.inputLine inf of - NONE => String.concat (List.rev lines) - | SOME line => loop (line :: lines) + 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 - val code = loop [] + val code = readFile fname + val msg = case libOpt of + NONE => MsgConfig code + | SOME fname' => MsgMultiConfig [readFile fname', code] in - TextIO.closeIn inf; - Msg.send (bio, MsgConfig code); + Msg.send (bio, msg); case Msg.recv bio of NONE => print "Server closed connection unexpectedly.\n" | SOME m => @@ -311,7 +327,7 @@ fun requestDir dname = val (_, files) = Order.order (SOME b) files val _ = if !ErrorMsg.anyErrors then - (print "J\n";raise ErrorMsg.Error) + raise ErrorMsg.Error else () @@ -911,6 +927,21 @@ fun requestDescribe dom = OpenSSL.close bio end +fun requestReUsers () = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgReUsers); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Callbacks run.\n" + | MsgError s => print ("Failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + structure SS = StringSet fun domainList dname = @@ -1094,6 +1125,10 @@ val regenerateTc = regenerateEither true (fn G => fn evs => fn file => (#1 (check G file), evs)) +fun usersChanged () = + (Domain.onUsersChange (); + ignore (OS.Process.system Config.publish_reusers)) + fun rmuser user = let val doms = Acl.class {user = user, class = "domain"} @@ -1103,7 +1138,8 @@ fun rmuser user = | _ => false) (StringSet.listItems doms) in Acl.rmuser user; - Domain.rmdom doms + Domain.rmdom doms; + usersChanged () end fun now () = Date.toString (Date.fromTimeUniv (Time.now ())) @@ -1128,10 +1164,12 @@ fun describeQuery q = fun service () = let + val host = Slave.hostname () + val () = Acl.read Config.aclFile - - val context = context (Config.serverCert, - Config.serverKey, + + val context = context (Config.certDir ^ "/" ^ host ^ ".pem", + Config.keyDir ^ "/" ^ host ^ "/key.pem", Config.trustStore) val _ = Domain.set_context context @@ -1247,6 +1285,10 @@ fun service () = if Acl.query {user = user, class = "priv", value = "all"} then (Acl.grant acl; Acl.write Config.aclFile; + if #class acl = "user" then + usersChanged () + else + (); ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".", NONE)) else @@ -1283,7 +1325,8 @@ fun service () = | MsgRmdom doms => doIt (fn () => if Acl.query {user = user, class = "priv", value = "all"} - orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then + orelse List.all (fn dom => Domain.validDomain dom + andalso Acl.queryDomain {user = user, domain = dom}) doms then (Domain.rmdom doms; (*app (fn dom => Acl.revokeFromAll {class = "domain", value = dom}) doms; @@ -1365,18 +1408,22 @@ fun service () = SOME ("Error adding user: " ^ msg))) (fn () => ()) - | MsgCreateDb {dbtype, dbname} => + | MsgCreateDb {dbtype, dbname, encoding} => doIt (fn () => if Dbms.validDbname dbname then case Dbms.lookup dbtype of NONE => ("Database creation request with unknown datatype type " ^ dbtype, SOME ("Unknown database type " ^ dbtype)) | SOME handler => - case #createdb handler {user = user, dbname = dbname} of - NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".", - NONE) - | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg, - SOME ("Error creating database: " ^ msg)) + if not (Dbms.validEncoding encoding) then + ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.", + SOME "Invalid encoding") + else + case #createdb handler {user = user, dbname = dbname, encoding = encoding} of + NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".", + NONE) + | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg, + SOME ("Error creating database: " ^ msg)) else ("Invalid database name " ^ user ^ "_" ^ dbname, SOME ("Invalid database name " ^ dbname))) @@ -1532,14 +1579,15 @@ fun service () = (fn () => ()) | MsgMysqlFixperms => - doIt (fn () => if OS.Process.isSuccess - (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then - ("Requested mysql-fixperms", - NONE) + (print "Starting mysql-fixperms\n"; + doIt (fn () => if OS.Process.isSuccess + (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then + ("Requested mysql-fixperms", + NONE) else ("Requested mysql-fixperms, but execution failed!", SOME "Script execution failed.")) - (fn () => ()) + (fn () => ())) | MsgDescribe dom => doIt (fn () => if not (Domain.validDomain dom) then @@ -1555,6 +1603,11 @@ fun service () = NONE))) (fn () => ()) + | MsgReUsers => + doIt (fn () => (usersChanged (); + ("Users change callbacks run", NONE))) + (fn () => ()) + | _ => doIt (fn () => ("Unexpected command", SOME "Unexpected command"))