X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/71420f8bc34bbe2c76bd368613d4e024072e9817..9ffe2f0fea48f1e2fa6a30b6a79b975b4a6f7671:/src/main.sml diff --git a/src/main.sml b/src/main.sml index f22c430..4fe8124 100644 --- a/src/main.sml +++ b/src/main.sml @@ -371,6 +371,112 @@ fun requestRmdom dom = OpenSSL.close bio end +fun requestRmuser user = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRmuser user); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Removal succeeded.\n" + | MsgError s => print ("Removal failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestDbUser dbtype = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgCreateDbUser dbtype); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Your user has been created.\n" + | MsgError s => print ("Creation failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestDbTable p = + let + val (user, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgCreateDbTable p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been created.\n") + | MsgError s => print ("Creation failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestListMailboxes domain = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgListMailboxes domain); + (case Msg.recv bio of + NONE => Vmail.Error "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgMailboxes users => (Msg.send (bio, MsgOk); + Vmail.Listing users) + | MsgError s => Vmail.Error ("Creation failed: " ^ s) + | _ => Vmail.Error "Unexpected server reply.\n") + before OpenSSL.close bio + end + +fun requestNewMailbox p = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgNewMailbox p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n") + | MsgError s => print ("Creation failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestPasswdMailbox p = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgPasswdMailbox p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n") + | MsgError s => print ("Set failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestRmMailbox p = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRmMailbox p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n") + | MsgError s => print ("Remove failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun regenerate context = let val b = basis () @@ -439,6 +545,18 @@ fun regenerate context = Env.post () end +fun rmuser user = + let + val doms = Acl.class {user = user, class = "domain"} + val doms = List.filter (fn dom => + case Acl.whoHas {class = "domain", value = dom} of + [_] => true + | _ => false) (StringSet.listItems doms) + in + Acl.rmuser user; + Domain.rmdom doms + end + fun service () = let val () = Acl.read Config.aclFile @@ -459,6 +577,40 @@ fun service () = val () = print ("\nConnection from " ^ user ^ "\n") val () = Domain.setUser user + fun doIt f cleanup = + ((case f () of + (msgLocal, SOME msgRemote) => + (print msgLocal; + print "\n"; + Msg.send (bio, MsgError msgRemote)) + | (msgLocal, NONE) => + (print msgLocal; + print "\n"; + Msg.send (bio, MsgOk))) + handle OpenSSL.OpenSSL _ => + print "OpenSSL error\n" + | OS.SysErr (s, _) => + (print "System error: "; + print s; + print "\n"; + Msg.send (bio, MsgError ("System error: " ^ s)) + handle OpenSSL.OpenSSL _ => ()) + | Fail s => + (print "Failure: "; + print s; + print "\n"; + Msg.send (bio, MsgError ("Failure: " ^ s)) + handle OpenSSL.OpenSSL _ => ()) + | ErrorMsg.Error => + (print "Compilation error\n"; + Msg.send (bio, MsgError "Error during configuration evaluation") + handle OpenSSL.OpenSSL _ => ()); + (cleanup (); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + fun doConfig codes = let val _ = print "Configuration:\n" @@ -476,25 +628,12 @@ fun service () = eval' outname end in - (Env.pre (); - app doOne codes; - Env.post (); - 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 () + doIt (fn () => (Env.pre (); + app doOne codes; + Env.post (); + Msg.send (bio, MsgOk); + ("Configuration complete.", NONE))) + (fn () => OS.FileSys.remove outname) end fun cmdLoop () = @@ -508,135 +647,191 @@ fun service () = | MsgMultiConfig codes => doConfig codes | MsgGrant acl => - if Acl.query {user = user, class = "priv", value = "all"} 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 ()) - + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "all"} then + (Acl.grant acl; + Acl.write Config.aclFile; + ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".", + NONE)) + else + ("Unauthorized user asked to grant a permission!", + SOME "Not authorized to grant privileges")) + (fn () => ()) + | MsgRevoke acl => - if Acl.query {user = user, class = "priv", value = "all"} 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 ()) + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "all"} then + (Acl.revoke acl; + Acl.write Config.aclFile; + ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".", + NONE)) + else + ("Unauthorized user asked to revoke a permission!", + SOME "Not authorized to revoke privileges")) + (fn () => ()) | 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 ()) + doIt (fn () => + (Msg.send (bio, MsgPerms (Acl.queryAll user)); + ("Sent permission list for user " ^ user ^ ".", + NONE))) + (fn () => ()) | 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 ()) - - | MsgRmdom dom => - if Acl.query {user = user, class = "priv", value = "all"} - orelse Acl.query {user = user, class = "domain", value = dom} then - ((Domain.rmdom dom; - Msg.send (bio, MsgOk); - print ("Removed domain " ^ dom ^ ".\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 remove that domain"); - print "Unauthorized user asked to remove a domain!\n"; - ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) + doIt (fn () => + (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm)); + ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".", + NONE))) + (fn () => ()) + + | 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 + (Domain.rmdom doms; + app (fn dom => + Acl.revokeFromAll {class = "domain", value = dom}) doms; + Acl.write Config.aclFile; + ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".", + NONE)) + else + ("Unauthorized user asked to remove a domain!", + SOME "Not authorized to remove that domain")) + (fn () => ()) | MsgRegenerate => - if Acl.query {user = user, class = "priv", value = "regen"} - orelse Acl.query {user = user, class = "priv", value = "all"} then - ((regenerate context; - Msg.send (bio, MsgOk); - print "Regenerated all configuration.\n") - handle OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during regeneration: " - ^ s))); - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) - else - ((Msg.send (bio, MsgError "Not authorized to regeneration"); - print "Unauthorized user asked to regenerate!\n"; - ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "regen"} + orelse Acl.query {user = user, class = "priv", value = "all"} then + (regenerate context; + ("Regenerated all configuration.", + NONE)) + else + ("Unauthorized user asked to regenerate!", + SOME "Not authorized to regenerate")) + (fn () => ()) + + | MsgRmuser user' => + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "all"} then + (rmuser user'; + Acl.write Config.aclFile; + ("Removed user " ^ user' ^ ".", + NONE)) + else + ("Unauthorized user asked to remove a user!", + SOME "Not authorized to remove users")) + (fn () => ()) + + | MsgCreateDbUser {dbtype, passwd} => + doIt (fn () => + case Dbms.lookup dbtype of + NONE => ("Database user creation request with unknown datatype type " ^ dbtype, + SOME ("Unknown database type " ^ dbtype)) + | SOME handler => + case #adduser handler {user = user, passwd = passwd} of + NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".", + NONE) + | SOME msg => + ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg, + SOME ("Error adding user: " ^ msg))) + (fn () => ()) + + | MsgCreateDbTable {dbtype, dbname} => + 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)) + else + ("Invalid database name " ^ user ^ "_" ^ dbname, + SOME ("Invalid database name " ^ dbname))) + (fn () => ()) + + | MsgListMailboxes domain => + doIt (fn () => + if not (Domain.yourDomain domain) then + ("User wasn't authorized to list mailboxes for " ^ domain, + SOME "You're not authorized to configure that domain.") + else + case Vmail.list domain of + Vmail.Listing users => (Msg.send (bio, MsgMailboxes users); + ("Sent mailbox list for " ^ domain, + NONE)) + | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg, + SOME msg)) + (fn () => ()) + + | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} => + doIt (fn () => + if not (Domain.yourDomain domain) then + ("User wasn't authorized to add a mailbox to " ^ domain, + SOME "You're not authorized to configure that domain.") + else if not (Domain.validUser emailUser) then + ("Invalid e-mail username " ^ emailUser, + SOME "Invalid e-mail username") + else if not (CharVector.all Char.isGraph passwd) then + ("Invalid password", + SOME "Invalid password; may only contain printable, non-space characters") + else if not (Domain.yourPath mailbox) then + ("User wasn't authorized to add a mailbox at " ^ mailbox, + SOME "You're not authorized to use that mailbox location.") + else + case Vmail.add {requester = user, + domain = domain, user = emailUser, + passwd = passwd, mailbox = mailbox} of + NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox, + NONE) + | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg, + SOME msg)) + (fn () => ()) + + | MsgPasswdMailbox {domain, user = emailUser, passwd} => + doIt (fn () => + if not (Domain.yourDomain domain) then + ("User wasn't authorized to change password of a mailbox for " ^ domain, + SOME "You're not authorized to configure that domain.") + else if not (Domain.validUser emailUser) then + ("Invalid e-mail username " ^ emailUser, + SOME "Invalid e-mail username") + else if not (CharVector.all Char.isGraph passwd) then + ("Invalid password", + SOME "Invalid password; may only contain printable, non-space characters") + else + case Vmail.passwd {domain = domain, user = emailUser, + passwd = passwd} of + NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain, + NONE) + | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg, + SOME msg)) + (fn () => ()) + + | MsgRmMailbox {domain, user = emailUser} => + doIt (fn () => + if not (Domain.yourDomain domain) then + ("User wasn't authorized to change password of a mailbox for " ^ domain, + SOME "You're not authorized to configure that domain.") + else if not (Domain.validUser emailUser) then + ("Invalid e-mail username " ^ emailUser, + SOME "Invalid e-mail username") + else + case Vmail.rm {domain = domain, user = emailUser} of + NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain, + NONE) + | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg, + SOME msg)) + (fn () => ()) | _ => - (Msg.send (bio, MsgError "Unexpected command") - handle OpenSSL.OpenSSL _ => (); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) + doIt (fn () => ("Unexpected command", + SOME "Unexpected command")) + (fn () => ()) in cmdLoop () end @@ -712,7 +907,7 @@ fun slave () = OpenSSL.shutdown sock end -fun autodocBasis outdir = +fun listBasis () = let val dir = Posix.FileSys.opendir Config.libRoot @@ -727,10 +922,11 @@ fun autodocBasis outdir = :: files) else loop files - - val files = loop [] in - Autodoc.autodoc {outdir = outdir, infiles = files} + loop [] end +fun autodocBasis outdir = + Autodoc.autodoc {outdir = outdir, infiles = listBasis ()} + end