From 2e96b9d42f6d2619f961c753ac3bbc9ba57c5147 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 23 Dec 2006 22:40:25 +0000 Subject: [PATCH] setsa --- Makefile | 8 ++++ bin/.cvsignore | 1 + configDefault/spamassassin.cfg | 5 +++ configDefault/spamassassin.cfs | 1 + configDefault/spamassassin.csg | 5 +++ src/.cvsignore | 1 + src/domain.sig | 1 + src/domain.sml | 8 ++++ src/mail/setsa.sig | 30 +++++++++++++ src/mail/setsa.sml | 41 ++++++++++++++++++ src/main-setsa.sml | 39 +++++++++++++++++ src/main.sig | 3 ++ src/main.sml | 79 +++++++++++++++++++++++++++++++--- src/msg.sml | 24 +++++++++++ src/msgTypes.sml | 6 +++ src/sources | 3 ++ 16 files changed, 250 insertions(+), 5 deletions(-) create mode 100644 configDefault/spamassassin.cfg create mode 100644 configDefault/spamassassin.cfs create mode 100644 configDefault/spamassassin.csg create mode 100644 src/mail/setsa.sig create mode 100644 src/mail/setsa.sml create mode 100644 src/main-setsa.sml diff --git a/Makefile b/Makefile index 42d1ccd..a89036b 100644 --- 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 +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*" \ @@ -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/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/ @@ -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/setsa /usr/local/bin/ 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 --- a/bin/.cvsignore +++ b/bin/.cvsignore @@ -5,3 +5,4 @@ domtool-admin 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 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 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 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 --- a/src/.cvsignore +++ b/src/.cvsignore @@ -9,3 +9,4 @@ domtool-admin.mlb domtool-doc.mlb dbtool.mlb vmail.mlb +setsa.mlb diff --git a/src/domain.sig b/src/domain.sig index be9bd8b..10a2d86 100644 --- 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 validEmailUser : string -> bool val ip : string Env.arg diff --git a/src/domain.sml b/src/domain.sml index 3d8290b..4e38a98 100644 --- 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 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" diff --git a/src/mail/setsa.sig b/src/mail/setsa.sig new file mode 100644 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 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 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 --- 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 requestSaQuery : string -> unit + val requestSaSet : string * bool -> unit end diff --git a/src/main.sml b/src/main.sml index 4fe8124..ef6e563 100644 --- 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 - 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) - | _ => Vmail.Error "Unexpected server reply.\n") + | _ => Vmail.Error "Unexpected server reply.") before OpenSSL.close bio end @@ -477,6 +477,39 @@ fun requestRmMailbox p = 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 () @@ -636,6 +669,20 @@ fun service () = (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 @@ -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.") - 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 @@ -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.") - 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 @@ -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.") - 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 @@ -828,6 +875,28 @@ fun service () = 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")) diff --git a/src/msg.sml b/src/msg.sml index 747572a..1d168af 100644 --- a/src/msg.sml +++ b/src/msg.sml @@ -76,6 +76,18 @@ fun recvOption f bio = | 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) @@ -143,6 +155,13 @@ fun send (bio, m) = (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 @@ -226,6 +245,11 @@ fun recv 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 diff --git a/src/msgTypes.sml b/src/msgTypes.sml index 3d5997d..7f328e3 100644 --- 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 *) + | 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 diff --git a/src/sources b/src/sources index cbb56cb..4eb2399 100644 --- a/src/sources +++ b/src/sources @@ -89,6 +89,9 @@ plugins/mysql.sml mail/vmail.sig mail/vmail.sml +mail/setsa.sig +mail/setsa.sml + order.sig order.sml -- 2.20.1