postie 0.2.0.2 → 0.3.0.0
raw patch · 6 files changed
+81/−47 lines, 6 filesdep +uuid
Dependencies added: uuid
Files
- examples/Simple.hs +8/−2
- postie.cabal +2/−2
- src/Web/Postie.hs +7/−6
- src/Web/Postie/Session.hs +26/−13
- src/Web/Postie/Settings.hs +26/−23
- src/Web/Postie/Types.hs +12/−1
examples/Simple.hs view
@@ -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
postie.cabal view
@@ -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
src/Web/Postie.hs view
@@ -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
src/Web/Postie/Session.hs view
@@ -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 <CR><LF>.<CR><LF>" (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
src/Web/Postie/Settings.hs view
@@ -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]
src/Web/Postie/Types.hs view
@@ -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 }