module Autoproc.Classifier where
import Control.Monad.Writer hiding (when)
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
(.&&.) :: 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 "\\*")))
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
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
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
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
subjectToMbox :: String -> String -> Writer [CExp] ()
subjectToMbox substr mbox = sortBySubject substr $ mailbox mbox
addressToMbox :: String -> String -> Writer [CExp] ()
addressToMbox addr mbox = sortByFrom (Addr addr) (mailbox mbox)
toAddressToMbox :: String -> String -> Writer [CExp] ()
toAddressToMbox addr mbox = sortByTo_ (Addr addr) (mailbox mbox)
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)
subjectsToMbox :: [String] -> String -> Writer [CExp] ()
subjectsToMbox x y = stuffToMbox Always subject (.&&.) y x
anySubjectsToMbox :: [String] -> String -> Writer [CExp] ()
anySubjectsToMbox x y = stuffToMbox Never subject (.||.) y x
insertMbox :: String -> Act
insertMbox = placeIn . mailbox