diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -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 ---------------------------------------------------------------- diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/Milter/Base.hs b/Milter/Base.hs --- a/Milter/Base.hs +++ b/Milter/Base.hs @@ -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 diff --git a/Milter/Switch.hs b/Milter/Switch.hs --- a/Milter/Switch.hs +++ b/Milter/Switch.hs @@ -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 diff --git a/Parsec.hs b/Parsec.hs deleted file mode 100644 --- a/Parsec.hs +++ /dev/null @@ -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 diff --git a/RPF/Lexer.hs b/RPF/Lexer.hs --- a/RPF/Lexer.hs +++ b/RPF/Lexer.hs @@ -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 ---------------------------------------------------------------- diff --git a/RPF/Parser.hs b/RPF/Parser.hs --- a/RPF/Parser.hs +++ b/RPF/Parser.hs @@ -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 diff --git a/rpf.cabal b/rpf.cabal --- a/rpf.cabal +++ b/rpf.cabal @@ -1,5 +1,5 @@ Name: rpf -Version: 0.2.3 +Version: 0.2.4 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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