postie 0.4.0.0 → 0.5.0.0
raw patch · 9 files changed
+342/−278 lines, 9 filesdep +stringsearchdep ~basedep ~bytestringdep ~data-default-classnew-component:exe:postie-example-tls
Dependencies added: stringsearch
Dependency ranges changed: base, bytestring, data-default-class, pipes, tls
Files
- examples/Simple.hs +2/−2
- examples/TLS.hs +42/−0
- postie.cabal +17/−3
- src/Web/Postie.hs +29/−21
- src/Web/Postie/Address.hs +28/−14
- src/Web/Postie/Connection.hs +59/−76
- src/Web/Postie/Protocol.hs +2/−1
- src/Web/Postie/Session.hs +137/−106
- src/Web/Postie/Settings.hs +26/−55
examples/Simple.hs view
@@ -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
+ examples/TLS.hs view
@@ -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
postie.cabal view
@@ -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
src/Web/Postie.hs view
@@ -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
src/Web/Postie/Address.hs view
@@ -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
src/Web/Postie/Connection.hs view
@@ -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
src/Web/Postie/Protocol.hs view
@@ -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
src/Web/Postie/Session.hs view
@@ -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 <CR><LF>.<CR><LF>"++ 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)
src/Web/Postie/Settings.hs view
@@ -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 ()