diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -6,8 +6,8 @@ import Pipes.ByteString (stdout) settings :: Settings -settings = defaultSettings { - settingsOnOpen = \sid -> do +settings = def { + settingsOnOpen = \sid _ -> do putStrLn $ show sid ++ " session opened" , settingsOnClose = \sid -> do diff --git a/examples/TLS.hs b/examples/TLS.hs new file mode 100644 --- /dev/null +++ b/examples/TLS.hs @@ -0,0 +1,42 @@ + +module Main where + +import Web.Postie + +import Pipes.ByteString (stdout) + +settings :: Settings +settings = def { + settingsOnOpen = \sid _ -> do + putStrLn $ show sid ++ " session opened" + , + settingsOnClose = \sid -> do + putStrLn $ show sid ++ " session closed" + , + settingsOnMailFrom = \sid addr -> do + putStrLn $ show sid ++ " mail from " ++ show addr + return Accepted + , + settingsOnRecipient = \sid addr -> do + putStrLn $ show sid ++ " rcpt to " ++ show addr + return Accepted + , + settingsOnStartTLS = \sid -> do + putStrLn $ show sid ++ " starttls" + + , + settingsTLS = Just def { + certFile = "server.crt" + , keyFile = "server.key" + } + + } + +main :: IO () +main = do + runSettings settings app + where + app (Mail sid _ _ body) = do + putStrLn $ show sid ++ " data" + 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.4.0.0 +version: 0.5.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -35,7 +35,7 @@ source-repository head type: git - location: https://bitbucket.org/alexbiehl/postie + location: https://github.com/alexbiehl/postie.git flag examples Description: Build examples @@ -46,7 +46,7 @@ build-depends: base >=4 && <=5, network >=2.4.1.2, bytestring >=0.10.0.2, tls >=1.2.6, 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, uuid >= 1.3.3 + mtl >=2.1.2, cprng-aes >=0.5.2, data-default-class >=0.0.1, uuid >= 1.3.3, stringsearch exposed-modules: Web.Postie Web.Postie.Types Web.Postie.Settings Web.Postie.Address Web.Postie.SessionID exposed: True buildable: True @@ -67,6 +67,20 @@ else buildable: False main-is: Simple.hs + buildable: True + default-language: Haskell2010 + hs-source-dirs: examples + +executable postie-example-tls + build-depends: base -any, bytestring -any, tls -any, + data-default-class -any, pipes -any, pipes-bytestring -any, + postie -any + + if flag(examples) + buildable: True + else + buildable: False + main-is: TLS.hs buildable: True default-language: Haskell2010 hs-source-dirs: examples diff --git a/src/Web/Postie.hs b/src/Web/Postie.hs --- a/src/Web/Postie.hs +++ b/src/Web/Postie.hs @@ -33,11 +33,11 @@ import Web.Postie.Connection import Web.Postie.Types import Web.Postie.Session -import Web.Postie.SessionID import Web.Postie.Pipes (UnexpectedEndOfInputException, TooMuchDataException) import Network (PortID (PortNumber), withSocketsDo, listenOn) import Network.Socket (Socket, SockAddr, accept, sClose) +import Network.TLS (ServerParams) import System.Timeout @@ -48,7 +48,7 @@ import qualified Pipes as P run :: Int -> Application -> IO () -run port = runSettings (defaultSettings { settingsPort = PortNumber (fromIntegral port) }) +run port = runSettings (def { settingsPort = PortNumber (fromIntegral port) }) runSettings :: Settings -> Application-> IO () runSettings settings app = withSocketsDo $ @@ -58,29 +58,40 @@ port = settingsPort settings runSettingsSocket :: Settings -> Socket -> Application -> IO () -runSettingsSocket settings socket app = do - policy <- settingsStartTLSPolicy settings - runSettingsConnection settings (getConn policy) app +runSettingsSocket settings socket app = + runSettingsConnection settings getConn app where - getConn policy = do + getConn = do (s, sa) <- accept socket - conn <- socketConnection s policy + conn <- mkSocketConnection s return (conn, sa) runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO () -runSettingsConnection settings getConn = runSettingsConnectionMaker settings getConnMaker +runSettingsConnection settings getConn app = do + serverParams <- mkServerParams' + runSettingsConnectionMaker settings (getConnMaker serverParams) serverParams app where - getConnMaker = do + getConnMaker serverParams = do (conn, sa) <- getConn let mkConn = do - case connStartTlsPolicy conn of - (Always _) -> connStartTls conn - _ -> return conn - + case settingsStartTLSPolicy settings of + Just ConnectWithTLS -> do + let (Just sp) = serverParams + connSetSecure conn sp + _ -> return () + return conn return (mkConn, sa) -runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () -runSettingsConnectionMaker settings getConnMaker app = do + mkServerParams' = + case settingsTLS settings of + Just tls -> do + serverParams <- mkServerParams tls + return (Just serverParams) + _ -> return Nothing + +runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) + -> Maybe ServerParams -> Application -> IO () +runSettingsConnectionMaker settings getConnMaker serverParams app = do settingsBeforeMainLoop settings void $ forever $ do (mkConn, sockAddr) <- getConnLoop @@ -90,8 +101,8 @@ void $ timeout maxDuration $ unmask . handle (onE $ Just sessionID ). - bracket_ (onOpen sessionID) (onClose sessionID) $ - serveConnection sessionID sockAddr settings conn app + bracket_ (onOpen sessionID sockAddr) (onClose sessionID) $ + runSession (mkSessionEnv sessionID app settings conn serverParams) return () return () where @@ -104,7 +115,4 @@ onOpen = settingsOnOpen settings onClose = settingsOnClose settings - maxDuration = (settingsTimeout settings) * 1000000 - -serveConnection :: SessionID -> SockAddr -> Settings -> Connection -> Application -> IO () -serveConnection sid _ = runSession sid + maxDuration = settingsTimeout settings * 1000000 diff --git a/src/Web/Postie/Address.hs b/src/Web/Postie/Address.hs --- a/src/Web/Postie/Address.hs +++ b/src/Web/Postie/Address.hs @@ -1,24 +1,30 @@ module Web.Postie.Address( - Address - , addressLocalPart - , addressDomain - , toByteString + Address -- | Represents an email address + , address -- | Returns address from local and domain part + , addressLocalPart -- | Returns local part of address + , addressDomain -- | Retuns domain part of address + , toByteString -- | Resulting ByteString has format localPart\@domainPart. + , toLazyByteString -- | Resulting Lazy.ByteString has format localPart\@domainPart. + + , parseAddress -- | Parses a ByteString to Address , addrSpec ) where import Data.String +import Data.Maybe (fromMaybe) import Data.Typeable (Typeable) import Data.Attoparsec.Char8 import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS import Control.Applicative +import Control.Monad (void) --- | Represents email address as local and domain parts data Address = Address { - addressLocalPart :: !BS.ByteString -- ^ local part of email address - , addressDomain :: !BS.ByteString -- ^ domain part of email address + addressLocalPart :: !BS.ByteString + , addressDomain :: !BS.ByteString } deriving (Eq, Ord, Typeable) @@ -26,13 +32,21 @@ show = BS.unpack . toByteString instance IsString Address where - fromString = either (error "invalid email literal") id . parseOnly addrSpec . BS.pack + fromString = fromMaybe (error "invalid email literal") . parseAddress . BS.pack --- | Formats Address to canonical string. +address :: BS.ByteString -> BS.ByteString -> Address +address = Address + toByteString :: Address -> BS.ByteString toByteString (Address l d) = BS.concat [l, BS.singleton '@', d] --- | Borrowed form email-validate-2.0.1. Parser for email address. +toLazyByteString :: Address -> LBS.ByteString +toLazyByteString (Address l d) = LBS.fromChunks [l, BS.singleton '@', d] + +parseAddress :: BS.ByteString -> Maybe Address +parseAddress = maybeResult . parse addrSpec + +-- | Address Parser. Borrowed form email-validate-2.0.1. Parser for email address. addrSpec :: Parser Address addrSpec = do localPart <- local @@ -64,7 +78,7 @@ isDomainText x = inClass "\33-\90\94-\126" x || isObsNoWsCtl x quotedString :: Parser BS.ByteString -quotedString = (\x -> BS.concat $ [BS.singleton '"', BS.concat x, BS.singleton '"']) <$> (between (char '"') (char '"') $ +quotedString = (\x -> BS.concat [BS.singleton '"', BS.concat x, BS.singleton '"']) <$> (between (char '"') (char '"') $ many (optional fws >> quotedContent) <* optional fws) quotedContent :: Parser BS.ByteString @@ -85,14 +99,14 @@ <|> ignore (many1 (crlf >> wsp1)) ignore :: Parser a -> Parser () -ignore x = x >> return () +ignore = void between :: Parser l -> Parser r -> Parser x -> Parser x between l r x = l *> x <* r comment :: Parser () -comment = ignore ((between (char '(') (char ')') $ - many (ignore commentContent <|> fws))) +comment = ignore (between (char '(') (char ')') $ + many (ignore commentContent <|> fws)) commentContent :: Parser () commentContent = skipWhile1 isCommentText <|> ignore quotedPair <|> comment diff --git a/src/Web/Postie/Connection.hs b/src/Web/Postie/Connection.hs --- a/src/Web/Postie/Connection.hs +++ b/src/Web/Postie/Connection.hs @@ -1,20 +1,12 @@ module Web.Postie.Connection( - Connection, - StartTLSPolicy(..), - - connRecv, - connSend, - connClose, - connIsSecure, - - connStartTlsPolicy, - connStartTls, - connAllowStartTLS, - connDemandStartTLS, - - socketConnection, - - connectionP + Connection + , connIsSecure + , connSetSecure + , connRecv + , connSend + , connClose + , mkSocketConnection + , toProducer ) where import Network.Socket hiding (send, sendTo, recv, recvFrom) @@ -28,77 +20,68 @@ import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Lazy.Internal (defaultChunkSize) +import Data.IORef + import Control.Exception (finally) import Control.Monad.IO.Class +import Control.Monad (unless) import qualified Pipes as P --- |Low-level connection abstraction -data Connection = Connection { - connRecv :: IO BS.ByteString -- ^ Reads data from connection. Returns empty bytestring if eof is reached. - , connSend :: LBS.ByteString -> IO () -- ^ Sends data over the connection. - , connClose :: IO () -- ^Closes the connection. - , connIsSecure :: Bool -- ^Returns true if this is a TLS-secured connection. - , connStartTlsPolicy :: StartTLSPolicy - , connStartTls :: IO Connection -- ^Creates new connection which is secured by TLS. - } +data ConnectionBackend = ConnPlain Socket + | ConnSecure Context -data StartTLSPolicy = Always ServerParams | Allow ServerParams | Demand ServerParams | NotAvailable +data Connection = Connection (IORef ConnectionBackend) --- | Upgradeable connection from Socket -socketConnection :: Socket -> StartTLSPolicy -> IO Connection -socketConnection socket policy = return connection - where - connection = Connection { - connRecv = recv socket defaultChunkSize - , connSend = sendAll socket - , connClose = sClose socket - , connIsSecure = False - , connStartTlsPolicy = policy - , connStartTls = secureConnection - } +connSetSecure :: Connection -> ServerParams -> IO () +connSetSecure (Connection cbe) params = do + backend <- readIORef cbe + securedBackend <- upgrade backend + writeIORef cbe securedBackend + where upgrade (ConnPlain be) = do + context <- contextNew be params =<< makeSystem + handshake context + return (ConnSecure context) + upgrade (ConnSecure _) = error "already on secure connection" - secureConnection = do - context <- contextNew socket params =<< makeSystem - handshake context +connIsSecure :: Connection -> IO Bool +connIsSecure (Connection cbe) = do + backend <- readIORef cbe + return $ case backend of + (ConnSecure _) -> True + _ -> False - return Connection { - connRecv = recvData context - , connSend = sendData context - , connClose = bye context `finally` contextClose context - , connIsSecure = True - , connStartTlsPolicy = policy - , connStartTls = error "already on secure connection" - } +mkSocketConnection :: Socket -> IO Connection +mkSocketConnection socket = do + conn <- newIORef (ConnPlain socket) + return (Connection conn) - params = case policy of - (Allow p) -> p - (Demand p) -> p - (Always p) -> p - _ -> error "no upgrade allowed" +connBackendRecv :: ConnectionBackend -> IO BS.ByteString +connBackendRecv (ConnPlain socket) = recv socket defaultChunkSize +connBackendRecv (ConnSecure ctx) = recvData ctx -connAllowStartTLS :: Connection -> Bool -connAllowStartTLS conn | connIsSecure conn = False - | allowedByPolicy (connStartTlsPolicy conn) = True - | otherwise = False - where - allowedByPolicy (Allow _) = True - allowedByPolicy (Demand _) = True - allowedByPolicy _ = False +connBackendSend :: ConnectionBackend -> LBS.ByteString -> IO () +connBackendSend (ConnPlain socket) = sendAll socket +connBackendSend (ConnSecure ctx) = sendData ctx -connDemandStartTLS :: Connection -> Bool -connDemandStartTLS conn | connIsSecure conn = False - | demandByPolicy (connStartTlsPolicy conn) = True - | otherwise = False +connRecv :: Connection -> IO BS.ByteString +connRecv (Connection cbe) = readIORef cbe >>= connBackendRecv + +connSend :: Connection -> LBS.ByteString -> IO () +connSend (Connection cbe) lbs = do + backend <- readIORef cbe + connBackendSend backend lbs + +connClose :: Connection -> IO () +connClose (Connection cbe) = closeBackend =<< readIORef cbe where - demandByPolicy (Demand _) = True - demandByPolicy _ = False + closeBackend (ConnPlain socket) = sClose socket + closeBackend (ConnSecure context) = bye context `finally` contextClose context -connectionP :: (MonadIO m) => Connection -> P.Producer' BS.ByteString m () -connectionP conn = go - where go = do - bs <- liftIO $ connRecv conn - if BS.null bs then - return () - else - P.yield bs >> go +toProducer :: (MonadIO m) => Connection -> P.Producer' BS.ByteString m () +toProducer conn = go + where + go = do + bs <- liftIO $ connRecv conn + unless (BS.null bs) $ + P.yield bs >> go diff --git a/src/Web/Postie/Protocol.hs b/src/Web/Postie/Protocol.hs --- a/src/Web/Postie/Protocol.hs +++ b/src/Web/Postie/Protocol.hs @@ -26,6 +26,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Control.Applicative +import Control.Monad (void) data TlsStatus = Active | Forbidden | Permitted | Required deriving (Eq) @@ -147,7 +148,7 @@ ] crlf :: Parser () -crlf = char '\r' >> char '\n' >> return () +crlf = void $ char '\r' >> char '\n' parseHello :: (BS.ByteString -> Command) -> BS.ByteString -> Parser Command parseHello f s = f `fmap` parser 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 + , mkSessionEnv , mkSessionID ) where @@ -15,193 +16,223 @@ import qualified Web.Postie.Protocol as SMTP import Web.Postie.Pipes -import qualified Data.ByteString.Char8 as BS - import qualified Pipes.Parse as P +import qualified Network.TLS as TLS import Control.Applicative +import Control.Monad.Reader import Control.Monad.State +data SessionEnv = SessionEnv { + sessionID :: SessionID + , sessionApp :: Application + , sessionSettings :: Settings + , sessionConnection :: Connection + , sessionServerParams :: Maybe TLS.ServerParams + } + data SessionState = SessionState { - sessionID :: SessionID - , sessionApp :: Application - , sessionSettings :: Settings - , sessionConnection :: Connection - , sessionConnectionInput :: P.Producer BS.ByteString IO () - , sessionProtocolState :: SMTP.SmtpFSM - , sessionTransaction :: Transaction + sessionProtocol :: SMTP.SmtpFSM + , sessionTransaction :: Transaction } +type SessionM a = ReaderT SessionEnv (StateT SessionState IO) a + data Transaction = TxnInitial | TxnHaveMailFrom Address | TxnHaveRecipient Address [Address] -runSession :: SessionID -> Settings -> Connection -> Application -> IO () -runSession sid settings connection app = - evalStateT startSession (initialSessionState sid settings connection app) +mkSessionEnv :: SessionID -> Application -> Settings -> Connection -> Maybe TLS.ServerParams -> SessionEnv +mkSessionEnv = SessionEnv -initialSessionState :: SessionID -> Settings -> Connection -> Application -> SessionState -initialSessionState sid settings connection app = SessionState { - sessionID = sid - , sessionApp = app - , sessionSettings = settings - , sessionConnection = connection - , sessionConnectionInput = connectionP connection - , sessionProtocolState = SMTP.initSmtpFSM - , sessionTransaction = TxnInitial +runSession :: SessionEnv -> IO () +runSession env = evalStateT (runReaderT startSession env) session + where + session = SessionState { + sessionProtocol = SMTP.initSmtpFSM + , sessionTransaction = TxnInitial } - -startSession :: StateT SessionState IO () +startSession :: SessionM () startSession = do sendReply $ reply 220 "hello!" - session + sessionLoop -session :: StateT SessionState IO () -session = do +sessionLoop :: SessionM () +sessionLoop = do (event, fsm') <- SMTP.step <$> getSmtpFsm <*> getCommand <*> getTlsStatus case event of WantQuit -> do sendReply $ reply 221 "goodbye" return () _ -> do - modify (\ss -> ss { sessionProtocolState = fsm' }) - handleEvent event >> session + modify (\ss -> ss { sessionProtocol = fsm' }) + handleEvent event >> sessionLoop where - getSmtpFsm = gets sessionProtocolState + getSmtpFsm = gets sessionProtocol getTlsStatus = do - conn <- gets sessionConnection + SessionEnv { + sessionConnection = conn + , sessionSettings = settings + } <- ask - return $ case conn of - _ | connIsSecure conn -> SMTP.Active - | connDemandStartTLS conn -> SMTP.Required - | connAllowStartTLS conn -> SMTP.Permitted - | otherwise -> SMTP.Forbidden + isSecure <- liftIO (connIsSecure conn) -handleEvent :: SMTP.Event -> StateT SessionState IO () + return $ case settingsStartTLSPolicy settings of + Just p | isSecure -> SMTP.Active + | p == AllowStartTLS -> SMTP.Permitted + | p == DemandStartTLS -> SMTP.Required + _ -> SMTP.Forbidden + +handleEvent :: SMTP.Event -> SessionM () handleEvent (SayHelo x) = do - sid <- gets sessionID - handler <- settingsOnHello <$> gets sessionSettings + SessionEnv { + sessionID = sid + , sessionSettings = settings + } <- ask + + let handler = settingsOnHello settings + result <- liftIO $ handler sid x - case result of - Accepted -> sendReply ok - _ -> sendReply reject + handlerResponse result (sendReply ok) handleEvent (SayEhlo x) = do - sid <- gets sessionID - handler <- settingsOnHello <$> gets sessionSettings + SessionEnv { + sessionID = sid + , sessionSettings = settings + } <- ask + + let handler = settingsOnHello settings + result <- liftIO $ handler sid x - case result of - Accepted -> sendReply =<< ehloAdvertisement - _ -> sendReply reject + handlerResponse result $ + sendReply =<< ehloAdvertisement handleEvent (SayEhloAgain _) = sendReply ok handleEvent (SayHeloAgain _) = sendReply ok handleEvent SayOK = sendReply ok handleEvent (SetMailFrom x) = do - sid <- gets sessionID - handler <- settingsOnMailFrom <$> gets sessionSettings + SessionEnv { + sessionID = sid + , sessionSettings = settings + } <- ask + + let handler = settingsOnMailFrom settings + result <- liftIO $ handler sid x - case result of - Accepted -> do - modify (\ss -> ss { sessionTransaction = TxnHaveMailFrom x }) - sendReply ok - _ -> sendReply reject + handlerResponse result $ do + modify (\ss -> ss { sessionTransaction = TxnHaveMailFrom x }) + sendReply ok handleEvent (AddRcptTo x) = do - sid <- gets sessionID - handler <- settingsOnRecipient <$> gets sessionSettings + SessionEnv { + sessionID = sid + , sessionSettings = settings + } <- ask + + let handler = settingsOnRecipient settings + result <- liftIO $ handler sid x - case result of - Accepted -> do - txn <- gets sessionTransaction - let txn' = case txn of - (TxnHaveMailFrom y) -> TxnHaveRecipient y [x] - (TxnHaveRecipient y xs) -> TxnHaveRecipient y (x:xs) - _ -> error "impossible" - modify (\ss -> ss {sessionTransaction = txn' }) - sendReply ok - _ -> sendReply reject + handlerResponse result $ do + txn <- gets sessionTransaction + let txn' = case txn of + (TxnHaveMailFrom y) -> TxnHaveRecipient y [x] + (TxnHaveRecipient y xs) -> TxnHaveRecipient y (x:xs) + _ -> error "impossible" + modify (\ss -> ss {sessionTransaction = txn' }) + sendReply ok handleEvent StartData = do sendReply $ reply 354 "End data with ." + + SessionEnv { + sessionID = sid + , sessionApp = app + , sessionSettings = settings + , sessionConnection = conn + } <- ask + (TxnHaveRecipient sender recipients) <- gets sessionTransaction - sid <- gets sessionID - mail <- Mail sid sender recipients <$> chunks - app <- gets sessionApp + let chunks = dataChunks (settingsMaxDataSize settings) (toProducer conn) + let mail = Mail sid sender recipients chunks + result <- liftIO $ app mail - case result of - Accepted -> do - sendReply ok - modify (\ss -> ss { sessionTransaction = TxnInitial }) - Rejected -> sendReply reject - where - maxDataLength = settingsMaxDataSize `fmap` gets sessionSettings - chunks = dataChunks <$> maxDataLength <*> gets sessionConnectionInput + handlerResponse result $ do + sendReply ok + modify (\ss -> ss { sessionTransaction = TxnInitial }) handleEvent WantTls = do - sid <- gets sessionID - handler <- settingsOnStartTLS <$> gets sessionSettings + + SessionEnv { + sessionID = sid + , sessionConnection = conn + , sessionSettings = settings + , sessionServerParams = Just serverParams + } <- ask + + let handler = settingsOnStartTLS settings + liftIO $ handler sid sendReply ok - conn <- gets sessionConnection - conn' <- liftIO $ connStartTls conn - modify (\ss -> ss { - sessionConnection = conn' - , sessionConnectionInput = connectionP conn' - , sessionTransaction = TxnInitial - }) + liftIO $ connSetSecure conn serverParams + modify (\ss -> ss { sessionTransaction = TxnInitial }) + handleEvent WantReset = do sendReply ok modify (\ss -> ss { sessionTransaction = TxnInitial }) -handleEvent TlsAlreadyActive = do +handleEvent TlsAlreadyActive = sendReply $ reply 454 "STARTTLS not support (already active)" -handleEvent TlsNotSupported = do +handleEvent TlsNotSupported = sendReply $ reply 454 "STARTTLS not supported" -handleEvent NeedStartTlsFirst = do +handleEvent NeedStartTlsFirst = sendReply $ reply 530 "Issue STARTTLS first" -handleEvent NeedHeloFirst = do +handleEvent NeedHeloFirst = sendReply $ reply 503 "Need EHLO first" -handleEvent NeedMailFromFirst = do +handleEvent NeedMailFromFirst = sendReply $ reply 503 "Need MAIL FROM first" -handleEvent NeedRcptToFirst = do +handleEvent NeedRcptToFirst = sendReply $ reply 503 "Need RCPT TO first" handleEvent _ = error "impossible" -getCommand :: StateT SessionState IO SMTP.Command +handlerResponse :: HandlerResponse -> SessionM () -> SessionM () +handlerResponse Accepted action = action +handlerResponse Rejected _ = sendReply reject + +getCommand :: SessionM SMTP.Command getCommand = do - input <- gets sessionConnectionInput + input <- toProducer `fmap` asks sessionConnection result <- liftIO $ P.evalStateT (attoParser SMTP.parseCommand) input case result of Nothing -> do sendReply $ reply 500 "Syntax error, command unrecognized" getCommand - Just command -> do - return command + Just command -> return command -ehloAdvertisement :: StateT SessionState IO Reply +ehloAdvertisement :: SessionM Reply ehloAdvertisement = do stls <- startTls - let extensions = ["8BITMIME"] ++ stls + let extensions = "8BITMIME" : stls return $ reply' 250 (extensions ++ ["OK"]) where startTls = do - conn <- gets sessionConnection - if (not $ connIsSecure conn) && - (connAllowStartTLS conn) || - (connDemandStartTLS conn) - then - return ["STARTTLS"] - else return [] + SessionEnv { + sessionConnection = conn + , sessionSettings = settings + } <- ask + secure <- liftIO (connIsSecure conn) + return ["STARTTLS" | not secure && ( + case settingsStartTLSPolicy settings of + Just _ -> True + _ -> False)] ok :: Reply ok = reply 250 "OK" @@ -209,7 +240,7 @@ reject :: Reply reject = reply 554 "Transaction failed" -sendReply :: Reply -> StateT SessionState IO () +sendReply :: Reply -> SessionM () sendReply r = do - conn <- gets sessionConnection + conn <- asks sessionConnection liftIO $ connSend conn (renderReply r) 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 @@ -1,38 +1,31 @@ module Web.Postie.Settings( Settings(..) - , defaultSettings , TLSSettings(..) , StartTLSPolicy(..) - , tlsSettings - , defaultTLSSettings - , defaultExceptionHandler , settingsStartTLSPolicy - , settingsConnectWithTLS - , settingsAllowStartTLS - , settingsDemandStartTLS + , defaultExceptionHandler + , mkServerParams + , def -- |reexport from Default class ) where import Web.Postie.Types import Web.Postie.Address import Web.Postie.SessionID -import qualified Web.Postie.Connection as Connection import Network (HostName, PortID(..)) import System.IO (hPrint, stderr) import System.IO.Error (ioeGetErrorType) import Data.ByteString (ByteString) +import Network.Socket (SockAddr) import qualified Network.TLS as TLS import qualified Network.TLS.Extra.Cipher as TLS import Data.Default.Class -import Data.Maybe (fromMaybe) import Control.Exception import GHC.IO.Exception (IOErrorType(..)) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe import Control.Applicative ((<$>)) -- | Settings to configure posties behaviour. @@ -44,7 +37,7 @@ , settingsTLS :: Maybe TLSSettings -- ^ TLS settings if you wish to secure connections. , settingsOnException :: Maybe SessionID -> SomeException -> IO () -- ^ Exception handler (default is defaultExceptionHandler) , settingsBeforeMainLoop :: IO () -- ^ Action will be performed before main processing begins. - , settingsOnOpen :: SessionID -> IO () -- ^ Action will be performed when connection has been opened. + , settingsOnOpen :: SessionID -> SockAddr -> 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 @@ -52,6 +45,9 @@ , settingsOnRecipient :: SessionID -> Address -> IO HandlerResponse -- ^ Performed when client adds recipient to mail transaction. } +instance Default Settings where + def = defaultSettings + -- | Default settings for postie defaultSettings :: Settings defaultSettings = Settings { @@ -62,7 +58,7 @@ , settingsTLS = Nothing , settingsOnException = defaultExceptionHandler , settingsBeforeMainLoop = return () - , settingsOnOpen = const $ return () + , settingsOnOpen = \_ _ -> return () , settingsOnClose = const $ return () , settingsOnStartTLS = const $ return () , settingsOnHello = void @@ -70,7 +66,7 @@ , settingsOnRecipient = void } where - void = \_ _ -> return Accepted + void _ _ = return Accepted -- | Settings for TLS handling @@ -83,6 +79,9 @@ , tlsCiphers :: [TLS.Cipher] -- ^ Supported ciphers } +instance Default TLSSettings where + def = defaultTLSSettings + -- | Connection security policy, either via STARTTLS command or on connection initiation. data StartTLSPolicy = AllowStartTLS -- ^ Allows clients to use STARTTLS command | DemandStartTLS -- ^ Client needs to send STARTTLS command before issuing a mail transaction @@ -99,52 +98,24 @@ , tlsCiphers = TLS.ciphersuite_all } --- | Convenience function for creation of TLSSettings taking certificate and key file paths as parameters. -tlsSettings :: FilePath -> FilePath -> TLSSettings -tlsSettings cert key = defaultTLSSettings { - certFile = cert - , keyFile = key - } - -settingsConnectWithTLS :: Settings -> Bool -settingsConnectWithTLS = checkSecurity ConnectWithTLS - -settingsAllowStartTLS :: Settings -> Bool -settingsAllowStartTLS = checkSecurity AllowStartTLS - -settingsDemandStartTLS :: Settings -> Bool -settingsDemandStartTLS = checkSecurity DemandStartTLS - -checkSecurity :: StartTLSPolicy -> Settings -> Bool -checkSecurity p s = fromMaybe False $ do - tlss <- settingsTLS s - return (security tlss == p) - -settingsStartTLSPolicy :: Settings -> IO Connection.StartTLSPolicy -settingsStartTLSPolicy settings = do - mserverParams <- settingsServerParams settings - return $ case mserverParams of - (Just params) | settingsDemandStartTLS settings -> Connection.Demand params - | settingsAllowStartTLS settings -> Connection.Allow params - | settingsConnectWithTLS settings -> Connection.Always params - _ -> Connection.NotAvailable +settingsStartTLSPolicy :: Settings -> Maybe StartTLSPolicy +settingsStartTLSPolicy settings = security `fmap` settingsTLS settings -settingsServerParams :: Settings -> IO (Maybe TLS.ServerParams) -settingsServerParams settings = runMaybeT $ do - tlss <- MaybeT . return $ settingsTLS settings - credential <- lift $ loadCredentials tlss +mkServerParams :: TLSSettings -> IO TLS.ServerParams +mkServerParams tlsSettings = do + credentials <- loadCredentials return def { TLS.serverShared = def { - TLS.sharedCredentials = TLS.Credentials [credential] + TLS.sharedCredentials = TLS.Credentials [credentials] }, TLS.serverSupported = def { - TLS.supportedCiphers = (tlsCiphers tlss) - , TLS.supportedVersions = (tlsAllowedVersions tlss) + TLS.supportedCiphers = tlsCiphers tlsSettings + , TLS.supportedVersions = tlsAllowedVersions tlsSettings } } where - loadCredentials tlss = either (throw . TLS.Error_Certificate) id <$> - TLS.credentialLoadX509 (certFile tlss) (keyFile tlss) + loadCredentials = either (throw . TLS.Error_Certificate) id <$> + TLS.credentialLoadX509 (certFile tlsSettings) (keyFile tlsSettings) defaultExceptionHandler :: Maybe SessionID -> SomeException -> IO () defaultExceptionHandler _ e = throwIO e `catches` handlers @@ -163,9 +134,9 @@ et = ioeGetErrorType x tlsh :: TLS.TLSException -> IO () - tlsh (TLS.Terminated _ _ _) = return () - tlsh (TLS.HandshakeFailed _) = return () - tlsh x = hPrint stderr x + tlsh TLS.Terminated{} = return () + tlsh TLS.HandshakeFailed{} = return () + tlsh x = hPrint stderr x th :: TLS.TLSError -> IO () th TLS.Error_EOF = return ()