postie (empty) → 0.1.0.0
raw patch · 12 files changed
+1073/−0 lines, 12 filesdep +attoparsecdep +basedep +bytestringsetup-changed
Dependencies added: attoparsec, base, bytestring, cprng-aes, data-default-class, mtl, network, pipes, pipes-bytestring, pipes-parse, postie, tls, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- examples/Simple.hs +14/−0
- postie.cabal +38/−0
- src/Web/Postie.hs +117/−0
- src/Web/Postie/Address.hs +141/−0
- src/Web/Postie/Connection.hs +102/−0
- src/Web/Postie/Pipes.hs +83/−0
- src/Web/Postie/Protocol.hs +179/−0
- src/Web/Postie/Session.hs +201/−0
- src/Web/Postie/Settings.hs +141/−0
- src/Web/Postie/Types.hs +25/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Simple.hs view
@@ -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
+ postie.cabal view
@@ -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
+ src/Web/Postie.hs view
@@ -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
+ src/Web/Postie/Address.hs view
@@ -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
+ src/Web/Postie/Connection.hs view
@@ -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
+ src/Web/Postie/Pipes.hs view
@@ -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
+ src/Web/Postie/Protocol.hs view
@@ -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
+ src/Web/Postie/Session.hs view
@@ -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 <CR><LF>.<CR><LF>"+ (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)
+ src/Web/Postie/Settings.hs view
@@ -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
+ src/Web/Postie/Types.hs view
@@ -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