X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/7f012ffdbae5dbee9642fee030647d558b25c8c4..2e96b9d42f6d2619f961c753ac3bbc9ba57c5147:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 705b20a..ef6e563 100644 --- a/src/main.sml +++ b/src/main.sml @@ -20,37 +20,20 @@ structure Main :> MAIN = struct -open Ast Print +open Ast MsgTypes Print structure SM = StringMap -val dmy = ErrorMsg.dummyLoc - -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 () = @@ -70,12 +53,14 @@ 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 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 = @@ -86,23 +71,60 @@ 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 +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 + raise ErrorMsg.Error + else + (foldl (fn (fname, G) => check' G fname) b files; + if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + ()) + end + fun reduce fname = let val (G, body) = check fname @@ -127,10 +149,853 @@ fun reduce fname = fun eval fname = case reduce fname of (SOME body') => + if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + Eval.exec (Defaults.eInit ()) body' + | NONE => raise ErrorMsg.Error + +fun eval' fname = + case reduce fname of + (SOME body') => + if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + ignore (Eval.exec' (Defaults.eInit ()) body') + | NONE => raise ErrorMsg.Error + +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 context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem", + Config.keyDir ^ "/" ^ user ^ "/key.pem", + Config.trustStore) + in + (user, context) + end + +fun requestBio f = + let + val (user, context) = requestContext f + in + (user, OpenSSL.connect (context, dispatcher)) + end + +fun request fname = + let + val (user, bio) = requestBio (fn () => ignore (check fname)) + + val inf = TextIO.openIn fname + + fun loop lines = + case TextIO.inputLine inf of + NONE => String.concat (List.rev lines) + | SOME line => loop (line :: lines) + + 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 requestDir dname = + let + val _ = ErrorMsg.reset () + + val (user, bio) = requestBio (fn () => 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 if !ErrorMsg.anyErrors then () else - Eval.exec (SM.map (fn f => f ()) (!defaultV)) body' - | NONE => () + (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 () => ()) + in + 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 requestRevoke acl = + let + 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 requestListPerms user = + let + val (_, bio) = requestBio (fn () => ()) + in + 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 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 requestRegen () = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRegenerate); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Regeneration succeeded.\n" + | MsgError s => print ("Regeneration failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestRmdom dom = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRmdom dom); + 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 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." + | 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.") + 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 requestSaQuery addr = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgSaQuery addr); + (case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is " + ^ (if b then "ON" else "OFF") ^ ".\n"); + Msg.send (bio, MsgOk)) + | MsgError s => print ("Query failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n") + before OpenSSL.close bio + end + +fun requestSaSet p = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgSaSet p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now " + ^ (if #2 p then "ON" else "OFF") ^ ".\n") + | MsgError s => print ("Set failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun regenerate context = + let + val b = basis () + val () = Tycheck.disallowExterns () + + val () = Domain.resetGlobal () + + fun contactNode (node, ip) = + if node = Config.defaultNode then + Domain.resetLocal () + else let + val bio = OpenSSL.connect (context, + ip + ^ ":" + ^ Int.toString Config.slavePort) + in + Msg.send (bio, MsgRegenerate); + case Msg.recv bio of + NONE => print "Slave closed connection unexpectedly\n" + | SOME m => + case m of + MsgOk => print ("Slave " ^ node ^ " pre-regeneration finished\n") + | MsgError s => print ("Slave " ^ node + ^ " returned error: " ^ + s ^ "\n") + | _ => print ("Slave " ^ node + ^ " returned unexpected command\n"); + OpenSSL.close bio + end + + fun doUser user = + let + val _ = Domain.setUser user + val _ = ErrorMsg.reset () + + val dname = Config.domtoolDir user + + 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 + print ("User " ^ user ^ "'s configuration has errors!\n") + else + app eval' files + end + handle IO.Io _ => () + | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") + in + app contactNode Config.nodeIps; + Env.pre (); + app doUser (Acl.users ()); + 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 + + 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 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" + 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 + + | 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 + (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.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 () => ()) + + | _ => + doIt (fn () => ("Unexpected command", + SOME "Unexpected command")) + (fn () => ()) + 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 + 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)) + | MsgRegenerate => (Domain.resetLocal (); + 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 listBasis () = + 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 + in + loop [] + end + +fun autodocBasis outdir = + Autodoc.autodoc {outdir = outdir, infiles = listBasis ()} end