diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Alex Biehl + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alex Biehl nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Simple.hs b/examples/Simple.hs new file mode 100644 --- /dev/null +++ b/examples/Simple.hs @@ -0,0 +1,14 @@ + +module Main where + +import Web.Postie + +import Pipes.ByteString (stdout) + +main :: IO () +main = do + run 8080 app + where + app (Mail _ _ body) = do + runEffect $ body >-> stdout + return Accepted diff --git a/postie.cabal b/postie.cabal new file mode 100644 --- /dev/null +++ b/postie.cabal @@ -0,0 +1,38 @@ +name: postie +version: 0.1.0.0 +cabal-version: >=1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: alex.biehl@gmail.com +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. + +library + build-depends: base >=4 && <=5, network >=2.4.1.2, bytestring >=0.10.0.2, + tls >=1.2.2, 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 + exposed-modules: Web.Postie Web.Postie.Types Web.Postie.Settings + exposed: True + buildable: True + default-language: Haskell2010 + default-extensions: Rank2Types OverloadedStrings DeriveDataTypeable + hs-source-dirs: src + other-modules: Web.Postie.Connection Web.Postie.Session + 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 + main-is: Simple.hs + buildable: True + default-language: Haskell2010 + hs-source-dirs: examples diff --git a/src/Web/Postie.hs b/src/Web/Postie.hs new file mode 100644 --- /dev/null +++ b/src/Web/Postie.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Web.Postie( + run + -- | Runs server with a given application on a specified port + , 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 + + -- * Settings + , module Web.Postie.Settings + + -- * Address + , module Web.Postie.Address + + -- * Exceptions + , UnexpectedEndOfInputException + , TooMuchDataException + + -- * Re-exports + -- $reexports + , P.Producer + , P.Consumer + , P.runEffect + , (P.>->) + ) where + +import Web.Postie.Address +import Web.Postie.Settings +import Web.Postie.Connection +import Web.Postie.Types +import Web.Postie.Session +import Web.Postie.Pipes (UnexpectedEndOfInputException, TooMuchDataException) + +import Network (PortID (PortNumber), withSocketsDo, listenOn) +import Network.Socket (Socket, SockAddr, accept, sClose) + +import System.Timeout + +import Control.Monad (forever, void) +import Control.Exception as E +import Control.Concurrent + +import qualified Pipes as P + +run :: Int -> Application -> IO () +run port = runSettings (defaultSettings { settingsPort = PortNumber (fromIntegral port) }) + +runSettings :: Settings -> Application-> IO () +runSettings settings app = withSocketsDo $ + bracket (listenOn port) sClose $ \socket -> + runSettingsSocket settings socket app + where + port = settingsPort settings + +runSettingsSocket :: Settings -> Socket -> Application -> IO () +runSettingsSocket settings socket app = do + policy <- startTlsPolicy + 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 + return (conn, sa) + +runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO () +runSettingsConnection settings getConn = runSettingsConnectionMaker settings getConnMaker + where + getConnMaker = do + (conn, sa) <- getConn + let mkConn = do + return conn + return (mkConn, sa) + +runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO () +runSettingsConnectionMaker settings getConnMaker app = do + settingsBeforeMainLoop settings + void $ forever $ do + (mkConn, sockAddr) <- getConnLoop + void $ forkIOWithUnmask $ \unmask -> do + bracket mkConn connClose $ \conn -> + void $ timeout maxDuration $ + unmask . + handle onE . + bracket_ onOpen onClose $ + serveConnection sockAddr settings conn app + return () + return () + where + getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do + onE (toException e) + threadDelay 1000000 + getConnLoop + + + onE = settingsOnException settings + onOpen = settingsOnOpen settings + onClose = settingsOnClose settings + + maxDuration = (settingsTimeout settings) * 1000000 + +serveConnection :: SockAddr -> Settings -> Connection -> Application -> IO () +serveConnection _ = runSession diff --git a/src/Web/Postie/Address.hs b/src/Web/Postie/Address.hs new file mode 100644 --- /dev/null +++ b/src/Web/Postie/Address.hs @@ -0,0 +1,141 @@ + +module Web.Postie.Address( + Address + , addressLocalPart + , addressDomain + , toByteString + + , addrSpec + ) where + +import Data.String +import Data.Typeable (Typeable) +import Data.Attoparsec.Char8 +import qualified Data.ByteString.Char8 as BS + +import Control.Applicative + +-- | 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 + } + deriving (Eq, Ord, Typeable) + +instance Show Address where + show = show . toByteString + +instance IsString Address where + fromString = either (error "invalid email literal") id . parseOnly addrSpec . BS.pack + +-- | Formats Address to canonical string. +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. +addrSpec :: Parser Address +addrSpec = do + localPart <- local + _ <- char '@' + domainPart <- domain + return (Address localPart domainPart) + +local :: Parser BS.ByteString +local = dottedAtoms + +domain :: Parser BS.ByteString +domain = dottedAtoms <|> domainLiteral + +dottedAtoms :: Parser BS.ByteString +dottedAtoms = BS.intercalate (BS.singleton '.') <$> + (optional cfws *> (atom <|> quotedString) <* optional cfws) `sepBy1` (char '.') + +atom :: Parser BS.ByteString +atom = takeWhile1 isAtomText + +isAtomText :: Char -> Bool +isAtomText x = isAlphaNum x || inClass "!#$%&'*+/=?^_`{|}~-" x + +domainLiteral :: Parser BS.ByteString +domainLiteral = (BS.cons '[' . flip BS.snoc ']' . BS.concat) <$> (between (optional cfws *> char '[') (char ']' <* optional cfws) $ + many (optional fws >> takeWhile1 isDomainText) <* optional fws) + +isDomainText :: Char -> Bool +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 '"') $ + many (optional fws >> quotedContent) <* optional fws) + +quotedContent :: Parser BS.ByteString +quotedContent = takeWhile1 isQuotedText <|> quotedPair + +isQuotedText :: Char -> Bool +isQuotedText x = inClass "\33\35-\91\93-\126" x || isObsNoWsCtl x + +quotedPair :: Parser BS.ByteString +quotedPair = (BS.cons '\\' . BS.singleton) <$> (char '\\' *> (vchar <|> wsp <|> lf <|> cr <|> obsNoWsCtl <|> nullChar)) + +cfws :: Parser () +cfws = ignore $ many (comment <|> fws) + +fws :: Parser () +fws = ignore $ + ignore (wsp1 >> optional (crlf >> wsp1)) + <|> ignore (many1 (crlf >> wsp1)) + +ignore :: Parser a -> Parser () +ignore x = x >> return () + +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))) + +commentContent :: Parser () +commentContent = skipWhile1 isCommentText <|> ignore quotedPair <|> comment + +isCommentText :: Char -> Bool +isCommentText x = inClass "\33-\39\42-\91\93-\126" x || isObsNoWsCtl x + +nullChar :: Parser Char +nullChar = char '\0' + +skipWhile1 :: (Char -> Bool) -> Parser () +skipWhile1 x = satisfy x >> skipWhile x + +wsp1 :: Parser() +wsp1 = skipWhile1 isWsp + +wsp :: Parser Char +wsp = satisfy isWsp + +isWsp :: Char -> Bool +isWsp x = x == ' ' || x == '\t' + + +isAlphaNum :: Char -> Bool +isAlphaNum x = isDigit x || isAlpha_ascii x + +cr :: Parser Char +cr = char '\r' + +lf :: Parser Char +lf = char '\n' + +crlf :: Parser () +crlf = cr >> lf >> return () + +isVchar :: Char -> Bool +isVchar = inClass "\x21-\x7e" + +vchar :: Parser Char +vchar = satisfy isVchar + +isObsNoWsCtl :: Char -> Bool +isObsNoWsCtl = inClass "\1-\8\11-\12\14-\31\127" + +obsNoWsCtl :: Parser Char +obsNoWsCtl = satisfy isObsNoWsCtl diff --git a/src/Web/Postie/Connection.hs b/src/Web/Postie/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Web/Postie/Connection.hs @@ -0,0 +1,102 @@ +module Web.Postie.Connection( + Connection, + StartTLSPolicy(..), + + connRecv, + connSend, + connClose, + connIsSecure, + + connStartTls, + connAllowStartTLS, + connDemandStartTLS, + + socketConnection, + + connectionP + ) where + +import Network.Socket hiding (send, sendTo, recv, recvFrom) +import Network.Socket.ByteString.Lazy (sendAll) +import Network.Socket.ByteString hiding (sendAll) + +import Network.TLS +import Crypto.Random.AESCtr + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.ByteString.Lazy.Internal (defaultChunkSize) + +import Control.Exception (finally) +import Control.Monad.IO.Class + +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 StartTLSPolicy = Allow ServerParams | Demand ServerParams | NotAvailable + +-- | 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 + } + + secureConnection = do + context <- contextNew socket params =<< makeSystem + handshake context + + return Connection { + connRecv = recvData context + , connSend = sendData context + , connClose = bye context `finally` contextClose context + , connIsSecure = True + , connStartTlsPolicy = policy + , connStartTls = error "already on secure connection" + } + + params = case policy of + (Allow p) -> p + (Demand p) -> p + _ -> error "no upgrade allowed" + +connAllowStartTLS :: Connection -> Bool +connAllowStartTLS conn | connIsSecure conn = False + | allowedByPolicy (connStartTlsPolicy conn) = True + | otherwise = False + where + allowedByPolicy (Allow _) = True + allowedByPolicy (Demand _) = True + allowedByPolicy _ = False + +connDemandStartTLS :: Connection -> Bool +connDemandStartTLS conn | connIsSecure conn = False + | demandByPolicy (connStartTlsPolicy conn) = True + | otherwise = False + where + demandByPolicy (Demand _) = True + demandByPolicy _ = False + +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 diff --git a/src/Web/Postie/Pipes.hs b/src/Web/Postie/Pipes.hs new file mode 100644 --- /dev/null +++ b/src/Web/Postie/Pipes.hs @@ -0,0 +1,83 @@ + +module Web.Postie.Pipes( + dataChunks + , attoParser + , UnexpectedEndOfInputException + , TooMuchDataException + ) where + +import Prelude hiding (lines) + +import Pipes +import Pipes.Parse + +import Data.Maybe (fromMaybe) +import Data.Typeable (Typeable) +import qualified Data.ByteString.Char8 as BS +import qualified Data.Attoparsec as AT + +import Control.Monad (unless) +import Control.Applicative +import Control.Exception (throw, Exception) + +data UnexpectedEndOfInputException = UnexpectedEndOfInputException + deriving (Show, Typeable) + +data TooMuchDataException = TooMuchDataException + deriving (Show, Typeable) + +instance Exception UnexpectedEndOfInputException +instance Exception TooMuchDataException + +attoParser :: AT.Parser r -> Parser BS.ByteString IO (Maybe r) +attoParser p = do + result <- AT.parseWith draw' p "" + case result of + AT.Done t r -> do + unless (BS.null t) (unDraw t) + return (Just r) + _ -> return Nothing + where + draw' = fromMaybe "" <$> draw + +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 = do + bs <- await + unless (bs == ".") $ do + yield (unescape bs) + yield "\r\n" + go (remaining - BS.length bs - 2) + + unescape bs | BS.null bs = bs + | BS.head bs == '.' && BS.length bs > 1 = BS.tail bs + | otherwise = bs + +lines :: Producer BS.ByteString IO () -> Producer BS.ByteString IO () +lines = go + where + go p = do + (line, leftover) <- lift $ runStateT lineParser p + yield line + go leftover + +lineParser :: Parser BS.ByteString IO BS.ByteString +lineParser = go id + where + go f = do + bs <- maybe (throw UnexpectedEndOfInputException) (return . f) =<< draw + case BS.elemIndex '\r' bs of + Nothing -> go (BS.append bs) + Just n -> do + let here = killCR $ BS.take n bs + rest = BS.drop (n + 1) bs + unDraw rest + return here + + killCR bs + | BS.null bs = bs + | BS.head bs == '\n' || BS.head bs == '\r' = killCR $ BS.tail bs + | BS.last bs == '\n' || BS.last bs == '\r' = killCR $ BS.init bs + | otherwise = bs diff --git a/src/Web/Postie/Protocol.hs b/src/Web/Postie/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Web/Postie/Protocol.hs @@ -0,0 +1,179 @@ + +module Web.Postie.Protocol( + TlsStatus(..) + , Mailbox + , Event(..) + , Command(..) + , SmtpFSM + , Reply + , initSmtpFSM + , step + , reply + , reply' + , renderReply + + , parseCommand + , parseHelo + , parseMailFrom + ) where + +import Prelude hiding (takeWhile) + +import Web.Postie.Address + +import Data.Attoparsec.Char8 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Control.Applicative + +data TlsStatus = Active | Forbidden | Permitted | Required deriving (Eq) + +data SessionState = Unknown + | HaveHelo + | HaveEhlo + | HaveMailFrom + | HaveRcptTo + | HaveData + | HaveQuit + +type Mailbox = Address + +data Event = SayHelo BS.ByteString + | SayHeloAgain BS.ByteString + | SayEhlo BS.ByteString + | SayEhloAgain BS.ByteString + | SayOK + | SetMailFrom Mailbox + | AddRcptTo Mailbox + | StartData + | WantTls + | WantReset + | WantQuit + | TlsAlreadyActive + | TlsNotSupported + | NeedStartTlsFirst + | NeedHeloFirst + | NeedMailFromFirst + | NeedRcptToFirst + deriving (Eq, Show) + +data Command = Helo BS.ByteString + | Ehlo BS.ByteString + | MailFrom Mailbox + | RcptTo Mailbox + | StartTls + | Data + | Rset + | Quit + deriving (Eq, Show) + +newtype SmtpFSM = SmtpFSM { step :: Command -> TlsStatus -> (Event, SmtpFSM) } + +initSmtpFSM :: SmtpFSM +initSmtpFSM = SmtpFSM (handleSmtpCmd Unknown) + +handleSmtpCmd :: SessionState -> Command -> TlsStatus -> (Event, SmtpFSM) +handleSmtpCmd st cmd tlsSt = match tlsSt st cmd + where + match :: TlsStatus -> SessionState -> Command -> (Event, SmtpFSM) + match _ HaveQuit _ = undefined + match _ HaveData Data = undefined + match _ _ Quit = trans (HaveQuit, WantQuit) + match _ Unknown (Helo x) = trans (HaveHelo, SayHelo x) + match _ _ (Helo x) = event (SayHeloAgain x) + match _ Unknown (Ehlo x) = trans (HaveEhlo, SayEhlo x) + match _ _ (Ehlo x) = event (SayEhloAgain x) + match Required _ (MailFrom _) = event NeedStartTlsFirst + match _ Unknown (MailFrom _) = event NeedHeloFirst + match _ _ (MailFrom x) = trans (HaveMailFrom, SetMailFrom x) + match Required _ (RcptTo _) = event NeedStartTlsFirst + match _ Unknown (RcptTo _) = event NeedHeloFirst + match _ HaveHelo (RcptTo _) = event NeedMailFromFirst + match _ HaveEhlo (RcptTo _) = event NeedMailFromFirst + match _ _ (RcptTo x) = trans (HaveRcptTo, AddRcptTo x) + match Required _ Data = event NeedStartTlsFirst + match _ Unknown Data = event NeedHeloFirst + match _ HaveHelo Data = event NeedMailFromFirst + match _ HaveEhlo Data = event NeedMailFromFirst + match _ HaveMailFrom Data = event NeedRcptToFirst + match _ HaveRcptTo Data = trans (HaveData, StartData) + match Required _ Rset = event NeedStartTlsFirst + match _ _ Rset = trans (HaveHelo, WantReset) + match Active _ StartTls = event TlsAlreadyActive + match Forbidden _ StartTls = event TlsNotSupported + match _ _ StartTls = trans (Unknown, WantTls) + + event :: Event -> (Event, SmtpFSM) + event e = (e, SmtpFSM (handleSmtpCmd st)) + + trans :: (SessionState, Event) -> (Event, SmtpFSM) + trans (st', e) = (e, SmtpFSM (handleSmtpCmd st')) + + +type StatusCode = Int + +data Reply = Reply StatusCode [LBS.ByteString] + +reply :: StatusCode -> LBS.ByteString -> Reply +reply c s = reply' c [s] + +reply' :: StatusCode -> [LBS.ByteString] -> Reply +reply' = Reply + +renderReply :: Reply -> LBS.ByteString +renderReply (Reply code msgs) = LBS.concat msg' + where + prefixCon = LBS.pack (show code ++ "-") + prefixEnd = LBS.pack (show code ++ " ") + fmt p l = LBS.concat [p, l, "\r\n"] + (x:xs) = reverse msgs + msgCon = map (fmt prefixCon) xs + msgEnd = fmt prefixEnd x + msg' = reverse (msgEnd:msgCon) + +parseCommand :: Parser Command +parseCommand = commands <* crlf + where + commands = choice [ + parseQuit + , parseData + , parseRset + , parseHelo + , parseEhlo + , parseStartTls + , parseMailFrom + , parseRcptTo + ] + +crlf :: Parser () +crlf = char '\r' >> char '\n' >> return () + +parseHello :: (BS.ByteString -> Command) -> BS.ByteString -> Parser Command +parseHello f s = f `fmap` parser + where + parser = stringCI s *> char ' ' *> takeWhile (notInClass "\r ") + +parseHelo :: Parser Command +parseHelo = parseHello Helo "HELO" + +parseEhlo :: Parser Command +parseEhlo = parseHello Ehlo "EHLO" + +parseMailFrom :: Parser Command +parseMailFrom = stringCI "mail from:<" *> (MailFrom `fmap` addrSpec) <* char '>' + +parseRcptTo :: Parser Command +parseRcptTo = stringCI "rcpt to:<" *> (RcptTo `fmap` addrSpec) <* char '>' + +parseStartTls :: Parser Command +parseStartTls = stringCI "starttls" *> pure StartTls + +parseRset :: Parser Command +parseRset = stringCI "rset" *> pure Rset + +parseData :: Parser Command +parseData = stringCI "data" *> pure Data + +parseQuit :: Parser Command +parseQuit = stringCI "quit" *> pure Quit diff --git a/src/Web/Postie/Session.hs b/src/Web/Postie/Session.hs new file mode 100644 --- /dev/null +++ b/src/Web/Postie/Session.hs @@ -0,0 +1,201 @@ + +module Web.Postie.Session( + runSession + ) where + +import Prelude hiding (lines) + +import Web.Postie.Address +import Web.Postie.Types +import Web.Postie.Settings +import Web.Postie.Connection +import Web.Postie.Protocol (Event(..), Reply, reply, reply', renderReply) +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 Control.Applicative +import Control.Monad.State + +data SessionState = SessionState { + sessionApp :: Application + , sessionSettings :: Settings + , sessionConnection :: Connection + , sessionConnectionInput :: P.Producer BS.ByteString IO () + , sessionProtocolState :: SMTP.SmtpFSM + , sessionTransaction :: Transaction + } + +data Transaction = TxnInitial + | TxnHaveMailFrom Address + | TxnHaveRecipient Address [Address] + +runSession :: Settings -> Connection -> Application -> IO () +runSession settings connection app = + evalStateT startSession (initialSessionState settings connection app) + +initialSessionState :: Settings -> Connection -> Application -> SessionState +initialSessionState settings connection app = SessionState { + sessionApp = app + , sessionSettings = settings + , sessionConnection = connection + , sessionConnectionInput = connectionP connection + , sessionProtocolState = SMTP.initSmtpFSM + , sessionTransaction = TxnInitial + } + + +startSession :: StateT SessionState IO () +startSession = do + sendReply $ reply 220 "hello!" + session + +session :: StateT SessionState IO () +session = 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 + where + getSmtpFsm = gets sessionProtocolState + getTlsStatus = do + conn <- gets sessionConnection + + return $ case conn of + _ | connIsSecure conn -> SMTP.Active + | connDemandStartTLS conn -> SMTP.Required + | connAllowStartTLS conn -> SMTP.Permitted + | otherwise -> SMTP.Forbidden + +handleEvent :: SMTP.Event -> StateT SessionState IO () +handleEvent (SayHelo x) = do + handler <- settingsOnHello <$> gets sessionSettings + result <- liftIO $ handler x + case result of + Accepted -> sendReply ok + _ -> sendReply reject + +handleEvent (SayEhlo x) = do + handler <- settingsOnHello <$> gets sessionSettings + result <- liftIO $ handler x + case result of + Accepted -> sendReply =<< ehloAdvertisement + _ -> sendReply reject + +handleEvent (SayEhloAgain _) = sendReply ok +handleEvent (SayHeloAgain _) = sendReply ok +handleEvent SayOK = sendReply ok + +handleEvent (SetMailFrom x) = do + handler <- settingsOnMailFrom <$> gets sessionSettings + result <- liftIO $ handler x + case result of + Accepted -> do + modify (\ss -> ss { sessionTransaction = TxnHaveMailFrom x }) + sendReply ok + _ -> sendReply reject + +handleEvent (AddRcptTo x) = do + handler <- settingsOnRecipient <$> gets sessionSettings + result <- liftIO $ handler 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) + modify (\ss -> ss {sessionTransaction = txn' }) + sendReply ok + _ -> sendReply reject + +handleEvent StartData = do + sendReply $ reply 354 "End data with ." + (TxnHaveRecipient sender recipients) <- gets sessionTransaction + mail <- Mail sender recipients <$> chunks + app <- gets sessionApp + 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 + +handleEvent WantTls = do + handler <- settingsOnStartTLS <$> gets sessionSettings + liftIO $ handler + sendReply ok + conn <- gets sessionConnection + conn' <- liftIO $ connStartTls conn + modify (\ss -> ss { + sessionConnection = conn' + , sessionConnectionInput = connectionP conn' + }) + +handleEvent WantReset = do + sendReply ok + modify (\ss -> ss { sessionTransaction = TxnInitial }) + +handleEvent TlsAlreadyActive = do + sendReply $ reply 454 "STARTTLS not support (already active)" + +handleEvent TlsNotSupported = do + sendReply $ reply 454 "STARTTLS not supported" + +handleEvent NeedStartTlsFirst = do + sendReply $ reply 530 "Issue STARTTLS first" + +handleEvent NeedHeloFirst = do + sendReply $ reply 503 "Need EHLO first" + +handleEvent NeedMailFromFirst = do + sendReply $ reply 503 "Need MAIL FROM first" + +handleEvent NeedRcptToFirst = do + sendReply $ reply 503 "Need RCPT TO first" + +getCommand :: StateT SessionState IO SMTP.Command +getCommand = do + input <- gets sessionConnectionInput + 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 + +ehloAdvertisement :: StateT SessionState IO Reply +ehloAdvertisement = do + stls <- startTls + 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 [] + +ok :: Reply +ok = reply 250 "OK" + +reject :: Reply +reject = reply 554 "Transaction failed" + +sendReply :: Reply -> StateT SessionState IO () +sendReply r = do + conn <- gets sessionConnection + liftIO $ connSend conn (renderReply r) diff --git a/src/Web/Postie/Settings.hs b/src/Web/Postie/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Web/Postie/Settings.hs @@ -0,0 +1,141 @@ + +module Web.Postie.Settings( + Settings(..) + , defaultSettings + , TLSSettings(..) + , tlsSettings + , defaultTLSSettings + , defaultExceptionHandler + , settingsServerParams + , settingsAllowSecure + , settingsDemandSecure + ) where + +import Web.Postie.Types +import Web.Postie.Address + +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) + +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TLS + +import Data.Default.Class + +import Control.Applicative ((<$>)) + +-- | Settings to configure posties behaviour. +data Settings = Settings { + settingsPort :: PortID -- ^ Port postie will run on. + , settingsTimeout :: Int -- ^ Timeout for connections in seconds + , 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. + , settingsBeforeMainLoop :: IO () -- ^ Action will be performed before main processing begins. + , settingsOnStartTLS :: IO () + , settingsOnHello :: ByteString -> IO HandlerResponse + , settingsOnMailFrom :: Address -> IO HandlerResponse + , settingsOnRecipient :: Address -> IO HandlerResponse + } + +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 + } + +data TLSSettings = TLSSettings { + certFile :: FilePath + , keyFile :: FilePath + , security :: ConnectionSecurity + , tlsLogging :: TLS.Logging + , tlsAllowedVersions :: [TLS.Version] + , tlsCiphers :: [TLS.Cipher] + } + +data ConnectionSecurity = AllowSecure + | DemandSecure + deriving (Eq, Show) + +defaultTLSSettings :: TLSSettings +defaultTLSSettings = TLSSettings { + certFile = "certificate.pem" + , keyFile = "key.pem" + , security = DemandSecure + , tlsLogging = def + , tlsAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12] + , tlsCiphers = TLS.ciphersuite_all + } + +tlsSettings :: FilePath -> FilePath -> TLSSettings +tlsSettings cert key = defaultTLSSettings { + certFile = cert + , keyFile = key + } + +settingsAllowSecure :: Settings -> Bool +settingsAllowSecure settings = + maybe False (== AllowSecure) $ settingsTLS settings >>= return . security + +settingsDemandSecure :: Settings -> Bool +settingsDemandSecure settings = + maybe False (== DemandSecure) $ settingsTLS settings >>= return . security + +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) + + return def { + TLS.serverShared = def { + TLS.sharedCredentials = TLS.Credentials [credential] + }, + TLS.serverSupported = def { + TLS.supportedCiphers = (tlsCiphers tls) + , TLS.supportedVersions = (tlsAllowedVersions tls) + } + } + +defaultExceptionHandler :: SomeException -> IO () +defaultExceptionHandler e = throwIO e `catches` handlers + where + handlers = [Handler ah, Handler oh, Handler sh] + + ah :: AsyncException -> IO () + ah ThreadKilled = return () + ah x = hPrint stderr x + + oh :: IOException -> IO () + oh x + | et == ResourceVanished || et == InvalidArgument = return () + | otherwise = hPrint stderr x + where + et = ioeGetErrorType x + + sh :: SomeException -> IO () + sh x = hPrint stderr x diff --git a/src/Web/Postie/Types.hs b/src/Web/Postie/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Postie/Types.hs @@ -0,0 +1,25 @@ + +module Web.Postie.Types( + HandlerResponse(..) + , Mail(..) + , Application + ) where + +import Web.Postie.Address + +import Data.ByteString (ByteString) +import Pipes (Producer) + +-- | 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 of email + , mailRecipients :: [Address] -- ^ Recipients of email + , mailBody :: Producer ByteString IO () -- ^ Producer of mail content + } + +-- | Application which receives Mails from postie +type Application = Mail -> IO HandlerResponse