rpf 0.2.3 → 0.2.4
raw patch · 8 files changed
+66/−101 lines, 8 filesdep +blaze-builderdep +unixdep −hdaemonize
Dependencies added: blaze-builder, unix
Dependencies removed: hdaemonize
Files
- Config.hs +3/−1
- Main.hs +21/−2
- Milter/Base.hs +31/−24
- Milter/Switch.hs +1/−1
- Parsec.hs +0/−52
- RPF/Lexer.hs +3/−2
- RPF/Parser.hs +4/−9
- rpf.cabal +3/−10
Config.hs view
@@ -2,8 +2,10 @@ module Config (Option(..), getOption, defaultOption) where +import Control.Applicative hiding (many,optional,(<|>)) import Data.List (isPrefixOf)-import Parsec+import Text.Parsec+import Text.Parsec.String ----------------------------------------------------------------
Main.hs view
@@ -15,10 +15,10 @@ import System.Environment import System.Exit import System.IO-import System.Posix.Daemonize (daemonize)+import System.Posix hiding (version, Limit) version :: String-version = "0.2.2"+version = "0.2.4" progName :: String progName = "rpf " ++ version@@ -115,3 +115,22 @@ , monitorHook = infoMsg , debugHook = debugMsg }++----------------------------------------------------------------++daemonize :: IO () -> IO ()+daemonize program = ensureDetachTerminalCanWork $ do+ detachTerminal+ ensureNeverAttachTerminal $ do+ changeWorkingDirectory "/"+ setFileCreationMask 0+ mapM_ closeFd [stdInput, stdOutput, stdError]+ program+ where+ ensureDetachTerminalCanWork p = do+ forkProcess p+ exitImmediately ExitSuccess+ ensureNeverAttachTerminal p = do+ forkProcess p+ exitImmediately ExitSuccess+ detachTerminal = createSession
Milter/Base.hs view
@@ -10,13 +10,16 @@ , accept, discard, hold, reject, continue ) where +import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8 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 qualified Data.ByteString as X (unpack)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS import Data.IP import Data.List (foldl')+import Data.Monoid import System.IO ----------------------------------------------------------------@@ -47,9 +50,9 @@ 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+ let len = BS.length bs + 1+ pkt = intToFourBytes len +++ fromChar c +++ fromByteString bs+ BS.hPut hdl $ toByteString pkt safePutPacket :: Handle -> Packet -> IO () safePutPacket hdl pkt = withOpenedHandleDo hdl $ putPacket hdl pkt@@ -64,14 +67,14 @@ getKeyVal :: ByteString -> (ByteString, ByteString) getKeyVal bs = (key,val) where- kv = L.split '\0' bs+ kv = BS.split '\0' bs key = kv !! 0 val = kv !! 1 ---------------------------------------------------------------- getBody :: ByteString -> ByteString-getBody = L.init -- removing the last '\0'+getBody = BS.init -- removing the last '\0' ---------------------------------------------------------------- @@ -80,9 +83,9 @@ | 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+ ip = BS.split '\0' bs !! 1+ fam = BS.head ip+ adr = BS.unpack $ BS.drop 3 ip ---------------------------------------------------------------- @@ -90,7 +93,7 @@ negotiate hdl = putPacket hdl negoPkt -- do NOT use safePutPacket negoPkt :: Packet-negoPkt = Packet 'O' $ ver +++ act +++ pro+negoPkt = Packet 'O' $ toByteString $ ver +++ act +++ pro where ver = intToFourBytes 2 -- Sendmail 8.13.8, sigh act = intToFourBytes 0@@ -106,22 +109,26 @@ ---------------------------------------------------------------- getNByte :: Handle -> Int -> IO ByteString-getNByte = L.hGet+getNByte = BS.hGet getCmd :: Handle -> IO Char-getCmd hdl = L.head <$> L.hGet hdl 1+getCmd hdl = BS.head <$> BS.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+fourBytesToInt = foldl' (\a b -> a * 256 + b) 0 . map fromIntegral . X.unpack -moddiv :: Int -> Int -> [Int]-moddiv 0 _ = []-moddiv i m = (m `mod` 256) : moddiv (i - 1) (m `div` 256)+intToFourBytes :: Int -> Builder+intToFourBytes = fromInt32be . fromIntegral -----------------------------------------------------------------+{-+moddiv :: Int -> [Int]+moddiv q0 = [r4,r3,r2,r1]+ where+ (q1,r1) = q0 `divMod` 256+ (q2,r2) = q1 `divMod` 256+ (q3,r3) = q2 `divMod` 256+ r4 = q3 `mod` 256+-} -(+++) :: ByteString -> ByteString -> ByteString-(+++) = L.append+(+++) :: Builder -> Builder -> Builder+(+++) = mappend
Milter/Switch.hs view
@@ -4,7 +4,7 @@ import Control.Applicative import Control.Monad (unless)-import Data.ByteString.Lazy.Char8 (ByteString)+import Data.ByteString.Char8 (ByteString) import Data.IORef import MailSpec import Milter.Base
− Parsec.hs
@@ -1,52 +0,0 @@-{-# 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
RPF/Lexer.hs view
@@ -1,9 +1,10 @@ module RPF.Lexer where -import Parsec+import RPF.Types+import Text.Parsec+import Text.Parsec.String import Text.ParserCombinators.Parsec.Language import Text.ParserCombinators.Parsec.Token as P-import RPF.Types ----------------------------------------------------------------
RPF/Parser.hs view
@@ -1,26 +1,21 @@ module RPF.Parser where +import Control.Applicative hiding (many,optional,(<|>)) import Control.Monad+import qualified Data.ByteString.Char8 as BS 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.Parsec 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@@ -208,7 +203,7 @@ ---------------------------------------------------------------- domain :: Parser Domain-domain = (char '"' >> many1 (noneOf "\"")) <* symbol "\""+domain = BS.pack <$> (char '"' >> many1 (noneOf "\"")) <* symbol "\"" domainList :: Parser Constant domainList = do
rpf.cabal view
@@ -1,5 +1,5 @@ Name: rpf-Version: 0.2.3+Version: 0.2.4 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -18,15 +18,9 @@ Extra-Source-Files: README Test.hs Executable rpf Main-Is: Main.hs- if impl(ghc >= 7)- GHC-Options: -Wall -O2 -fno-warn-unused-do-bind -threaded- else- if impl(ghc >= 6.12)- GHC-Options: -Wall -O2 -fno-warn-unused-do-bind- else- GHC-Options: -Wall -O2+ GHC-Options: -Wall -fno-warn-unused-do-bind -threaded Build-Depends: base >= 4.0 && < 5, containers, bytestring,- hdaemonize, hslogger, parsec,+ hslogger, parsec, unix, blaze-builder, appar, c10k, iproute, dns, domain-auth Other-Modules: Config LogMsg@@ -37,7 +31,6 @@ Milter.Switch Milter.Types MailSpec- Parsec RPF RPF.Domain RPF.Eval