diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -5,9 +5,16 @@ import Pipes.ByteString (stdout) +settings :: Settings +settings = defaultSettings { + settingsTLS = Just $ (tlsSettings "server.crt" "server.key") { + security = DemandStartTLS + } + } + main :: IO () main = do - run 8080 app + runSettings settings app where app (Mail _ _ body) = do runEffect $ body >-> stdout diff --git a/postie.cabal b/postie.cabal --- a/postie.cabal +++ b/postie.cabal @@ -1,23 +1,43 @@ name: postie -version: 0.1.0.0 +version: 0.2.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3 license-file: LICENSE maintainer: alex.biehl@gmail.com +description: `postie` is a little smtp server library for receiving emails. It is currently + in a very early stage and not yet fully standard compatible although the standard + protocol is already supported. + - At the time of writing parameters on smtp commands can not be parsed. + - Handler functions need to return more detailed information to cancel a transaction. + `postie` supportes hooks on key commands in an smtp session like + - on connection open and close + - on `MAIL FROM` command e.g. to intercept transaction if sender is blacklisted + - on `RCPT TO` command e.g. to check if recipient is existent on your server + - and many more + To run `postie` you only need to supply a function which takes a `Mail` and + return `Accepted` or `Rejected`. `mailBody` is a `pipes` `Producer` which + streams the encoded body directly to your application code. The body is not + parsed by `postie` since it depends on what the application wants to do with + the mail data. Eventually I will create a seperate package for parsing mime + messages with `pipes-parse` when postie becomes more stable and standard compliant. author: Alex Biehl data-dir: "" -description: - `postie` is a little smtp server library for receiving emails. It is currently - in a very early stage and not yet standard compatible although the standard - use cases, e.g. receiving emails already work. +source-repository head + type: git + location: https://bitbucket.org/alexbiehl/postie + +flag examples + Description: Build examples + Default: False + Manual: True + library - build-depends: base >=4 && <=5, network >=2.4.1.2, bytestring >=0.10.0.2, - tls >=1.2.2, pipes >=4.1.0, + 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 exposed-modules: Web.Postie Web.Postie.Types Web.Postie.Settings exposed: True buildable: True @@ -28,10 +48,15 @@ Web.Postie.Protocol Web.Postie.Pipes Web.Postie.Address ghc-options: -O2 -Wall -executable simple - build-depends: base -any, bytestring >=0.10.0.2, tls >=1.2.2, - data-default-class >=0.0.1, pipes >=4.1.0, - pipes-bytestring >=2.0.1, postie -any +executable postie-example-simple + 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: Simple.hs buildable: True default-language: Haskell2010 diff --git a/src/Web/Postie.hs b/src/Web/Postie.hs --- a/src/Web/Postie.hs +++ b/src/Web/Postie.hs @@ -6,10 +6,6 @@ , runSettings -- | Runs server with a given application and settings , runSettingsSocket - -- | Runs server with a given application, settings and socket - , runSettingsConnection - -- | Runs server with a given application, settings and an action to open new connections - , runSettingsConnectionMaker -- * Application , module Web.Postie.Types @@ -62,16 +58,9 @@ runSettingsSocket :: Settings -> Socket -> Application -> IO () runSettingsSocket settings socket app = do - policy <- startTlsPolicy + policy <- settingsStartTLSPolicy settings runSettingsConnection settings (getConn policy) app where - startTlsPolicy = do - tlsServerParams <- settingsServerParams settings - return $ case tlsServerParams of - (Just params) | settingsDemandSecure settings -> Demand params - | settingsAllowSecure settings -> Allow params - _ -> NotAvailable - getConn policy = do (s, sa) <- accept socket conn <- socketConnection s policy @@ -83,7 +72,10 @@ getConnMaker = do (conn, sa) <- getConn let mkConn = do - return conn + case connStartTlsPolicy conn of + (Always _) -> connStartTls conn + _ -> return conn + return (mkConn, sa) runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () @@ -105,7 +97,6 @@ onE (toException e) threadDelay 1000000 getConnLoop - onE = settingsOnException settings onOpen = settingsOnOpen settings 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 @@ -7,6 +7,7 @@ connClose, connIsSecure, + connStartTlsPolicy, connStartTls, connAllowStartTLS, connDemandStartTLS, @@ -42,11 +43,11 @@ , connStartTls :: IO Connection -- ^Creates new connection which is secured by TLS. } -data StartTLSPolicy = Allow ServerParams | Demand ServerParams | NotAvailable +data StartTLSPolicy = Always ServerParams | Allow ServerParams | Demand ServerParams | NotAvailable -- | Upgradeable connection from Socket socketConnection :: Socket -> StartTLSPolicy -> IO Connection -socketConnection socket policy = return connection +socketConnection socket policy = return connection where connection = Connection { connRecv = recv socket defaultChunkSize @@ -73,6 +74,7 @@ params = case policy of (Allow p) -> p (Demand p) -> p + (Always p) -> p _ -> error "no upgrade allowed" connAllowStartTLS :: Connection -> Bool diff --git a/src/Web/Postie/Pipes.hs b/src/Web/Postie/Pipes.hs --- a/src/Web/Postie/Pipes.hs +++ b/src/Web/Postie/Pipes.hs @@ -43,7 +43,7 @@ dataChunks :: Int -> Producer BS.ByteString IO () -> Producer BS.ByteString IO () dataChunks n p = lines p >-> go n where - go remaining | remaining <= 0 = throw UnexpectedEndOfInputException + go remaining | remaining <= 0 = throw TooMuchDataException go remaining = do bs <- await unless (bs == ".") $ do 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 @@ -155,10 +155,10 @@ parser = stringCI s *> char ' ' *> takeWhile (notInClass "\r ") parseHelo :: Parser Command -parseHelo = parseHello Helo "HELO" +parseHelo = parseHello Helo "helo" parseEhlo :: Parser Command -parseEhlo = parseHello Ehlo "EHLO" +parseEhlo = parseHello Ehlo "ehlo" parseMailFrom :: Parser Command parseMailFrom = stringCI "mail from:<" *> (MailFrom `fmap` addrSpec) <* char '>' 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 @@ -111,6 +111,7 @@ 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 @@ -139,6 +140,7 @@ modify (\ss -> ss { sessionConnection = conn' , sessionConnectionInput = connectionP conn' + , sessionTransaction = TxnInitial }) handleEvent WantReset = do @@ -162,6 +164,8 @@ handleEvent NeedRcptToFirst = do sendReply $ reply 503 "Need RCPT TO first" + +handleEvent _ = error "impossible" getCommand :: StateT SessionState IO SMTP.Command getCommand = do 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 @@ -3,20 +3,21 @@ Settings(..) , defaultSettings , TLSSettings(..) + , StartTLSPolicy(..) , tlsSettings , defaultTLSSettings , defaultExceptionHandler - , settingsServerParams - , settingsAllowSecure - , settingsDemandSecure + , settingsStartTLSPolicy + , settingsConnectWithTLS + , settingsAllowStartTLS + , settingsDemandStartTLS ) where import Web.Postie.Types import Web.Postie.Address +import qualified Web.Postie.Connection as Connection import Network (HostName, PortID(..)) -import Control.Exception -import GHC.IO.Exception (IOErrorType(..)) import System.IO (hPrint, stderr) import System.IO.Error (ioeGetErrorType) import Data.ByteString (ByteString) @@ -25,7 +26,12 @@ 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. @@ -39,12 +45,13 @@ , settingsOnOpen :: IO () -- ^ Action will be performed when connection has been opened. , settingsOnClose :: IO () -- ^ Action will be performed when connection has been closed. , settingsBeforeMainLoop :: IO () -- ^ Action will be performed before main processing begins. - , settingsOnStartTLS :: IO () - , settingsOnHello :: ByteString -> IO HandlerResponse - , settingsOnMailFrom :: Address -> IO HandlerResponse - , settingsOnRecipient :: Address -> IO HandlerResponse + , 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. } +-- | Default settings for postie defaultSettings :: Settings defaultSettings = Settings { settingsPort = PortNumber 3001 @@ -62,69 +69,83 @@ , settingsOnRecipient = const $ return Accepted } +-- | Settings for TLS handling data TLSSettings = TLSSettings { - certFile :: FilePath - , keyFile :: FilePath - , security :: ConnectionSecurity - , tlsLogging :: TLS.Logging - , tlsAllowedVersions :: [TLS.Version] - , tlsCiphers :: [TLS.Cipher] + certFile :: FilePath -- ^ Path to certificate file + , keyFile :: FilePath -- ^ Path to private key file belonging to certificate + , security :: StartTLSPolicy -- ^ Connection security mode, default is DemandStartTLS + , tlsLogging :: TLS.Logging -- ^ Logging for TLS + , tlsAllowedVersions :: [TLS.Version] -- ^ Supported TLS versions + , tlsCiphers :: [TLS.Cipher] -- ^ Supported ciphers } -data ConnectionSecurity = AllowSecure - | DemandSecure - deriving (Eq, Show) +-- | 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 + | ConnectWithTLS -- ^ Negotiates a TSL context on connection startup. + deriving (Eq, Show) defaultTLSSettings :: TLSSettings defaultTLSSettings = TLSSettings { certFile = "certificate.pem" , keyFile = "key.pem" - , security = DemandSecure + , security = DemandStartTLS , tlsLogging = def , tlsAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12] , 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 } -settingsAllowSecure :: Settings -> Bool -settingsAllowSecure settings = - maybe False (== AllowSecure) $ settingsTLS settings >>= return . security +settingsConnectWithTLS :: Settings -> Bool +settingsConnectWithTLS = checkSecurity ConnectWithTLS -settingsDemandSecure :: Settings -> Bool -settingsDemandSecure settings = - maybe False (== DemandSecure) $ settingsTLS settings >>= return . security +settingsAllowStartTLS :: Settings -> Bool +settingsAllowStartTLS = checkSecurity AllowStartTLS -settingsServerParams :: Settings -> IO (Maybe TLS.ServerParams) -settingsServerParams settings = do - case settingsTLS settings of - Just ts -> do - params <- mkServerParams ts - return $ Just params - _ -> return Nothing - where - mkServerParams tls = do - credential <- either (throw . TLS.Error_Certificate) id <$> - TLS.credentialLoadX509 (certFile tls) (keyFile tls) +settingsDemandStartTLS :: Settings -> Bool +settingsDemandStartTLS = checkSecurity DemandStartTLS - return def { - TLS.serverShared = def { - TLS.sharedCredentials = TLS.Credentials [credential] - }, - TLS.serverSupported = def { - TLS.supportedCiphers = (tlsCiphers tls) - , TLS.supportedVersions = (tlsAllowedVersions tls) - } +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 + +settingsServerParams :: Settings -> IO (Maybe TLS.ServerParams) +settingsServerParams settings = runMaybeT $ do + tlss <- MaybeT . return $ settingsTLS settings + credential <- lift $ loadCredentials tlss + return def { + TLS.serverShared = def { + TLS.sharedCredentials = TLS.Credentials [credential] + }, + TLS.serverSupported = def { + TLS.supportedCiphers = (tlsCiphers tlss) + , TLS.supportedVersions = (tlsAllowedVersions tlss) } + } + where + loadCredentials tlss = either (throw . TLS.Error_Certificate) id <$> + TLS.credentialLoadX509 (certFile tlss) (keyFile tlss) defaultExceptionHandler :: SomeException -> IO () defaultExceptionHandler e = throwIO e `catches` handlers where - handlers = [Handler ah, Handler oh, Handler sh] + handlers = [Handler ah, Handler oh, Handler tlsh, Handler th, Handler sh] ah :: AsyncException -> IO () ah ThreadKilled = return () @@ -136,6 +157,18 @@ | otherwise = hPrint stderr x where et = ioeGetErrorType x + + tlsh :: TLS.TLSException -> IO () + tlsh (TLS.Terminated _ _ _) = return () + tlsh (TLS.HandshakeFailed _) = return () + tlsh x = hPrint stderr x + + th :: TLS.TLSError -> IO () + th TLS.Error_EOF = return () + th (TLS.Error_Packet_Parsing _) = return () + th (TLS.Error_Packet _) = return () + th (TLS.Error_Protocol _) = return () + th x = hPrint stderr x sh :: SomeException -> IO () sh x = hPrint stderr x 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 @@ -12,14 +12,15 @@ -- | Handler response indicating validity of email transaction. data HandlerResponse = Accepted -- ^ Accepted, allow further processing. - | Rejected -- ^ Rejected, stop transaction. + | Rejected -- ^ Rejected, stop transaction. -- | Received email data Mail = Mail { - mailSender :: Address -- ^ Sender of email - , mailRecipients :: [Address] -- ^ Recipients of email - , mailBody :: Producer ByteString IO () -- ^ Producer of mail content + mailSender :: Address -- ^ Sender + , mailRecipients :: [Address] -- ^ Recipients + , mailBody :: Producer ByteString IO () -- ^ Mail content } -- | Application which receives Mails from postie +-- An Application has to fully consume the mailBody part of a mail, the behaviour is undefined if not. type Application = Mail -> IO HandlerResponse