setsa

diff --git a/Makefile b/Makefile
index 42d1ccd..a89036b 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -69,6 +69,10 @@ src/vmail.mlb: src/prefix.mlb src/sources src/suffix.mlb
        $(MAKE_MLB_BASE) >src/vmail.mlb
        echo "main-vmail.sml" >>src/vmail.mlb
 
        $(MAKE_MLB_BASE) >src/vmail.mlb
        echo "main-vmail.sml" >>src/vmail.mlb
 

+src/setsa.mlb: src/prefix.mlb src/sources src/suffix.mlb
+       $(MAKE_MLB_BASE) >src/setsa.mlb
+       echo "main-setsa.sml" >>src/setsa.mlb
+

 openssl/smlnj/FFI/libssl.h.cm: openssl/openssl_sml.h
        cd openssl/smlnj ; ml-nlffigen -d FFI -lh LibsslH.libh -include ../libssl-h.sml \
        -cm libssl.h.cm -D__builtin_va_list="void*" \
 openssl/smlnj/FFI/libssl.h.cm: openssl/openssl_sml.h
        cd openssl/smlnj ; ml-nlffigen -d FFI -lh LibsslH.libh -include ../libssl-h.sml \
        -cm libssl.h.cm -D__builtin_va_list="void*" \


@@ -113,6 +117,9 @@ bin/dbtool: $(COMMON_MLTON_DEPS) src/dbtool.mlb
 bin/vmail: $(COMMON_MLTON_DEPS) src/vmail.mlb
        mlton -output bin/vmail -link-opt -ldl src/vmail.mlb
 
 bin/vmail: $(COMMON_MLTON_DEPS) src/vmail.mlb
        mlton -output bin/vmail -link-opt -ldl src/vmail.mlb
 

+bin/setsa: $(COMMON_MLTON_DEPS) src/setsa.mlb
+       mlton -output bin/setsa -link-opt -ldl src/setsa.mlb
+

 install:
        cp scripts/domtool-publish /usr/local/sbin/
        cp scripts/domtool-reset-global /usr/local/sbin/
 install:
        cp scripts/domtool-publish /usr/local/sbin/
        cp scripts/domtool-reset-global /usr/local/sbin/


@@ -129,6 +136,7 @@ install:
        -cp bin/domtool-doc /usr/local/bin/
        -cp bin/dbtool /usr/local/bin/
        -cp bin/vmail /usr/local/bin/
        -cp bin/domtool-doc /usr/local/bin/
        -cp bin/dbtool /usr/local/bin/
        -cp bin/vmail /usr/local/bin/

+       -cp bin/setsa /usr/local/bin/

        cp src/plugins/domtool-postgres /usr/local/sbin/
        cp src/plugins/domtool-mysql /usr/local/sbin/
 
        cp src/plugins/domtool-postgres /usr/local/sbin/
        cp src/plugins/domtool-mysql /usr/local/sbin/
 

diff --git a/bin/.cvsignore b/bin/.cvsignore
index df0fc62..21f1267 100644 (file)
--- a/bin/.cvsignore
+++ b/bin/.cvsignore
@@ -5,3 +5,4 @@ domtool-admin
 domtool-doc
 dbtool
 vmail
 domtool-doc
 dbtool
 vmail

+setsa
\ No newline at end of file

diff --git a/configDefault/spamassassin.cfg b/configDefault/spamassassin.cfg
new file mode 100644 (file)
index 0000000..9be1007
--- /dev/null
+++ b/configDefault/spamassassin.cfg
@@ -0,0 +1,5 @@
+structure SpamAssassin :> SPAM_ASSASSIN_CONFIG = struct
+
+val addrsDir = "/etc/spamassassin/addrs"
+
+end

diff --git a/configDefault/spamassassin.cfs b/configDefault/spamassassin.cfs
new file mode 100644 (file)
index 0000000..1a7790e
--- /dev/null
+++ b/configDefault/spamassassin.cfs
@@ -0,0 +1 @@
+structure SpamAssassin : SPAM_ASSASSIN_CONFIG

diff --git a/configDefault/spamassassin.csg b/configDefault/spamassassin.csg
new file mode 100644 (file)
index 0000000..5bbab44
--- /dev/null
+++ b/configDefault/spamassassin.csg
@@ -0,0 +1,5 @@
+signature SPAM_ASSASSIN_CONFIG = sig
+
+    val addrsDir : string
+
+end

diff --git a/src/.cvsignore b/src/.cvsignore
index e1d7ea7..09dde33 100644 (file)
--- a/src/.cvsignore
+++ b/src/.cvsignore
@@ -9,3 +9,4 @@ domtool-admin.mlb
 domtool-doc.mlb
 dbtool.mlb
 vmail.mlb
 domtool-doc.mlb
 dbtool.mlb
 vmail.mlb

+setsa.mlb

diff --git a/src/domain.sig b/src/domain.sig
index be9bd8b..10a2d86 100644 (file)
--- a/src/domain.sig
+++ b/src/domain.sig
@@ -26,6 +26,7 @@ signature DOMAIN = sig
     val validDomain : string -> bool
     val yourDomain : string -> bool
     val validUser : string -> bool
     val validDomain : string -> bool
     val yourDomain : string -> bool
     val validUser : string -> bool

+    val validEmailUser : string -> bool

 
     val ip : string Env.arg
 
 
     val ip : string Env.arg
 

diff --git a/src/domain.sml b/src/domain.sml
index 3d8290b..4e38a98 100644 (file)
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -102,6 +102,14 @@ val yourDomain = yourDomainHost
 fun validUser s = size s > 0 andalso size s < 20
                  andalso CharVector.all Char.isAlphaNum s
 
 fun validUser s = size s > 0 andalso size s < 20
                  andalso CharVector.all Char.isAlphaNum s
 

+fun validEmailUser s =
+    size s > 0 andalso size s < 50
+    andalso CharVector.all (fn ch => Char.isAlphaNum ch
+                                    orelse ch = #"."
+                                    orelse ch = #"_"
+                                    orelse ch = #"-"
+                                    orelse ch = #"+") s
+

 val validGroup = validUser
 
 val _ = Env.type_one "no_spaces"
 val validGroup = validUser
 
 val _ = Env.type_one "no_spaces"

diff --git a/src/mail/setsa.sig b/src/mail/setsa.sig
new file mode 100644 (file)
index 0000000..bc81859
--- /dev/null
+++ b/src/mail/setsa.sig
@@ -0,0 +1,30 @@
+(* 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.
+ *)
+
+(* Setting SpamAssassin filtering preferences *)
+
+signature SET_SA = sig
+
+    datatype address =
+            User of string
+          | Email of string
+
+    val query : address -> bool
+    val set : address * bool -> unit
+
+end

diff --git a/src/mail/setsa.sml b/src/mail/setsa.sml
new file mode 100644 (file)
index 0000000..ef60dca
--- /dev/null
+++ b/src/mail/setsa.sml
@@ -0,0 +1,41 @@
+(* 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.
+ *)
+
+(* Setting SpamAssassin filtering preferences *)
+
+structure SetSA :> SET_SA = struct
+
+datatype address =
+        User of string
+       | Email of string
+
+fun address (User s) = s ^ "@localhost"
+  | address (Email s) = s
+
+fun file addr = OS.Path.joinDirFile {dir = Config.SpamAssassin.addrsDir,
+                                    file = address addr}
+
+fun query addr = Posix.FileSys.access (file addr, [])
+
+fun set (addr, setting) =
+    if setting then
+       TextIO.closeOut (TextIO.openAppend (file addr))
+    else
+       OS.FileSys.remove (file addr)
+
+end

diff --git a/src/main-setsa.sml b/src/main-setsa.sml
new file mode 100644 (file)
index 0000000..76a947d
--- /dev/null
+++ b/src/main-setsa.sml
@@ -0,0 +1,39 @@
+(* 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 SpamAssassin filtering preferences *)
+
+val _ =
+    let
+       fun defaultEmail () = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid (Posix.ProcEnv.getuid ()))
+
+       val args = CommandLine.arguments ()
+
+       val (addr, args) =
+           case args of
+               "on" :: _ => (defaultEmail (), args)
+             | "off" :: _ => (defaultEmail (), args)
+             | addr :: rest => (addr, rest)
+             | [] => (defaultEmail (), args)
+    in
+       case args of
+           [] => Main.requestSaQuery addr
+         | ["on"] => Main.requestSaSet (addr, true)
+         | ["off"] => Main.requestSaSet (addr, false)
+         | _ => print "Invalid command-line argiments\n"
+    end

diff --git a/src/main.sig b/src/main.sig
index 1449967..621b455 100644 (file)
--- a/src/main.sig
+++ b/src/main.sig
@@ -57,4 +57,7 @@ signature MAIN = sig
     val requestPasswdMailbox : {domain : string, user : string, passwd : string}
                               -> unit
     val requestRmMailbox : {domain : string, user : string} -> unit
     val requestPasswdMailbox : {domain : string, user : string, passwd : string}
                               -> unit
     val requestRmMailbox : {domain : string, user : string} -> unit

+
+    val requestSaQuery : string -> unit
+    val requestSaSet : string * bool -> unit

 end
 end

diff --git a/src/main.sml b/src/main.sml
index 4fe8124..ef6e563 100644 (file)
--- a/src/main.sml
+++ b/src/main.sml
@@ -422,13 +422,13 @@ fun requestListMailboxes domain =
     in
        Msg.send (bio, MsgListMailboxes domain);
        (case Msg.recv bio of
     in
        Msg.send (bio, MsgListMailboxes domain);
        (case Msg.recv bio of

-            NONE => Vmail.Error "Server closed connection unexpectedly.\n"
+            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)
           | 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")
+              | _ => Vmail.Error "Unexpected server reply.")

        before OpenSSL.close bio
     end
 
        before OpenSSL.close bio
     end
 


@@ -477,6 +477,39 @@ fun requestRmMailbox p =
        OpenSSL.close bio
     end
 
        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 ()
 fun regenerate context =
     let
        val b = basis ()


@@ -636,6 +669,20 @@ fun service () =
                                 (fn () => OS.FileSys.remove outname)
                        end
 
                                 (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
                    fun cmdLoop () =
                        case Msg.recv bio of
                            NONE => (OpenSSL.close bio


@@ -773,7 +820,7 @@ fun service () =
                                         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.")
                                         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
+                                        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 e-mail username " ^ emailUser,
                                              SOME "Invalid e-mail username")
                                         else if not (CharVector.all Char.isGraph passwd) then


@@ -797,7 +844,7 @@ fun service () =
                                         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.")
                                         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
+                                        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 e-mail username " ^ emailUser,
                                              SOME "Invalid e-mail username")
                                         else if not (CharVector.all Char.isGraph passwd) then


@@ -817,7 +864,7 @@ fun service () =
                                         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.")
                                         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
+                                        else if not (Domain.validEmailUser emailUser) then

                                             ("Invalid e-mail username " ^ emailUser,
                                              SOME "Invalid e-mail username")
                                         else
                                             ("Invalid e-mail username " ^ emailUser,
                                              SOME "Invalid e-mail username")
                                         else


@@ -828,6 +875,28 @@ fun service () =
                                                              SOME msg))
                                     (fn () => ())
 
                                                              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"))
                              | _ =>
                                doIt (fn () => ("Unexpected command",
                                                SOME "Unexpected command"))

diff --git a/src/msg.sml b/src/msg.sml
index 747572a..1d168af 100644 (file)
--- a/src/msg.sml
+++ b/src/msg.sml
@@ -76,6 +76,18 @@ fun recvOption f bio =
           | NONE => NONE)
       | _ => NONE
 
           | NONE => NONE)
       | _ => NONE
 

+fun sendBool (bio, b) =
+    if b then
+       OpenSSL.writeInt (bio, 1)
+    else
+       OpenSSL.writeInt (bio, 0)
+
+fun recvBool bio =
+    case OpenSSL.readInt bio of
+       SOME 0 => SOME false
+      | SOME 1 => SOME true
+      | _ => NONE
+

 fun send (bio, m) =
     case m of
        MsgOk => OpenSSL.writeInt (bio, 1)
 fun send (bio, m) =
     case m of
        MsgOk => OpenSSL.writeInt (bio, 1)


@@ -143,6 +155,13 @@ fun send (bio, m) =
                            (OpenSSL.writeString (bio, user);
                             OpenSSL.writeString (bio, mailbox)))
         (bio, users))
                            (OpenSSL.writeString (bio, user);
                             OpenSSL.writeString (bio, mailbox)))
         (bio, users))

+      | MsgSaQuery addr => (OpenSSL.writeInt (bio, 23);
+                           OpenSSL.writeString (bio, addr))
+      | MsgSaStatus b => (OpenSSL.writeInt (bio, 24);
+                         sendBool (bio, b))
+      | MsgSaSet (addr, b) => (OpenSSL.writeInt (bio, 25);
+                              OpenSSL.writeString (bio, addr);
+                              sendBool (bio, b))

 
 fun checkIt v =
     case v of
 
 fun checkIt v =
     case v of


@@ -226,6 +245,11 @@ fun recv bio =
                                                                SOME {user = user, mailbox = mailbox}
                                                              | _ => NONE)
                                                        bio)
                                                                SOME {user = user, mailbox = mailbox}
                                                              | _ => NONE)
                                                        bio)

+                  | 23 => Option.map MsgSaQuery (OpenSSL.readString bio)
+                  | 24 => Option.map MsgSaStatus (recvBool bio)
+                  | 25 => (case (OpenSSL.readString bio, recvBool bio) of
+                               (SOME user, SOME b) => SOME (MsgSaSet (user, b))
+                             | _ => NONE)

                   | _ => NONE)
         
 end
                   | _ => NONE)
         
 end

diff --git a/src/msgTypes.sml b/src/msgTypes.sml
index 3d5997d..7f328e3 100644 (file)
--- a/src/msgTypes.sml
+++ b/src/msgTypes.sml
@@ -69,5 +69,11 @@ datatype msg =
        (* List all mailboxes for a domain *)
        | MsgMailboxes of {user : string, mailbox : string} list
        (* Reply to MsgListMailboxes *)
        (* List all mailboxes for a domain *)
        | MsgMailboxes of {user : string, mailbox : string} list
        (* Reply to MsgListMailboxes *)

+       | MsgSaQuery of string
+       (* Check on the SpamAsssassin filtering status of a user or e-mail address *)
+       | MsgSaStatus of bool
+       (* Response to MsgSaQuery *)
+       | MsgSaSet of string * bool
+       (* Set the filtering status of a user or e-mail address *)

 
 end
 
 end

diff --git a/src/sources b/src/sources
index cbb56cb..4eb2399 100644 (file)
--- a/src/sources
+++ b/src/sources
@@ -89,6 +89,9 @@ plugins/mysql.sml
 mail/vmail.sig
 mail/vmail.sml
 
 mail/vmail.sig
 mail/vmail.sml
 

+mail/setsa.sig
+mail/setsa.sml
+

 order.sig
 order.sml
 
 order.sig
 order.sml