diff --git a/Autoproc/Classifier.hs b/Autoproc/Classifier.hs new file mode 100644 --- /dev/null +++ b/Autoproc/Classifier.hs @@ -0,0 +1,280 @@ +module Autoproc.Classifier where + +-- The purpose of this module is to define the abstract and concrete +-- syntax for the condition expression language. + +import Control.Monad.Writer hiding (when) + +-- Some functions in this module get their meaning and values from +-- Configuration module. If you want to change a default such as +-- locking, check the Configuration module. +import Autoproc.Configuration + +data EmailAddress = Addr String deriving Show + +data Mailbox = Mailbox String + +data CExp = CExp [Flag] Cond Act deriving Show + +data Flag = Copy + | Wait + | IgnoreErrors + | RawWrite + | NeedLock Bool + | Chain + | CaseSensitive deriving (Eq, Show) + +data Cond = And Cond Cond + | Or Cond Cond + | Not Cond + | Always + | Never + | CheckMatch String + | CheckHeader String + | CheckBody String deriving (Eq, Show) + +data Act = File String + | Fwd [EmailAddress] + | Filter String + | Nest [CExp] deriving Show + +--type Rule = Cond -> Act -> m CExp +--type Rule = Cond -> Act -> CExp +--data RuleM a = RuleM a + +--------------------------------------------------------------------------- +-- Basic functions for manipulating conditions and creating Rules + +(.&&.) :: Cond -> Cond -> Cond +c1 .&&. c2 = And c1 c2 + +(.||.) :: Cond -> Cond -> Cond +c1 .||. c2 = Or c1 c2 + +subject, body, said :: String -> Cond +subject s = CheckHeader ("^Subject.*"++s) +body s = CheckBody s +said s = subject s .||. body s + +from, to, to_ :: EmailAddress -> Cond +from (Addr s) = CheckHeader ("^From.*"++s) +to (Addr s) = CheckHeader ("^TO"++s) +to_ (Addr s) = CheckHeader ("^TO_"++s) + +when :: Cond -> Act -> Writer [CExp] () +when c a = whenWithOptions [lock] c a + +whenWithOptions :: [Flag] -> Cond -> Act -> Writer [CExp] () +whenWithOptions fs c a = tell [CExp fs c a] + +placeIn :: Mailbox -> Act +placeIn (Mailbox m) = File m + +also :: Act -> Act -> Act +also (Nest as) (Nest bs) = Nest (flagAllButLast Copy (as++bs)) +also (Nest as) b = Nest (flagAllButLast Copy + (as++(execWriter $ + whenWithOptions [] Always b))) +also a (Nest bs) = Nest (flagAllButLast Copy + ((execWriter + (whenWithOptions [] Always a))++bs)) +also a b = Nest (flagAllButLast Copy + ((execWriter $ whenWithOptions [] Always a)++ + (execWriter $ whenWithOptions [] Always b))) + +flagAllButLast :: Flag -> [CExp] -> [CExp] +flagAllButLast _ [] = [] +flagAllButLast f cs = (map (addFlag f) (init cs))++[removeFlag f (last cs)] + +addFlag :: Flag -> CExp -> CExp +addFlag f (CExp fs a c) = (CExp (f:fs) a c) + +removeFlag :: Flag -> CExp -> CExp +removeFlag f (CExp fs a c) = (CExp (filter (/= f) fs) a c) + +forwardTo :: [EmailAddress] -> Act +forwardTo es = Fwd es + +isSpam :: Cond +isSpam = CheckHeader ("^x-spam-status: yes") .||. + CheckHeader ("^x-spam-flag: yes") + +spamLevel :: Int -> Cond +spamLevel n = CheckHeader ("^x-spam-Level: "++(concat (replicate n "\\*"))) + +-------------------------------------------------------------------------- +-- Match monad is just the identity monad, this makes it so that the user +-- cannot use match arbitrarily. Used a monad instead of just a data +-- wrapper because now we can use the monad utilities like liftM + +data Match a = Match a + +instance Monad Match where + return = Match + (>>=) (Match a) f = (f a) + +match :: Match String +match = return "$MATCH" + +whenMatch :: Match Cond -> Match Act -> Writer [CExp] () +whenMatch mc ma = whenMatchWithOptions [lock] mc ma + +whenMatchWithOptions :: [Flag] -> Match Cond -> Match Act -> Writer [CExp] () +whenMatchWithOptions fs (Match c) (Match a) = tell [CExp fs c a] + +placeInUsingMatch :: Match Mailbox -> Match Act +placeInUsingMatch = liftM placeIn + +(%) :: Cond -> String -> Match Cond +(CheckHeader s1) % s2 = return (CheckHeader (s1++"\\/"++s2)) +(CheckBody s1) % s2 = return (CheckBody (s1++"\\/"++s2)) +(CheckMatch s1) % s2 = return (CheckMatch (s1++"\\/"++s2)) + +refineBy :: Match Cond -> Match Cond -> Match Cond +refineBy = liftM2 (.&&.) + +alsoUsingMatch :: Match Act -> Match Act -> Match Act +alsoUsingMatch = liftM2 also + +--------------------------------------------------------------------------- +-- A few functions to create short hand for sorting +sortBy :: (a -> Cond) -> a -> Mailbox -> Writer [CExp] () +sortBy f s m = when (f s) (placeIn m) + +sortByTo_, sortByTo, sortByFrom :: EmailAddress -> Mailbox -> Writer [CExp] () +sortByTo_ = sortBy to_ +sortByTo = sortBy to +sortByFrom = sortBy from + +sortBySubject :: String -> Mailbox -> Writer [CExp] () +sortBySubject = sortBy subject + +---------------------------------------------------------------------------- +-- Everything below here depends on the values in the Configuration module + +-- | If the email address (the String argument) contains "foo", then place the email into a folder +-- by the name "foo". Actually, the name of the mailbox is created by +-- appending boxPrefix which is defined in the Configuration module. +simpleSortByFrom :: String -> Writer [CExp] () +simpleSortByFrom s = sortByFrom (Addr s) (mailbox s) + +simpleSortByTo_, simpleSortByTo:: String -> Writer [CExp] () +simpleSortByTo s = sortByTo (Addr s) (mailbox s) +simpleSortByTo_ s = sortByTo_ (Addr s) (mailbox s) + +mailbox :: String -> Mailbox +mailbox s = Mailbox (boxPrefix++s) + +mailBoxFromMatch :: Match String -> Match Mailbox +mailBoxFromMatch = liftM mailbox + +lock :: Flag +lock = NeedLock lockDefault + +--------------------------------------------------------------------------- +-- This is the actually "Classifier" implementation. It's not as powerful. +-- Please consider this "syntax" to be experimental. + +type Class = (String, [Cond]) + +type Trigger = (String, Int, Act) + +type Classifier = Writer [CExp] () + +mkTrigger :: Trigger -> Classifier +mkTrigger (s, i, a) = when (CheckHeader + ("^"++(mkHeader s)++(replicate i '*'))) + a + +mkClassifiers :: Class -> Writer [CExp] () +mkClassifiers (s, cs) = more (length cs) s cs + where + more _ _ [] = return () + more n t (x:xs) = (when x $ Nest $ incrementHeader t n) >> + (more n t xs) + +incrementHeader :: String -> Int -> [CExp] +incrementHeader s n = concat + [execWriter (whenMatch ((CheckHeader ("^"++mkHeader s)) % + (replicate n '*')) + updateHeader), + execWriter (when (Not (CheckHeader ("^"++mkHeader s))) + writeHeader)] + where + updateHeader = do { m <- match; + return (Filter ("formail -I\""++mkHeader s++m++"*\"")) } + writeHeader = Filter ("formail -I\""++mkHeader s++"*\"") + +mkHeader :: String -> String +mkHeader s = "X-classifier-"++s++": " + +classify :: [Class] -> [Trigger] -> Writer [CExp] () +classify cs ts = mapM_ mkClassifiers cs >> mapM_ mkTrigger ts + +classifyBy :: (String, Cond) -> Act -> Writer [CExp] () +classifyBy (s, c) a = classify [(s,[c])] [(s, 1, a)] + +classifyByAddress::(EmailAddress -> Cond) -> EmailAddress -> Mailbox -> Writer [CExp] () +classifyByAddress f e@(Addr s) m = classify [(s, [f e])] [(s, 1, placeIn m)] + +classifyByTo_, classifyByTo, classifyByFrom:: EmailAddress -> Mailbox -> Writer [CExp] () +classifyByTo_ = classifyByAddress to_ +classifyByTo = classifyByAddress to +classifyByFrom = classifyByAddress from + +classifyByFromAddr :: String -> String -> Writer [CExp] () +classifyByFromAddr x y = classifyByFrom (Addr x) (mailbox y) + +classifyBySubject :: String -> Mailbox -> Writer [CExp] () +classifyBySubject s m = classify [(s, [subject s])] [(s, 1, placeIn m)] + +simpleClassifyBySubject :: String -> Writer [CExp] () +simpleClassifyBySubject x = classifyBySubject x (mailbox x) + +simpleClassifyByFrom, simpleClassifyByTo_, simpleClassifyByTo::String -> Writer [CExp] () +simpleClassifyByFrom s = classifyByFrom (Addr s) (mailbox s) +simpleClassifyByTo s = classifyByTo (Addr s) (mailbox s) +simpleClassifyByTo_ s = classifyByTo_ (Addr s) (mailbox s) + +defaultRule :: String -> Writer [CExp] () +defaultRule str = when Always $ File str + +-- | If the subject line contains a certain string, send it to a certain mailbox. +subjectToMbox :: String -> String -> Writer [CExp] () +subjectToMbox substr mbox = sortBySubject substr $ mailbox mbox + +-- | As with 'subjectToMbox', except by email address. +addressToMbox :: String -> String -> Writer [CExp] () +addressToMbox addr mbox = sortByFrom (Addr addr) (mailbox mbox) + +-- | 'addressToMbox' is fine, but may not work well for mailing lists. +toAddressToMbox :: String -> String -> Writer [CExp] () +toAddressToMbox addr mbox = sortByTo_ (Addr addr) (mailbox mbox) + +{- | 'stuffToMbox' is a very general filtering statement, which is intended for specialization + by other functions. + + The idea is to take a logical operator and fold it over a list of strings. + If the result is @True@, then the email gets dropped into a specified mailbox. + So if you wanted to insist that only an email which has strings @x@, @y@, and @z@ in + the subject-line could appear in the xyz mailbox, you'd use .&&. as the logical operator, + "xyz" as the @mbox@ argument, [x, y, z] as the list, and a seed value of True. You also need the + 'subject' operator, which will map over the list and turn it into properly typed + stuff. -} +stuffToMbox :: Cond -> (a1 -> a) -> (a -> Cond -> Cond) -> String -> [a1] -> Writer [CExp] () +stuffToMbox seed header operator mbox items = when (foldr (operator) seed $ map header items) + (insertMbox mbox) + +-- | If all the strings appear in the subject line, deposit the email in the specified mailbox +subjectsToMbox :: [String] -> String -> Writer [CExp] () +subjectsToMbox x y = stuffToMbox Always subject (.&&.) y x + +-- | If any of the strings appear in the subject line, send it to the mbox +-- This is currently a bit of a null-op, and I'm not sure it works. +anySubjectsToMbox :: [String] -> String -> Writer [CExp] () +anySubjectsToMbox x y = stuffToMbox Never subject (.||.) y x + +-- subjectsNotToMbox = stuffToMbox Never subject ((.||.) .) "" + +insertMbox :: String -> Act +insertMbox = placeIn . mailbox diff --git a/Autoproc/Configuration.hs b/Autoproc/Configuration.hs new file mode 100644 --- /dev/null +++ b/Autoproc/Configuration.hs @@ -0,0 +1,27 @@ +module Autoproc.Configuration where + +-- Anything which is specific to your system should be changed here. + +boxPrefix :: String +boxPrefix = "INBOX." + +lockDefault :: Bool +lockDefault = True + +-- These variables are used to generate the start of .procmailrc +defaultVariables :: [(String, String)] +defaultVariables = [("SHELL", "/bin/sh"), + ("PATH", "/usr/local/bin:/usr/bin:/bin:$PATH"), + ("DATE", "`date +%m_%d_%Y`"), + ("MAILDIR", "$HOME"), + ("DEFAULT", "$HOME"), + ("PMDIR", "$HOME/.procmail"), + ("DUMMY", "`test -d $PMDIR || mkdir $PMDIR`"), + ("LOGFILE", "$PMDIR/$DATE.log"), + ("LOGABSTRACT", "on"), + ("VERBOSE", "off")] + +showVars :: [(String, String)] -> String +showVars [] = "" +showVars (v:vs) = (fst v) ++ " = " ++ (snd v) ++ "\n" + ++ showVars vs diff --git a/Autoproc/Procmail.hs b/Autoproc/Procmail.hs new file mode 100644 --- /dev/null +++ b/Autoproc/Procmail.hs @@ -0,0 +1,103 @@ +module Autoproc.Procmail where +-- One thing to keep in mind: +-- Procmail seems to "just work" by running regular expressions over the +-- email and doing something. + +-- The goal of this module is to capture the abstract syntax of procmail +-- and to output to the procmail syntax. + +import Data.List (sort) + +data PExp = PExp [RecipeFlag] [Condition] Action + +data RecipeFlag = CheckHeader | CheckBody + | CaseSensitive | Chain + | ElseIf | PipeAsFilter | Copy + | Wait | IgnoreErrors | RawWrite | NeedLock Bool deriving (Eq, Ord) + +data Condition = Condition ConditionFlag String +data ConditionFlag = Normal | Invert | Eval | UseExitCode + | LessThan | GreaterThan | Var String + +{- + + There are two types of actions: + + 1) delivering + 2) non-delivering + + The difference is that a delivering message stops execution of rules + a non-delivering rule feeds a carbon-copy of the message to rule and + then continues on trying rules. + +-} + +data Action = Forward [String] | Pipe String | File String + | Nest [PExp] + +--This is useful when used with the list monad +--to print each element of the list xs on a line by itself use: +-- xs >>= showLn +showLn :: (Show a) => a -> String +showLn = (++ "\n") . show + +instance Show PExp where + show (PExp fs cs a) = ":0"++showFlags fs++"\n" + ++(cs >>= (\x -> if show x == "" then "" + else showLn x)) + ++show a++"\n" + where + showFlags [NeedLock b] = show (NeedLock b) + showFlags hs = " " ++ ((show =<<) . sort) hs + +instance Show RecipeFlag where + show CheckHeader = "H" + show CheckBody = "B" + show CaseSensitive = "D" + show Chain = "A" + show ElseIf = "E" + show PipeAsFilter = "f" + show Copy = "c" + show Wait = "w" + show IgnoreErrors = "i" + show RawWrite = "r" + show (NeedLock True) = ":" + show (NeedLock False) = "" + +instance Show Condition where + show (Condition _ []) = "" + show (Condition cf s) = "* " ++ show cf ++ s + +instance Show ConditionFlag where + show Normal = "" + show Invert = "!" + show Eval = "$" + show UseExitCode = "?" + show LessThan = "<" + show GreaterThan = ">" + show (Var s) = s++" ?? " + +instance Show Action where + show (Nest es) = "{ \n"++(es >>= showLn)++"}" + show (File s) = s + show (Forward es) = "! "++(es >>= (++ " ")) + show (Pipe s) = "| "++s + + +{- +Here is a test case to try: +PExp [] [(Condition Normal "^From.*peter"), (Condition Normal "^Subject:.*compilers")] (Nest [PExp [Copy] [] (Forward "william@somewhere.edu"), PExp [] [] (File "petcompil")]) + +It should generate output equivalent to: +:0 +* ^From.*peter +* ^Subject:.*compilers + { + :0 c + ! william@somewhere.edu + + :0 + petcompil + } + +-} diff --git a/Autoproc/Rules/Dagit.hs b/Autoproc/Rules/Dagit.hs new file mode 100644 --- /dev/null +++ b/Autoproc/Rules/Dagit.hs @@ -0,0 +1,310 @@ +module Autoproc.Rules.Dagit where + +import Autoproc.Classifier + +import Control.Monad.Writer hiding (when) + +{- | Any rules that you create need to end up in the rules list. Other + than that, feel free to define your own rules using these rules an + examples. + + A rule is something of the form: + +> when condition action + +Examples of condition might include: + +> (from (Addr "foo@bar")) +> (subject "Hi again") + +And example actions are things like: + +> (insertMbox "steve")@, @(forward [Addr "friend@yahoo.com"]) + + I have created some aliases for commonly used constructions + For example, @simpleSortByFrom "joe"@, is equivalent to: + +> when (from (Addr "joe")) (insertMbox "joe") + + For a full list of what is possible, check the "Autoproc.Classifier" module. -} +--Rules start here: +dagitRules :: Writer [CExp] () +dagitRules = do spamc; spamcheck; sarah; mom; dad; rogan; lkm; cvsupdates; + cdspaper; bugs; forms3Tech; forms3; euses; darcsUsers; + darcsDevel; sbclDevel; ogi; clispDevel; csGradTalk; + classes; nwn; debian; csmaillist; momentum; fixReplyTo; dagitDefaultRule + +-- | I use this rule to make sure any mail that is not sorted goes into +-- my mail spool. It uses "Autoproc.Classifier"'s 'defaultRule' +dagitDefaultRule :: Writer [CExp] () +dagitDefaultRule = defaultRule "/var/mail/dagit" + +--Friends/Family +-- | If the email address contains "sparish", then place the email into a folder +-- by the name "sparish". Actually, the name of the mailbox is created by +-- appending boxPrefix which is defined in the Configuration module. +sarah :: Writer [CExp] () +sarah = simpleSortByFrom "sparish" + +-- | Similar to 'sarah', except we are sorting based on the subject line, +-- and giving the mailbox. As above, boxPrefix will be added to "nwn". +nwn :: Writer [CExp] () +nwn = subjectToMbox "nwn" "nwn" +-- If the email address contains Griffinmndm then the email is from Mom. +mom :: Writer [CExp] () +mom = addressToMbox "Griffinmndm" "mom" +dad :: Writer [CExp] () +dad = addressToMbox "naturesgifts" "dad" +rogan :: Writer [CExp] () +rogan = addressToMbox "creswick" "rogan" + +--Mailing lists +lkm :: Writer [CExp] () +lkm = toAddressToMbox "linux-kernel@vger.kernel.org" "linux-kernel" + +-- This is an example of the general syntax. The above examples are converted +-- to an analogous when statement. + +cvsupdates :: Writer [CExp] () +cvsupdates = subjectsToMbox ["\\[forms3-tech\\]", "\\[cvs\\]"] "cvsupdates" + +cdspaper :: Writer [CExp] () +cdspaper = subjectsToMbox ["\\[CDs Paper Update\\]"] "cdpaper" + +bugs :: Writer [CExp] () +bugs = subjectsToMbox ["\\[forms3-tech\\]", "\\[jira\\]"] "bugs" + +forms3Tech :: Writer [CExp] () +forms3Tech = simpleSortByTo_ "forms3-tech" + +forms3 :: Writer [CExp] () +forms3 = simpleSortByTo_ "forms3" + +euses :: Writer [CExp] () +euses = when ((subject "\\[eusesnewsletter\\]") .||. + (to_ (Addr "eusesosugrads")) .||. + (to_ (Addr "eusesall"))) + (insertMbox "euses") + +darcsUsers :: Writer [CExp] () +darcsUsers = simpleSortByTo_ "darcs-users" + +darcsDevel :: Writer [CExp] () +darcsDevel = simpleSortByTo_ "darcs-devel" + +sbclDevel :: Writer [CExp] () +sbclDevel = simpleSortByTo_ "sbcl-devel" + +ogi :: Writer [CExp] () +ogi = subjectToMbox "OGI" "csmaillist" + +clispDevel :: Writer [CExp] () +clispDevel = simpleSortByTo_ "clisp-devel" + +csGradTalk :: Writer [CExp] () +csGradTalk = simpleSortByTo_ "cs-grad-talk" + +-- This rule has a custom header check. It checks the header of the +-- email for a line that begins with "X-Loop: ...". +-- People familiar with regular expressions will recognize the meaning. +-- of ^ and .* +debian :: Writer [CExp] () +debian = when (CheckHeader "^X-Loop: debian.*@lists.debian.org") + (insertMbox "debian") + +csmaillist :: Writer [CExp] () +csmaillist = when (subject "\\[cs-grads\\]" .||. + subject "\\[eecs-grads\\]" .||. + to_ (Addr "eecs-grads")) + (insertMbox "csmaillist") + +--Class lists + +-- This is a rather sophisticated example demonstrating matching. +-- When the % operator is used, the text that matches the regular +-- expression on the right hand side of the %, is stored in the variable +-- match. This requires whenMatch instead of when. +classes :: Writer [CExp] () +classes = whenMatch (((to_ (Addr "class-")) % ".*@") `refineBy` + ((CheckMatch "()") % "[^@]+")) + (placeInUsingMatch (mailBoxFromMatch match)) + +-- Example showing that usage of match is checked using the type +-- system. In this example match would not have a value because the +-- operator % has not been used in the condition. +--test = when (to_ (Addr "test")) +-- (placeInUsingMatch (mailbox match)) + +--spam rules +-- | A filter is a special action that transforms the email for +-- the benefit of future rules. This particular rule, +-- hands the email off to spam assassin so that it can be checked for +-- signs of spam. +spamc :: Writer [CExp] () +spamc = when Always (Filter "/usr/local/bin/spamc") + +-- isSpam and spamLevel are special conditions for use with SpamAssassin. +spamcheck :: Writer [CExp] () +spamcheck = when (isSpam .||. + (spamLevel 3) .||. + (from (Addr "nationalmkt@planters.net"))) + (insertMbox "caughtspam") + +momentum :: Writer [CExp] () +momentum = subjectToMbox "momentum!" "caughtspam" + +--Random Examples +-- | An example that demonstrates forwarding an email. +sharing :: Writer [CExp] () +sharing = when (said "caring" .&&. from (Addr "ecards")) + (forwardTo [(Addr "dagit@codersbase.com"), + (Addr "thedagit@hotmail.com")]) + +-- | This rules "fixes" the reply-to header of a mailing list. I don't +-- recommend doing this unless you know what you are doing. +fixReplyTo :: Writer [CExp] () +fixReplyTo = whenMatch (to_ (Addr "") % "osu-free@lists") filter' + where filter' = do m <- match + return $ Filter $ "formail -I\"Reply-To: "++m++"\"" + +-- This example shows that conditions can be inverted. +notTest :: Writer [CExp] () +notTest = when ((Not ((said "caring") .||. + (subject "Hi"))) .&&. + (from (Addr "steve"))) + (insertMbox "notCaring") + +-- | Sometimes we want just one condition, but we have multiple actions. +-- In this case, use the also syntax. It allows multiple action for +-- one rule. +alsoTest :: Writer [CExp] () +alsoTest = when (from (Addr "steve")) + ((insertMbox "steve") `also` + (forwardTo [Addr "steve's boss", Addr "steve's friend"]) `also` + (insertMbox "backup")) + +--End of Rules + + +-- Example Classifiers, not all of the rules have been captured as +-- classifiers + +--Friends/Family +sarah' :: Writer [CExp] () +sarah' = simpleClassifyByFrom "sparish" +nwn' :: Writer [CExp] () +nwn' = simpleClassifyBySubject "nwn" +mom' :: Writer [CExp] () +mom' = classifyByFromAddr "Griffinmndm" "mom" +dad' :: Writer [CExp] () +dad' = classifyByFromAddr "naturesgifts" "dad" +rogan' :: Writer [CExp] () +rogan' = classifyByFromAddr "creswick" "rogan" + +--Mailing lists +lkm' :: Writer [CExp] () +lkm' = classifyByTo_ (Addr "linux-kernel@vger.kernel.org") + (mailbox "linux-kernel") + +--------------------------------------------------------- + +-- TODO: do some refactoring here + +ogi' :: Writer [CExp] () +ogi' = classifyBy ("ogi", + (subject "OGI")) + (insertMbox "csmaillist") + +debian' :: Writer [CExp] () +debian' = classifyBy ("debian", + (CheckHeader "^X-Loop: debian.*@lists.debian.org") ) + (insertMbox "debian") + +--- + +cvsupdates' :: Writer [CExp] () +cvsupdates' = classifyBy ("cvsupdates", + (subject "[forms3-tech]" .&&. + subject "[cvs]")) + (insertMbox "cvsupdates") + +bugs' :: Writer [CExp] () +bugs' = classifyBy ("bugs", + (subject "[forms3-tech]" .&&. + subject "[jira]")) + (insertMbox "bugs") + +csmaillist' :: Writer [CExp] () +csmaillist' = classifyBy ("csmaillist", (subject "[cs-grads]" .||. + subject "[eecs-grads]" .||. + to_ (Addr "eecs-grads"))) + (insertMbox "csmaillist") + +euses' :: Writer [CExp] () +euses' = classifyBy ("euses", ((subject "[eusesnewsletter]") .||. + (to_ (Addr "eusesosugrads")) .||. + (to_ (Addr "eusesall")))) + (insertMbox "euses") + +-------------------------------------------------------------- + + +forms3Tech' :: Writer [CExp] () +forms3Tech' = simpleClassifyByTo_ "forms3-tech" + +forms3' :: Writer [CExp] () +forms3' = simpleClassifyByTo_ "forms3" + +darcsUsers' :: Writer [CExp] () +darcsUsers' = simpleClassifyByTo_ "darcs-users" + +darcsDevel' :: Writer [CExp] () +darcsDevel' = simpleClassifyByTo_ "darcs-devel" + +sbclDevel' :: Writer [CExp] () +sbclDevel' = simpleClassifyByTo_ "sbcl-devel" + +clispDevel' :: Writer [CExp] () +clispDevel' = simpleClassifyByTo_ "clisp-devel" + +csGradTalk' :: Writer [CExp] () +csGradTalk' = simpleClassifyByTo_ "cs-grad-talk" + +momentum' :: Writer [CExp] () +momentum' = classifyBySubject "momentum!" (mailbox "caughtspam") + +orTest :: Writer [CExp] () +orTest = when (subject "1" .||. + subject "2" .&&. + subject "3" .&&. + subject "4" .&&. + subject "5" .&&. + subject "6" .&&. + subject "7" .&&. + subject "8" .&&. + subject "9" .&&. + subject "10" .&&. + subject "11" .&&. + subject "12" .&&. + subject "13" .&&. + subject "14" .&&. + subject "15") + (insertMbox "orTest") + +notOrTest :: Writer [CExp] () +notOrTest = when (Not (subject "1" .||. + subject "2" .&&. + subject "3" .&&. + subject "4" .&&. + subject "5" .&&. + subject "6" .&&. + subject "7" .&&. + subject "8" .&&. + subject "9" .&&. + subject "10" .&&. + subject "11" .&&. + subject "12" .&&. + subject "13" .&&. + subject "14" .&&. + subject "15")) + (insertMbox "notOrTest") diff --git a/Autoproc/Run.hs b/Autoproc/Run.hs new file mode 100644 --- /dev/null +++ b/Autoproc/Run.hs @@ -0,0 +1,27 @@ +module Autoproc.Run where + +import Autoproc.Classifier (CExp) +import Autoproc.Configuration (showVars) +import Autoproc.Procmail (PExp, showLn) +import Autoproc.Transform (generate) + +import Control.Monad.Writer (execWriter, Writer) + +showProcmailrc :: [(String, String)] -> [PExp] -> String +showProcmailrc vars ps = showVars (vars) ++ + "\n\n" ++ + "############################\n\n" ++ + (ps >>= showLn) + +autoprocMessage :: IO () +autoprocMessage = putStr $ unlines ["#.procmailrc", + "# Automatically generated procmail recipes by Autoproc.", + "# To find out more about Autoproc visit:", + "# 'http://www.codersbase.com/Autoproc'", + "# To fetch the latest version of autoproc with Darcs:", + "# 'darcs get http://projects.codersbase.com/repos/autoproc'", + "", + ""] + +autoprocMain :: [(String, String)] -> Writer [CExp] a -> IO () +autoprocMain vars rules = autoprocMessage >> (putStrLn . showProcmailrc vars . concatMap generate $ execWriter rules) diff --git a/Autoproc/Transform.hs b/Autoproc/Transform.hs new file mode 100644 --- /dev/null +++ b/Autoproc/Transform.hs @@ -0,0 +1,134 @@ +module Autoproc.Transform (generate) where + +-- The purpose of this module is to define the transformations from +-- condition expression to procmail representation. + +import qualified Autoproc.Procmail as Pm +import qualified Autoproc.Classifier as Cf + +import Data.List (nub) + +-- This raises the question, Why not use RecipeFlag for CExp? The +-- reason is that we are trying to separate the final representation +-- (procmail) from the condition expression representation. So in the +-- future if CExp flags change, we need only redefine this function. +-- Similar logic applies to Act and Cond. +-- Note: The above reasoning has saved me many times during development. +transformFlag :: Cf.Flag -> Pm.RecipeFlag +transformFlag Cf.Copy = Pm.Copy +transformFlag Cf.Wait = Pm.Wait +transformFlag Cf.IgnoreErrors = Pm.IgnoreErrors +transformFlag (Cf.NeedLock b) = (Pm.NeedLock b) +transformFlag Cf.Chain = Pm.Chain +transformFlag Cf.CaseSensitive = Pm.CaseSensitive + +transformCond :: Cf.Cond -> [Pm.Condition] +transformCond (Cf.Or _ _) = error "transformCond cannot handle Or." +transformCond (Cf.And c1 c2) = transformCond c1 ++ transformCond c2 +transformCond (Cf.Not c) = [Pm.Condition Pm.Invert c'] + where [Pm.Condition _ c'] = transformCond c +transformCond Cf.Always = [Pm.Condition Pm.Normal []] +transformCond (Cf.CheckHeader s) = [Pm.Condition Pm.Normal s] +transformCond (Cf.CheckBody s) = [Pm.Condition Pm.Normal s] +transformCond (Cf.CheckMatch s) = [Pm.Condition (Pm.Var "$MATCH") s] + +transformAct :: Cf.Act -> Pm.Action +transformAct (Cf.File s) = Pm.File s +transformAct (Cf.Filter s) = Pm.Pipe s +transformAct (Cf.Fwd es) = Pm.Forward (map unAddress es) + where unAddress (Cf.Addr a) = a +transformAct (Cf.Nest as) = Pm.Nest (map transform as) + +-- This pushes "not" as far down as possible. +-- This helps us to reach a "normal" form +distributeNot :: Cf.Cond -> Cf.Cond +distributeNot (Cf.Not (Cf.And c1 c2)) = Cf.Or (distributeNot (Cf.Not c1)) + (distributeNot (Cf.Not c2)) +distributeNot (Cf.Not (Cf.Or c1 c2)) = Cf.And (distributeNot (Cf.Not c1)) + (distributeNot (Cf.Not c2)) +distributeNot (Cf.Not (Cf.Not c)) = distributeNot c +distributeNot (Cf.And c1 c2) = Cf.And (distributeNot c1) + (distributeNot c2) +distributeNot (Cf.Or c1 c2) = Cf.Or (distributeNot c1) + (distributeNot c2) +distributeNot c = c + +-- Each call to factor moves the Or one step closer to the top. This must +-- be called many times by repeated to reach a normal form. +-- The goal here is to pull Or to the outside. +-- We don't worry about not, because that should have been handled by +-- distributeNot already. +factor :: Cf.Cond -> Cf.Cond +factor (Cf.And (Cf.Or c1 c2) c3) = (Cf.Or (Cf.And (factor c1) (factor c3)) + (Cf.And (factor c2) (factor c3))) +factor (Cf.And c1 (Cf.Or c2 c3)) = (Cf.Or (Cf.And (factor c1) (factor c2)) + (Cf.And (factor c1) (factor c3))) +factor (Cf.Or c1 c2) = (Cf.Or (factor c1) (factor c2)) +factor (Cf.And c1 c2) = (Cf.And (factor c1) (factor c2)) +factor c = c + +repeated :: (Cf.Cond -> Cf.Cond) -> Cf.Cond -> Cf.Cond +repeated t c = loop c + where loop c' = if c' == (t c') then c' + else repeated t (t c') + +-- Procmail does not have a notion of Or, so we must put the +-- conditions at the same level and repeat the action. This way, when +-- one of the conditions becomes true, the action is performed. +reduceOr :: Cf.CExp -> [Cf.CExp] +reduceOr (Cf.CExp fs (Cf.Or c1 c2) a) = (reduceOr (Cf.CExp fs c1 a)) ++ + (reduceOr (Cf.CExp fs c2 a)) +reduceOr x = [x] + +-- 1. distrubuteNot +-- 2. factor +-- 3. reduceOr +-- The result is a list of CExp, none of which have an Or in their conditions +-- and not is only used on individual conditions +simplify :: Cf.CExp -> [Cf.CExp] +simplify (Cf.CExp fs c a) = reduceOr (Cf.CExp fs c'' a) + where + c' = repeated distributeNot c + c'' = repeated factor c' + +-- This function assumses a simplified CExp, hence the first pattern match. +transform :: Cf.CExp -> Pm.PExp +transform (Cf.CExp _ (Cf.Or _ _) _) = error "use simplify." +transform (Cf.CExp fs c a) = Pm.PExp (nub fs') (transformCond c) + (transformAct a) + where + fs' = (if any' then [Pm.CheckHeader,Pm.CheckBody] else + if body then [Pm.CheckBody] else + if header then [Pm.CheckHeader] else [])++newFlags + body = checksBody c + header = checksHeader c + any' = checksAny c + newFlags = (if isFilter a then [Pm.Wait, Pm.PipeAsFilter] else [])++ + (map transformFlag fs) + +isFilter :: Cf.Act -> Bool +isFilter (Cf.Filter _) = True +isFilter _ = False + +checksHeader :: Cf.Cond -> Bool +checksHeader (Cf.And c1 c2) = checksHeader c1 || checksHeader c2 +checksHeader (Cf.Or c1 c2) = checksHeader c1 || checksHeader c2 +checksHeader (Cf.Not c) = checksHeader c +checksHeader (Cf.CheckHeader _) = True +checksHeader _ = False + +checksBody :: Cf.Cond -> Bool +checksBody (Cf.And c1 c2) = checksBody c1 || checksBody c2 +checksBody (Cf.Or c1 c2) = checksBody c1 || checksBody c2 +checksBody (Cf.Not c) = checksBody c +checksBody (Cf.CheckBody _) = True +checksBody _ = False + +-- Perhaps checksEither is a better name? +checksAny :: Cf.Cond -> Bool +checksAny c = checksHeader c && checksBody c + +-- This is how to generate a procmail recipe from a single expression +-- in the condition expression language. +generate :: Cf.CExp -> [Pm.PExp] +generate c = map transform (simplify c) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,93 @@ +module Main (main) where + +import Autoproc.Configuration (defaultVariables) +import Autoproc.Run (autoprocMain) +import Autoproc.Rules.Dagit (dagitRules) + +import Prelude hiding (catch) +import System.IO (openFile, IOMode(WriteMode), hClose) +import System.Posix.Process (executeFile, forkProcess, createSession, getProcessStatus) +import System.Process (runProcess, waitForProcess) +import System.Directory (getAppUserDataDirectory, getModificationTime) +import Control.Monad.Trans (liftIO, MonadIO) +import Control.Exception (bracket, catch) +import Control.Monad (when) +import System.Exit (ExitCode(..), exitWith) +import Control.Applicative ((<$>)) + +-- | The entry point into autoproc. Attempts to compile @~/.autoproc/autoproc.hs@ +-- for autoproc, and if it doesn't find one, just compiles the default. +-- This code and method is totally stolen from XMonad. Thanks guys! +main :: IO () +main = catch (buildLaunch) (\_ -> autoprocMain defaultVariables dagitRules) + +-- | Build "~/.autoproc/autoproc.hs" with GHC, then execute it. If there are no +-- errors, this function does not return. An exception is raised in any of +-- these cases: +-- * ghc missing +-- * ~/.autoproc/autoproc.hs missing +-- * autoproc.hs fails to compile +-- ** wrong ghc in path (fails to compile) +-- ** type error, syntax error, .. +-- * Missing autoproc/AutoprocContrib modules due to ghc upgrade +-- +buildLaunch :: IO () +buildLaunch = do + recompile True + dir <- getAutoprocDir + executeFile (dir ++ "/autoproc") False [] Nothing + return () + +-- | Return the path to @~\/.autoproc@. +getAutoprocDir :: MonadIO m => m String +getAutoprocDir = liftIO $ getAppUserDataDirectory "autoproc" + +-- | 'recompile force', recompile @~\/.autoproc\/autoproc.hs@ when any of the +-- following apply: +-- * force is True +-- * the autoproc executable does not exist +-- * the autoproc executable is older than autoproc.hs +-- +-- The -i flag is used to restrict recompilation to the autoproc.hs file only. +-- +-- Compilation errors (if any) are logged to ~\/.autoproc\/autoproc.errors. If +-- GHC indicates failure with a non-zero exit code, an xmessage displaying +-- that file is spawned. +-- +-- False is returned if there are compilation errors. +recompile :: MonadIO m => Bool -> m Bool +recompile force = liftIO $ do + dir <- getAutoprocDir + let binn = "autoproc" + bin = dir ++ "/" ++ binn + base = dir ++ "/" ++ "autoproc" + err = base ++ ".errors" + src = base ++ ".hs" + srcT <- getModTime src + binT <- getModTime bin + if (force || srcT > binT) + then do + status <- bracket (openFile err WriteMode) hClose $ \h -> do + waitForProcess =<< runProcess "ghc" ["--make", "autoproc.hs", "-i", "-no-recomp", "-v0", "-o",binn] (Just dir) + Nothing Nothing Nothing (Just h) + + -- now, if it fails, run xmessage to let the user know: + when (status /= ExitSuccess) $ do + ghcErr <- readFile err + let msg = unlines $ + ["Error detected while loading autoproc configuration file: " ++ src] + ++ lines ghcErr ++ ["","Please check the file for errors."] + doubleFork $ executeFile "xmessage" True ["-default", "okay", msg] Nothing + return (status == ExitSuccess) + else return True + where getModTime f = catch (Just <$> getModificationTime f) (const $ return Nothing) + +-- | Double fork and execute an IO action (usually one of the exec family of +-- functions) +doubleFork :: MonadIO m => IO () -> m () +doubleFork m = liftIO $ do + pid <- forkProcess $ do + forkProcess (createSession >> m) + exitWith ExitSuccess + getProcessStatus True False pid + return () diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,63 @@ += Autoproc = + +Autoproc is a utility/language for email filtering. Autoproc makes it +easy to define filtering rules. The rules define a Haskell program, +that when executed generates a valid Procmail recipes file. This file +can then be used with Procmail to sort and filter your email before +you see it. + +You will need to have GHC or Hugs, Procmail and formail installed. + +== Installation == + +To get a copy of Autoproc, use + + darcs get http://projects.codersbase.com/repos/autoproc + +If you don't have darcs do not despair, currently Autoproc is about 5 +files and can be easily downloaded by pointing your web browser at the +address just given. + +You can also visit Hackage, where you should be able to find a tarball of autoproc (or eventually you could install Autoproc through cabal-install). + +== Customizing Autoproc == + +Autoproc runs on the XMonad model. If you aren't familiar with XMonad, the idea is that the package is constructed such that it provides a library, and then it compiles a thin executable using that library. + +This is fine if the baked in configuration exactly suits your needs, but how do you have a system-wide XMonad which you can configure in a full Haskell style without some sort of Emacs-style interpreter? Well, the thin executable is tasked with looking for a xmonad.hs in a fixed location; if it exists, it gets compiled and the *new* binary gets run. And your personal xmonad.hs can do anything it wants - as all of XMonad's functionality is exposed as a library your xmonad.hs can import and modify at will. So your xmonad.hs boils down to 'main = xmonad $ myCrazyFunkyArgs'. + +In Autoproc's case, what you do is create ~/.autoproc/autoproc.hs, and then set things up. (If you don't, Autoproc will use its compiled in configuration, which is surely not what you want.) + +While I was testing this Xmonad-style configuration, I created an autoproc.hs that looks like this: + +> import Autoproc.Configuration (defaultVariables) +> import Autoproc.Run +> import Autoproc.Rules.Dagit + +> main ∷ IO () +> main = do print "foo bar" +> autoprocMain defaultVariables dagitRules + +('defaultVariables' provides the key-values of environmental variables, and 'dagitRules' is all the Procmail filtering rules.) + +Now, this is the same environmental variables and configuration rules used by default, but there's nothing stopping me from taking defaultVariables and replacing it with + +> myVariables = [("SHELL", "/bin/zsh")] + +And I can run arbitrary stuff before and after the rules and variables are compiled down to text - my output will start with "foo bar", as useless a customization as that is... + +== Running Autoproc == + +To run the autoproc binary and save your rules to the file recipes use the +following command: + + $ autoproc > recipes + +If you are familiar with Procmail you may want to examine the file to +see that everything was generated correctly. Once you are confident +that you would like to use this file, you can simply move it to +$HOME/.procmailrc Depending on your system you may need to do +additional configuration to get Procmail itself running. Usually this +is done with a .forward file, or on some systems having a .procmailrc +is enough. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks simpleUserHooks diff --git a/autoproc.cabal b/autoproc.cabal new file mode 100644 --- /dev/null +++ b/autoproc.cabal @@ -0,0 +1,32 @@ +name: autoproc +version: 0.1 +synopsis: EDSL for Procmail scripts +description: Autoproc is a utility which allows you to write an email filterer in an Haskell + EDSL (embedded domain specific language); autoproc will then compile + it down to a Procmail configuration file (.procmailrc). This file can + then be used with Procmail to sort and filter your email before + you see it. +category: System +license: BSD3 +license-file: LICENSE +author: Jason Dagit +maintainer: Jason Dagit +homepage: http://projects.codersbase.com/repos/autoproc + +build-type: Simple +Cabal-Version: >= 1.2 +tested-with: GHC==6.8.2 + +data-files: README + +Library + exposed-modules: Autoproc.Classifier, Autoproc.Configuration, Autoproc.Run, + Autoproc.Procmail, Autoproc.Rules.Dagit, Autoproc.Transform + + build-depends: base>3, mtl, unix, directory, process + + ghc-options: -Wall -optl-Wl,-s + ghc-prof-options: -prof -auto-all + +Executable autoproc + main-is: Main.hs