diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -9,13 +9,19 @@ settings = defaultSettings { settingsTLS = Just $ (tlsSettings "server.crt" "server.key") { security = DemandStartTLS - } + }, + settingsOnOpen = \sid -> do + putStrLn $ show sid ++ " session opened" + , + settingsOnClose = \sid -> do + putStrLn $ show sid ++ " session closed" } main :: IO () main = do runSettings settings app where - app (Mail _ _ body) = do + app (Mail sid _ _ body) = do + putStrLn $ show sid ++ " receiving mail" runEffect $ body >-> stdout return Accepted diff --git a/postie.cabal b/postie.cabal --- a/postie.cabal +++ b/postie.cabal @@ -1,5 +1,5 @@ name: postie -version: 0.2.0.2 +version: 0.3.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -47,7 +47,7 @@ build-depends: base >=4 && <=5, network >=2.4.1.2, bytestring >=0.10.0.2, tls >=1.2.3, pipes >=4.1.0, pipes-parse >=3.0.1, attoparsec >=0.10.4.0, transformers >=0.3.0.0, - mtl >=2.1.2, cprng-aes >=0.5.2, data-default-class >=0.0.1 + mtl >=2.1.2, cprng-aes >=0.5.2, data-default-class >=0.0.1, uuid >= 1.3.3 exposed-modules: Web.Postie Web.Postie.Types Web.Postie.Settings exposed: True buildable: True diff --git a/src/Web/Postie.hs b/src/Web/Postie.hs --- a/src/Web/Postie.hs +++ b/src/Web/Postie.hs @@ -84,17 +84,18 @@ void $ forever $ do (mkConn, sockAddr) <- getConnLoop void $ forkIOWithUnmask $ \unmask -> do + sessionID <- mkSessionID bracket mkConn connClose $ \conn -> void $ timeout maxDuration $ unmask . - handle onE . - bracket_ onOpen onClose $ - serveConnection sockAddr settings conn app + handle (onE $ Just sessionID ). + bracket_ (onOpen sessionID) (onClose sessionID) $ + serveConnection sessionID sockAddr settings conn app return () return () where getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do - onE (toException e) + onE Nothing (toException e) threadDelay 1000000 getConnLoop @@ -104,5 +105,5 @@ maxDuration = (settingsTimeout settings) * 1000000 -serveConnection :: SockAddr -> Settings -> Connection -> Application -> IO () -serveConnection _ = runSession +serveConnection :: SessionID -> SockAddr -> Settings -> Connection -> Application -> IO () +serveConnection sid _ = runSession sid diff --git a/src/Web/Postie/Session.hs b/src/Web/Postie/Session.hs --- a/src/Web/Postie/Session.hs +++ b/src/Web/Postie/Session.hs @@ -1,6 +1,7 @@ module Web.Postie.Session( runSession + , mkSessionID ) where import Prelude hiding (lines) @@ -13,6 +14,7 @@ import qualified Web.Postie.Protocol as SMTP import Web.Postie.Pipes +import Data.UUID.V4 import qualified Data.ByteString.Char8 as BS import qualified Pipes.Parse as P @@ -21,7 +23,8 @@ import Control.Monad.State data SessionState = SessionState { - sessionApp :: Application + sessionID :: SessionID + , sessionApp :: Application , sessionSettings :: Settings , sessionConnection :: Connection , sessionConnectionInput :: P.Producer BS.ByteString IO () @@ -33,13 +36,17 @@ | TxnHaveMailFrom Address | TxnHaveRecipient Address [Address] -runSession :: Settings -> Connection -> Application -> IO () -runSession settings connection app = - evalStateT startSession (initialSessionState settings connection app) +mkSessionID :: IO SessionID +mkSessionID = SessionID `fmap` nextRandom -initialSessionState :: Settings -> Connection -> Application -> SessionState -initialSessionState settings connection app = SessionState { - sessionApp = app +runSession :: SessionID -> Settings -> Connection -> Application -> IO () +runSession sid settings connection app = + evalStateT startSession (initialSessionState sid settings connection app) + +initialSessionState :: SessionID -> Settings -> Connection -> Application -> SessionState +initialSessionState sid settings connection app = SessionState { + sessionID = sid + , sessionApp = app , sessionSettings = settings , sessionConnection = connection , sessionConnectionInput = connectionP connection @@ -76,15 +83,17 @@ handleEvent :: SMTP.Event -> StateT SessionState IO () handleEvent (SayHelo x) = do + sid <- gets sessionID handler <- settingsOnHello <$> gets sessionSettings - result <- liftIO $ handler x + result <- liftIO $ handler sid x case result of Accepted -> sendReply ok _ -> sendReply reject handleEvent (SayEhlo x) = do + sid <- gets sessionID handler <- settingsOnHello <$> gets sessionSettings - result <- liftIO $ handler x + result <- liftIO $ handler sid x case result of Accepted -> sendReply =<< ehloAdvertisement _ -> sendReply reject @@ -94,8 +103,9 @@ handleEvent SayOK = sendReply ok handleEvent (SetMailFrom x) = do + sid <- gets sessionID handler <- settingsOnMailFrom <$> gets sessionSettings - result <- liftIO $ handler x + result <- liftIO $ handler sid x case result of Accepted -> do modify (\ss -> ss { sessionTransaction = TxnHaveMailFrom x }) @@ -103,8 +113,9 @@ _ -> sendReply reject handleEvent (AddRcptTo x) = do + sid <- gets sessionID handler <- settingsOnRecipient <$> gets sessionSettings - result <- liftIO $ handler x + result <- liftIO $ handler sid x case result of Accepted -> do txn <- gets sessionTransaction @@ -119,7 +130,8 @@ handleEvent StartData = do sendReply $ reply 354 "End data with ." (TxnHaveRecipient sender recipients) <- gets sessionTransaction - mail <- Mail sender recipients <$> chunks + sid <- gets sessionID + mail <- Mail sid sender recipients <$> chunks app <- gets sessionApp result <- liftIO $ app mail case result of @@ -132,8 +144,9 @@ chunks = dataChunks <$> maxDataLength <*> gets sessionConnectionInput handleEvent WantTls = do + sid <- gets sessionID handler <- settingsOnStartTLS <$> gets sessionSettings - liftIO $ handler + liftIO $ handler sid sendReply ok conn <- gets sessionConnection conn' <- liftIO $ connStartTls conn diff --git a/src/Web/Postie/Settings.hs b/src/Web/Postie/Settings.hs --- a/src/Web/Postie/Settings.hs +++ b/src/Web/Postie/Settings.hs @@ -41,34 +41,37 @@ , settingsMaxDataSize :: Int -- ^ Maximal size of incoming mail data , settingsHost :: Maybe HostName -- ^ Hostname which is shown in posties greeting. , settingsTLS :: Maybe TLSSettings -- ^ TLS settings if you wish to secure connections. - , settingsOnException :: SomeException -> IO () -- ^ Exception handler (default is defaultExceptionHandler) - , settingsOnOpen :: IO () -- ^ Action will be performed when connection has been opened. - , settingsOnClose :: IO () -- ^ Action will be performed when connection has been closed. + , settingsOnException :: Maybe SessionID -> SomeException -> IO () -- ^ Exception handler (default is defaultExceptionHandler) , settingsBeforeMainLoop :: IO () -- ^ Action will be performed before main processing begins. - , settingsOnStartTLS :: IO () -- ^ Action will be performend on STARTTLS command. - , settingsOnHello :: ByteString -> IO HandlerResponse -- ^ Performed when client says hello - , settingsOnMailFrom :: Address -> IO HandlerResponse -- ^ Performed when client starts mail transaction - , settingsOnRecipient :: Address -> IO HandlerResponse -- ^ Performed when client adds recipient to mail transaction. + , settingsOnOpen :: SessionID -> IO () -- ^ Action will be performed when connection has been opened. + , settingsOnClose :: SessionID -> IO () -- ^ Action will be performed when connection has been closed. + , settingsOnStartTLS :: SessionID -> IO () -- ^ Action will be performend on STARTTLS command. + , settingsOnHello :: SessionID -> ByteString -> IO HandlerResponse -- ^ Performed when client says hello + , settingsOnMailFrom :: SessionID -> Address -> IO HandlerResponse -- ^ Performed when client starts mail transaction + , settingsOnRecipient :: SessionID -> Address -> IO HandlerResponse -- ^ Performed when client adds recipient to mail transaction. } -- | Default settings for postie defaultSettings :: Settings defaultSettings = Settings { - settingsPort = PortNumber 3001 - , settingsTimeout = 1800 - , settingsMaxDataSize = 32000 - , settingsHost = Nothing - , settingsTLS = Nothing - , settingsOnException = defaultExceptionHandler - , settingsOnOpen = return () - , settingsOnClose = return () - , settingsBeforeMainLoop = return () - , settingsOnStartTLS = return () - , settingsOnHello = const $ return Accepted - , settingsOnMailFrom = const $ return Accepted - , settingsOnRecipient = const $ return Accepted - } + settingsPort = PortNumber 3001 + , settingsTimeout = 1800 + , settingsMaxDataSize = 32000 + , settingsHost = Nothing + , settingsTLS = Nothing + , settingsOnException = defaultExceptionHandler + , settingsBeforeMainLoop = return () + , settingsOnOpen = const $ return () + , settingsOnClose = const $ return () + , settingsOnStartTLS = const $ return () + , settingsOnHello = void + , settingsOnMailFrom = void + , settingsOnRecipient = void + } + where + void = \_ _ -> return Accepted + -- | Settings for TLS handling data TLSSettings = TLSSettings { certFile :: FilePath -- ^ Path to certificate file @@ -142,8 +145,8 @@ loadCredentials tlss = either (throw . TLS.Error_Certificate) id <$> TLS.credentialLoadX509 (certFile tlss) (keyFile tlss) -defaultExceptionHandler :: SomeException -> IO () -defaultExceptionHandler e = throwIO e `catches` handlers +defaultExceptionHandler :: Maybe SessionID -> SomeException -> IO () +defaultExceptionHandler _ e = throwIO e `catches` handlers where handlers = [Handler ah, Handler oh, Handler tlsh, Handler th, Handler sh] diff --git a/src/Web/Postie/Types.hs b/src/Web/Postie/Types.hs --- a/src/Web/Postie/Types.hs +++ b/src/Web/Postie/Types.hs @@ -3,20 +3,31 @@ HandlerResponse(..) , Mail(..) , Application + , SessionID(..) ) where import Web.Postie.Address +import Data.UUID +import Data.Typeable (Typeable) import Data.ByteString (ByteString) + import Pipes (Producer) +newtype SessionID = SessionID { toUUID :: UUID } + deriving (Eq, Ord, Typeable) + +instance Show SessionID where + show = show . toUUID + -- | Handler response indicating validity of email transaction. data HandlerResponse = Accepted -- ^ Accepted, allow further processing. | Rejected -- ^ Rejected, stop transaction. -- | Received email data Mail = Mail { - mailSender :: Address -- ^ Sender + mailSessionID :: SessionID + , mailSender :: Address -- ^ Sender , mailRecipients :: [Address] -- ^ Recipients , mailBody :: Producer ByteString IO () -- ^ Mail content }