postmaster 0.3 → 0.3.1

raw patch · 15 files changed

+61/−62 lines, 15 filesdep ~hopenssldep ~hsdnsdep ~hsemail

Dependency ranges changed: hopenssl, hsdns, hsemail, hsyslog

Files

• Postmaster.hs +2/−8
• Postmaster/Base.hs +1/−1
• Postmaster/FSM.hs +1/−1
• Postmaster/FSM/Announce.hs +1/−1
• Postmaster/FSM/EhloPeer.hs +1/−1
• Postmaster/FSM/EventHandler.hs +1/−1
• Postmaster/FSM/HeloName.hs +1/−1
• Postmaster/FSM/MailFrom.hs +1/−1
• Postmaster/FSM/MailID.hs +1/−1
• Postmaster/FSM/PeerHelo.hs +1/−1
• Postmaster/FSM/SessionState.hs +1/−1
• Postmaster/FSM/Spooler.hs +23/−19
• Postmaster/IO.hs +4/−4
• Postmaster/Main.hs +18/−16
• postmaster.cabal +4/−5

@@ -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: ***

@@ -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

@@ -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

@@ -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'.

@@ -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'@ 

@@ -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)

@@ -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'@ 

@@ -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

@@ -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'@ 

@@ -12,7 +12,7 @@  import Network ( HostName ) import Postmaster.Base-import Text.ParserCombinators.Parsec.Rfc2821+import Text.Parsec.Rfc2821  -- |Local Variable: @PEERHELO :: 'HostName'@ 

@@ -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

@@ -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 <CRLF>.<CRLF>"   `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)

@@ -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 ()

@@ -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

@@ -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