From 2ee5022632bb4c4f183991b387e4eff7f76dbad8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 1 Jul 2007 02:08:39 +0000 Subject: [PATCH] Better OpenSSL error reporting --- openssl/openssl_sml.c | 2 + src/main-admin.sml | 119 +++--- src/main.sml | 821 +++++++++++++++++++++--------------------- 3 files changed, 480 insertions(+), 462 deletions(-) rewrite src/main-admin.sml (61%) diff --git a/openssl/openssl_sml.c b/openssl/openssl_sml.c index 407e74f..0ce16d2 100644 --- a/openssl/openssl_sml.c +++ b/openssl/openssl_sml.c @@ -73,6 +73,8 @@ SSL_CTX *OpenSSL_SML_CTX_new(SSL_METHOD *meth) { SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER | SSL_VERIFY_FAIL_IF_NO_PEER_CERT, 0); + SSL_CTX_set_verify_depth(ctx, + 2); return ctx; } diff --git a/src/main-admin.sml b/src/main-admin.sml dissimilarity index 61% index 0af7088..201456e 100644 --- a/src/main-admin.sml +++ b/src/main-admin.sml @@ -1,59 +1,60 @@ -(* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2006, Adam Chlipala - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * 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. - *) - -(* Driver for admin requests *) - -fun requestPerms user = - case Main.requestListPerms user of - NONE => () - | SOME classes => - (print ("Permissions for " ^ user ^ ":\n"); - app (fn (class, values) => - (print (class ^ ":"); - app (fn value => print (" " ^ value)) values; - print "\n")) classes) - -val _ = - case CommandLine.arguments () of - ["shutdown"] => Main.requestShutdown () - | ["grant", user, class, value] => Main.requestGrant {user = user, class = class, value = value} - | ["revoke", user, class, value] => Main.requestRevoke {user = user, class = class, value = value} - | ["perms", user] => requestPerms user - | ["perms"] => requestPerms (Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid (Posix.ProcEnv.getuid ()))) - | ["whohas", class, value] => - (case Main.requestWhoHas {class = class, value = value} of - NONE => () - | SOME users => - (print ("whohas " ^ class ^ " / " ^ value ^ ":"); - app (fn user => print (" " ^ user)) users; - print "\n")) - | "rmdom" :: doms => Main.requestRmdom doms - | ["regen"] => Main.requestRegen () - | ["regen", "-tc"] => Main.requestRegenTc () - | ["rmuser", user] => Main.requestRmuser user - | ["ping"] => OS.Process.exit (Main.requestPing ()) - | ["slave-shutdown"] => Main.requestSlaveShutdown () - | ["slave-ping"] => OS.Process.exit (Main.requestSlavePing ()) - | ["package", node, pkg] => OS.Process.exit (Main.requestApt {node = node, pkg = pkg}) - | ["cron", node, uname] => OS.Process.exit (Main.requestCron {node = node, uname = uname}) - | ["ftp", node, uname] => OS.Process.exit (Main.requestFtp {node = node, uname = uname}) - | ["tpe", node, uname] => OS.Process.exit (Main.requestTrustedPath {node = node, uname = uname}) - | ["sockperm", node, uname] => OS.Process.exit (Main.requestSocketPerm {node = node, uname = uname}) - | ["firewall", node, uname] => OS.Process.exit (Main.requestFirewall {node = node, uname = uname}) - | _ => (print "Invalid command-line arguments\n"; - print "See the documentation: http://wiki.hcoop.net/wiki/DomTool/AdminProcedures\n") +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * 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. + *) + +(* Driver for admin requests *) + +fun requestPerms user = + case Main.requestListPerms user of + NONE => () + | SOME classes => + (print ("Permissions for " ^ user ^ ":\n"); + app (fn (class, values) => + (print (class ^ ":"); + app (fn value => print (" " ^ value)) values; + print "\n")) classes) + +val _ = + (case CommandLine.arguments () of + ["shutdown"] => Main.requestShutdown () + | ["grant", user, class, value] => Main.requestGrant {user = user, class = class, value = value} + | ["revoke", user, class, value] => Main.requestRevoke {user = user, class = class, value = value} + | ["perms", user] => requestPerms user + | ["perms"] => requestPerms (Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid (Posix.ProcEnv.getuid ()))) + | ["whohas", class, value] => + (case Main.requestWhoHas {class = class, value = value} of + NONE => () + | SOME users => + (print ("whohas " ^ class ^ " / " ^ value ^ ":"); + app (fn user => print (" " ^ user)) users; + print "\n")) + | "rmdom" :: doms => Main.requestRmdom doms + | ["regen"] => Main.requestRegen () + | ["regen", "-tc"] => Main.requestRegenTc () + | ["rmuser", user] => Main.requestRmuser user + | ["ping"] => OS.Process.exit (Main.requestPing ()) + | ["slave-shutdown"] => Main.requestSlaveShutdown () + | ["slave-ping"] => OS.Process.exit (Main.requestSlavePing ()) + | ["package", node, pkg] => OS.Process.exit (Main.requestApt {node = node, pkg = pkg}) + | ["cron", node, uname] => OS.Process.exit (Main.requestCron {node = node, uname = uname}) + | ["ftp", node, uname] => OS.Process.exit (Main.requestFtp {node = node, uname = uname}) + | ["tpe", node, uname] => OS.Process.exit (Main.requestTrustedPath {node = node, uname = uname}) + | ["sockperm", node, uname] => OS.Process.exit (Main.requestSocketPerm {node = node, uname = uname}) + | ["firewall", node, uname] => OS.Process.exit (Main.requestFirewall {node = node, uname = uname}) + | _ => (print "Invalid command-line arguments\n"; + print "See the documentation: http://wiki.hcoop.net/wiki/DomTool/AdminProcedures\n")) + handle OpenSSL.OpenSSL s => print ("OpenSSL exception: " ^ s ^ "\n") diff --git a/src/main.sml b/src/main.sml index db657da..6644d76 100644 --- a/src/main.sml +++ b/src/main.sml @@ -1025,411 +1025,426 @@ fun service () = 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 ^ " at " ^ now () ^ "\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 e as (OpenSSL.OpenSSL s) => - (print ("OpenSSL error: " ^ s ^ "\n"); - app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); - Msg.send (bio, MsgError ("OpenSSL error: " ^ s)) - handle OpenSSL.OpenSSL _ => ()) - | 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) + (case OpenSSL.accept sock of + NONE => () + | SOME bio => + let + val user = OpenSSL.peerCN bio + val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\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 e as (OpenSSL.OpenSSL s) => + (print ("OpenSSL error: " ^ s ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + Msg.send (bio, MsgError ("OpenSSL error: " ^ s)) + handle OpenSSL.OpenSSL _ => ()) + | 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" + 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 + doIt (fn () => (Env.pre (); + app doOne codes; + Env.post (); + Msg.send (bio, MsgOk); + ("Configuration complete.", NONE))) + (fn () => OS.FileSys.remove outname) + end + + fun checkAddr s = + case String.fields (fn ch => ch = #"@") s of + [user'] => + if user = user' then + SOME (SetSA.User s) + else + NONE + | [user', domain] => + if Domain.validEmailUser user' andalso Domain.yourDomain domain then + SOME (SetSA.Email s) + else + NONE + | _ => NONE + + fun cmdLoop () = + case Msg.recv bio of + NONE => (OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | SOME m => + case m of + MsgConfig code => doConfig [code] + | MsgMultiConfig codes => doConfig codes + + | MsgShutdown => + if Acl.query {user = user, class = "priv", value = "all"} + orelse Acl.query {user = user, class = "priv", value = "shutdown"} then + print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n") + else + (print "Unauthorized shutdown command!\n"; + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgGrant acl => + 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 => + 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 => + doIt (fn () => + (Msg.send (bio, MsgPerms (Acl.queryAll user)); + ("Sent permission list for user " ^ user ^ ".", + NONE))) + (fn () => ()) + + | MsgWhoHas perm => + 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 => + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "regen"} + orelse Acl.query {user = user, class = "priv", value = "all"} then + (if regenerate context then + ("Regenerated all configuration.", + NONE) + else + ("Error regenerating configuration!", + SOME "Error regenerating configuration! Consult /var/log/domtool.log.")) + else + ("Unauthorized user asked to regenerate!", + SOME "Not authorized to regenerate")) + (fn () => ()) + + | MsgRegenerateTc => + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "regen"} + orelse Acl.query {user = user, class = "priv", value = "all"} then + (if regenerateTc context then + ("Checked all configuration.", + NONE) + else + ("Found a compilation error!", + SOME "Found a compilation error! Consult /var/log/domtool.log.")) + else + ("Unauthorized user asked to regenerate -tc!", + SOME "Not authorized to regenerate -tc")) + (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 () => ()) + + | MsgDbPasswd {dbtype, passwd} => + doIt (fn () => + case Dbms.lookup dbtype of + NONE => ("Database passwd request with unknown datatype type " ^ dbtype, + SOME ("Unknown database type " ^ dbtype)) + | SOME handler => + case #passwd handler {user = user, passwd = passwd} of + NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".", + NONE) + | SOME msg => + ("Error setting " ^ dbtype ^ " password of 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 () => ()) + + | MsgDropDb {dbtype, dbname} => + doIt (fn () => + if Dbms.validDbname dbname then + case Dbms.lookup dbtype of + NONE => ("Database drop request with unknown datatype type " ^ dbtype, + SOME ("Unknown database type " ^ dbtype)) + | SOME handler => + case #dropdb handler {user = user, dbname = dbname} of + NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".", + NONE) + | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg, + SOME ("Error dropping 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.validEmailUser 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.validEmailUser 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.validEmailUser 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 () => ()) + + | MsgSaQuery addr => + doIt (fn () => + case checkAddr addr of + NONE => ("User tried to query SA filtering for " ^ addr, + SOME "You aren't allowed to configure SA filtering for that recipient.") + | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr')); + ("Queried SA filtering status for " ^ addr, + NONE))) + (fn () => ()) + + | MsgSaSet (addr, b) => + doIt (fn () => + case checkAddr addr of + NONE => ("User tried to set SA filtering for " ^ addr, + SOME "You aren't allowed to configure SA filtering for that recipient.") + | SOME addr' => (SetSA.set (addr', b); + Msg.send (bio, MsgOk); + ("Set SA filtering status for " ^ addr ^ " to " + ^ (if b then "ON" else "OFF"), + NONE))) + (fn () => ()) + + | MsgSmtpLogReq domain => + doIt (fn () => + if not (Domain.yourDomain domain) then + ("Unauthorized user tried to request SMTP logs for " ^ domain, + SOME "You aren't authorized to configure that domain.") + else + (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line)) + domain; + ("Requested SMTP logs for " ^ domain, + NONE))) + (fn () => ()) + + | MsgQuery q => + doIt (fn () => (Msg.send (bio, answerQuery q); + (describeQuery q, + NONE))) + (fn () => ()) + + | _ => + doIt (fn () => ("Unexpected command", + SOME "Unexpected command")) + (fn () => ()) + in + cmdLoop () + end + handle e as (OpenSSL.OpenSSL s) => + (print ("OpenSSL error: " ^ s ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ()) - - 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 - doIt (fn () => (Env.pre (); - app doOne codes; - Env.post (); - Msg.send (bio, MsgOk); - ("Configuration complete.", NONE))) - (fn () => OS.FileSys.remove outname) - end - - fun checkAddr s = - case String.fields (fn ch => ch = #"@") s of - [user'] => - if user = user' then - SOME (SetSA.User s) - else - NONE - | [user', domain] => - if Domain.validEmailUser user' andalso Domain.yourDomain domain then - SOME (SetSA.Email s) - else - NONE - | _ => NONE - - fun cmdLoop () = - case Msg.recv bio of - NONE => (OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | SOME m => - case m of - MsgConfig code => doConfig [code] - | MsgMultiConfig codes => doConfig codes - - | MsgShutdown => - if Acl.query {user = user, class = "priv", value = "all"} - orelse Acl.query {user = user, class = "priv", value = "shutdown"} then - print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n") - else - (print "Unauthorized shutdown command!\n"; - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - - | MsgGrant acl => - 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 => - 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 => - doIt (fn () => - (Msg.send (bio, MsgPerms (Acl.queryAll user)); - ("Sent permission list for user " ^ user ^ ".", - NONE))) - (fn () => ()) - - | MsgWhoHas perm => - 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 => - doIt (fn () => - if Acl.query {user = user, class = "priv", value = "regen"} - orelse Acl.query {user = user, class = "priv", value = "all"} then - (if regenerate context then - ("Regenerated all configuration.", - NONE) - else - ("Error regenerating configuration!", - SOME "Error regenerating configuration! Consult /var/log/domtool.log.")) - else - ("Unauthorized user asked to regenerate!", - SOME "Not authorized to regenerate")) - (fn () => ()) - - | MsgRegenerateTc => - doIt (fn () => - if Acl.query {user = user, class = "priv", value = "regen"} - orelse Acl.query {user = user, class = "priv", value = "all"} then - (if regenerateTc context then - ("Checked all configuration.", - NONE) - else - ("Found a compilation error!", - SOME "Found a compilation error! Consult /var/log/domtool.log.")) - else - ("Unauthorized user asked to regenerate -tc!", - SOME "Not authorized to regenerate -tc")) - (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 () => ()) - - | MsgDbPasswd {dbtype, passwd} => - doIt (fn () => - case Dbms.lookup dbtype of - NONE => ("Database passwd request with unknown datatype type " ^ dbtype, - SOME ("Unknown database type " ^ dbtype)) - | SOME handler => - case #passwd handler {user = user, passwd = passwd} of - NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".", - NONE) - | SOME msg => - ("Error setting " ^ dbtype ^ " password of 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 () => ()) - - | MsgDropDb {dbtype, dbname} => - doIt (fn () => - if Dbms.validDbname dbname then - case Dbms.lookup dbtype of - NONE => ("Database drop request with unknown datatype type " ^ dbtype, - SOME ("Unknown database type " ^ dbtype)) - | SOME handler => - case #dropdb handler {user = user, dbname = dbname} of - NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".", - NONE) - | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg, - SOME ("Error dropping 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.validEmailUser 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.validEmailUser 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.validEmailUser 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 () => ()) - - | MsgSaQuery addr => - doIt (fn () => - case checkAddr addr of - NONE => ("User tried to query SA filtering for " ^ addr, - SOME "You aren't allowed to configure SA filtering for that recipient.") - | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr')); - ("Queried SA filtering status for " ^ addr, - NONE))) - (fn () => ()) - - | MsgSaSet (addr, b) => - doIt (fn () => - case checkAddr addr of - NONE => ("User tried to set SA filtering for " ^ addr, - SOME "You aren't allowed to configure SA filtering for that recipient.") - | SOME addr' => (SetSA.set (addr', b); - Msg.send (bio, MsgOk); - ("Set SA filtering status for " ^ addr ^ " to " - ^ (if b then "ON" else "OFF"), - NONE))) - (fn () => ()) - - | MsgSmtpLogReq domain => - doIt (fn () => - if not (Domain.yourDomain domain) then - ("Unauthorized user tried to request SMTP logs for " ^ domain, - SOME "You aren't authorized to configure that domain.") - else - (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line)) - domain; - ("Requested SMTP logs for " ^ domain, - NONE))) - (fn () => ()) - - | MsgQuery q => - doIt (fn () => (Msg.send (bio, answerQuery q); - (describeQuery q, - NONE))) - (fn () => ()) - - | _ => - doIt (fn () => ("Unexpected command", - SOME "Unexpected command")) - (fn () => ()) - in - cmdLoop () - end - handle e as (OpenSSL.OpenSSL s) => - (print ("OpenSSL error: " ^ s ^ "\n"); - app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | OS.SysErr (s, _) => - (print ("System error: " ^ s ^ "\n"); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | IO.Io {name, function, cause} => - (print ("IO error: " ^ function ^ " for " ^ name ^ "\n"); - app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | e => - (print "Unknown exception in main loop!\n"; - app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) + | OS.SysErr (s, _) => + (print ("System error: " ^ s ^ "\n"); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | IO.Io {name, function, cause} => + (print ("IO error: " ^ function ^ " for " ^ name ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | e => + (print "Unknown exception in main loop!\n"; + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ())) + handle e as (OpenSSL.OpenSSL s) => + (print ("OpenSSL error: " ^ s ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + loop ()) + | OS.SysErr (s, _) => + (print ("System error: " ^ s ^ "\n"); + loop ()) + | IO.Io {name, function, cause} => + (print ("IO error: " ^ function ^ " for " ^ name ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause); + loop ()) + | e => + (print "Unknown exception in main loop!\n"; + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + loop ()) in print ("Domtool dispatcher starting up at " ^ now () ^ "\n"); print "Listening for connections....\n"; -- 2.20.1