diff --git a/Postmaster.hs b/Postmaster.hs --- a/Postmaster.hs +++ b/Postmaster.hs @@ -21,7 +21,7 @@ , module Data.Typeable , module Network , module ADNS - , module Text.ParserCombinators.Parsec.Rfc2821 + , module Text.Parsec.Rfc2821 , module System.Posix.Syslog ) where @@ -30,15 +30,9 @@ import Control.Monad.RWS hiding ( local ) import ADNS hiding ( Debug, queryMX, queryA, queryPTR ) import Data.Typeable -import Text.ParserCombinators.Parsec.Rfc2821 hiding ( path ) +import Text.Parsec.Rfc2821 hiding ( path ) import System.Posix.Syslog import Postmaster.Base import Postmaster.FSM import Postmaster.IO import Postmaster.Main - --- ----- Configure Emacs ----- --- --- Local Variables: *** --- haskell-program-name: "ghci -ladns -lcrypto" *** --- End: *** diff --git a/Postmaster/Base.hs b/Postmaster/Base.hs --- a/Postmaster/Base.hs +++ b/Postmaster/Base.hs @@ -22,7 +22,7 @@ import Control.Monad.RWS hiding ( local ) import Control.Concurrent import Data.Typeable -import Text.ParserCombinators.Parsec.Rfc2821 hiding ( path ) +import Text.Parsec.Rfc2821 hiding ( path ) import Postmaster.Env -- * The @Smtpd@ Monad diff --git a/Postmaster/FSM.hs b/Postmaster/FSM.hs --- a/Postmaster/FSM.hs +++ b/Postmaster/FSM.hs @@ -38,7 +38,7 @@ import Postmaster.FSM.PeerHelo import Postmaster.FSM.SessionState import Postmaster.FSM.Spooler -import Text.ParserCombinators.Parsec.Rfc2821 +import Text.Parsec.Rfc2821 -- |Generate the standard ESMTP event handler. The -- parameters are the path to the spool directory and our diff --git a/Postmaster/FSM/Announce.hs b/Postmaster/FSM/Announce.hs --- a/Postmaster/FSM/Announce.hs +++ b/Postmaster/FSM/Announce.hs @@ -13,7 +13,7 @@ module Postmaster.FSM.Announce where import Postmaster.Base -import Text.ParserCombinators.Parsec.Rfc2821 +import Text.Parsec.Rfc2821 -- |Append the given ESMTP keyword to the reply produced -- during 'SayEhlo'. diff --git a/Postmaster/FSM/EhloPeer.hs b/Postmaster/FSM/EhloPeer.hs --- a/Postmaster/FSM/EhloPeer.hs +++ b/Postmaster/FSM/EhloPeer.hs @@ -11,7 +11,7 @@ module Postmaster.FSM.EhloPeer where import Postmaster.Base -import Text.ParserCombinators.Parsec.Rfc2821 +import Text.Parsec.Rfc2821 -- |Local Variable: @EHLOPEER :: 'Bool'@ diff --git a/Postmaster/FSM/EventHandler.hs b/Postmaster/FSM/EventHandler.hs --- a/Postmaster/FSM/EventHandler.hs +++ b/Postmaster/FSM/EventHandler.hs @@ -13,7 +13,7 @@ import Data.Typeable import Postmaster.Base -import Text.ParserCombinators.Parsec.Rfc2821 +import Text.Parsec.Rfc2821 newtype EH = EH EventHandler deriving (Typeable) diff --git a/Postmaster/FSM/HeloName.hs b/Postmaster/FSM/HeloName.hs --- a/Postmaster/FSM/HeloName.hs +++ b/Postmaster/FSM/HeloName.hs @@ -13,7 +13,7 @@ import Control.Monad import Network ( HostName ) import Postmaster.Base -import Text.ParserCombinators.Parsec.Rfc2821 +import Text.Parsec.Rfc2821 -- |Local Variable: @HELONAME :: 'HostName'@ diff --git a/Postmaster/FSM/MailFrom.hs b/Postmaster/FSM/MailFrom.hs --- a/Postmaster/FSM/MailFrom.hs +++ b/Postmaster/FSM/MailFrom.hs @@ -12,7 +12,7 @@ module Postmaster.FSM.MailFrom where import Postmaster.Base -import Text.ParserCombinators.Parsec.Rfc2821 +import Text.Parsec.Rfc2821 import Data.Typeable newtype SmtpMailbox = SMB Mailbox diff --git a/Postmaster/FSM/MailID.hs b/Postmaster/FSM/MailID.hs --- a/Postmaster/FSM/MailID.hs +++ b/Postmaster/FSM/MailID.hs @@ -11,7 +11,7 @@ module Postmaster.FSM.MailID where import Postmaster.Base -import Text.ParserCombinators.Parsec.Rfc2821 +import Text.Parsec.Rfc2821 -- |Local Variable: @MAILID :: 'ID'@ diff --git a/Postmaster/FSM/PeerHelo.hs b/Postmaster/FSM/PeerHelo.hs --- a/Postmaster/FSM/PeerHelo.hs +++ b/Postmaster/FSM/PeerHelo.hs @@ -12,7 +12,7 @@ import Network ( HostName ) import Postmaster.Base -import Text.ParserCombinators.Parsec.Rfc2821 +import Text.Parsec.Rfc2821 -- |Local Variable: @PEERHELO :: 'HostName'@ diff --git a/Postmaster/FSM/SessionState.hs b/Postmaster/FSM/SessionState.hs --- a/Postmaster/FSM/SessionState.hs +++ b/Postmaster/FSM/SessionState.hs @@ -12,7 +12,7 @@ module Postmaster.FSM.SessionState where import Postmaster.Base -import Text.ParserCombinators.Parsec.Rfc2821 +import Text.Parsec.Rfc2821 import Data.Typeable newtype SmtpSessionState = SSST SessionState diff --git a/Postmaster/FSM/Spooler.hs b/Postmaster/FSM/Spooler.hs --- a/Postmaster/FSM/Spooler.hs +++ b/Postmaster/FSM/Spooler.hs @@ -23,11 +23,11 @@ import Postmaster.FSM.SessionState import Postmaster.FSM.DataHandler import Postmaster.FSM.MailID -import Text.ParserCombinators.Parsec.Rfc2821 hiding ( path ) -import OpenSSL.Digest +import Text.Parsec.Rfc2821 hiding ( path ) +import OpenSSL.EVP.Digest import Data.Typeable -data Spooler = S (Maybe FilePath) (Maybe WriteHandle) DigestState +data Spooler = S (Maybe FilePath) (Maybe WriteHandle) (Ptr OpaqueDigestContext) deriving (Typeable) spoolerState :: SmtpdVariable @@ -45,7 +45,7 @@ handlePayload :: FilePath -> EventT handlePayload _ f Greeting = do - liftIO (newMVar (S Nothing Nothing (DST nullPtr))) >>= setState + liftIO (newMVar (S Nothing Nothing nullPtr)) >>= setState setDataHandler feeder f Greeting @@ -53,21 +53,20 @@ do st <- getState mid <- getMailID let path = spool ++ "/temp." ++ show mid - liftIO . modifyMVar_ st $ \(S p' h' (DST c')) -> + liftIO . modifyMVar_ st $ \(S p' h' c') -> assert (p' == Nothing) $ assert (h' == Nothing) $ assert (c' == nullPtr) $ bracketOnError (openBinaryFile path WriteMode) (hClose) - (\h -> bracketOnError ctxCreate ctxDestroy $ \ctx -> do + (\h -> bracketOnError _createContext _destroyContext $ \ctx -> do hSetBuffering h NoBuffering when (ctx == nullPtr) (fail "can't initialize SHA1 digest context") - md <- toMDEngine SHA1 - when (md == nullPtr) (fail "can't initialize SHA1 digest engine") - rc <- digestInit ctx md + let DigestDescription md = digestByName "SHA1" + rc <- _initDigest ctx md nullPtr when (rc == 0) (fail "can't initialize SHA1 digest") - return (S (Just path) (Just h) (DST ctx))) + return (S (Just path) (Just h) ctx)) say 3 5 4 "terminate data with ." `fallback` say 4 5 1 "requested action aborted: error in processing" @@ -75,10 +74,15 @@ handlePayload spool _ Deliver = do st <- getState sha1 <- liftIO $ - modifyMVar st $ \(S (Just p) (Just h) ctx@(DST c)) -> - assert (c /= nullPtr) $ do + modifyMVar st $ \(S (Just p) (Just h) ctx) -> + assert (ctx /= nullPtr) $ do hClose h - sha1 <- fmap (>>= toHex) (evalStateT final ctx) + sha1 <- alloca $ \sizePtr -> + allocaArray maxDigestSize $ \mdPtr -> do + _finalizeDigest ctx mdPtr sizePtr + len <- peek sizePtr + md <- peekArray (fromIntegral len) mdPtr + return (md >>= toHex) let fname = spool ++ "/" ++ sha1 renameFile p fname return (S Nothing Nothing ctx, sha1) @@ -100,10 +104,10 @@ Just j -> (True, fromIntegral (j-3)) i' = fromIntegral i st <- getState - buf' <- liftIO . withMVar st $ \(S _ (Just h) ctx@(DST c)) -> - assert (c /= nullPtr) $ do + buf' <- liftIO . withMVar st $ \(S _ (Just h) ctx) -> + assert (ctx /= nullPtr) $ do hPutBuf h ptr i' - _ <- execStateT (update' (ptr, i')) ctx + _ <- _updateDigest ctx (castPtr ptr) (fromIntegral i') flush i buf if not eod then return (Nothing, buf') else do r <- trigger Deliver @@ -114,10 +118,10 @@ clearState :: Smtpd () clearState = do st <- getState - liftIO . modifyMVar_ st $ \(S path h (DST ctx)) -> do + liftIO . modifyMVar_ st $ \(S path h ctx) -> do let clean Nothing _ = return () clean (Just x) f = (try (f x) :: IO (Either SomeException ())) >> return () clean h hClose clean path removeFile - when (ctx /= nullPtr) (ctxDestroy ctx) - return (S Nothing Nothing (DST nullPtr)) + when (ctx /= nullPtr) (_destroyContext ctx) + return (S Nothing Nothing nullPtr) diff --git a/Postmaster/IO.hs b/Postmaster/IO.hs --- a/Postmaster/IO.hs +++ b/Postmaster/IO.hs @@ -21,7 +21,7 @@ import System.Timeout import Network ( listenOn, PortID(..) ) import Network.Socket -import Text.ParserCombinators.Parsec.Rfc2821 +import Text.Parsec.Rfc2821 import Foreign import Postmaster.Base @@ -177,7 +177,7 @@ -- incoming connection. listener :: PortID -> SocketHandler -> IO () -listener p h = bracket (listenOn p) (sClose) (acceptor h) +listener p h = bracket (listenOn p) (close) (acceptor h) -- |Given a listening socket, this function will loop -- forever 'accept'ing incoming connections. For each @@ -187,8 +187,8 @@ acceptor h ls = do bracketOnError (accept ls) - (sClose . fst) - (\peer@(s,_) -> fork $ h peer `finally` sClose s) + (close . fst) + (\peer@(s,_) -> fork $ h peer `finally` close s) acceptor h ls where fork f = forkIO f >> return () diff --git a/Postmaster/Main.hs b/Postmaster/Main.hs --- a/Postmaster/Main.hs +++ b/Postmaster/Main.hs @@ -12,18 +12,6 @@ module Postmaster.Main where -import Prelude hiding ( catch ) -import Data.Maybe -import Control.Concurrent.MVar -import Control.Monad.RWS hiding ( local ) -import Control.Monad.State -import System.IO -import System.Posix.Signals -import Network ( PortID(..) ) -import Network.Socket -import Network.BSD ( getHostName ) -import ADNS -import Foreign import Postmaster.Base import Postmaster.FSM import Postmaster.FSM.DNSResolver ( setDNSResolver ) @@ -31,8 +19,21 @@ import Postmaster.FSM.PeerAddr ( setPeerAddr ) import Postmaster.FSM.SessionState ( setSessionState ) import Postmaster.IO -import Text.ParserCombinators.Parsec.Rfc2821 + +import ADNS +import Control.Concurrent.MVar +import Control.Monad.RWS hiding ( local ) +import Control.Monad.State +import Data.Maybe +import Foreign.C.String +import Foreign.Marshal.Array +import Network ( PortID(..) ) +import Network.BSD ( getHostName ) +import Network.Socket +import System.IO +import System.Posix.Signals import System.Posix.Syslog +import Text.Parsec.Rfc2821 -- * Speaking ESMTP @@ -158,7 +159,7 @@ _ <- installHandler sigCHLD (Catch (return ())) Nothing whoami <- getHostName withSocketsDo $ - withSyslog "postmaster" [PID, PERROR] MAIL $ + withSyslog "postmaster" [LogPID] Mail $ initResolver [NoErrPrint,NoServerWarn] $ \dns -> withGlobalEnv whoami dns eventT $ listener port . smtpdServer cap @@ -183,5 +184,6 @@ -- |Our default logging back-end. syslogger :: Logger -syslogger (LogMsg sid _ e) = syslog Info $ - showString "SID " . shows sid . (':':) . (' ':) $ show e +syslogger (LogMsg sid _ e) = + withCStringLen (showString "SID " . shows sid . (':':) . (' ':) $ show e) $ + syslog Nothing Info diff --git a/postmaster.cabal b/postmaster.cabal --- a/postmaster.cabal +++ b/postmaster.cabal @@ -1,5 +1,5 @@ Name: postmaster -Version: 0.3 +Version: 0.3.1 Copyright: Peter Simons License: GPL License-File: COPYING @@ -18,7 +18,7 @@ call-back functions. Cabal-Version: >= 1.6 Build-Type: Simple -Tested-With: GHC >= 6.12.3 && <= 7.6.2 +Tested-With: GHC >= 7.6 && < 8.1 Extra-Source-Files: Postmaster/Base.hs Postmaster/FSM/HeloName.hs @@ -46,7 +46,6 @@ Executable postmaster Main-Is: tutorial.lhs GHC-Options: -Wall -threaded - Extra-Libraries: adns crypto Build-Depends: base >=3 && <5, directory, mtl, network, unix, parsec, - containers, bytestring, old-time, hsyslog, hsdns, hsemail, - hopenssl + containers, bytestring, old-time, hsyslog >= 5, hsdns >= 1, hsemail >= 2, + hopenssl >= 2