Initial version

.gitignore

@@ -0,0 +1,7 @@
+dist/
+.cabal-sandbox/
+cabal.sandbox.config
+*~
+**/*~
+
+

ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for fcmtp-client
+
+## 0.1.0.0  -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2017 Marcos Dumay de Medeiros
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

fcmtp-client.cabal

@@ -0,0 +1,45 @@
+-- Initial fcmtp-client.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                fcmtp-client
+version:             0.1.0.0
+-- synopsis:            
+-- description:         
+license:             MIT
+license-file:        LICENSE
+author:              Marcos Dumay de Medeiros
+maintainer:          marcos@marcosdumay.com
+-- copyright:           
+category:            Network
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+library
+  exposed-modules:
+                  Network.FCMTP.Client
+                  Network.FCMTP.ClientError
+                  Network.FCMTP.Relay
+  other-modules:
+                Network.FCMTP.SendingState
+  -- other-extensions:    
+  build-depends: base >=4.9 && <4.10,
+                 uniform-io,
+                 cond,
+                 interruptible,
+                 dns,
+                 mtl,
+                 data-default-class,
+                 attoparsec,
+                 bytestring,
+                 stringsearch,
+                 random,
+                 string-convert,
+                 monad-control,
+                 transformers-base,
+                 either,
+                 regex-tdfa,
+                 lens,
+                 fcmtp-data
+  hs-source-dirs:      src
+  default-language:    Haskell2010

src/Network/FCMTP/Client.hs

@@ -0,0 +1,174 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.FCMTP.Client (DebugOption(..), sendEmail) where
+
+import Network.DNS (Domain)
+import qualified Network.DNS.Lookup as DNS
+import Network.DNS.Resolver (makeResolvSeed, defaultResolvConf, withResolver)
+import qualified Data.List as List
+import System.Random(randomIO)
+import Control.Exception
+import Control.Monad.Trans.Interruptible
+import Control.Monad.Trans.SafeIO
+import Control.Monad.Trans.Either
+import Control.Lens
+import Data.Function (on)
+import Text.Regex.TDFA ((=~))
+
+import Text.StringConvert
+import Network.FCMTP.Relay
+import Network.FCMTP.ClientError
+import Data.FCMTP.Constants
+import Data.FCMTP.Host
+import Data.FCMTP.Account (Account, HostName(..))
+import qualified Data.FCMTP.Account as Ac
+--import Data.FCMTP.Address (Address(..))
+import Data.FCMTP.ResponseCode
+import Data.FCMTP.Response (Response)
+import qualified Data.FCMTP.Mime as Mime
+--import qualified Data.FCMTP.Address as Add
+import Network.FCMTP.SendingState
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import System.IO (hPutStrLn, stderr)
+import System.IO.Uniform (TlsSettings, SomeIO(..))
+import qualified System.IO.Uniform as U
+import System.IO.Uniform.Std
+import System.IO.Uniform.Network
+
+--fetchResource :: Settings -> AuthData -> ResourceURI -> IO SealedResource
+--listResource :: Settings -> AuthData -> ResourceURI -> IO ResourceList
+--deleteResource :: Settings -> AuthData -> ResourceURI -> IO ()
+--updateResource :: Settings -> AuthData -> ResourceURI SealedResource -> IO ()
+--monitorResource :: Settings -> AuthData -> ResourceURI -> MVar ResourceURI -> IO ()
+
+data DebugOption = RunStdIO | EchoProto deriving (Eq, Ord, Read, Show, Bounded, Enum)
+
+-- sendEmail :: debugOpts -> localhostName -> tlsSettngs -> relays -> from  -> [rcpt] -> Mime.BodyEncoding -> mailData -> IO failures
+sendEmail :: ToString host => [DebugOption] -> host -> TlsSettings -> [Relay] -> Account -> [Account] -> Mime.BodyEncoding -> LBS.ByteString -> IO [(Account, Response)]
+sendEmail dbg h set relays fromAdd rcptTo enc mailData = do
+  resp <- try $! sendEmail' dbg h set relays fromAdd rcptTo enc mailData :: IO (Either IOError [(Account, Response)])
+  case resp of
+    Right a -> return a
+    Left e -> do
+      hPutStrLn stderr $ "Error sending email: " ++ show e
+      return $ map (\x -> (x, toResponse BadConnection)) rcptTo
+    
+
+sendEmail' :: ToString host => [DebugOption] -> host -> TlsSettings ->[Relay] -> Account -> [Account] -> Mime.BodyEncoding -> LBS.ByteString -> IO [(Account, Response)]
+sendEmail' _ _ _ _ _ [] _ _ = return []
+sendEmail' dbg h set relays fromAdd rcptTo enc mailData = do
+  let byhost = List.groupBy ((==) `on` getHost relays) rcptTo
+  conn <- if RunStdIO `elem` dbg
+    then do
+    t <- getStdIO
+    return [inSendingCtx h set t . inEitherTCtx $ rcptTo]
+    else mapM (connHost) byhost
+  results <- mapM (resume2 $ startHost dbg fromAdd enc) conn >>=
+             intercalateFold resume2 dataToHost (LBS.toChunks mailData) >>=
+             mapM (resume2 closeHost) >>=
+             mapM peelCtx
+  return . concat $ zipWith resolveErrors byhost results
+  where
+    getHost :: [Relay] -> Account -> Host
+    getHost [] a = ByName $ Ac.domain a
+    getHost (r:rr) a = if null (r^.relayRules)
+      then r^.relayHost
+      else if (Ac.normalize a) =~ (r^.relayRules)
+           then r^.relayHost
+           else getHost rr a
+    inCtx :: U.UniformIO io => io -> a -> RSt Sending a
+    inCtx = inSendingCtx h set
+    connHost :: [Account] -> IO (RSt Sending (RSt (EitherT ClientError) [Account]))
+    connHost x = case x of
+      [] -> do
+        t <- getStdIO
+        return . inCtx t . Left $ CanNotConnect
+      rr@(r:_) -> do
+        c <- openMailHost $ getHost relays r
+        case c of
+          Left e -> do
+            t <- getStdIO
+            return . inCtx t . Left $ e
+          Right c' -> return . inCtx c' . inEitherTCtx $ rr
+
+type SendingType a = EitherT ClientError (Sending IO) a
+
+startHost :: [DebugOption] -> Account -> Mime.BodyEncoding -> [Account] -> SendingType ()
+startHost dbg fromAdd enc rcptTo = do
+  let echo = if EchoProto `elem` dbg then Just stderr else Nothing
+  safeCT $ do
+    startSending echo
+    startSession
+    mailCmd fromAdd
+    mapM_ rcptCmd rcptTo
+    startData enc
+
+dataToHost :: BS.ByteString -> () -> SendingType ()
+dataToHost dt _ = safeCT $ dataChunk dt False
+
+closeHost :: () -> SendingType ()
+closeHost _ = safeCT $ do
+  dataChunk BS.empty True
+  quitCmd
+
+peelCtx :: RSt Sending (RSt (EitherT ClientError) ()) -> IO (Either ClientError [(Account, Response)])
+peelCtx c = do
+  let (c', io, ff) = peelSendingCtx c
+  U.uClose io
+  case peelEitherTCtx c' of
+    Left e -> return . Left $ e
+    Right _ -> return . Right $ ff
+
+resolveErrors :: [Account] -> Either ClientError [(Account, Response)] -> [(Account, Response)]
+resolveErrors aa rt = case rt of
+  Right ff -> ff
+  Left _ -> map (\x -> (x, toResponse BadConnection)) aa
+
+-- Returns the mailservers for a given domain name, ordered by priority
+emailAddrs :: BS.ByteString -> IO [Domain]
+emailAddrs a = do
+  let hostname = a
+  rs <- makeResolvSeed defaultResolvConf
+  hs <- withResolver rs $ \resolver -> DNS.lookupMX resolver hostname
+  case hs of
+    Right ds -> do
+      dr <- mapM randMX ds
+      return $ map fst3 $ List.sortBy orderMX dr
+    Left _ -> throwIO MXLookupError
+  
+randMX :: (Domain, Int) -> IO (Domain, Int, Int)
+randMX (d, p) = do
+  r <- randomIO
+  return (d, p, r)
+  
+orderMX :: (Domain, Int, Int) -> (Domain, Int, Int) -> Ordering
+orderMX (_, pa, ra) (_, pb, rb) = if pa == pb then compare ra rb else compare pa pb
+
+fst3 :: (a, b, c) -> a
+fst3 (a, _, _) = a
+
+openMailHost :: Host -> IO (Either ClientError SomeIO)
+openMailHost host =
+  case host of
+    ByName (HostName h) -> do
+      mxs <- geterr $ emailAddrs h
+      case mxs of
+        Right [] -> tryOpen [h]
+        Right adds -> tryOpen adds
+        Left _ -> tryOpen [h]
+    ByIP ip -> tryOpen [s . show $ ip]
+  where
+    pp = fromIntegral relayPortNumber :: Int
+    tryOpen :: [BS.ByteString] -> IO (Either ClientError SomeIO)
+    tryOpen [] = return . Left $ CanNotConnect
+    tryOpen (a:aa) = do
+      ret <- geterr $ connectToHost (s a) pp
+      case ret of
+        Right con -> return . Right . SomeIO $ con
+        Left _ -> tryOpen aa
+
+geterr :: IO a -> IO (Either ClientError a)
+geterr f = do
+  r <- f
+  return . Right $ r

src/Network/FCMTP/ClientError.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Network.FCMTP.ClientError where
+
+import Control.Exception(Exception)
+import Data.Typeable(Typeable)
+import Control.Monad.Trans.SafeIO
+
+instance IOErrorDerivation ClientError where
+  coerceIOError _ = CanNotConnect
+data ClientError = MXLookupError | CanNotConnect | ProtocolError deriving (Eq, Read, Show, Typeable)
+instance Exception ClientError

src/Network/FCMTP/Relay.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Network.FCMTP.Relay where
+
+import Data.FCMTP.Host
+import qualified Control.Lens as L
+
+data Relay = Relay {
+  _relayHost :: Host -- ^ Relay through this hosts
+  , _relayRules :: String -- ^ When the destinatary account fits this regexp
+  , _relayAuth :: Maybe (String, String) -- ^ Authenticate with this (account_name, password)
+  } deriving (Show)
+
+L.makeLenses ''Relay

src/Network/FCMTP/SendingState.hs

@@ -0,0 +1,487 @@
+{-# LANGUAGE OverloadedStrings, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, RankNTypes #-}
+
+module Network.FCMTP.SendingState (
+  Sending,
+  inSendingConnection,
+  inSendingSession,
+  inSendingCtx,
+  peelSendingCtx,
+  startSending,
+  startSession,
+  failures,
+  extensions,
+  quitCmd,
+  rsetCmd,
+  mailCmd,
+  dataCmd,
+  startData,
+  dataChunk,
+  rcptCmd
+  ) where
+
+-- That's another StateT that encapsulates a Stream and sending data
+-- Only a bit more complicated, because every command leads to a response
+-- that may be treated in batch or individually according to the PIPELINING
+-- or XTUNNEL extension.
+
+import qualified Data.FCMTP.Account as Ac
+import qualified Data.FCMTP.Extension as Ex
+import qualified Data.FCMTP.Mime as Mime
+import System.IO (Handle)
+import qualified System.IO.Uniform as U
+import qualified System.IO.Uniform.Streamline as S
+import qualified Network.FCMTP.ClientError as CE
+import qualified Data.FCMTP.Response as Resp
+import Data.FCMTP.Response (Response, ResponseStatus(..))
+import Data.FCMTP.ResponseCode (toResponse, ResponseCode(..))
+import Control.Conditional
+
+import Control.Monad (ap, liftM)
+import Control.Monad.IO.Class
+import Control.Monad.Trans
+import Control.Monad.Trans.Interruptible
+import Control.Monad.Trans.Control
+import Control.Monad.Base
+
+import Control.Exception
+
+import Data.Maybe (isJust)
+import Data.Default.Class
+import qualified Data.Attoparsec.ByteString as A
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy.Search as Search
+
+import Text.StringConvert
+import Debug.Trace
+
+chunkSize :: Int
+chunkSize = 100000 -- bytes - about 10 normal ethernet packages
+
+{- |
+How to chunk data for sending.
+filter text isLast = [(generatesAReply, sentText)]
+-}
+type SendingDataFilter = ByteString -> Bool -> [(Bool, ByteString)]
+data Data = Data {
+  hostName :: ByteString, tlsSettings :: U.TlsSettings,
+  getExtensions :: [Ex.Extension], activeRcpt :: [Ac.Account],
+  failure :: [(Ac.Account, Response)],
+  pendingCommands :: [PendingCommand], isPipelining :: Bool,
+  dataFilter :: SendingDataFilter}
+
+newtype Sending m a = Sending {withSending :: Data -> S.Streamline m (a, Data)}
+
+-- Commands with pending replies, segregated by what failure means.
+data PendingCommand = DummyCommand | TotalyImportantCommand | CommandForRcpt Ac.Account
+
+dummyFilter :: SendingDataFilter
+dummyFilter dt _ = [(False, dt)]
+
+startSending :: MonadIO m => Maybe Handle -> Sending m ()
+startSending ec = do
+  lifts $ S.echoTo ec
+  handshake
+
+startSession :: MonadIO m => Sending m ()
+startSession = startSendingSession
+
+inSendingConnection :: MonadIO m => ToString host => host -> U.TlsSettings -> Sending m a -> S.Streamline m a
+inSendingConnection h set f = do
+  (ret, _) <- withSending f' $ Data (s . toString $ h) set [] [] [] [] False dummyFilter
+  return ret
+  where
+    f' = do
+      handshake
+      ret <- f
+      quitCmd
+      return ret
+
+startSendingSession :: MonadIO m => Sending m ()
+startSendingSession = Sending $ \st -> do
+  let s' = st{activeRcpt=[]}{failure=[]}
+  return ((), s')
+
+clearSendingSession :: MonadIO m => Sending m ()
+clearSendingSession = Sending $ \st -> do
+  let s' = st{activeRcpt=[]}{failure=[]}
+  return ((), s')
+
+inSendingSession :: MonadIO m => Sending m a -> Sending m (a, [(Ac.Account, Response)])
+inSendingSession f = do
+  sync
+  startSendingSession
+  ret <- f
+  rsetCmd
+  sync
+  ff <- failures
+  clearSendingSession
+  return (ret, ff)
+
+-- | Returns (success address, temporary failures, permanent failures)
+failures :: Monad m => Sending m [(Ac.Account, Response)]
+failures = Sending $ \st -> return (failure st, st)
+
+extensions :: Monad m => Sending m [Ex.Extension]
+extensions = Sending $ \st -> return (getExtensions st, st)
+
+quitCmd :: MonadIO m => Sending m ()
+quitCmd = do
+  sync
+  sendDummyCommand "QUIT"
+
+rsetCmd :: MonadIO m => Sending m ()
+rsetCmd = do
+  sendDummyCommand "RSET"
+  sync
+
+mailCmd :: MonadIO m => Ac.Account -> Sending m ()
+mailCmd from = sendTotalyCommand . BS.concat $ ["MAIL FROM:<", Ac.normalize from, ">"]
+
+rcptCmd :: MonadIO m => Ac.Account -> Sending m ()
+rcptCmd to = let
+  cmd = ["RCPT TO:", s . Ac.fullAccount $ to]
+  in sendRcptCommand (BS.concat cmd) to
+
+setDataFilter :: Monad m => SendingDataFilter -> Sending m ()
+setDataFilter f = Sending $ \st -> return ((), st{dataFilter=f})
+
+getDataFilter :: Monad m => Sending m SendingDataFilter
+getDataFilter = Sending $ \st -> return (dataFilter st, st)
+
+{- |
+Starts a data sending command (DATA or BDAT).
+-}
+startData :: MonadIO m => Mime.BodyEncoding -> Sending m ()
+startData enc = do
+  sync
+  ifM (hasEx Ex.CHUNKING) (
+    setDataFilter sendBdatBody
+    )(
+    do
+      ch <- canHandle enc
+      traceShow enc $ return ()
+      traceShow ch $ return ()
+      ifM (canHandle enc) (
+        do
+          totalyDataIfActive $ case enc of
+            Mime.B7BitEncoding -> "DATA\r\n"
+            Mime.B8BitEncoding -> "DATA BODY=8BIT\r\n"
+            Mime.BBinaryEncoding -> "DATA BODY=BINARY\r\n"
+          sync
+          setDataFilter $ \m lst ->
+            (False, LBS.toStrict . dotStuff . LBS.fromStrict $ m) :
+            if lst then [(True, "\r\n.\r\n")] else []
+        ) (failAll' . toResponse $ NoConversion)
+    )
+  where
+    canHandle :: Monad m => Mime.BodyEncoding -> Sending m Bool
+    canHandle Mime.B7BitEncoding = return True
+    canHandle Mime.B8BitEncoding = hasEx Ex.E8BITMIME
+    canHandle Mime.BBinaryEncoding = hasEx Ex.BINARYMIME
+    -- desiredEncoding :: Mime.BodyEncoding -> Sending m m Mime.BodyEncoding
+    -- desiredEncoding o = case o of
+    --   Mime.B7BitEncoding -> return Mime.B7BitEncoding
+    --   Mime.B8BitEncoding -> ifM (hasEx Ex.E8BITMIME) (return Mime.B8BitEncoding) (
+    --     ifM (hasEx Ex.BINARYMIME) (return Mime.BBinaryEncoding) (return Mime.B7BitEncoding)
+    --     )
+    --   Mime.BBinaryEncoding -> ifM (hasEx Ex.BINARYMIME) (
+    --     return Mime.BBinaryEncoding) (return Mime.B7BitEncoding)
+    sendBdatBody :: SendingDataFilter
+    sendBdatBody dt lst = if lst
+                          then [(True, BS.concat ["BDAT ", s . show . BS.length $ dt, " LAST\r\n", dt])]
+                          else [(True, BS.concat ["BDAT ", s . show . BS.length $ dt, "\r\n", dt])]
+
+dataChunk :: MonadIO m => ByteString -> Bool -> Sending m ()
+dataChunk dt lst = do
+  f <- getDataFilter
+  let dt' = f dt lst
+  mapM_ sendChunk dt'
+  where
+    --sendChunk :: (Bool, ByteString) -> Sending m ()
+    sendChunk (repl, ck) = if repl
+                           then totalyCommandNoLn ck
+                           else dataIfActive ck
+
+dataCmd :: MonadIO m => Mime.BodyEncoding -> LBS.ByteString -> Sending m ()
+dataCmd enc m = ifM (hasEx Ex.CHUNKING) (
+  sendBdatBody m -- No reencode is needed.
+  ) $ do
+    sendTotalyCommand $ case enc of
+      Mime.B7BitEncoding -> "DATA"
+      Mime.B8BitEncoding -> "DATA BODY=8BIT"
+      Mime.BBinaryEncoding -> "DATA BODY=BINARY"
+    sync
+    totalyDataIfActive' $ LBS.append (dotStuff m) "\r\n.\r\n"
+  where
+    -- desiredEncoding :: Mime.BodyEncoding -> Sending m m Mime.BodyEncoding
+    -- desiredEncoding o = case o of
+    --   Mime.B7BitEncoding -> return Mime.B7BitEncoding
+    --   Mime.B8BitEncoding -> ifM (hasEx Ex.E8BITMIME) (return Mime.B8BitEncoding) (
+    --     ifM (hasEx Ex.BINARYMIME) (return Mime.BBinaryEncoding) (return Mime.B7BitEncoding)
+    --     )
+    --   Mime.BBinaryEncoding -> ifM (hasEx Ex.BINARYMIME) (
+    --     return Mime.BBinaryEncoding) (return Mime.B7BitEncoding)
+    sendBdatBody :: MonadIO m => LBS.ByteString -> Sending m ()
+    sendBdatBody dt = do
+      let (d, r) = LBS.splitAt (fromIntegral chunkSize) dt
+      if LBS.null r
+        then
+        totalyDataIfActive $ BS.concat [
+          "BDAT ", s . show . LBS.length $ d, " LAST\r\n", LBS.toStrict d]
+        else do
+        totalyDataIfActive $ BS.concat [
+          "BDAT ", s . show . LBS.length $ d, "\r\n", LBS.toStrict d]
+        sendBdatBody r
+
+sendDummyCommand :: MonadIO m => ByteString -> Sending m () 
+sendDummyCommand cmd = do
+  lifts . S.send . BS.concat $ [cmd, "\r\n"]
+  pipeline DummyCommand
+
+sendTotalyCommand :: MonadIO m => ByteString -> Sending m () 
+sendTotalyCommand cmd = totalyCommandNoLn $ BS.concat [cmd, "\r\n"]
+
+totalyCommandNoLn :: MonadIO m => ByteString -> Sending m ()
+totalyCommandNoLn cmd = do
+  lifts . S.send $ cmd
+  pipeline TotalyImportantCommand
+
+dataIfActive :: MonadIO m => ByteString -> Sending m ()
+dataIfActive dt = whenM hasActiveRcpt (lifts $ S.send dt)
+
+totalyDataIfActive :: MonadIO m => ByteString -> Sending m ()
+totalyDataIfActive dt = whenM hasActiveRcpt $ do
+  lifts $ S.send dt
+  pipeline TotalyImportantCommand
+  
+totalyDataIfActive' :: MonadIO m => LBS.ByteString -> Sending m ()
+totalyDataIfActive' dt = whenM hasActiveRcpt $ do
+  lifts $ S.send' dt
+  pipeline TotalyImportantCommand
+
+sendRcptCommand :: MonadIO m => ByteString -> Ac.Account -> Sending m () 
+sendRcptCommand cmd e = do
+  lifts . S.send . BS.concat $ [cmd, "\r\n"]
+  Sending (\st -> let
+                   a = e : activeRcpt st
+                   st' = st{activeRcpt=a}
+                   in if  e `elem` activeRcpt st then return ((), st) else return ((), st')
+               )
+  pipeline . CommandForRcpt $ e
+
+pipeline :: MonadIO m => PendingCommand -> Sending m ()
+pipeline cmd = Sending $ \st ->
+  if isPipelining st
+  then 
+    let p = cmd : pendingCommands st
+    in return ((), st{pendingCommands=p}) 
+  else do
+    repl <- receiveReply
+    let st' = resolveCommand repl cmd st
+    return ((), st')
+
+resolveCommand :: Response -> PendingCommand -> Data -> Data
+resolveCommand repl cmd st = case Resp.status repl of
+  Preliminary -> st
+  Completion -> st
+  Intermediate -> st
+  TransientError -> case cmd of 
+    DummyCommand -> st
+    TotalyImportantCommand -> failAll repl st
+    CommandForRcpt e -> failAdd repl st e
+  PermanentError -> case cmd of
+    DummyCommand -> st
+    TotalyImportantCommand -> failAll repl st
+    CommandForRcpt e -> failAdd repl st e
+  DataFollows -> failAll repl st -- Shouldn't appear when sending
+  Asynchronous -> st
+
+failAdd :: Response -> Data -> Ac.Account -> Data
+failAdd r st e = st{activeRcpt = a}{failure = (e, r): failure st}
+  where
+    a = removeElem (activeRcpt st) e
+
+removeElem :: Eq a => [a] -> a -> [a]
+removeElem l e = filter (/= e) l
+
+failAll :: Response -> Data -> Data
+failAll r st = st{activeRcpt=[]}{failure = a  ++ failure st}
+  where
+    a = map (\x -> (x, r)) $ activeRcpt st
+
+failAll' :: Monad m => Response -> Sending m ()
+failAll' r = Sending $ \st -> return ((), failAll r st)
+
+sync :: MonadIO m => Sending m ()
+sync = do
+  cmds <- queryState pendingCommands
+  mapM_ getReply $ reverse cmds
+  zeroPendingCommands
+  where
+    getReply :: MonadIO m => PendingCommand -> Sending m ()
+    getReply cmd = Sending $ \st -> do
+      repl <- receiveReply
+      let st' = resolveCommand repl cmd st
+      return ((), st')
+    zeroPendingCommands :: MonadIO m => Sending m ()
+    zeroPendingCommands = Sending $ \st -> do
+      return ((), st{pendingCommands=[]})
+
+queryState :: Monad m => (Data -> a) -> Sending m a
+queryState f = Sending $ \st ->
+  return (f st, st)
+
+handshake :: MonadIO m => Sending m ()
+handshake = Sending (
+  \st -> do
+    S.recieveLine
+    let host = hostName st
+    exts <- getEhlo host
+    secureLine <- S.isSecure
+    let tls = Ex.hasExtension exts Ex.STARTTLS && not secureLine
+    if tls
+      then do
+      S.send "STARTTLS\r\n"
+      S.recieveLine
+      S.startTls $ tlsSettings st
+      exts' <- getEhlo host
+      let pipe = Ex.hasExtension exts' Ex.PIPELINING
+      let st' = st{getExtensions=exts'}{isPipelining=pipe}
+      return ((), st')
+      else do
+      let pipe = Ex.hasExtension exts Ex.PIPELINING
+      let st' = st{getExtensions=exts}{isPipelining=pipe}
+      return ((), st')
+  )
+  where
+    getEhlo host = do
+      S.send . BS.concat $ ["EHLO ", host, "\r\n"]
+      repl <- receiveReply
+      if isSuccess . Resp.status $ repl
+        then do
+        let exts = ehloExts repl
+        return exts
+        else do
+        S.send . BS.concat $ ["HELO ", host, "\r\n"]
+        repl' <- receiveReply
+        if isSuccess . Resp.status $ repl'
+          then return []
+          else liftIO . throwIO $ CE.ProtocolError
+
+--Client code needs:
+--A parser that reads the server response, and breaks it in:
+--Error with:
+--  Type and message
+--Success with:
+--  Message, and possibly contents, where contents are
+--  EHLO extension support, MNTR changes, CHSM values, or RTRV data
+--
+--Because of MNTR, the parser must be lazy, and return
+--before command termination.
+
+ehloExts :: Response -> [Ex.Extension]
+ehloExts r = map (\msg -> case A.parseOnly Ex.parseExtension msg of
+                             Right e -> e         
+                             Left e -> Ex.StringExt Ex.UNRECOGNIZED $ BS.concat [s e, ": ", msg]
+                         ) $ Resp.respLines r
+
+isSuccess :: ResponseStatus -> Bool
+isSuccess TransientError = False
+isSuccess PermanentError = False
+isSuccess _ = True
+
+
+receiveReply :: MonadIO m => S.Streamline m Resp.Response
+receiveReply = do
+  r <- S.runAttoparsec Resp.parseResponse
+  case r of
+    Left e -> return def{Resp.message=s e}
+    Right v -> return v
+
+-- Here Sending becomes a usefull Monad
+
+instance Monad m => Monad (Sending m) where
+  --return :: (Monad m) => a -> Sending m a
+  return x = Sending  $ \cl -> return (x, cl)
+  --(>>=) :: Sending m a -> (a -> Sending m b) -> Sending m b
+  a >>= b = Sending $ \cl -> do
+    (x, cl') <- withSending a cl
+    withSending (b x) cl'
+
+instance Monad m => Functor (Sending m) where
+  --fmap :: (a -> b) -> Sending m a -> Sending m b
+  fmap f m = Sending $ \cl -> do
+    (x, cl') <- withSending m cl
+    return (f x, cl')
+
+instance Monad m => Applicative (Sending m) where
+    pure = return
+    (<*>) = ap
+
+
+instance MonadTrans Sending where
+  lift = lifts . lift
+
+lifts :: Monad m => S.Streamline m a -> Sending m a
+lifts x = Sending $ \st -> do
+  r <- x
+  return (r, st)
+
+instance MonadIO m => MonadIO (Sending m) where
+  liftIO = lifts . liftIO
+
+dotStuff :: LBS.ByteString -> LBS.ByteString
+dotStuff m = LBS.append
+             (LBS.fromStrict leading)
+             (Search.replace ("\r\n."::ByteString) ("\r\n.."::ByteString) m)
+  where
+    leading = if LBS.take 1 m == "." then "a" else ""
+
+hasEx :: Monad m => Ex.ExtName -> Sending m Bool
+hasEx x = Sending $ \st -> return (isJust $ Ex.getExtension (getExtensions st) x, st)
+
+hasActiveRcpt :: Monad m => Sending m Bool
+hasActiveRcpt = Sending $ \st -> return (not . null . activeRcpt $ st, st)
+
+
+--------------------------------------------
+-- Interruptible and MonadControl support --
+--------------------------------------------
+
+instance Interruptible Sending where
+  type RSt Sending a = RSt S.Streamline (a, Data)
+  resume f st = resume (\(x, dt) -> withSending (f x) dt) st
+
+peelSendingCtx :: RSt Sending a -> (a, U.SomeIO, [(Ac.Account, Response)])
+peelSendingCtx st = let
+  ((a, dt), io) = S.peelStreamlineCtx st
+  in (a, io, failure dt)
+
+inSendingCtx :: (ToString host, U.UniformIO io) => host -> U.TlsSettings -> io -> a -> RSt Sending a
+inSendingCtx h set io a = let
+  dt = Data (s . toString $ h) set [] [] [] [] False dummyFilter
+  in S.inStreamlineCtx io (a, dt)
+
+instance MonadTransControl Sending where
+  type StT Sending a = StT S.Streamline (a, Data)
+  -- liftWith :: (Run Sending -> m a) -> Sending m a
+  liftWith f = Sending $ \st ->
+    liftM (\x -> (x, st)) $ liftWith $ \f' -> do
+      f $ \(Sending t) -> do
+        f' $ t st
+  --restoreT :: m (St Sending a) -> Sending m a
+  restoreT r = Sending . const . restoreT $ r
+    --Sending $ \s -> do
+    --(st, dt) <- r
+    --restoreT . return $ (\(v, x) -> ((v, dt), x)) st
+
+instance MonadBase b m => MonadBase b (Sending m) where
+  liftBase = liftBaseDefault
+
+instance MonadBaseControl b m => MonadBaseControl b (Sending m) where
+  type StM (Sending m) a = ComposeSt Sending m a
+  liftBaseWith     = defaultLiftBaseWith
+  restoreM         = defaultRestoreM
+