packages feed

rpf (empty) → 0.2.0

raw patch · 26 files changed

+1648/−0 lines, 26 filesdep +appardep +basedep +bytestringsetup-changed

Dependencies added: appar, base, bytestring, c10k, containers, dns, domain-auth, hdaemonize, hslogger, iproute, parsec

Files

+ Config.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE TypeSynonymInstances #-}++module Config (Option(..), getOption, defaultOption) where++import Data.List (isPrefixOf)+import Parsec++----------------------------------------------------------------++defaultOption :: Option+defaultOption = Option {+    opt_addr = "127.0.0.1"+  , opt_port = 10025+  , opt_reject_plus_all = True+  , opt_minimum_ipv4_mask_length = 24+  , opt_minimum_ipv6_mask_length = 48+  , opt_include_redirect_limit = 10+  , opt_syslog_facility = "local4"+  , opt_log_level = "info"+  , opt_logonly = False+  , opt_debug_mode = False+  , opt_prefork_process_number = 20+  , opt_thread_number_per_process = 500+  , opt_sleep_timer = 2+  , opt_user = "nobody"+  , opt_group = "nobody"+  , opt_pid_file = "/var/run/rpf.pid"+  }++data Option = Option {+    opt_addr :: String+  , opt_port :: Int+  , opt_reject_plus_all :: Bool+  , opt_minimum_ipv4_mask_length :: Int+  , opt_minimum_ipv6_mask_length :: Int+  , opt_include_redirect_limit :: Int+  , opt_syslog_facility :: String+  , opt_log_level :: String+  , opt_logonly :: Bool+  , opt_debug_mode :: Bool+  , opt_prefork_process_number :: Int+  , opt_thread_number_per_process :: Int+  , opt_sleep_timer :: Int+  , opt_user :: String+  , opt_group :: String+  , opt_pid_file :: String+  } deriving Show++----------------------------------------------------------------++getOption :: String -> Option+getOption = makeOpt defaultOption . parseConfig++----------------------------------------------------------------++makeOpt :: Option -> [Conf] -> Option+makeOpt def conf = Option {+    opt_addr = get "Address" opt_addr+  , opt_port = get "Port" opt_port+  , opt_reject_plus_all = get "Reject_Plus_All" opt_reject_plus_all+  , opt_minimum_ipv4_mask_length = get "Minimum_IPv4_Mask_Length" opt_minimum_ipv4_mask_length+  , opt_minimum_ipv6_mask_length = get "Minimum_IPv6_Mask_Length" opt_minimum_ipv6_mask_length+  , opt_include_redirect_limit = get "Include_Redirect_Limit" opt_include_redirect_limit+  , opt_syslog_facility = get "Syslog_Facility" opt_syslog_facility+  , opt_log_level = get "Log_Level" opt_log_level+  , opt_logonly = get "Logonly" opt_logonly+  , opt_debug_mode = get "Debug" opt_debug_mode+  , opt_prefork_process_number = get "Prefork_Process_Number" opt_prefork_process_number+  , opt_thread_number_per_process = get "Thread_Number_Per_Process" opt_thread_number_per_process+  , opt_sleep_timer      = get "Sleep_Timer" opt_sleep_timer+  , opt_user             = get "User" opt_user+  , opt_group            = get "Group" opt_group+  , opt_pid_file         = get "Pid_File" opt_pid_file+  }+    where+      get key func = maybe (func def) fromConf $ lookup key conf++----------------------------------------------------------------++type Conf = (String, ConfValue)++data ConfValue = CV_Int Int | CV_Bool Bool | CV_String String deriving Show++class FromConf a where+    fromConf :: ConfValue -> a++instance FromConf Int where+    fromConf (CV_Int n) = n+    fromConf _ = error "fromConf int"++instance FromConf Bool where+    fromConf (CV_Bool b) = b+    fromConf _ = error "fromConf bool"++instance FromConf String where+    fromConf (CV_String s) = s+    fromConf _ = error "fromConf string"++----------------------------------------------------------------++parseConfig :: String -> [Conf]+parseConfig cs = map parseConf css+    where+      css = filter (not.isPrefixOf "#") . lines $ cs+      parseConf xs = case parse config "config" xs of+                       Right cnf -> cnf+                       Left  err -> error $ show err++----------------------------------------------------------------++config :: Parser Conf+config = (,) <$> name <*> (spaces >> char ':' >> spaces *> value)++name :: Parser String+name = many1.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"++value :: Parser ConfValue+value = choice [try cv_int, try cv_bool, cv_string]++cv_int :: Parser ConfValue+cv_int = CV_Int . read <$> (many1 digit <* (spaces >> eof))++cv_bool :: Parser ConfValue+cv_bool = CV_Bool True  <$ (string "Yes" >> spaces >> eof) <|>+          CV_Bool False <$ (string "No"  >> spaces >> eof)++cv_string :: Parser ConfValue+cv_string = CV_String <$> many1 (noneOf " \t\n")
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2009, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++  * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.+  * 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.+  * Neither the name of the copyright holders nor the names of its+    contributors may be used to endorse or promote products derived+    from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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+COPYRIGHT OWNER 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.
+ LogMsg.hs view
@@ -0,0 +1,85 @@+module LogMsg (initLog,+               FacilityString, LevelString, LogSystem(..),+               errorMsg, warnMsg, noticeMsg,+               infoMsg, debugMsg) where++import Data.Maybe+import System.Log.Logger+import System.Log.Handler.Syslog++errorMsg :: String -> IO ()+errorMsg = errorM rootLoggerName++warnMsg :: String -> IO ()+warnMsg = warningM rootLoggerName++noticeMsg :: String -> IO ()+noticeMsg = noticeM rootLoggerName++infoMsg :: String -> IO ()+infoMsg = infoM rootLoggerName++debugMsg :: String -> IO ()+debugMsg = debugM rootLoggerName++type FacilityString = String+type LevelString = String++data LogSystem = StdErr | SysLog++initLog :: String+        -> FacilityString+        -> LevelString+        -> LogSystem+        -> IO ()++initLog name fcl lvl SysLog = do+    let level = toLevel lvl+        facility = toFacility fcl+    s <- openlog name [PID] facility level+    updateGlobalLogger rootLoggerName (setLevel level . setHandlers [s])+initLog _ _ lvl StdErr = do+    let level = toLevel lvl+    updateGlobalLogger rootLoggerName (setLevel level)++toLevel :: String -> Priority+toLevel str = fromMaybe (error $ "Unknown level " ++ show str) (lookup str levelDB)++toFacility :: String -> Facility+toFacility str = fromMaybe (error $ "Unknown facility " ++ show str) (lookup str facilityDB)++levelDB :: [(String, Priority)]+levelDB = [+    ("debug",DEBUG)+  , ("info",INFO)+  , ("notice",NOTICE)+  , ("warning",WARNING)+  , ("error",ERROR)+  , ("critical",CRITICAL)+  , ("alert",ALERT)+  , ("emergency",EMERGENCY)+  ]++facilityDB :: [(String, Facility)]+facilityDB = [+    ("kern",KERN)+  , ("use",USER)+  , ("mail",MAIL)+  , ("daemon",DAEMON)+  , ("auth",AUTH)+  , ("syslog",SYSLOG)+  , ("lpr",LPR)+  , ("news",NEWS)+  , ("uucp",UUCP)+  , ("cron",CRON)+  , ("authpriv",AUTHPRIV)+  , ("ftp",FTP)+  , ("local0",LOCAL0)+  , ("local1",LOCAL1)+  , ("local2",LOCAL2)+  , ("local3",LOCAL3)+  , ("local4",LOCAL4)+  , ("local5",LOCAL5)+  , ("local6",LOCAL6)+  , ("local7",LOCAL7)+  ]
+ MailSpec.hs view
@@ -0,0 +1,56 @@+module MailSpec where++import Data.IP+import Network.DNS.Types (Domain)+import Network.DomainAuth++----------------------------------------------------------------++data MailSpec = MailSpec {+    msPeerIP         :: IP           -- #ip+  , msMailFrom       :: Maybe Domain -- #mail_from+  , msFrom           :: Maybe Domain -- #from+  , msPRA            :: Maybe Domain -- #pra+  , msDKIMFrom       :: Maybe Domain -- #dkim_from+  , msDKFrom         :: Maybe Domain -- #domainkeys_from+  , msSPFResult      :: DAResult     -- #spf+  , msSenderIDResult :: DAResult     -- #sender_id+  , msDKIMResult     :: DAResult     -- #dkim+  , msDKResult       :: DAResult     -- #domainkeys+  , msADSPResult     :: DAResult     -- #adsp+  , msSigDKIM        :: Bool         -- #sig_dkim+  , msSigDK          :: Bool         -- #sig_domainkeys+  }++instance Show MailSpec where+    show ms = "{#ip=" ++ show (msPeerIP ms)+           ++ ",#mail_from=" ++ show (msMailFrom ms)+           ++ ",#from=" ++ show (msFrom ms)+           ++ ",#pra=" ++ show (msPRA ms)+           ++ ",#dkim_from=" ++ show (msDKIMFrom ms)+           ++ ",#domainkeys_from=" ++ show (msDKFrom ms)+           ++ ",#spf=" ++ show (msSPFResult ms)+           ++ ",#sender_id=" ++ show (msSenderIDResult ms)+           ++ ",#dkim=" ++ show (msDKIMResult ms)+           ++ ",#domainkeys=" ++ show (msDKResult ms)+--           ++ ",#adsp=" ++ show (msADSPResult ms)+           ++ ",#sig_dkim=" ++ show (msSigDKIM ms)+           ++ ",#sig_domainkyes=" ++ show (msSigDK ms)+           ++ "}"++initialMailSpec :: MailSpec+initialMailSpec = MailSpec {+    msPeerIP         = IPv4 $ read "127.0.0.1" -- xxx+  , msMailFrom       = Nothing+  , msFrom           = Nothing+  , msPRA            = Nothing+  , msDKIMFrom       = Nothing+  , msDKFrom         = Nothing+  , msSPFResult      = DANone+  , msSenderIDResult = DANone+  , msDKIMResult     = DANone+  , msDKResult       = DANone+  , msADSPResult     = DANone+  , msSigDKIM        = False+  , msSigDK          = False+  }
+ Main.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE BangPatterns#-}++module Main where++import Config+import Control.Monad+import Data.IORef+import LogMsg+import Milter+import Network.C10kServer+import Network.DNS+import Network.DomainAuth+import Network.TCPInfo+import RPF+import System.Environment+import System.Exit+import System.IO+import System.Posix.Daemonize (daemonize)++progName :: String+progName = "rpf 0.2.0"++----------------------------------------------------------------++main :: IO ()+main = do+    resSeed <- makeResolvSeed defaultResolvConf+    conf <- readFile =<< fileName 0+    polf <- readFile =<< fileName 1+    let !opt        = getOption conf+        !plcy       = parsePolicy polf+        !c10kConfig = toC10kConfig opt+        !lim        = toLimit opt+        !env        = toEnv opt plcy+        !prog       = milterWapper resSeed lim env+    if opt_debug_mode opt+       then runC10kServerH prog c10kConfig+       else daemonize $ runC10kServerH prog c10kConfig+  where+    fileName n = do+        args <- getArgs+        when (length args /= 2) $ do+            hPutStrLn stderr "Usage: rpf config_file policy_file"+            exitFailure+        return $ args !! n++milterWapper :: ResolvSeed -> Limit -> Env -> Handle -> TCPInfo -> IO ()+milterWapper rs lim env hdl _ = do+    hSetBuffering hdl NoBuffering+    st <- newIORef initialState+    withResolver rs $ \resolver -> do+        let env' = env {+                spf  = runSPF lim resolver+              , dk   = runDK' resolver+              , dkim = runDKIM' resolver+              }+        milter env' hdl st++----------------------------------------------------------------++toC10kConfig :: Option -> C10kConfig+toC10kConfig opt = C10kConfig {+    initHook = makeInitHook opt+  , exitHook = makeExitHook+  , parentStartedHook = makeParentHook+  , startedHook = makeStartedHook opt+  , sleepTimer = opt_sleep_timer opt+  , preforkProcessNumber = opt_prefork_process_number opt+  , threadNumberPerProcess = opt_thread_number_per_process opt+  , portName = show $ opt_port opt+  , ipAddr = Just $ opt_addr opt+  , pidFile = opt_pid_file opt+  , user = opt_user opt+  , group = opt_group opt+}++makeInitHook :: Option -> IO ()+makeInitHook opt =+  if opt_debug_mode opt+  then initLog progName "" (opt_log_level opt) StdErr+  else initLog progName (opt_syslog_facility opt) (opt_log_level opt) SysLog++makeExitHook :: String -> IO ()+makeExitHook = errorMsg++makeParentHook :: IO ()+makeParentHook = infoMsg $ progName ++ " started"++makeStartedHook :: Option -> IO ()+makeStartedHook opt =+  if opt_debug_mode opt+  then initLog progName "" (opt_log_level opt) StdErr+  else initLog progName (opt_syslog_facility opt) (opt_log_level opt) SysLog++----------------------------------------------------------------++toLimit :: Option -> Limit+toLimit opt = Limit {+    limit = opt_include_redirect_limit opt+  , ipv4_masklen = opt_minimum_ipv4_mask_length opt+  , ipv6_masklen = opt_minimum_ipv6_mask_length opt+  , reject_plus_all = opt_reject_plus_all opt+  }++toEnv :: Option -> Policy -> Env+toEnv opt plcy = defaultEnv {+    policy  = plcy+  , logonly = opt_logonly opt+  , debug   = opt_debug_mode opt+  , errorHook   = warnMsg+  , resultHook  = noticeMsg+  , monitorHook = infoMsg+  , debugHook   = debugMsg+  }
+ Milter.hs view
@@ -0,0 +1,9 @@+module Milter (+    Env(..), defaultEnv+  , initialState+  , milter+  ) where++import Milter.Env+import Milter.Types+import Milter.Switch
+ Milter/Base.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}++module Milter.Base (+    Packet (..)+  , getPacket+  , getIP+  , getKeyVal+  , getBody+  , negoticate+  , accept, discard, hold, reject, continue+  ) where++import Control.Applicative+import Control.Monad+import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Char8 as L hiding (ByteString)+import Data.Char+import Data.IP+import Data.List (foldl')+import System.IO++----------------------------------------------------------------++accept :: Handle -> IO ()+accept hdl   = safePutPacket hdl $ Packet 'a' ""++discard :: Handle -> IO ()+discard hdl  = safePutPacket hdl $ Packet 'd' ""++hold :: Handle -> IO ()+hold hdl     = safePutPacket hdl $ Packet 't' ""++reject :: Handle -> IO ()+reject hdl   = safePutPacket hdl $ Packet 'r' ""++continue :: Handle -> IO ()+continue hdl = safePutPacket hdl $ Packet 'c' ""++----------------------------------------------------------------++data Packet = Packet Char ByteString++getPacket :: Handle -> IO Packet+getPacket hdl = do+    n <- fourBytesToInt <$> getNByte hdl 4+    Packet <$> getCmd hdl <*> getNByte hdl (n - 1)++putPacket :: Handle -> Packet -> IO ()+putPacket hdl (Packet c bs) = do+    let len = fromIntegral (L.length bs) + 1+    L.hPut hdl $ intToFourBytes len+    L.hPut hdl $ c `L.cons` bs++safePutPacket :: Handle -> Packet -> IO ()+safePutPacket hdl pkt = withOpenedHandleDo hdl $ putPacket hdl pkt++withOpenedHandleDo :: Handle -> IO () -> IO ()+withOpenedHandleDo hdl block = do+  closed <- hIsClosed hdl+  unless closed block++----------------------------------------------------------------++getKeyVal :: ByteString -> (ByteString, ByteString)+getKeyVal bs = (key,val)+  where+    kv = L.split '\0' bs+    key = kv !! 0+    val = kv !! 1++----------------------------------------------------------------++getBody :: ByteString -> ByteString+getBody = L.init -- removing the last '\0'++----------------------------------------------------------------++getIP :: ByteString -> IP+getIP bs+  | fam == '4' = IPv4 . read $ adr+  | otherwise  = IPv6 . read $ adr+  where+    ip  = L.split '\0' bs !! 1+    fam = L.head ip+    adr = L.unpack $ L.drop 3 ip++----------------------------------------------------------------++negoticate :: Handle -> IO ()+negoticate hdl =  putPacket hdl negoPkt -- do NOT use safePutPacket++negoPkt :: Packet+negoPkt = Packet 'O' $ ver +++ act +++ pro+  where+    ver = intToFourBytes 2 -- Sendmail 8.13.8, sigh+    act = intToFourBytes 0+    pro = intToFourBytes noRcpt++noRcpt :: Int+noRcpt    = 0x8+{- version 2 does not support, sigh+noUnknown = 0x100+noData    = 0x200+-}++----------------------------------------------------------------++getNByte :: Handle -> Int -> IO ByteString+getNByte = L.hGet++getCmd :: Handle -> IO Char+getCmd hdl = L.head <$> L.hGet hdl 1++fourBytesToInt :: ByteString -> Int+fourBytesToInt = foldl' (\a b -> a * 256 + b) 0 . map ord . L.unpack++intToFourBytes :: Int -> ByteString+intToFourBytes = L.pack. reverse . map chr . moddiv 4++moddiv :: Int -> Int -> [Int]+moddiv 0 _ = []+moddiv i m = (m `mod` 256) : moddiv (i - 1) (m `div` 256)++----------------------------------------------------------------++(+++) :: ByteString -> ByteString -> ByteString+(+++) = L.append
+ Milter/Env.hs view
@@ -0,0 +1,33 @@+module Milter.Env where++import Data.IP+import Network.DNS+import Network.DomainAuth+import RPF++data Env = Env {+    policy   :: Policy+  , logonly  :: Bool+  , debug    :: Bool+  , spf      :: Domain -> IP -> IO DAResult+  , dk       :: Mail -> DK -> IO DAResult+  , dkim     :: Mail -> DKIM -> IO DAResult+  , errorHook   :: String -> IO ()+  , resultHook  :: String -> IO ()+  , monitorHook :: String -> IO ()+  , debugHook   :: String -> IO ()+  }++defaultEnv :: Env+defaultEnv = Env {+    policy  = undefined+  , logonly = undefined+  , debug   = undefined+  , spf     = undefined+  , dk      = undefined+  , dkim    = undefined+  , errorHook   = undefined+  , resultHook  = undefined+  , monitorHook = undefined+  , debugHook   = undefined+  }
+ Milter/Log.hs view
@@ -0,0 +1,35 @@+module Milter.Log where++import Control.Applicative+import Data.IORef+import MailSpec+import Milter.Env+import Milter.Types++----------------------------------------------------------------++logError :: Env -> IORef State -> String -> IO ()+logError env st msg = do+    msg' <- addIP st msg+    errorHook env msg'++logResult :: Env -> IORef State -> String -> IO ()+logResult env st msg = do+    msg' <- addIP st msg+    let msg'' = msg' ++ if logonly env then " (log only)" else ""+    resultHook env msg''++logMonitor :: Env -> IORef State -> String -> IO ()+logMonitor env st msg = do+    msg' <- addIP st msg+    monitorHook env msg'++logDebug :: Env -> IORef State -> String -> IO ()+logDebug env st msg = do+    msg' <- addIP st msg+    debugHook env msg'++addIP :: IORef State -> String -> IO String+addIP st msg = do+    ip <- msPeerIP . mailspec <$> readIORef st+    return $ show ip ++ " " ++ msg
+ Milter/Switch.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE OverloadedStrings #-}++module Milter.Switch (milter) where++import Control.Applicative+import Control.Monad+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.IORef+import MailSpec+import Milter.Base+import Milter.Env+import Milter.Log+import Milter.Types+import Network.DomainAuth+import RPF+import System.IO++----------------------------------------------------------------++milter :: Env -> Handle -> IORef State -> IO ()+milter env hdl ref = withValidHandleDo $+    flip catch errorHandle $ do+      rpkt <- getPacket hdl+      switch env hdl ref rpkt+      milter env hdl ref+  where+    errorHandle e = logDebug env ref $ show e+    withValidHandleDo block = do+        closed <- hIsClosed hdl+        eof <- hIsEOF hdl+        unless (eof || closed) block++switch :: Env -> Handle -> IORef State -> Packet -> IO ()+switch env hdl ref (Packet 'O' bs) = open env hdl ref bs+switch env hdl ref (Packet 'C' bs) = conn env hdl ref bs+switch env hdl ref (Packet 'H' bs) = helo env hdl ref bs+switch env hdl ref (Packet 'M' bs) = mfro env hdl ref bs+switch _   hdl _   (Packet 'R' _ ) = continue hdl+switch _   hdl _   (Packet 'A' _ ) = continue hdl -- xxx+switch env hdl ref (Packet 'L' bs) = hedr env hdl ref bs+switch env hdl ref (Packet 'N' bs) = eohd env hdl ref bs+switch env hdl ref (Packet 'B' bs) = body env hdl ref bs+switch env hdl ref (Packet 'E' bs) = eoms env hdl ref bs+switch _   _   _   (Packet 'D'  _) = return ()+switch _   _   _   (Packet 'Q'  _) = return ()+switch env _   ref (Packet x    _) = logError env ref $ "Switch: " ++ [x]++----------------------------------------------------------------++mfilter :: Env -> Handle -> IORef State -> MailSpec -> BlockName -> IO ()+mfilter env hdl ref ms bn =+    let ply = policy env+    in case evalRPF ms ply bn of+         (l,A_Accept)   -> doit accept  "Accepted"  l+         (l,A_Discard)  -> doit discard "Discarded" l+         (l,A_Hold)     -> doit hold    "Held"      l+         (l,A_Reject)   -> doit reject  "Rejected"  l+         (_,A_Continue) -> logMonitor env ref "continue" >> continue hdl+  where+    doit act m l = do+        logResult env ref $ m ++ " in line " ++ show l+        if logonly env+           then accept hdl+           else act hdl++----------------------------------------------------------------++type Filter = Env -> Handle -> IORef State -> ByteString -> IO ()++----------------------------------------------------------------++open :: Filter+open env hdl ref _ = do+    logMonitor env ref "Milter opened:"+    negoticate hdl++----------------------------------------------------------------++conn :: Filter+conn env hdl ref bs = do+    logMonitor env ref "SMTP Connected:"+    st <- readIORef ref+    let ip = getIP bs+        ms = (mailspec st) { msPeerIP = ip }+    writeIORef ref st { mailspec = ms }+    -- after IP set+    logDebug env ref $ '\t' : show ms+    mfilter env hdl ref ms B_Connect++----------------------------------------------------------------++helo :: Filter+helo env hdl ref _ = do+  logMonitor env ref "HELO:"+  continue hdl++----------------------------------------------------------------++mfro :: Filter+mfro env hdl ref bs = do+    logMonitor env ref "MAIL FROM:"+    let jmailfrom = extractDomain bs+    case jmailfrom of+      Nothing -> continue hdl -- xxx+      Just dom  -> do+          st <- readIORef ref+          xspf <- getSPF dom st+          let ms = (mailspec st) { msSPFResult = xspf, msMailFrom = jmailfrom }+          writeIORef ref st { mailspec = ms }+          logDebug env ref $ '\t' : show ms+          mfilter env hdl ref ms B_MailFrom+  where+    getSPF dom st = do+        let ip = msPeerIP (mailspec st)+        spf env dom ip++----------------------------------------------------------------++hedr :: Filter+hedr env hdl ref bs = do+    logMonitor env ref "DATA HEADER FIELD:"+    st <- readIORef ref+    let (key,val) = getKeyVal bs+        ckey = canonicalizeKey key+        xm = pushField key val (xmail st)+        prd = pushPRD key val (prdspec st)+        (pv,ms) = checkField ckey val (parsedv st) (mailspec st)+    writeIORef ref $ st { xmail = xm, mailspec = ms, prdspec = prd, parsedv = pv}+    logDebug env ref $ "\t" ++ show xm ++ "\n\t" ++ show ms ++ "\n\t" ++ show prd+    continue hdl+  where+    checkField ckey val pv ms+      | ckey == dkFieldKey   = case parseDK val of+          Nothing -> (pv, ms)+          x@(Just pdk) -> (pv { mpdk = x},+                           ms { msSigDK = True+                              , msDKFrom = Just (dkDomain pdk) })+      | ckey == dkimFieldKey = case parseDKIM val of+          Nothing -> (pv, ms)+          x@(Just pdkim) -> (pv { mpdkim = x},+                             ms { msSigDKIM = True+                                , msDKIMFrom = Just (dkimDomain pdkim) })+      | otherwise = (pv, ms)++----------------------------------------------------------------++eohd :: Filter+eohd env hdl ref _ = do+    logMonitor env ref "DATA HEADER END:"+    st <- readIORef ref+    let jfrom = getFrom st+        jprd  = decidePRD (prdspec st)+    sid <- getSenderID jprd+    let ms = (mailspec st) { msSenderIDResult = sid, msFrom = jfrom, msPRA = jprd }+    writeIORef ref st { mailspec = ms }+    mfilter env hdl ref ms B_Header+  where+    getFrom = decideFrom . prdspec+    getSenderID jprd =+        case jprd of+          Nothing  -> return DAPermError+          Just dom -> do+              ms <- mailspec <$> readIORef ref+              if jprd == msMailFrom ms+                 then return $ msSPFResult ms+                 else let ip = msPeerIP ms+                      in spf env dom ip++----------------------------------------------------------------++body :: Filter+body env hdl ref bs = do+    logMonitor env ref "DATA BODY:"+    st <- readIORef ref+    let bc = getBody bs+        xm = pushBody bc (xmail st)+    writeIORef ref st { xmail = xm }+    continue hdl++----------------------------------------------------------------++eoms :: Filter+eoms env hdl ref _ = do+  logMonitor env ref "DATA BODY END:"+  st <- readIORef ref+  let mail = finalizeMail (xmail st)+      mdk = mpdk (parsedv st)+      mdkim = mpdkim (parsedv st)+  xdk <- maybe (return DANone) (dk env mail) mdk+  xdkim <- maybe (return DANone) (dkim env mail) mdkim+  let ms = (mailspec st) { msDKResult = xdk, msDKIMResult = xdkim }+  mfilter env hdl ref ms B_Body
+ Milter/Types.hs view
@@ -0,0 +1,34 @@+module Milter.Types where++import MailSpec+import Network.DomainAuth++----------------------------------------------------------------++data State = State {+    xmail    :: XMail+  , mailspec :: MailSpec+  , prdspec  :: PRD+  , parsedv  :: ParsedValue+  } deriving Show++initialState :: State+initialState = State {+    xmail    = initialXMail+  , mailspec = initialMailSpec+  , prdspec  = initialPRD+  , parsedv  = initialParsedValue+  }++----------------------------------------------------------------++data ParsedValue = ParsedValue {+    mpdk   :: Maybe DK+  , mpdkim :: Maybe DKIM+  } deriving Show++initialParsedValue :: ParsedValue+initialParsedValue = ParsedValue {+    mpdk   = Nothing+  , mpdkim = Nothing+  }
+ Parsec.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}++#ifndef MIN_VERSION_parsec+#define MIN_VERSION_parsec(x,y,z) 0+#endif++#if MIN_VERSION_parsec(3,0,0)+module Parsec (+      module Control.Applicative+    , module Text.Parsec+    , module Text.Parsec.String+    ) where++import Control.Applicative hiding (many,optional,(<|>))+import Text.Parsec+import Text.Parsec.String+#else+module Parsec (+      module Text.ParserCombinators.Parsec+    , (<$>), (<$), (<*>), (<*), (*>), pure+    ) where++import Control.Monad (ap, liftM)+import Text.ParserCombinators.Parsec++{-+  GenParser cannot be an instance of Applicative and Alternative+  due to the overlapping instances error, sigh!+-}++(<$>) :: Monad m => (a -> b) -> m a -> m b+(<$>) = liftM++(<$) :: Monad m => a -> m b -> m a+a <$ m = m >> return a++(<*>) :: Monad m => m (a -> b) -> m a -> m b+(<*>) = ap++(*>) :: Monad m => m a -> m b -> m b+(*>) = (>>)++(<*) :: Monad m => m a -> m b -> m a+m1 <* m2 = do x <- m1+              m2+              return x++pure :: Monad m => a -> m a+pure = return++infixl 4 <$>, <$, <*>, <*, *>+#endif
+ README view
@@ -0,0 +1,4 @@+This is RPF version 0.2.0.++Please read:+	 http://www.mew.org/~kazu/proj/rpf/
+ RPF.hs view
@@ -0,0 +1,9 @@+module RPF (+    Policy, parsePolicy+  , Action(..), BlockName(..)+  , evalRPF+  ) where++import RPF.Eval+import RPF.Parser+import RPF.Types
+ RPF/Domain.hs view
@@ -0,0 +1,17 @@+module RPF.Domain where++import Data.Map (Map)+import qualified Data.Map as M hiding (Map)+import Data.Maybe+import Network.DNS.Types (Domain)++type DomainTable = Map Domain Bool++domainMatch :: Domain -> DomainTable -> Bool+domainMatch dom = fromMaybe False . M.lookup dom++makeDomainTable :: [Domain] -> DomainTable+makeDomainTable ds = M.fromList $ zip ds (repeat True)+++
+ RPF/Eval.hs view
@@ -0,0 +1,71 @@+module RPF.Eval (evalRPF) where++import Control.Monad+import Data.List (foldl')+import Data.Maybe+import MailSpec+import RPF.Domain+import RPF.IP+import RPF.Types++----------------------------------------------------------------++evalRPF :: MailSpec -> Policy -> BlockName -> (Pline, Action)+evalRPF ms (Policy bs is ds) bn = evalBlock ms is ds (bs !! fromEnum bn)++----------------------------------------------------------------++evalBlock :: MailSpec -> [IPTable] -> [DomainTable] -> Block -> (Pline, Action)+evalBlock ms is ds (Block _ as) =+    fromJust $ foldl' mplus mzero (map (evalAction ms is ds) as)++----------------------------------------------------------------++evalAction :: MailSpec -> [IPTable] -> [DomainTable] -> ActionCond -> Maybe (Pline, Action)+evalAction _ _ _ (ActionCond l Nothing act) = Just (l, act)+evalAction ms is ds (ActionCond l (Just cnd) act) =+    if evalCnd ms is ds cnd+    then Just (l, act)+    else Nothing++----------------------------------------------------------------++evalCnd :: MailSpec -> [IPTable] -> [DomainTable] -> Cond -> Bool+evalCnd ms is ds (v :== d) = include ms is ds v d+evalCnd ms is ds (v :!= d) = exclude ms is ds v d+evalCnd ms is ds (c1 :&& c2) = evalCnd ms is ds c1 && evalCnd ms is ds c2++----------------------------------------------------------------++include :: MailSpec -> [IPTable] -> [DomainTable] -> Variable -> Constant -> Bool+include ms is _ (DT_IP,  _) (_, CV_Index n) = ipMatch (msPeerIP ms) (is!!n)+include ms _ ds (DT_Dom, vid) (_, CV_Index n) =+    case getDom vid of+      Nothing -> False+      Just dom -> domainMatch dom (ds!!n)+  where+    getDom V_PRA      = msPRA ms+    getDom V_MAILFROM = msMailFrom ms+    getDom V_FROM     = msFrom ms+    getDom V_DKIMFROM = msDKIMFrom ms+    getDom V_DKFROM   = msDKFrom ms+    getDom _          = error "getDom"+include ms _ _ (DT_Res, vid) (_, CV_Result rs) = getRes vid `elem` rs+  where+    getRes V_SPF  = msSPFResult ms+    getRes V_SID  = msSenderIDResult ms+    getRes V_ADSP = msADSPResult ms+    getRes V_DKIM = msDKIMResult ms+    getRes V_DK   = msDKResult ms+    getRes _      = error "getRes"+include ms _ _ (DT_Sig, vid) (_, CV_Sig b) = getSig vid == b+  where+    getSig V_SIGDKIM = msSigDKIM ms+    getSig V_SIGDK   = msSigDK ms+    getSig _         = error "getSig"+include _ _ _ _ _ = error "include"++----------------------------------------------------------------++exclude :: MailSpec -> [IPTable] -> [DomainTable] -> Variable -> Constant -> Bool+exclude a b c d e = not (include a b c d e)
+ RPF/IP.hs view
@@ -0,0 +1,50 @@+module RPF.IP where++import Data.IP+import Data.IP.RouteTable (IPRTable)+import qualified Data.IP.RouteTable as T hiding (IPRTable)+import Data.Maybe++----------------------------------------------------------------++data IPTable = IPTable {+    ipv4table :: IPRTable IPv4 Bool -- Bool is dummy+  , ipv6table :: IPRTable IPv6 Bool -- Bool is dummy+  } deriving (Eq,Show)++----------------------------------------------------------------++ipMatch :: IP -> IPTable -> Bool+ipMatch (IPv4 ip) tbl = fromMaybe False $ T.lookup ir (ipv4table tbl)+  where+    ir = makeAddrRange ip 32+ipMatch (IPv6 ip) tbl = fromMaybe False $ T.lookup ir (ipv6table tbl)+  where+    ir = makeAddrRange ip 128++----------------------------------------------------------------++makeIPTable :: [IPRange] -> IPTable+makeIPTable is = IPTable {+    ipv4table = T.fromList $ zip ipv4addrRange (repeat True)+  , ipv6table = T.fromList $ zip ipv6addrRange (repeat True)+  }+  where+    ipv4addrRange = map toIPv4AddrRange $ filter isIPv4Range is+    ipv6addrRange = map toIPv6AddrRange $ filter isIPv6Range is++isIPv4Range :: IPRange -> Bool+isIPv4Range (IPv4Range _) = True+isIPv4Range _             = False++toIPv4AddrRange :: IPRange -> AddrRange IPv4+toIPv4AddrRange (IPv4Range x) = x+toIPv4AddrRange _             = error "toIPv4AddrRange"++isIPv6Range :: IPRange -> Bool+isIPv6Range (IPv6Range _) = True+isIPv6Range _             = False++toIPv6AddrRange :: IPRange -> AddrRange IPv6+toIPv6AddrRange (IPv6Range x) = x+toIPv6AddrRange _             = error "toIPv6AddrRange"
+ RPF/Lexer.hs view
@@ -0,0 +1,70 @@+module RPF.Lexer where++import Parsec+import Text.ParserCombinators.Parsec.Language+import Text.ParserCombinators.Parsec.Token as P+import RPF.Types++----------------------------------------------------------------++type Lexer st a = GenParser Char st a++----------------------------------------------------------------++rpfStyle :: LanguageDef st+rpfStyle = emptyDef {+    commentStart   = "/*"+  , commentEnd     = "*/"+  , commentLine    = "//"+  , nestedComments = True+  , identStart     = char '$'+  , identLetter    = alphaNum <|> oneOf "_-"+  , reservedOpNames= ["&&", "==", "!=", "="]+  , reservedNames  = actionWords ++ variableNames+                  ++ resultWords ++ blockNames ++ noyes+  , caseSensitive  = True+  }++lexer :: P.TokenParser a+lexer  = P.makeTokenParser rpfStyle++----------------------------------------------------------------++whiteSpace :: Lexer st ()+whiteSpace = P.whiteSpace lexer++----------------------------------------------------------------++semi :: Lexer st String+semi       = P.semi lexer++comma :: Lexer st String+comma      = P.comma lexer++colon :: Lexer st String+colon      = P.colon lexer++identifier :: Lexer st String+identifier = P.identifier lexer++----------------------------------------------------------------++symbol :: String -> Lexer st String+symbol     = P.symbol lexer++reserved :: String -> Lexer st ()+reserved   = P.reserved lexer++reservedOp :: String -> Lexer st ()+reservedOp = P.reservedOp lexer++----------------------------------------------------------------++braces :: Lexer st a -> Lexer st a+braces     = P.braces lexer++lexeme :: Lexer st a -> Lexer st a+lexeme     = P.lexeme lexer++commaSep1 :: Lexer st a -> Lexer st [a]+commaSep1  = P.commaSep1 lexer
+ RPF/Parser.hs view
@@ -0,0 +1,268 @@+module RPF.Parser where++import Control.Monad+import Data.IP+import Data.List+import Data.Maybe+import Network.DNS.Types (Domain)+import Network.DomainAuth+import Parsec hiding (Parser)+import RPF.Domain+import RPF.IP+import RPF.Lexer+import RPF.State+import RPF.Types+import Text.ParserCombinators.Parsec.Expr++{-+import Debug.Trace+infixr 0 .$.+(.$.) :: Show a => (a -> b) -> a -> b+f .$. x = trace (show x) f x+-}++----------------------------------------------------------------++type Parser a = Lexer ParserState a++----------------------------------------------------------------++parsePolicy :: String -> Policy+parsePolicy cs = case runParser config initialState "" cs of+                   Left  err -> error $ show err+                   Right rs  -> rs++----------------------------------------------------------------++config :: Parser Policy+config = do+    whiteSpace+    blks <- many1 defBlock+    eof+    st <- getState+    checkUnused (unused st)+    return $ Policy blks (iptbls st) (domtbls st)+  where+    iptbls = map makeIPTable . reverse . iplol+    domtbls = map makeDomainTable . reverse . domlol+    checkUnused [] = return ()+    checkUnused us = unexpected $ ": Not used -- " ++ concat (intersperse ", " us)++----------------------------------------------------------------++defBlock :: Parser Block+defBlock = many definition >> block++definition :: Parser ()+definition = do+    cst <- identifier -- $foo+    reservedOp "="+    dat <- ipList <|> domainList <|> resultList+    semi+    define cst dat+    return ()+  where+    define cst dat = do+        st <- getState+        let ent = lookup cst (consttbl st)+        when (isJust ent) $ unexpected $ ": Multiple declarations of '" ++ cst ++ "'"+        setState st {+            consttbl = (cst, dat) : consttbl st+          , unused = cst : unused st+          }++block :: Parser Block+block = do+    blknm <- blockname+    checkBlock blknm+    cs <- braces (many actionCond)+    check blknm cs+    nextBlock+    return $ Block blknm cs+  where+    blockname :: Parser BlockName+    blockname = sym2enum blockNames [minBound..maxBound]+    checkBlock blknm = do+        st <- getState+        let cblknm = head $ blocks st+        when (blknm /= cblknm) $ unexpected $ ": " ++ show cblknm ++ "{} is expected"+    nextBlock = do st <- getState+                   setState st { blocks = tail $ blocks st }+    check blknm cs = case last cs of+      ActionCond _ Nothing _ -> return ()+      _                      -> unexpected $ ": action without condition must exist in " ++ show blknm ++ "{}"++----------------------------------------------------------------++actionCond :: Parser ActionCond+actionCond = do+    pos <- getPosition+    let l = sourceLine pos+    act <- action+    cnd <- option Nothing condition+    semi+    return $ ActionCond l cnd act+  where+    action :: Parser Action+    action = sym2enum actionWords [minBound..maxBound]+    condition = do+        colon+        cnd <- cond+        return $ Just cnd++----------------------------------------------------------------++cond :: Parser Cond+cond = buildExpressionParser table term+    where+      table = [[Infix opAnd AssocRight]]++term :: Parser Cond+term = do+    char '#'+    var@(vtyp,vid) <- variable+    checkVar vid+    opr <- opMatch <|> opNotMatch+    cst@(ctyp,cval) <- constant+    when (vtyp /= ctyp) $ unexpected ": Data type mismatch"+    when (vtyp == DT_Res) $ checkResult vid cval+    return $ var `opr` cst+  where+    variable :: Parser Variable+    variable = var2enum variableNames [minBound..maxBound] variableTypes+    checkVar vid = do+        st <- getState+        let blknm = head $ blocks st+            sanity = fromJust $ lookup blknm varSanity+        unless (vid `elem` sanity) $ unexpected $ ": #" ++ show vid ++ " cannot be used in " ++ show blknm ++ "{}"+    checkResult vid (CV_Result cval) = do+        let sanity = fromJust $ lookup vid resultSanity+        mapM_ (test vid sanity) cval+    checkResult _ _ = return ()+    test vid rs r = unless (r `elem` rs) $ unexpected $ ": '" ++ show r ++ "' cannot be used for #" ++ show vid++----------------------------------------------------------------++constant :: Parser Constant+constant = ipList <|> domainList <|> resultList2+       <|> definedConstant <|> yesOrNo++definedConstant :: Parser Constant+definedConstant = identifier >>= resolve+  where+    resolve cst = do+        st <- getState+        let ent = lookup cst $ consttbl st+        when (isNothing ent) $ unexpected $ ": No definition of '" ++ cst ++ "'"+        let cused = cst : used st+            cunused = delete cst $ unused st+        setState st { used = cused, unused = cunused }+        let cd@(typ, CV_Index n) = fromJust ent+        if typ == DT_Res then return (typ, CV_Result (reslol st !! n))+                         else return cd++yesOrNo :: Parser Constant+yesOrNo = do+    b <- yesno+    return (DT_Sig, CV_Sig b)+  where+    yesno :: Parser Bool+    yesno = sym2enum noyes [minBound..maxBound]++----------------------------------------------------------------++op :: String -> a -> Parser a+op str opr = do reservedOp str+                return opr+opAnd :: Parser (Cond -> Cond -> Cond)+opAnd      = op "&&" (:&&)++opMatch :: Parser (Variable -> Constant -> Cond)+opMatch    = op "==" (:==)++opNotMatch :: Parser (Variable -> Constant -> Cond)+opNotMatch = op "!=" (:!=)++----------------------------------------------------------------++ip4range :: Parser IPRange+ip4range = IPv4Range . read <$> many1 (oneOf $ ['0'..'9'] ++ "./")+ip6range :: Parser IPRange+ip6range = IPv6Range . read <$> many1 (oneOf $ ['0'..'9'] ++ ['a'..'f']  ++ ['A'..'F'] ++ ".:/")++ipList :: Parser Constant+ipList = do+    ips <- commaSep1 (try(lexeme ip4range) <|> lexeme ip6range)+    n <- index ips+    return (DT_IP, CV_Index n)+  where+    index ips = do+        st <- getState+        let n = ipcnt st+        setState st {+            iplol = ips : iplol st+          , ipcnt = n + 1+          }+        return n++----------------------------------------------------------------++domain :: Parser Domain+domain = (char '"' >> many1 (noneOf "\"")) <* symbol "\""++domainList :: Parser Constant+domainList = do+    dms <- commaSep1 (lexeme domain)+    n <- index dms+    return (DT_Dom, CV_Index n)+  where+    index dms = do+        st <- getState+        let n = domcnt st+        setState st {+            domlol = dms : domlol st+          , domcnt = n + 1+          }+        return n++----------------------------------------------------------------++result :: Parser DAResult+result = (char '\'' >> authResult) <* char '\''+  where+    authResult :: Parser DAResult+    authResult = sym2enum resultWords [minBound..maxBound]++resultList :: Parser Constant+resultList = do+    rs <- commaSep1 (lexeme result)+    n <- index rs+    return (DT_Res, CV_Index n)+  where+    index rs = do+        st <- getState+        let n = rescnt st+        setState st {+            reslol = rs : reslol st+          , rescnt = n + 1+          }+        return n++resultList2 :: Parser Constant+resultList2 = do+  rs <- commaSep1 (lexeme result)+  return (DT_Res, CV_Result rs)++----------------------------------------------------------------++sym2enum :: [String] -> [a] -> Parser a+sym2enum ss es = choice ps+  where+    func res sym = do {reserved res; return sym}+    ps = zipWith func ss es++var2enum :: [String] -> [VariableId] -> [DataType] -> Parser Variable+var2enum ss ns ts = choice ps+  where+    func res nam typ = do {reserved res; return (typ,nam)}+    ps = zipWith3 func ss ns ts
+ RPF/State.hs view
@@ -0,0 +1,36 @@+module RPF.State where++import Data.IP+import Network.DNS.Types (Domain)+import Network.DomainAuth+import RPF.Types++type ConstName = String+type ConstTable  = [(ConstName, Constant)]++data ParserState = ParserState {+    consttbl :: ConstTable+  , used     :: [ConstName]+  , unused   :: [ConstName]+  , iplol    :: [[IPRange]]+  , ipcnt    :: Int+  , domlol   :: [[Domain]]+  , domcnt   :: Int+  , reslol   :: [[DAResult]]+  , rescnt   :: Int+  , blocks   :: [BlockName]+  } deriving Show++initialState :: ParserState+initialState = ParserState {+    consttbl = []+  , used     = []+  , unused   = []+  , iplol    = []+  , ipcnt    = 0+  , domlol   = []+  , domcnt   = 0+  , reslol   = []+  , rescnt   = 0+  , blocks   = [minBound..maxBound]+  }
+ RPF/Types.hs view
@@ -0,0 +1,103 @@+module RPF.Types where++import Network.DomainAuth+import RPF.IP+import RPF.Domain++type Pline = Int++----------------------------------------------------------------++data Action = A_Accept | A_Discard | A_Hold | A_Reject | A_Continue deriving (Eq, Enum, Bounded, Show)++{-+instance Show Action where+    show act = "\"" ++ actionWords !! fromEnum act ++ "\""+-}++actionWords :: [String]+actionWords = ["accept","discard","hold","reject","continue"]++----------------------------------------------------------------++data DataType = DT_Sig | DT_Res | DT_Dom | DT_IP deriving (Eq, Show)++type Variable = (DataType, VariableId)++data VariableId = V_SIGDKIM | V_SIGDK+                | V_SPF | V_SID | V_DKIM | V_DK | V_ADSP+                | V_MAILFROM | V_FROM | V_PRA | V_DKIMFROM | V_DKFROM+                | V_IP+                deriving (Eq, Enum, Bounded, Show)++{-+instance Show VariableId where+    show vid = "\"" ++ variableNames !! fromEnum vid ++ "\""+-}++variableNames :: [String]+variableNames = [ "sig_dkim", "sig_domainkeys"+                , "spf", "sender_id", "dkim", "domainkeys", "adsp"+                , "mail_from", "from", "pra", "dkim_from", "domainkeys_from"+                , "ip"+                ]++variableTypes :: [DataType]+variableTypes = [ DT_Sig, DT_Sig+                , DT_Res, DT_Res, DT_Res, DT_Res, DT_Res+                , DT_Dom, DT_Dom, DT_Dom, DT_Dom, DT_Dom+                , DT_IP+                ]++varSanity :: [(BlockName, [VariableId])]+varSanity = [(B_Connect,  [V_IP]),+             (B_MailFrom, [V_IP, V_MAILFROM, V_SPF]),+             (B_Header,   [V_IP, V_MAILFROM, V_SPF, V_FROM, V_PRA, V_SID, V_DKIMFROM, V_DKFROM, V_SIGDKIM, V_SIGDK]),+             (B_Body,     [V_IP, V_MAILFROM, V_SPF, V_FROM, V_PRA, V_SID, V_DKIMFROM, V_DKFROM, V_SIGDKIM, V_SIGDK, V_DKIM, V_DK, V_ADSP])]++resultSanity :: [(VariableId, [DAResult])]+resultSanity =  [(V_SPF,  [DANone, DANeutral, DAPass, DAPolicy, DAHardFail, DASoftFail, DATempError, DAPermError]),+                 (V_SID,  [DANone, DANeutral, DAPass, DAPolicy, DAHardFail, DASoftFail, DATempError, DAPermError]),+                 (V_DKIM, [DANone, DAPass, DAFail, DAPolicy, DANeutral, DATempError, DAPermError]),+                 (V_DK,   [DANone, DAPass, DAFail, DAPolicy, DANeutral, DATempError, DAPermError]),+                 (V_ADSP, [DANone, DAPass, DAUnknown, DAFail, DADiscard, DANxDomain, DATempError, DAPermError])]+++----------------------------------------------------------------++resultWords :: [String]+resultWords = [+    "pass", "hardfail", "softfail", "neutral"+  , "fail", "temperror", "permerror", "none"+  , "policy", "nxdomain", "discard", "unknown"+  ]++----------------------------------------------------------------++data BlockName = B_Connect | B_MailFrom | B_Header | B_Body deriving (Eq, Enum, Bounded, Show)++blockNames :: [String]+blockNames = ["connect", "mail_from", "header", "body"]++{-+instance Show BlockName where+    show blknm = "\"" ++ blockNames !! fromEnum blknm ++ "\""+-}++----------------------------------------------------------------++noyes :: [String]+noyes = ["No", "Yes"]++----------------------------------------------------------------++type Constant = (DataType, ConstantValue)+data ConstantValue = CV_Index Int | CV_Result [DAResult] | CV_Sig Bool+                     deriving (Eq, Show)++----------------------------------------------------------------++data Policy = Policy [Block] [IPTable] [DomainTable] deriving (Eq, Show)+data Block = Block BlockName [ActionCond] deriving (Eq, Show)+data ActionCond = ActionCond Pline (Maybe Cond) Action deriving (Eq, Show)+data Cond = Variable :== Constant | Variable :!= Constant | Cond :&& Cond deriving (Eq, Show)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++module Test where++import Control.Applicative+import Data.Map as M+import Data.IP+import Data.IP.RouteTable as T+import Network.DomainAuth+import RPF.Parser+import RPF.Types+import RPF.IP+import Test.Framework (defaultMain, testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)++tests :: [Test]+tests = [+    testGroup "Policy" [+         testCase "policy1" test_policy1+--       , testCase "policy2" test_policy2+       ]+  ]++----------------------------------------------------------------++test_policy1 :: Assertion+test_policy1 = do+    plcy <- parsePolicy <$> readFile "config/rpf.policy"+    plcy @?= res+  where+    res = Policy [+        Block B_Connect [ActionCond 3 (Just ((DT_IP,V_IP) :== (DT_IP,CV_Index 0))) A_Accept,ActionCond 4 Nothing A_Continue]+      , Block B_MailFrom [ActionCond 9 (Just ((DT_Res,V_SPF) :== (DT_Res,CV_Result [DAPass]))) A_Accept,ActionCond 10 Nothing A_Continue]+      , Block B_Header [ActionCond 15 (Just ((DT_Res,V_SID) :== (DT_Res,CV_Result [DAPass]))) A_Accept,ActionCond 16 (Just (((DT_Dom,V_MAILFROM) :== (DT_Dom,CV_Index 0)) :&& ((DT_Sig,V_SIGDK) :== (DT_Sig,CV_Sig False)))) A_Reject,ActionCond 17 Nothing A_Continue]+      , Block B_Body [ActionCond 22 (Just ((DT_Res,V_DKIM) :== (DT_Res,CV_Result [DAPass]))) A_Accept,ActionCond 23 (Just ((DT_Res,V_DK) :== (DT_Res,CV_Result [DAPass]))) A_Accept,ActionCond 24 Nothing A_Continue]+      ]+          [IPTable (T.fromList [(makeAddrRange (toIPv4 [127,0,0,1]) 32,True)]) T.empty]+          [M.fromList [("yahoo.com",True)]]++----------------------------------------------------------------++main :: IO ()+main = defaultMain tests
+ config/rpf.conf view
@@ -0,0 +1,10 @@+#Port: 10025+#Address: 127.0.0.1+#Reject_Plus_All: Yes+#Minimum_IPv4_Mask_Length: 24+#Minimum_IPv6_Mask_Length: 48+#Include_Redirect_Limit: 10+#Syslog_Facility: local4+#Log_Level: notice+#Logonly: No+#Debug: No
+ config/rpf.policy view
@@ -0,0 +1,25 @@+// #ip+connect {+	accept: #ip == 127.0.0.1;+	continue;+}++// #spf, #mail_from+mail_from {+	accept: #spf == 'pass';+	continue;+}++// #from, #pra, #sender_id, #dkim_from, #domainkeys_from, #sig_dkim, #sig_domainkeys+header {+	accept: #sender_id == 'pass';+	reject: #mail_from == "yahoo.com" && #sig_domainkeys == No;+	continue;+}++// #dkim, #domainkeys+body {+	accept: #dkim == 'pass';+	accept: #domainkeys == 'pass';+	continue;+}
+ rpf.cabal view
@@ -0,0 +1,45 @@+Name:                   rpf+Version:                0.2.0+Author:                 Kazu Yamamoto <kazu@iij.ad.jp>+Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>+License:                BSD3+License-File:           LICENSE+Homepage:               http://www.mew.org/~kazu/proj/rpf/+Synopsis:               Receiver Policy Framework+Description:            Receiver Policy Framework (RPF) is a Milter+                        program to change actions of e-mail receiver+                        side according to results of the anti-spam+                        technologies.+Category:               Network+Cabal-Version:          >= 1.6+Build-Type:             Simple+Data-Files:             rpf.conf, rpf.policy+Data-Dir:               config+Extra-Source-Files:     README Test.hs+Executable rpf+  Main-Is:              Main.hs+  if impl(ghc >= 6.12)+    GHC-Options:        -Wall -fno-warn-unused-do-bind+  else+    GHC-Options:        -Wall+  Build-Depends:        base >= 4.0 && < 5, containers, bytestring,+                        hdaemonize, hslogger, parsec,+                        appar, c10k, iproute, dns, domain-auth+  Other-Modules:        Config+                        LogMsg+                        Milter+                        Milter.Base+                        Milter.Env+                        Milter.Log+                        Milter.Switch+                        Milter.Types+                        MailSpec+                        Parsec+                        RPF+                        RPF.Domain+                        RPF.Eval+                        RPF.IP+                        RPF.Lexer+                        RPF.Parser+                        RPF.State+                        RPF.Types