basic internal ipv6 support

[hcoop/domtool2.git] / src / main.sml

diff --git a/src/main.sml b/src/main.sml
index 6df1525..dfe0bd5 100644 (file)
--- a/src/main.sml
+++ b/src/main.sml
@@ -1,5 +1,6 @@
 (* HCoop Domtool (http://hcoop.sourceforge.net/)
  * Copyright (c) 2006-2009, Adam Chlipala
 (* HCoop Domtool (http://hcoop.sourceforge.net/)
  * Copyright (c) 2006-2009, Adam Chlipala

+ * Copyright (c) 2012,2013,2014 Clinton Ebadi <clinton@unknownlamer.org>

  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License
  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License


@@ -50,11 +51,12 @@ fun check' G fname =
                 ()
             else
                 Option.app (Unused.check G) (#3 prog);
                 ()
             else
                 Option.app (Unused.check G) (#3 prog);

-            Tycheck.checkFile G (Defaults.tInit prog) prog)
+            Tycheck.checkFile G prog)

     end
 
 fun basis () =
     let
     end
 
 fun basis () =
     let

+       val _ = ErrorMsg.reset ()

        val dir = Posix.FileSys.opendir Config.libRoot
 
        fun loop files =
        val dir = Posix.FileSys.opendir Config.libRoot
 
        fun loop files =


@@ -100,7 +102,7 @@ fun check G fname =
                    raise ErrorMsg.Error
                else
                    let
                    raise ErrorMsg.Error
                else
                    let

-                       val G' = Tycheck.checkFile G (Defaults.tInit prog) prog
+                       val G' = Tycheck.checkFile G prog

                    in
                        if !ErrorMsg.anyErrors then
                            raise ErrorMsg.Error
                    in
                        if !ErrorMsg.anyErrors then
                            raise ErrorMsg.Error


@@ -116,6 +118,7 @@ fun check G fname =
 
 fun notTmp s =
     String.sub (s, 0) <> #"."
 
 fun notTmp s =
     String.sub (s, 0) <> #"."

+    andalso s <> "_darcs"

     andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") s
 
 fun setupUser () =
     andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") s
 
 fun setupUser () =


@@ -193,6 +196,8 @@ fun reduce G fname =
 
 (*(Defaults.eInit ())*)
 
 
 (*(Defaults.eInit ())*)
 

+val toplevel = Env.initialDynEnvVals Reduce.reduceExp
+

 fun eval G evs fname =
     case reduce G fname of
        (G, SOME body') =>
 fun eval G evs fname =
     case reduce G fname of
        (G, SOME body') =>


@@ -200,14 +205,14 @@ fun eval G evs fname =
            raise ErrorMsg.Error
        else
            let
            raise ErrorMsg.Error
        else
            let

-               val evs' = Eval.exec' evs body'
+               val evs' = Eval.exec' (toplevel G, evs) body'

            in
                (G, evs')
            end
       | (G, NONE) => (G, evs)
 
 val dispatcher =
            in
                (G, evs')
            end
       | (G, NONE) => (G, evs)
 
 val dispatcher =

-    Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort
+    Domain.nodeIp Config.dispatcherName ^ ":" ^ Int.toString Config.dispatcherPort

 
 val self =
     "localhost:" ^ Int.toString Config.slavePort
 
 val self =
     "localhost:" ^ Int.toString Config.slavePort


@@ -537,7 +542,7 @@ fun requestDbUser dbtype =
     let
        val (_, context) = requestContext (fn () => ())
        val bio = OpenSSL.connect true (context,
     let
        val (_, context) = requestContext (fn () => ())
        val bio = OpenSSL.connect true (context,

-                                       Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)
+                                       Domain.nodeIp Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort)

     in
        Msg.send (bio, MsgCreateDbUser dbtype);
        case Msg.recv bio of
     in
        Msg.send (bio, MsgCreateDbUser dbtype);
        case Msg.recv bio of


@@ -664,6 +669,22 @@ fun requestPasswdMailbox p =
        OpenSSL.close bio
     end
 
        OpenSSL.close bio
     end
 

+fun requestPortalPasswdMailbox p =
+    let
+       val (_, bio) = requestBio (fn () => ())
+    in
+       (Msg.send (bio, MsgPortalPasswdMailbox p);
+        case Msg.recv bio of
+            NONE => (print "Server closed connection unexpectedly.\n"; OS.Process.failure)
+          | SOME m =>
+            case m of
+                MsgOk => (print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n");
+                          OS.Process.success)
+              | MsgError s => (print ("Set failed: " ^ s ^ "\n"); OS.Process.failure)
+              | _ => (print "Unexpected server reply.\n"; OS.Process.failure))
+       before OpenSSL.close bio
+    end 
+

 fun requestRmMailbox p =
     let
        val (_, bio) = requestBio (fn () => ())
 fun requestRmMailbox p =
     let
        val (_, bio) = requestBio (fn () => ())


@@ -795,10 +816,13 @@ fun requestAptExists {node, pkg} =
                         OS.Process.failure)
              | SOME m =>
                case m of
                         OS.Process.failure)
              | SOME m =>
                case m of

-                   MsgYes => (print "Package exists.\n";
-                              OS.Process.success)
+                   MsgAptQuery {section,description}  =>  (print "Package exists.\n";
+                                                           print ("Section: " ^ section ^ "\n");
+                                                           print ("Description: " ^ description ^ "\n");
+                                                           OS.Process.success)

                  | MsgNo => (print "Package does not exist.\n";
                  | MsgNo => (print "Package does not exist.\n";

-                             OS.Process.failure)
+                             OS.Process.failure
+                            (* It might be the Wrong Thing (tm) to use MsgNo like this *))

                  | MsgError s => (print ("APT existence query failed: " ^ s ^ "\n");
                                   OS.Process.failure)
                  | _ => (print "Unexpected server reply.\n";
                  | MsgError s => (print ("APT existence query failed: " ^ s ^ "\n");
                                   OS.Process.failure)
                  | _ => (print "Unexpected server reply.\n";


@@ -934,7 +958,7 @@ fun requestFirewall {node, uname} =
                                                 else
                                                     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
                  
                                                 else
                                                     Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort)
                  

-       val _ = Msg.send (bio, MsgQuery (QFirewall uname))
+       val _ = Msg.send (bio, MsgQuery (QFirewall {node = node, user = uname}))

 
        fun loop () =
            case Msg.recv bio of
 
        fun loop () =
            case Msg.recv bio of


@@ -1086,8 +1110,8 @@ fun regenerateEither tc checker context =
 
        val ok = ref true
  
 
        val ok = ref true
  

-       fun contactNode (node, ip) =
-           if node = Config.defaultNode then
+       fun contactNode (node, ip, ipv6) =
+           if node = Config.dispatcherName then

                Domain.resetLocal ()
            else let
                    val bio = OpenSSL.connect true (context,
                Domain.resetLocal ()
            else let
                    val bio = OpenSSL.connect true (context,


@@ -1145,9 +1169,11 @@ fun regenerateEither tc checker context =
                             ok := false)
                        else
                            ();
                             ok := false)
                        else
                            ();

-                       ignore (foldl checker' (basis (), Defaults.eInit ()) files)
+                       let val basis' = basis () in
+                           ignore (foldl checker' (basis', SM.empty) files)
+                       end

                    end
                    end

-               else if String.isSuffix "_admin" user then
+               else if (String.isSuffix "_admin" user) orelse (String.isSuffix ".daemon" user) then

                    ()    
                else
                    (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n");
                    ()    
                else
                    (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n");


@@ -1213,12 +1239,14 @@ fun now () = Date.toString (Date.fromTimeUniv (Time.now ()))
 fun answerQuery q =
     case q of
        QApt pkg => if Apt.installed pkg then MsgYes else MsgNo
 fun answerQuery q =
     case q of
        QApt pkg => if Apt.installed pkg then MsgYes else MsgNo

-      | QAptExists pkg => if Apt.exists pkg then MsgYes else MsgNo
+      | QAptExists pkg => (case Apt.info pkg of
+                             SOME {section, description} => MsgAptQuery {section = section, description = description}
+                           | NONE => MsgNo)

       | QCron user => if Cron.allowed user then MsgYes else MsgNo
       | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
       | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
       | QSocket user => MsgSocket (SocketPerm.query user)
       | QCron user => if Cron.allowed user then MsgYes else MsgNo
       | QFtp user => if Ftp.allowed user then MsgYes else MsgNo
       | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo
       | QSocket user => MsgSocket (SocketPerm.query user)

-      | QFirewall user => MsgFirewall (Firewall.query user)
+      | QFirewall {node, user} => MsgFirewall (Firewall.query (node, user))

 
 fun describeQuery q =
     case q of
 
 fun describeQuery q =
     case q of


@@ -1228,7 +1256,7 @@ fun describeQuery q =
       | QFtp user => "Asked about FTP permissions for user " ^ user
       | QTrustedPath user => "Asked about trusted path settings for user " ^ user
       | QSocket user => "Asked about socket permissions for user " ^ user
       | QFtp user => "Asked about FTP permissions for user " ^ user
       | QTrustedPath user => "Asked about trusted path settings for user " ^ user
       | QSocket user => "Asked about socket permissions for user " ^ user

-      | QFirewall user => "Asked about firewall rules for user " ^ user
+      | QFirewall {node, user} => "Asked about firewall rules on " ^ node ^ " for user " ^ user

 
 fun doIt' loop bio f cleanup =
               ((case f () of
 
 fun doIt' loop bio f cleanup =
               ((case f () of


@@ -1308,7 +1336,9 @@ fun service () =
                                 end
                         in
                             doIt (fn () => (Env.pre ();
                                 end
                         in
                             doIt (fn () => (Env.pre ();

-                                            ignore (foldl doOne (basis (), Defaults.eInit ()) codes);
+                                            let val basis' = basis () in
+                                                ignore (foldl doOne (basis', SM.empty) codes)
+                                            end;

                                             Env.post ();
                                             Msg.send (bio, MsgOk);
                                             ("Configuration complete.", NONE)))
                                             Env.post ();
                                             Msg.send (bio, MsgOk);
                                             ("Configuration complete.", NONE)))


@@ -1508,6 +1538,27 @@ fun service () =
                                                               SOME msg))
                                      (fn () => ())
 
                                                               SOME msg))
                                      (fn () => ())
 

+                              | MsgPortalPasswdMailbox {domain, user = emailUser, oldpasswd, newpasswd} =>
+                                doIt (fn () =>
+                                         if not (Acl.query {user = user, class = "priv", value = "vmail"}) then
+                                                ("User is not authorized to run portal vmail password",
+                                              SOME "You're not authorized to use the portal password command")
+                                         else if not (Domain.validEmailUser emailUser) then
+                                             ("Invalid e-mail username " ^ emailUser,
+                                              SOME "Invalid e-mail username")
+                                         else if not (CharVector.all Char.isGraph oldpasswd
+                                                     andalso CharVector.all Char.isGraph newpasswd) then
+                                             ("Invalid password",
+                                              SOME "Invalid password; may only contain printable, non-space characters")
+                                         else
+                                             case Vmail.portalpasswd {domain = domain, user = emailUser,
+                                                                      oldpasswd = oldpasswd, newpasswd = newpasswd} 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
                               | MsgRmMailbox {domain, user = emailUser} =>
                                 doIt (fn () =>
                                          if not (Domain.yourDomain domain) then


@@ -1540,6 +1591,7 @@ fun service () =
                                              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);
                                              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);

+                                                            SetSA.rebuild ();

                                                             Msg.send (bio, MsgOk);
                                                             ("Set SA filtering status for " ^ addr ^ " to "
                                                              ^ (if b then "ON" else "OFF"),
                                                             Msg.send (bio, MsgOk);
                                                             ("Set SA filtering status for " ^ addr ^ " to "
                                                              ^ (if b then "ON" else "OFF"),


@@ -1657,8 +1709,7 @@ fun slave () =
        val _ = print ("Slave server starting at " ^ now () ^ "\n")
 
        fun loop () =
        val _ = print ("Slave server starting at " ^ now () ^ "\n")
 
        fun loop () =

-           (Acl.read Config.aclFile;
-            case OpenSSL.accept sock of
+           (case OpenSSL.accept sock of

                 NONE => ()
               | SOME bio =>
                 let
                 NONE => ()
               | SOME bio =>
                 let


@@ -1680,6 +1731,10 @@ fun slave () =
                                                                 Msg.send (bio, MsgOk)
                                                             else
                                                                 Msg.send (bio, MsgError "userdb update failed"))
                                                                 Msg.send (bio, MsgOk)
                                                             else
                                                                 Msg.send (bio, MsgError "userdb update failed"))

+                                      | MsgSaChanged => (if Slave.shell [Config.SpamAssassin.postReload] then
+                                                             Msg.send (bio, MsgOk)
+                                                         else
+                                                             Msg.send (bio, MsgError "Error reloading SpamAssassin addresses"))

                                       | _ => (print "Dispatcher sent unexpected command\n";
                                               Msg.send (bio, MsgError "Unexpected command"))
                         in
                                       | _ => (print "Dispatcher sent unexpected command\n";
                                               Msg.send (bio, MsgError "Unexpected command"))
                         in


@@ -1803,16 +1858,17 @@ fun slave () =
                                                          SOME "Script execution failed."))
                                           (fn () => ()))
                                   | MsgFirewallRegen =>
                                                          SOME "Script execution failed."))
                                           (fn () => ()))
                                   | MsgFirewallRegen =>

-                                    doIt (fn () => if Acl.query {user = user, class = "priv", value = "all"} then
-                                                       if List.exists (fn x => x = host) Config.Firewall.firewallNodes then
-                                                           if (Firewall.generateFirewallConfig (Firewall.parseRules ()) andalso Firewall.publishConfig ())
-                                                           then
-                                                               ("Firewall rules regenerated.", NONE)
-                                                           else
+                                    doIt (fn () => (Acl.read Config.aclFile;
+                                                    if Acl.query {user = user, class = "priv", value = "all"} then
+                                                        if List.exists (fn x => x = host) Config.Firewall.firewallNodes then
+                                                            if (Firewall.generateFirewallConfig (Firewall.parseRules ()) andalso Firewall.publishConfig ())
+                                                            then
+                                                                ("Firewall rules regenerated.", NONE)
+                                                            else

                                                                ("Rules regeneration failed!", SOME "Script execution failed.")
                                                        else ("Node not controlled by domtool firewall.", SOME (host))
                                                                ("Rules regeneration failed!", SOME "Script execution failed.")
                                                        else ("Node not controlled by domtool firewall.", SOME (host))

-                                                   else
-                                                       ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ " attempted to regenerated firewall")))
+                                                    else
+                                                        ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ " attempted to regenerated firewall"))))

                                          (fn () => ())
 
                                   | _ => (OpenSSL.close bio;
                                          (fn () => ())
 
                                   | _ => (OpenSSL.close bio;