diff --git a/examples/Simple.hs b/examples/Simple.hs --- a/examples/Simple.hs +++ b/examples/Simple.hs @@ -1,35 +1,26 @@ - module Main where -import Web.Postie - +import Network.Mail.Postie import Pipes.ByteString (stdout) settings :: Settings -settings = def { - settingsOnOpen = \sid _ -> do - putStrLn $ show sid ++ " session opened" - , - settingsOnClose = \sid -> do - putStrLn $ show sid ++ " session closed" - , - settingsOnMailFrom = \sid addr -> do - putStrLn $ show sid ++ " mail from " ++ show addr - return Accepted - , - settingsOnRecipient = \sid addr -> do - putStrLn $ show sid ++ " rcpt to " ++ show addr - return Accepted - , - settingsOnStartTLS = \sid -> do - putStrLn $ show sid ++ " starttls" - } +settings = + def + { settingsOnOpen = \sid _ -> putStrLn $ show sid ++ " session opened", + settingsOnClose = \sid -> putStrLn $ show sid ++ " session closed", + settingsOnMailFrom = \sid addr -> do + putStrLn $ show sid ++ " mail from " ++ show addr + return Accepted, + settingsOnRecipient = \sid addr -> do + putStrLn $ show sid ++ " rcpt to " ++ show addr + return Accepted, + settingsOnStartTLS = \sid -> putStrLn $ show sid ++ " starttls" + } main :: IO () -main = do - runSettings settings app +main = runSettings settings app where - app (Mail sid _ _ body) = do + app (Mail sid _ _ _ body) = do putStrLn $ show sid ++ " data" runEffect $ body >-> stdout return Accepted diff --git a/examples/TLS.hs b/examples/TLS.hs --- a/examples/TLS.hs +++ b/examples/TLS.hs @@ -1,42 +1,32 @@ - module Main where -import Web.Postie - +import Network.Mail.Postie import Pipes.ByteString (stdout) settings :: Settings -settings = def { - settingsOnOpen = \sid _ -> do - putStrLn $ show sid ++ " session opened" - , - settingsOnClose = \sid -> do - putStrLn $ show sid ++ " session closed" - , - settingsOnMailFrom = \sid addr -> do - putStrLn $ show sid ++ " mail from " ++ show addr - return Accepted - , - settingsOnRecipient = \sid addr -> do - putStrLn $ show sid ++ " rcpt to " ++ show addr - return Accepted - , - settingsOnStartTLS = \sid -> do - putStrLn $ show sid ++ " starttls" - - , - settingsTLS = Just def { - certFile = "server.crt" - , keyFile = "server.key" +settings = + def + { settingsOnOpen = \sid _ -> putStrLn $ show sid ++ " session opened", + settingsOnClose = \sid -> putStrLn $ show sid ++ " session closed", + settingsOnMailFrom = \sid addr -> do + putStrLn $ show sid ++ " mail from " ++ show addr + return Accepted, + settingsOnRecipient = \sid addr -> do + putStrLn $ show sid ++ " rcpt to " ++ show addr + return Accepted, + settingsOnStartTLS = \sid -> putStrLn $ show sid ++ " starttls", + settingsTLS = + Just + def + { certFile = "examples/tls/server.crt", + keyFile = "examples/tls/server.key" + } } - } - main :: IO () -main = do - runSettings settings app +main = runSettings settings app where - app (Mail sid _ _ body) = do + app (Mail sid _ _ _ body) = do putStrLn $ show sid ++ " data" runEffect $ body >-> stdout return Accepted diff --git a/examples/tls/server.crt b/examples/tls/server.crt new file mode 100644 --- /dev/null +++ b/examples/tls/server.crt @@ -0,0 +1,20 @@ +-----BEGIN CERTIFICATE----- +MIIDLjCCAhYCCQD9AANY/EgjUTANBgkqhkiG9w0BAQUFADBZMQswCQYDVQQGEwJB +VTETMBEGA1UECBMKU29tZS1TdGF0ZTEhMB8GA1UEChMYSW50ZXJuZXQgV2lkZ2l0 +cyBQdHkgTHRkMRIwEAYDVQQDEwlsb2NhbGhvc3QwHhcNMTQwMTMwMTgwODA3WhcN +MTUwMTMwMTgwODA3WjBZMQswCQYDVQQGEwJBVTETMBEGA1UECBMKU29tZS1TdGF0 +ZTEhMB8GA1UEChMYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMRIwEAYDVQQDEwls +b2NhbGhvc3QwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDMkphMqZpM +mMDNZbsLZ1DnjvfhkASG5BJ/VpDc/UmEp0KKmnE55oATNXtu5SbYD12tG2swQw2V +duVnjHBcc5Qvnah2mRkF6g9yVJoE4s+6Vr3CwkKEHHfcf81mzSPAzsKb3HIyk7SF +/RbM77iedhhWHA3V+4Q7ecZbUlivxf+BZCgzPpq+Fvwm6u9T7ulr0g+SCMw6l2IM +dZ4tw5J9DQ9EDj2oxXcwiARd1uVMm30pNKnXEAvzHpfav1QJzLisJhcE6Yy2fmnh +eZ6pg/mo4yiaRSA/eauMXmLdCHYC8cODu0PtQdKw1MEp8Gl6hv1ZRFCJlgUSyK8K +mWBUFeoAdvdnAgMBAAEwDQYJKoZIhvcNAQEFBQADggEBAA9awB37Ifk1YUejLmpa +Itf0P24UiNZJt5VPYX9V6fyj48b/F1vUQ5zxBziW+cnarKEqNen3JJpwkVT4fZzq +XzwdcSekSffWJlzrFZx8Rcbxd/9jEKisMmLNt1/S50qeWiz+exjQ9QL8/EWit53n +b3Rc7uo3Ilu4dZIMuQYwngNiQyaZeLzG/3xLjTOf6t1DfJYzmQONPeaO+P6HE9TS +INOczC232ZpAv0E/cQDq1P7ORQJMpl9TupWXYenWF2+Igb+wVVrkPmb06qvHI6ie +smPVo3Yovah6RrkNdDLPjfdSQnPaRvI9qWFTLVCJFNjKQln8pYp1sf5Xqnec4XMC +nKo= +-----END CERTIFICATE----- diff --git a/examples/tls/server.key b/examples/tls/server.key new file mode 100644 --- /dev/null +++ b/examples/tls/server.key @@ -0,0 +1,27 @@ +-----BEGIN RSA PRIVATE KEY----- +MIIEpAIBAAKCAQEAzJKYTKmaTJjAzWW7C2dQ54734ZAEhuQSf1aQ3P1JhKdCippx +OeaAEzV7buUm2A9drRtrMEMNlXblZ4xwXHOUL52odpkZBeoPclSaBOLPula9wsJC +hBx33H/NZs0jwM7Cm9xyMpO0hf0WzO+4nnYYVhwN1fuEO3nGW1JYr8X/gWQoMz6a +vhb8JurvU+7pa9IPkgjMOpdiDHWeLcOSfQ0PRA49qMV3MIgEXdblTJt9KTSp1xAL +8x6X2r9UCcy4rCYXBOmMtn5p4XmeqYP5qOMomkUgP3mrjF5i3Qh2AvHDg7tD7UHS +sNTBKfBpeob9WURQiZYFEsivCplgVBXqAHb3ZwIDAQABAoIBAFDMseTNtEj+qGA4 +Bxmo8/aRrGxl8rPIj1nGOi9ex1PisFCIUaJZ3Uo4/Ii/b4k1AH3n730/brUTIea1 +PIf3ipcIAUrei1ifqvwwWCkH4J4rtoWfLqB5kgoAXIN3EOENiSYAewZo+otVfFTz +dgr4gAI60GgtEHxhS6w0KR076gATdztk/HxjhgKzV67hMyMWdemmLrNAJ6IVNc3t +b8FYBtM8dZNmO2cEQlM3Fle8hzUm1Hqu2MU/7j8GfV4Pz/Q+pAmnSaaADxtCPuOz +nfG7q1fH7c7XsUb0IKgebUdhFNCqIgF1/huR8B3xmDMRyuFf82pDrJvw3Dz2d8SV +GecjSLkCgYEA7WUOoSYa6yX3cswkB5M6fnhJy95eRn9Lwy54EQI+2kiTfGGSIbyj +iD3ixpw+6vPqh0cBZ3a65uw0h+y3H5cPf6MlU+aBHwaHub/9vZ0ZnMuLr91BOC1p +UYnvY9t/UDeV8E5QPKvL8GZIr30wsBMTKNpNZ6MI7ep4WXmLt14Lmo0CgYEA3JsD +0VkVtPxjbSjKk1FDPtrnnaKPvAC1bsVO3xmCxmkiyUVDlbmFT52XPQNZWPp+aCIR +hBh0eCoK25Nx4+2170Av4+ZfhdNYkdPj4CfRr0xDmFTLgyOQgEv048W7N+QvCCo7 +p92IorfUaFyYwKhwnt2gd9vUwj6sAx1jDwTAtsMCgYEA62nRriC5hQLrdh3WhOSN +lyj2FYN4ffRyTyXfzw4pAhICn8+qOGZ2zP6Bym7bPeeQZYIWdGGbSrBmD3zAxETr +C6nftGnbFcdGBP/NQqFt6r020rlYmbr+u+tLR/09LXFR8THYA7Jh1Q25er1s8M6Z +q2OAawuUKUrg+em8kaRjYWkCgYBjXwxkM928Teg3lqVRoMxKtu6YKk7Wn/caM5So +mGQ5HcjGowWjnxL23wTuPeD0XLmuDJKZTy6/piiH6i3mPwCyCdbIsNAchywhXDIM +mcMxVIgqSR/3LYD82boxE7OWpJmu8t82aWsP6QCsFfHU7sr0NN8Avqxi5zoymP0z +Ga/5YwKBgQDqHfZWKp0+gzq22xXQomc4756Uo2eSQq4TGipGoUQBkkQmiACYoDCA +4doWcRCL8jT0p9pp/M79YG5+zvTbCFdRhNqllWM6uLJVGmgX9RMlj5jbjAu3RkTe +vxZiYqlsnSetmxFyI1kXCUQkL4/VqAThpnpSz/SNeummsTTkkvYS0g== +-----END RSA PRIVATE KEY----- diff --git a/postie.cabal b/postie.cabal --- a/postie.cabal +++ b/postie.cabal @@ -1,6 +1,6 @@ -name: postie -version: 0.5.0.0 cabal-version: >=1.10 +name: postie +version: 0.6.0.2 build-type: Simple license: BSD3 license-file: LICENSE @@ -32,55 +32,80 @@ 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 +extra-source-files: + examples/tls/server.crt, + examples/tls/server.key source-repository head - type: git - location: https://github.com/alexbiehl/postie.git + type: git + location: https://github.com/alexbiehl/postie.git flag examples - Description: Build examples - Default: False - Manual: True + 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.6, pipes >=4.1.0, - pipes-parse >=3.0.1, attoparsec >=0.10.4.0, transformers >=0.3.0.0, - mtl >=2.1.2, cprng-aes >=0.5.2, data-default-class >=0.0.1, uuid >= 1.3.3, stringsearch - exposed-modules: Web.Postie Web.Postie.Types Web.Postie.Settings Web.Postie.Address Web.Postie.SessionID - 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 - ghc-options: -O2 -Wall + build-depends: + attoparsec >= 0.13.2 && < 0.14, + base >= 4.13.0 && < 4.14, + bytestring >= 0.10.10 && < 0.11, + data-default-class >= 0.1.2 && < 0.2, + mtl >= 2.2.2 && < 2.3, + network >= 3.1.1 && < 3.2, + pipes >= 4.3.14 && < 4.4, + pipes-parse >= 3.0.8 && < 3.1, + tls >= 1.5.4 && < 1.6, + uuid >= 1.3.13 && < 1.4 + exposed-modules: + Network.Mail.Postie + Network.Mail.Postie.Address + Network.Mail.Postie.Types + Network.Mail.Postie.SessionID + Network.Mail.Postie.Settings + exposed: True + buildable: True + default-language: Haskell2010 + default-extensions: Rank2Types OverloadedStrings DeriveDataTypeable + hs-source-dirs: src + other-modules: + Network.Mail.Postie.Connection + Network.Mail.Postie.Pipes + Network.Mail.Postie.Protocol + Network.Mail.Postie.Session + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints 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 + build-depends: + postie, + base >= 4.13.0 && < 4.14, + pipes-bytestring >= 2.1.6 && < 2.2 + if flag(examples) buildable: True - default-language: Haskell2010 - hs-source-dirs: examples + else + buildable: False + main-is: Simple.hs + buildable: True + default-language: Haskell2010 + hs-source-dirs: examples executable postie-example-tls - build-depends: base -any, bytestring -any, tls -any, - data-default-class -any, pipes -any, pipes-bytestring -any, - postie -any - - if flag(examples) - buildable: True - else - buildable: False - main-is: TLS.hs + build-depends: + postie, + base >= 4.13.0 && < 4.14, + pipes-bytestring >= 2.1.6 && < 2.2 + if flag(examples) buildable: True - default-language: Haskell2010 - hs-source-dirs: examples + else + buildable: False + main-is: TLS.hs + buildable: True + default-language: Haskell2010 + hs-source-dirs: examples diff --git a/src/Network/Mail/Postie.hs b/src/Network/Mail/Postie.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Postie.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Mail.Postie + ( run, + -- | Runs server with a given application on a specified port + runSettings, + -- | Runs server with a given application and settings + runSettingsSocket, + + -- * Application + module Network.Mail.Postie.Types, + + -- * Settings + module Network.Mail.Postie.Settings, + + -- * Address + module Network.Mail.Postie.Address, + + -- * Exceptions + UnexpectedEndOfInputException, + TooMuchDataException, + + -- * Re-exports + P.Producer, + P.Consumer, + P.runEffect, + (P.>->), + ) +where + +import Control.Concurrent +import Control.Exception as E +import Control.Monad (forever, void) +import Network.Socket +import Network.TLS (ServerParams) +import qualified Pipes as P +import System.Timeout +import Network.Mail.Postie.Address +import Network.Mail.Postie.Connection +import Network.Mail.Postie.Pipes (TooMuchDataException, UnexpectedEndOfInputException) +import Network.Mail.Postie.Session +import Network.Mail.Postie.Settings +import Network.Mail.Postie.Types + +run :: Int -> Application -> IO () +run port = runSettings (def {settingsPort = fromIntegral port}) + +runSettings :: Settings -> Application -> IO () +runSettings settings app = withSocketsDo + $ bracket (listenOn port) close + $ \sock -> + runSettingsSocket settings sock app + where + port = settingsPort settings + listenOn portNum = + bracketOnError + (socket AF_INET6 Stream defaultProtocol) + close + ( \sock -> do + setSocketOption sock ReuseAddr 1 + bind sock (SockAddrInet6 portNum 0 (0, 0, 0, 0) 0) + listen sock maxListenQueue + return sock + ) + +runSettingsSocket :: Settings -> Socket -> Application -> IO () +runSettingsSocket settings sock = + runSettingsConnection settings getConn + where + getConn = do + (s, sa) <- accept sock + conn <- mkSocketConnection s + return (conn, sa) + +runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO () +runSettingsConnection settings getConn app = do + serverParams <- mkServerParams' + runSettingsConnectionMaker settings (getConnMaker serverParams) serverParams app + where + getConnMaker serverParams = do + (conn, sa) <- getConn + let mkConn = do + case settingsStartTLSPolicy settings of + Just ConnectWithTLS -> do + let (Just sp) = serverParams + connSetSecure conn sp + _ -> return () + return conn + return (mkConn, sa) + mkServerParams' = + case settingsTLS settings of + Just tls -> do + serverParams <- mkServerParams tls + return (Just serverParams) + _ -> return Nothing + +runSettingsConnectionMaker :: + Settings -> + IO (IO Connection, SockAddr) -> + Maybe ServerParams -> + Application -> + IO () +runSettingsConnectionMaker settings getConnMaker serverParams app = do + settingsBeforeMainLoop settings + void $ forever $ do + (mkConn, sockAddr) <- getConnLoop + void $ forkIOWithUnmask $ \unmask -> do + sessionID <- mkSessionID + bracket mkConn connClose $ \conn -> + void $ timeout maxDuration + $ unmask + . handle (onE $ Just sessionID) + . bracket_ (onOpen sessionID sockAddr) (onClose sessionID) + $ runSession (mkSessionEnv sessionID app settings conn serverParams) + where + getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do + onE Nothing (toException e) + threadDelay 1000000 + getConnLoop + onE = settingsOnException settings + onOpen = settingsOnOpen settings + onClose = settingsOnClose settings + maxDuration = settingsTimeout settings * 1000000 diff --git a/src/Network/Mail/Postie/Address.hs b/src/Network/Mail/Postie/Address.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Postie/Address.hs @@ -0,0 +1,171 @@ +module Network.Mail.Postie.Address + ( Address, + -- | Represents an email address + address, + -- | Returns address from local and domain part + addressLocalPart, + -- | Returns local part of address + addressDomain, + -- | Retuns domain part of address + toByteString, + -- | Resulting ByteString has format localPart\@domainPart. + toLazyByteString, + -- | Resulting Lazy.ByteString has format localPart\@domainPart. + parseAddress, + -- | Parses a ByteString to Address + addrSpec, + ) +where + +import Control.Applicative +import Control.Monad (void) +import Data.Attoparsec.ByteString.Char8 +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Maybe (fromMaybe) +import Data.String +import Data.Typeable (Typeable) + +data Address + = Address + { addressLocalPart :: !BS.ByteString, + addressDomain :: !BS.ByteString + } + deriving (Eq, Ord, Typeable) + +instance Show Address where + show = BS.unpack . toByteString + +instance IsString Address where + fromString = fromMaybe (error "invalid email literal") . parseAddress . BS.pack + +address :: BS.ByteString -> BS.ByteString -> Address +address = Address + +toByteString :: Address -> BS.ByteString +toByteString (Address l d) = BS.concat [l, BS.singleton '@', d] + +toLazyByteString :: Address -> LBS.ByteString +toLazyByteString (Address l d) = LBS.fromChunks [l, BS.singleton '@', d] + +parseAddress :: BS.ByteString -> Maybe Address +parseAddress = maybeResult . parse addrSpec + +-- | Address Parser. Borrowed form email-validate-2.0.1. Parser for email address. +addrSpec :: Parser Address +addrSpec = do + localPart <- local + _ <- char '@' + Address localPart <$> domain + +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 = void + +between :: Parser l -> Parser r -> Parser x -> Parser x +between l r x = l *> x <* r + +comment :: Parser () +comment = + ignore + ( between (char '(') (char ')') $ + many (ignore commentContent <|> fws) + ) + +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/Network/Mail/Postie/Connection.hs b/src/Network/Mail/Postie/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Postie/Connection.hs @@ -0,0 +1,84 @@ +module Network.Mail.Postie.Connection + ( Connection, + connIsSecure, + connSetSecure, + connRecv, + connSend, + connClose, + mkSocketConnection, + toProducer, + ) +where + +import Control.Exception (finally) +import Control.Monad (unless) +import Control.Monad.IO.Class +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.ByteString.Lazy.Internal (defaultChunkSize) +import Data.IORef +import Network.Socket +import Network.Socket.ByteString hiding (sendAll) +import Network.Socket.ByteString.Lazy (sendAll) +import Network.TLS +import qualified Pipes as P + +data ConnectionBackend + = ConnPlain Socket + | ConnSecure Context + +newtype Connection = Connection (IORef ConnectionBackend) + +connSetSecure :: Connection -> ServerParams -> IO () +connSetSecure (Connection cbe) params = do + backend <- readIORef cbe + securedBackend <- upgrade backend + writeIORef cbe securedBackend + where + upgrade (ConnPlain be) = do + context <- contextNew be params + handshake context + return (ConnSecure context) + upgrade (ConnSecure _) = error "already on secure connection" + +connIsSecure :: Connection -> IO Bool +connIsSecure (Connection cbe) = do + backend <- readIORef cbe + return $ case backend of + (ConnSecure _) -> True + _ -> False + +mkSocketConnection :: Socket -> IO Connection +mkSocketConnection s = do + conn <- newIORef (ConnPlain s) + return (Connection conn) + +connBackendRecv :: ConnectionBackend -> IO BS.ByteString +connBackendRecv (ConnPlain s) = recv s defaultChunkSize +connBackendRecv (ConnSecure ctx) = recvData ctx + +connBackendSend :: ConnectionBackend -> LBS.ByteString -> IO () +connBackendSend (ConnPlain s) = sendAll s +connBackendSend (ConnSecure ctx) = sendData ctx + +connRecv :: Connection -> IO BS.ByteString +connRecv (Connection cbe) = readIORef cbe >>= connBackendRecv + +connSend :: Connection -> LBS.ByteString -> IO () +connSend (Connection cbe) lbs = do + backend <- readIORef cbe + connBackendSend backend lbs + +connClose :: Connection -> IO () +connClose (Connection cbe) = closeBackend =<< readIORef cbe + where + closeBackend (ConnPlain s) = close s + closeBackend (ConnSecure context) = bye context `finally` contextClose context + +toProducer :: (MonadIO m) => Connection -> P.Producer' BS.ByteString m () +toProducer conn = go + where + go = do + bs <- liftIO $ connRecv conn + unless (BS.null bs) $ + P.yield bs >> go diff --git a/src/Network/Mail/Postie/Pipes.hs b/src/Network/Mail/Postie/Pipes.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Postie/Pipes.hs @@ -0,0 +1,80 @@ +module Network.Mail.Postie.Pipes + ( dataChunks, + attoParser, + UnexpectedEndOfInputException, + TooMuchDataException, + ) +where + +import Control.Applicative +import Control.Exception (Exception, throw) +import Control.Monad (unless) +import qualified Data.Attoparsec.ByteString as AT +import qualified Data.ByteString.Char8 as BS +import Data.Maybe (fromMaybe) +import Data.Typeable (Typeable) +import Pipes +import Pipes.Parse +import Prelude hiding (lines) + +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 TooMuchDataException + 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/Network/Mail/Postie/Protocol.hs b/src/Network/Mail/Postie/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Postie/Protocol.hs @@ -0,0 +1,193 @@ +module Network.Mail.Postie.Protocol + ( TlsStatus (..), + AuthStatus (..), + Mailbox, + Event (..), + Command (..), + SmtpFSM, + Reply, + initSmtpFSM, + step, + reply, + reply', + renderReply, + parseCommand, + parseHelo, + parseMailFrom, + ) +where + +import Control.Applicative +import Control.Monad (void) +import Data.Attoparsec.ByteString.Char8 hiding (match) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Functor (($>)) +import Network.Mail.Postie.Address +import Prelude hiding (takeWhile) + +data TlsStatus = Active | Forbidden | Permitted | Required deriving (Eq) + +data AuthStatus = Authed | NoAuth | AuthRequired 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 + | WantAuth BS.ByteString + | WantReset + | WantQuit + | TlsAlreadyActive + | TlsNotSupported + | NeedStartTlsFirst + | NeedAuthFirst + | NeedHeloFirst + | NeedMailFromFirst + | NeedRcptToFirst + deriving (Eq, Show) + +data Command + = Helo BS.ByteString + | Ehlo BS.ByteString + | MailFrom Mailbox + | RcptTo Mailbox + | StartTls + | Auth BS.ByteString + | Data + | Rset + | Quit + deriving (Eq, Show) + +newtype SmtpFSM = SmtpFSM {step :: Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM)} + +initSmtpFSM :: SmtpFSM +initSmtpFSM = SmtpFSM (handleSmtpCmd Unknown) + +handleSmtpCmd :: SessionState -> Command -> TlsStatus -> AuthStatus -> (Event, SmtpFSM) +handleSmtpCmd st cmd tlsSt auth = match tlsSt auth st cmd + where + match :: TlsStatus -> AuthStatus -> 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 _ AuthRequired _ (MailFrom _) = event NeedAuthFirst + match _ _ Unknown (MailFrom _) = event NeedHeloFirst + match _ _ _ (MailFrom x) = trans (HaveMailFrom, SetMailFrom x) + match Required _ _ (RcptTo _) = event NeedStartTlsFirst + match _ AuthRequired _ (RcptTo _) = event NeedAuthFirst + 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 _ AuthRequired _ Data = event NeedAuthFirst + 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) + match Required _ _ (Auth _) = event NeedStartTlsFirst + match _ _ _ (Auth d) = trans (HaveEhlo, WantAuth d) + 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, + parseAuth, + parseMailFrom, + parseRcptTo + ] + +crlf :: Parser () +crlf = void $ char '\r' >> char '\n' + +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" $> StartTls + +parseAuth :: Parser Command +parseAuth = Auth <$> (stringCI "auth plain" *> char ' ' *> takeWhile (notInClass "\r ")) + +parseRset :: Parser Command +parseRset = stringCI "rset" $> Rset + +parseData :: Parser Command +parseData = stringCI "data" $> Data + +parseQuit :: Parser Command +parseQuit = stringCI "quit" $> Quit diff --git a/src/Network/Mail/Postie/Session.hs b/src/Network/Mail/Postie/Session.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Postie/Session.hs @@ -0,0 +1,255 @@ +module Network.Mail.Postie.Session + ( runSession, + mkSessionEnv, + mkSessionID, + ) +where + +import Control.Applicative +import Control.Arrow ((&&&)) +import Control.Monad.Reader +import Control.Monad.State +import Data.ByteString (ByteString) +import qualified Network.TLS as TLS +import qualified Pipes.Parse as P +import Network.Mail.Postie.Address +import Network.Mail.Postie.Connection +import Network.Mail.Postie.Pipes +import Network.Mail.Postie.Protocol (Event (..), Reply, renderReply, reply, reply') +import qualified Network.Mail.Postie.Protocol as SMTP +import Network.Mail.Postie.SessionID +import Network.Mail.Postie.Settings +import Network.Mail.Postie.Types +import Prelude hiding (lines) + +data SessionEnv + = SessionEnv + { sessionID :: SessionID, + sessionApp :: Application, + sessionSettings :: Settings, + sessionConnection :: Connection, + sessionServerParams :: Maybe TLS.ServerParams + } + +data SessionState + = SessionState + { sessionProtocol :: SMTP.SmtpFSM, + sessionTransaction :: Transaction + } + +type SessionM a = ReaderT SessionEnv (StateT SessionState IO) a + +data Transaction + = TxnInitial + | TxnHaveAuth ByteString + | TxnHaveMailFrom (Maybe ByteString) Address + | TxnHaveRecipient (Maybe ByteString) Address [Address] + +mkSessionEnv :: SessionID -> Application -> Settings -> Connection -> Maybe TLS.ServerParams -> SessionEnv +mkSessionEnv = SessionEnv + +runSession :: SessionEnv -> IO () +runSession env = evalStateT (runReaderT startSession env) session + where + session = + SessionState + { sessionProtocol = SMTP.initSmtpFSM, + sessionTransaction = TxnInitial + } + +startSession :: SessionM () +startSession = do + sendReply $ reply 220 "hello!" + sessionLoop + +sessionLoop :: SessionM () +sessionLoop = do + (event, fsm') <- SMTP.step <$> getSmtpFsm <*> getCommand <*> getTlsStatus <*> getAuthStatus + case event of + WantQuit -> do + sendReply $ reply 221 "goodbye" + return () + _ -> do + modify (\ss -> ss {sessionProtocol = fsm'}) + handleEvent event >> sessionLoop + where + getSmtpFsm = gets sessionProtocol + getTlsStatus = do + SessionEnv + { sessionConnection = conn, + sessionSettings = settings + } <- + ask + isSecure <- liftIO (connIsSecure conn) + return $ case settingsStartTLSPolicy settings of + Just p + | isSecure -> SMTP.Active + | p == AllowStartTLS -> SMTP.Permitted + | p == DemandStartTLS -> SMTP.Required + _ -> SMTP.Forbidden + getAuthStatus = do + reqAuth <- asks (settingsRequireAuth . sessionSettings) + txn <- gets sessionTransaction + return $ case txn of + TxnInitial -> if reqAuth then SMTP.AuthRequired else SMTP.NoAuth + TxnHaveAuth _ -> SMTP.Authed + TxnHaveMailFrom (Just _) _ -> SMTP.Authed + TxnHaveRecipient (Just _) _ _ -> SMTP.Authed + _ -> SMTP.NoAuth + +preserveAuth :: (Maybe ByteString -> Transaction) -> Transaction -> Transaction +preserveAuth f t = case t of + TxnInitial -> f Nothing + TxnHaveAuth d -> f (Just d) + TxnHaveMailFrom a _ -> f a + TxnHaveRecipient a _ _ -> f a + +handleHelo :: ByteString -> SessionM HandlerResponse +handleHelo x = do + SessionEnv + { sessionID = sid, + sessionSettings = settings + } <- + ask + let handler = settingsOnHello settings + liftIO $ handler sid x + +handleEvent :: SMTP.Event -> SessionM () +handleEvent (SayHelo x) = do + result <- handleHelo x + handlerResponse result (sendReply ok) +handleEvent (SayEhlo x) = do + result <- handleHelo x + handlerResponse result $ + sendReply =<< ehloAdvertisement +handleEvent (SayEhloAgain _) = sendReply ok +handleEvent (SayHeloAgain _) = sendReply ok +handleEvent SayOK = sendReply ok +handleEvent (SetMailFrom x) = do + SessionEnv + { sessionID = sid, + sessionSettings = settings + } <- + ask + let handler = settingsOnMailFrom settings + result <- liftIO $ handler sid x + handlerResponse result $ do + modify (\ss -> ss {sessionTransaction = preserveAuth (`TxnHaveMailFrom` x) (sessionTransaction ss)}) + sendReply ok +handleEvent (AddRcptTo x) = do + SessionEnv + { sessionID = sid, + sessionSettings = settings + } <- + ask + let handler = settingsOnRecipient settings + result <- liftIO $ handler sid x + handlerResponse result $ do + txn <- gets sessionTransaction + let txn' = case txn of + (TxnHaveMailFrom a y) -> TxnHaveRecipient a y [x] + (TxnHaveRecipient a y xs) -> TxnHaveRecipient a y (x : xs) + _ -> error "impossible" + modify (\ss -> ss {sessionTransaction = txn'}) + sendReply ok +handleEvent StartData = do + sendReply $ reply 354 "End data with ." + SessionEnv + { sessionID = sid, + sessionApp = app, + sessionSettings = settings, + sessionConnection = conn + } <- + ask + (TxnHaveRecipient auth sender recipients) <- gets sessionTransaction + let chunks = dataChunks (settingsMaxDataSize settings) (toProducer conn) + let mail = Mail sid auth sender recipients chunks + result <- liftIO $ app mail + handlerResponse result $ do + sendReply ok + modify (\ss -> ss {sessionTransaction = TxnInitial}) +handleEvent WantTls = do + SessionEnv + { sessionID = sid, + sessionConnection = conn, + sessionSettings = settings, + sessionServerParams = Just serverParams + } <- + ask + let handler = settingsOnStartTLS settings + liftIO $ handler sid + sendReply ok + liftIO $ connSetSecure conn serverParams + modify (\ss -> ss {sessionTransaction = TxnInitial}) +handleEvent (WantAuth d) = do + (sid, settings) <- asks (sessionID &&& sessionSettings) + let handler = settingsOnAuth settings + result <- liftIO $ handler sid d + handlerResponse result $ do + sendReply ok + modify (\ss -> ss {sessionTransaction = TxnHaveAuth d}) +handleEvent WantReset = do + sendReply ok + modify (\ss -> ss {sessionTransaction = TxnInitial}) +handleEvent TlsAlreadyActive = + sendReply $ reply 454 "STARTTLS not supported (already active)" +handleEvent TlsNotSupported = + sendReply $ reply 454 "STARTTLS not supported" +handleEvent NeedStartTlsFirst = + sendReply $ reply 530 "Issue STARTTLS first" +handleEvent NeedAuthFirst = + sendReply $ reply 530 "5.7.1 Authentication required" +handleEvent NeedHeloFirst = + sendReply $ reply 503 "Need EHLO first" +handleEvent NeedMailFromFirst = + sendReply $ reply 503 "Need MAIL FROM first" +handleEvent NeedRcptToFirst = + sendReply $ reply 503 "Need RCPT TO first" +handleEvent _ = error "impossible" + +handlerResponse :: HandlerResponse -> SessionM () -> SessionM () +handlerResponse Accepted action = action +handlerResponse Rejected _ = sendReply reject + +getCommand :: SessionM SMTP.Command +getCommand = do + input <- toProducer `fmap` asks sessionConnection + result <- liftIO $ P.evalStateT (attoParser SMTP.parseCommand) input + case result of + Nothing -> do + sendReply $ reply 500 "Syntax error, command unrecognized" + getCommand + Just command -> return command + +ehloAdvertisement :: SessionM Reply +ehloAdvertisement = do + stls <- startTls + let extensions = "8BITMIME" : stls + return $ reply' 250 (extensions ++ ["OK"]) + where + startTls = do + SessionEnv + { sessionConnection = conn, + sessionSettings = settings + } <- + ask + secure <- liftIO (connIsSecure conn) + return + [ "STARTTLS" + | not secure + && ( case settingsStartTLSPolicy settings of + Just _ -> True + _ -> False + ) + ] + +ok :: Reply +ok = reply 250 "OK" + +reject :: Reply +reject = reply 554 "Transaction failed" + +sendReply :: Reply -> SessionM () +sendReply r = do + conn <- asks sessionConnection + liftIO $ connSend conn (renderReply r) diff --git a/src/Network/Mail/Postie/SessionID.hs b/src/Network/Mail/Postie/SessionID.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Postie/SessionID.hs @@ -0,0 +1,26 @@ +module Network.Mail.Postie.SessionID + ( SessionID, + -- | Unique session identifier + mkSessionID, + -- | Creates a SessionID + toByteString, + -- | Converts SessionID to ByteString + ) +where + +import Data.ByteString (ByteString) +import Data.Typeable (Typeable) +import Data.UUID (UUID, toASCIIBytes, toString) +import Data.UUID.V4 (nextRandom) + +newtype SessionID = SessionID {toUUID :: UUID} + deriving (Eq, Ord, Typeable) + +instance Show SessionID where + show = toString . toUUID + +mkSessionID :: IO SessionID +mkSessionID = SessionID `fmap` nextRandom + +toByteString :: SessionID -> ByteString +toByteString = toASCIIBytes . toUUID diff --git a/src/Network/Mail/Postie/Settings.hs b/src/Network/Mail/Postie/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Postie/Settings.hs @@ -0,0 +1,177 @@ +module Network.Mail.Postie.Settings + ( Settings (..), + TLSSettings (..), + StartTLSPolicy (..), + settingsStartTLSPolicy, + defaultExceptionHandler, + mkServerParams, + def, + -- | reexport from Default class + ) +where + +import Control.Applicative +import Control.Exception +import Data.ByteString (ByteString) +import Data.Default.Class +import GHC.IO.Exception (IOErrorType (..)) +import Network.Socket (HostName, PortNumber, SockAddr) +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TLS +import System.IO (hPrint, stderr) +import System.IO.Error (ioeGetErrorType) +import Network.Mail.Postie.Address +import Network.Mail.Postie.SessionID +import Network.Mail.Postie.Types +import Prelude + +-- | Settings to configure posties behaviour. +data Settings + = Settings + { -- | Port postie will run on. + settingsPort :: PortNumber, + -- | Timeout for connections in seconds + settingsTimeout :: Int, + -- | Maximal size of incoming mail data + settingsMaxDataSize :: Int, + -- | Hostname which is shown in posties greeting. + settingsHost :: Maybe HostName, + -- | TLS settings if you wish to secure connections. + settingsTLS :: Maybe TLSSettings, + -- | Whether authentication is required + settingsRequireAuth :: Bool, + -- | Exception handler (default is defaultExceptionHandler) + settingsOnException :: Maybe SessionID -> SomeException -> IO (), + -- | Action will be performed before main processing begins. + settingsBeforeMainLoop :: IO (), + -- | Action will be performed when connection has been opened. + settingsOnOpen :: SessionID -> SockAddr -> IO (), + -- | Action will be performed when connection has been closed. + settingsOnClose :: SessionID -> IO (), + -- | Action will be performend on STARTTLS command. + settingsOnStartTLS :: SessionID -> IO (), + -- | Performed when client says hello + settingsOnHello :: SessionID -> ByteString -> IO HandlerResponse, + -- | Performed when client authenticates + settingsOnAuth :: SessionID -> ByteString -> IO HandlerResponse, + -- | Performed when client starts mail transaction + settingsOnMailFrom :: SessionID -> Address -> IO HandlerResponse, + -- | Performed when client adds recipient to mail transaction. + settingsOnRecipient :: SessionID -> Address -> IO HandlerResponse + } + +instance Default Settings where + def = defaultSettings + +-- | Default settings for postie +defaultSettings :: Settings +defaultSettings = + Settings + { settingsPort = 3001, + settingsTimeout = 1800, + settingsMaxDataSize = 32000, + settingsHost = Nothing, + settingsTLS = Nothing, + settingsRequireAuth = False, + settingsOnException = defaultExceptionHandler, + settingsBeforeMainLoop = return (), + settingsOnOpen = \_ _ -> return (), + settingsOnClose = const $ return (), + settingsOnStartTLS = const $ return (), + settingsOnAuth = void, + settingsOnHello = void, + settingsOnMailFrom = void, + settingsOnRecipient = void + } + where + void _ _ = return Accepted + +-- | Settings for TLS handling +data TLSSettings + = TLSSettings + { -- | Path to certificate file + certFile :: FilePath, + -- | Path to private key file belonging to certificate + keyFile :: FilePath, + -- | Connection security mode, default is DemandStartTLS + security :: StartTLSPolicy, + -- | Logging for TLS + tlsLogging :: TLS.Logging, + -- | Supported TLS versions + tlsAllowedVersions :: [TLS.Version], + -- | Supported ciphers + tlsCiphers :: [TLS.Cipher] + } + +instance Default TLSSettings where + def = defaultTLSSettings + +-- | Connection security policy, either via STARTTLS command or on connection initiation. +data StartTLSPolicy + = -- | Allows clients to use STARTTLS command + AllowStartTLS + | -- | Client needs to send STARTTLS command before issuing a mail transaction + DemandStartTLS + | -- | Negotiates a TSL context on connection startup. + ConnectWithTLS + deriving (Eq, Show) + +defaultTLSSettings :: TLSSettings +defaultTLSSettings = + TLSSettings + { certFile = "certificate.pem", + keyFile = "key.pem", + security = DemandStartTLS, + tlsLogging = def, + tlsAllowedVersions = [TLS.SSL3, TLS.TLS10, TLS.TLS11, TLS.TLS12], + tlsCiphers = TLS.ciphersuite_default + } + +settingsStartTLSPolicy :: Settings -> Maybe StartTLSPolicy +settingsStartTLSPolicy settings = security `fmap` settingsTLS settings + +mkServerParams :: TLSSettings -> IO TLS.ServerParams +mkServerParams tlsSettings = do + credentials <- loadCredentials + return + def + { TLS.serverShared = + def + { TLS.sharedCredentials = TLS.Credentials [credentials] + }, + TLS.serverSupported = + def + { TLS.supportedCiphers = tlsCiphers tlsSettings, + TLS.supportedVersions = tlsAllowedVersions tlsSettings + } + } + where + loadCredentials = + either (throw . TLS.Error_Certificate) id + <$> TLS.credentialLoadX509 (certFile tlsSettings) (keyFile tlsSettings) + +defaultExceptionHandler :: Maybe SessionID -> SomeException -> IO () +defaultExceptionHandler _ e = throwIO e `catches` handlers + where + handlers = [Handler ah, Handler oh, Handler tlsh, Handler th, 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 + 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 = hPrint stderr diff --git a/src/Network/Mail/Postie/Types.hs b/src/Network/Mail/Postie/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Postie/Types.hs @@ -0,0 +1,35 @@ +module Network.Mail.Postie.Types + ( HandlerResponse (..), + Mail (..), + Application, + ) +where + +import Data.ByteString (ByteString) +import Pipes (Producer) +import Network.Mail.Postie.Address +import Network.Mail.Postie.SessionID (SessionID) + +-- | Handler response indicating validity of email transaction. +data HandlerResponse + = -- | Accepted, allow further processing. + Accepted + | -- | Rejected, stop transaction. + Rejected + +-- | Received email +data Mail + = Mail + { mailSessionID :: SessionID, + mailAuth :: Maybe ByteString, + -- | Sender + mailSender :: Address, + -- | Recipients + mailRecipients :: [Address], + -- | Mail content + mailBody :: Producer ByteString IO () + } + +-- | 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 diff --git a/src/Web/Postie.hs b/src/Web/Postie.hs deleted file mode 100644 --- a/src/Web/Postie.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# 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 - - -- * 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 Network.TLS (ServerParams) - -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 (def { 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 = - runSettingsConnection settings getConn app - where - getConn = do - (s, sa) <- accept socket - conn <- mkSocketConnection s - return (conn, sa) - -runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> Application -> IO () -runSettingsConnection settings getConn app = do - serverParams <- mkServerParams' - runSettingsConnectionMaker settings (getConnMaker serverParams) serverParams app - where - getConnMaker serverParams = do - (conn, sa) <- getConn - let mkConn = do - case settingsStartTLSPolicy settings of - Just ConnectWithTLS -> do - let (Just sp) = serverParams - connSetSecure conn sp - _ -> return () - return conn - return (mkConn, sa) - - mkServerParams' = - case settingsTLS settings of - Just tls -> do - serverParams <- mkServerParams tls - return (Just serverParams) - _ -> return Nothing - -runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) - -> Maybe ServerParams -> Application -> IO () -runSettingsConnectionMaker settings getConnMaker serverParams app = do - settingsBeforeMainLoop settings - void $ forever $ do - (mkConn, sockAddr) <- getConnLoop - void $ forkIOWithUnmask $ \unmask -> do - sessionID <- mkSessionID - bracket mkConn connClose $ \conn -> - void $ timeout maxDuration $ - unmask . - handle (onE $ Just sessionID ). - bracket_ (onOpen sessionID sockAddr) (onClose sessionID) $ - runSession (mkSessionEnv sessionID app settings conn serverParams) - return () - return () - where - getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do - onE Nothing (toException e) - threadDelay 1000000 - getConnLoop - - onE = settingsOnException settings - onOpen = settingsOnOpen settings - onClose = settingsOnClose settings - - maxDuration = settingsTimeout settings * 1000000 diff --git a/src/Web/Postie/Address.hs b/src/Web/Postie/Address.hs deleted file mode 100644 --- a/src/Web/Postie/Address.hs +++ /dev/null @@ -1,155 +0,0 @@ - -module Web.Postie.Address( - Address -- | Represents an email address - , address -- | Returns address from local and domain part - , addressLocalPart -- | Returns local part of address - , addressDomain -- | Retuns domain part of address - - , toByteString -- | Resulting ByteString has format localPart\@domainPart. - , toLazyByteString -- | Resulting Lazy.ByteString has format localPart\@domainPart. - - , parseAddress -- | Parses a ByteString to Address - , addrSpec - ) where - -import Data.String -import Data.Maybe (fromMaybe) -import Data.Typeable (Typeable) -import Data.Attoparsec.Char8 -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as LBS - -import Control.Applicative -import Control.Monad (void) - -data Address = Address { - addressLocalPart :: !BS.ByteString - , addressDomain :: !BS.ByteString - } - deriving (Eq, Ord, Typeable) - -instance Show Address where - show = BS.unpack . toByteString - -instance IsString Address where - fromString = fromMaybe (error "invalid email literal") . parseAddress . BS.pack - -address :: BS.ByteString -> BS.ByteString -> Address -address = Address - -toByteString :: Address -> BS.ByteString -toByteString (Address l d) = BS.concat [l, BS.singleton '@', d] - -toLazyByteString :: Address -> LBS.ByteString -toLazyByteString (Address l d) = LBS.fromChunks [l, BS.singleton '@', d] - -parseAddress :: BS.ByteString -> Maybe Address -parseAddress = maybeResult . parse addrSpec - --- | Address Parser. Borrowed form email-validate-2.0.1. Parser for email address. -addrSpec :: Parser Address -addrSpec = do - localPart <- local - _ <- 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 = void - -between :: Parser l -> Parser r -> Parser x -> Parser x -between l r x = l *> x <* r - -comment :: Parser () -comment = ignore (between (char '(') (char ')') $ - many (ignore commentContent <|> fws)) - -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 deleted file mode 100644 --- a/src/Web/Postie/Connection.hs +++ /dev/null @@ -1,87 +0,0 @@ -module Web.Postie.Connection( - Connection - , connIsSecure - , connSetSecure - , connRecv - , connSend - , connClose - , mkSocketConnection - , toProducer - ) 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 Data.IORef - -import Control.Exception (finally) -import Control.Monad.IO.Class -import Control.Monad (unless) - -import qualified Pipes as P - -data ConnectionBackend = ConnPlain Socket - | ConnSecure Context - -data Connection = Connection (IORef ConnectionBackend) - -connSetSecure :: Connection -> ServerParams -> IO () -connSetSecure (Connection cbe) params = do - backend <- readIORef cbe - securedBackend <- upgrade backend - writeIORef cbe securedBackend - where upgrade (ConnPlain be) = do - context <- contextNew be params =<< makeSystem - handshake context - return (ConnSecure context) - upgrade (ConnSecure _) = error "already on secure connection" - -connIsSecure :: Connection -> IO Bool -connIsSecure (Connection cbe) = do - backend <- readIORef cbe - return $ case backend of - (ConnSecure _) -> True - _ -> False - -mkSocketConnection :: Socket -> IO Connection -mkSocketConnection socket = do - conn <- newIORef (ConnPlain socket) - return (Connection conn) - -connBackendRecv :: ConnectionBackend -> IO BS.ByteString -connBackendRecv (ConnPlain socket) = recv socket defaultChunkSize -connBackendRecv (ConnSecure ctx) = recvData ctx - -connBackendSend :: ConnectionBackend -> LBS.ByteString -> IO () -connBackendSend (ConnPlain socket) = sendAll socket -connBackendSend (ConnSecure ctx) = sendData ctx - -connRecv :: Connection -> IO BS.ByteString -connRecv (Connection cbe) = readIORef cbe >>= connBackendRecv - -connSend :: Connection -> LBS.ByteString -> IO () -connSend (Connection cbe) lbs = do - backend <- readIORef cbe - connBackendSend backend lbs - -connClose :: Connection -> IO () -connClose (Connection cbe) = closeBackend =<< readIORef cbe - where - closeBackend (ConnPlain socket) = sClose socket - closeBackend (ConnSecure context) = bye context `finally` contextClose context - -toProducer :: (MonadIO m) => Connection -> P.Producer' BS.ByteString m () -toProducer conn = go - where - go = do - bs <- liftIO $ connRecv conn - unless (BS.null bs) $ - P.yield bs >> go diff --git a/src/Web/Postie/Pipes.hs b/src/Web/Postie/Pipes.hs deleted file mode 100644 --- a/src/Web/Postie/Pipes.hs +++ /dev/null @@ -1,83 +0,0 @@ - -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 TooMuchDataException - 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 deleted file mode 100644 --- a/src/Web/Postie/Protocol.hs +++ /dev/null @@ -1,180 +0,0 @@ - -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 -import Control.Monad (void) - -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 = void $ char '\r' >> char '\n' - -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 deleted file mode 100644 --- a/src/Web/Postie/Session.hs +++ /dev/null @@ -1,246 +0,0 @@ - -module Web.Postie.Session( - runSession - , mkSessionEnv - , mkSessionID - ) where - -import Prelude hiding (lines) - -import Web.Postie.Address -import Web.Postie.Types -import Web.Postie.Settings -import Web.Postie.Connection -import Web.Postie.SessionID -import Web.Postie.Protocol (Event(..), Reply, reply, reply', renderReply) -import qualified Web.Postie.Protocol as SMTP -import Web.Postie.Pipes - -import qualified Pipes.Parse as P -import qualified Network.TLS as TLS - -import Control.Applicative -import Control.Monad.Reader -import Control.Monad.State - -data SessionEnv = SessionEnv { - sessionID :: SessionID - , sessionApp :: Application - , sessionSettings :: Settings - , sessionConnection :: Connection - , sessionServerParams :: Maybe TLS.ServerParams - } - -data SessionState = SessionState { - sessionProtocol :: SMTP.SmtpFSM - , sessionTransaction :: Transaction - } - -type SessionM a = ReaderT SessionEnv (StateT SessionState IO) a - -data Transaction = TxnInitial - | TxnHaveMailFrom Address - | TxnHaveRecipient Address [Address] - -mkSessionEnv :: SessionID -> Application -> Settings -> Connection -> Maybe TLS.ServerParams -> SessionEnv -mkSessionEnv = SessionEnv - -runSession :: SessionEnv -> IO () -runSession env = evalStateT (runReaderT startSession env) session - where - session = SessionState { - sessionProtocol = SMTP.initSmtpFSM - , sessionTransaction = TxnInitial - } - -startSession :: SessionM () -startSession = do - sendReply $ reply 220 "hello!" - sessionLoop - -sessionLoop :: SessionM () -sessionLoop = do - (event, fsm') <- SMTP.step <$> getSmtpFsm <*> getCommand <*> getTlsStatus - case event of - WantQuit -> do - sendReply $ reply 221 "goodbye" - return () - _ -> do - modify (\ss -> ss { sessionProtocol = fsm' }) - handleEvent event >> sessionLoop - where - getSmtpFsm = gets sessionProtocol - getTlsStatus = do - SessionEnv { - sessionConnection = conn - , sessionSettings = settings - } <- ask - - isSecure <- liftIO (connIsSecure conn) - - return $ case settingsStartTLSPolicy settings of - Just p | isSecure -> SMTP.Active - | p == AllowStartTLS -> SMTP.Permitted - | p == DemandStartTLS -> SMTP.Required - _ -> SMTP.Forbidden - -handleEvent :: SMTP.Event -> SessionM () -handleEvent (SayHelo x) = do - SessionEnv { - sessionID = sid - , sessionSettings = settings - } <- ask - - let handler = settingsOnHello settings - - result <- liftIO $ handler sid x - handlerResponse result (sendReply ok) - -handleEvent (SayEhlo x) = do - SessionEnv { - sessionID = sid - , sessionSettings = settings - } <- ask - - let handler = settingsOnHello settings - - result <- liftIO $ handler sid x - handlerResponse result $ - sendReply =<< ehloAdvertisement - -handleEvent (SayEhloAgain _) = sendReply ok -handleEvent (SayHeloAgain _) = sendReply ok -handleEvent SayOK = sendReply ok - -handleEvent (SetMailFrom x) = do - SessionEnv { - sessionID = sid - , sessionSettings = settings - } <- ask - - let handler = settingsOnMailFrom settings - - result <- liftIO $ handler sid x - handlerResponse result $ do - modify (\ss -> ss { sessionTransaction = TxnHaveMailFrom x }) - sendReply ok - -handleEvent (AddRcptTo x) = do - SessionEnv { - sessionID = sid - , sessionSettings = settings - } <- ask - - let handler = settingsOnRecipient settings - - result <- liftIO $ handler sid x - handlerResponse result $ do - txn <- gets sessionTransaction - let txn' = case txn of - (TxnHaveMailFrom y) -> TxnHaveRecipient y [x] - (TxnHaveRecipient y xs) -> TxnHaveRecipient y (x:xs) - _ -> error "impossible" - modify (\ss -> ss {sessionTransaction = txn' }) - sendReply ok - -handleEvent StartData = do - sendReply $ reply 354 "End data with ." - - SessionEnv { - sessionID = sid - , sessionApp = app - , sessionSettings = settings - , sessionConnection = conn - } <- ask - - (TxnHaveRecipient sender recipients) <- gets sessionTransaction - let chunks = dataChunks (settingsMaxDataSize settings) (toProducer conn) - let mail = Mail sid sender recipients chunks - - result <- liftIO $ app mail - handlerResponse result $ do - sendReply ok - modify (\ss -> ss { sessionTransaction = TxnInitial }) - -handleEvent WantTls = do - - SessionEnv { - sessionID = sid - , sessionConnection = conn - , sessionSettings = settings - , sessionServerParams = Just serverParams - } <- ask - - let handler = settingsOnStartTLS settings - - liftIO $ handler sid - sendReply ok - - liftIO $ connSetSecure conn serverParams - modify (\ss -> ss { sessionTransaction = TxnInitial }) - -handleEvent WantReset = do - sendReply ok - modify (\ss -> ss { sessionTransaction = TxnInitial }) - -handleEvent TlsAlreadyActive = - sendReply $ reply 454 "STARTTLS not support (already active)" - -handleEvent TlsNotSupported = - sendReply $ reply 454 "STARTTLS not supported" - -handleEvent NeedStartTlsFirst = - sendReply $ reply 530 "Issue STARTTLS first" - -handleEvent NeedHeloFirst = - sendReply $ reply 503 "Need EHLO first" - -handleEvent NeedMailFromFirst = - sendReply $ reply 503 "Need MAIL FROM first" - -handleEvent NeedRcptToFirst = - sendReply $ reply 503 "Need RCPT TO first" - -handleEvent _ = error "impossible" - -handlerResponse :: HandlerResponse -> SessionM () -> SessionM () -handlerResponse Accepted action = action -handlerResponse Rejected _ = sendReply reject - -getCommand :: SessionM SMTP.Command -getCommand = do - input <- toProducer `fmap` asks sessionConnection - result <- liftIO $ P.evalStateT (attoParser SMTP.parseCommand) input - case result of - Nothing -> do - sendReply $ reply 500 "Syntax error, command unrecognized" - getCommand - Just command -> return command - -ehloAdvertisement :: SessionM Reply -ehloAdvertisement = do - stls <- startTls - let extensions = "8BITMIME" : stls - return $ reply' 250 (extensions ++ ["OK"]) - where - startTls = do - SessionEnv { - sessionConnection = conn - , sessionSettings = settings - } <- ask - secure <- liftIO (connIsSecure conn) - return ["STARTTLS" | not secure && ( - case settingsStartTLSPolicy settings of - Just _ -> True - _ -> False)] - -ok :: Reply -ok = reply 250 "OK" - -reject :: Reply -reject = reply 554 "Transaction failed" - -sendReply :: Reply -> SessionM () -sendReply r = do - conn <- asks sessionConnection - liftIO $ connSend conn (renderReply r) diff --git a/src/Web/Postie/SessionID.hs b/src/Web/Postie/SessionID.hs deleted file mode 100644 --- a/src/Web/Postie/SessionID.hs +++ /dev/null @@ -1,23 +0,0 @@ - -module Web.Postie.SessionID ( - SessionID -- | Unique session identifier - , mkSessionID -- | Creates a SessionID - , toByteString -- | Converts SessionID to ByteString - ) where - -import Data.UUID (UUID, toString, toASCIIBytes) -import Data.UUID.V4 (nextRandom) -import Data.ByteString (ByteString) -import Data.Typeable (Typeable) - -newtype SessionID = SessionID { toUUID :: UUID } - deriving (Eq, Ord, Typeable) - -instance Show SessionID where - show = toString . toUUID - -mkSessionID :: IO SessionID -mkSessionID = SessionID `fmap` nextRandom - -toByteString :: SessionID -> ByteString -toByteString = toASCIIBytes . toUUID diff --git a/src/Web/Postie/Settings.hs b/src/Web/Postie/Settings.hs deleted file mode 100644 --- a/src/Web/Postie/Settings.hs +++ /dev/null @@ -1,149 +0,0 @@ - -module Web.Postie.Settings( - Settings(..) - , TLSSettings(..) - , StartTLSPolicy(..) - , settingsStartTLSPolicy - , defaultExceptionHandler - , mkServerParams - , def -- |reexport from Default class - ) where - -import Web.Postie.Types -import Web.Postie.Address -import Web.Postie.SessionID - -import Network (HostName, PortID(..)) -import System.IO (hPrint, stderr) -import System.IO.Error (ioeGetErrorType) -import Data.ByteString (ByteString) - -import Network.Socket (SockAddr) -import qualified Network.TLS as TLS -import qualified Network.TLS.Extra.Cipher as TLS - -import Data.Default.Class - -import Control.Exception -import GHC.IO.Exception (IOErrorType(..)) -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 :: Maybe SessionID -> SomeException -> IO () -- ^ Exception handler (default is defaultExceptionHandler) - , settingsBeforeMainLoop :: IO () -- ^ Action will be performed before main processing begins. - , settingsOnOpen :: SessionID -> SockAddr -> IO () -- ^ Action will be performed when connection has been opened. - , settingsOnClose :: SessionID -> IO () -- ^ Action will be performed when connection has been closed. - , settingsOnStartTLS :: SessionID -> IO () -- ^ Action will be performend on STARTTLS command. - , settingsOnHello :: SessionID -> ByteString -> IO HandlerResponse -- ^ Performed when client says hello - , settingsOnMailFrom :: SessionID -> Address -> IO HandlerResponse -- ^ Performed when client starts mail transaction - , settingsOnRecipient :: SessionID -> Address -> IO HandlerResponse -- ^ Performed when client adds recipient to mail transaction. - } - -instance Default Settings where - def = defaultSettings - --- | Default settings for postie -defaultSettings :: Settings -defaultSettings = Settings { - settingsPort = PortNumber 3001 - , settingsTimeout = 1800 - , settingsMaxDataSize = 32000 - , settingsHost = Nothing - , settingsTLS = Nothing - , settingsOnException = defaultExceptionHandler - , settingsBeforeMainLoop = return () - , settingsOnOpen = \_ _ -> return () - , settingsOnClose = const $ return () - , settingsOnStartTLS = const $ return () - , settingsOnHello = void - , settingsOnMailFrom = void - , settingsOnRecipient = void - } - where - void _ _ = return Accepted - - --- | Settings for TLS handling -data TLSSettings = TLSSettings { - 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 - } - -instance Default TLSSettings where - def = defaultTLSSettings - --- | Connection security policy, either via STARTTLS command or on connection initiation. -data StartTLSPolicy = AllowStartTLS -- ^ Allows clients to use STARTTLS command - | DemandStartTLS -- ^ Client needs to send STARTTLS command before issuing a mail transaction - | ConnectWithTLS -- ^ Negotiates a TSL context on connection startup. - deriving (Eq, Show) - -defaultTLSSettings :: TLSSettings -defaultTLSSettings = TLSSettings { - certFile = "certificate.pem" - , keyFile = "key.pem" - , security = DemandStartTLS - , tlsLogging = def - , tlsAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12] - , tlsCiphers = TLS.ciphersuite_all - } - -settingsStartTLSPolicy :: Settings -> Maybe StartTLSPolicy -settingsStartTLSPolicy settings = security `fmap` settingsTLS settings - -mkServerParams :: TLSSettings -> IO TLS.ServerParams -mkServerParams tlsSettings = do - credentials <- loadCredentials - return def { - TLS.serverShared = def { - TLS.sharedCredentials = TLS.Credentials [credentials] - }, - TLS.serverSupported = def { - TLS.supportedCiphers = tlsCiphers tlsSettings - , TLS.supportedVersions = tlsAllowedVersions tlsSettings - } - } - where - loadCredentials = either (throw . TLS.Error_Certificate) id <$> - TLS.credentialLoadX509 (certFile tlsSettings) (keyFile tlsSettings) - -defaultExceptionHandler :: Maybe SessionID -> SomeException -> IO () -defaultExceptionHandler _ e = throwIO e `catches` handlers - where - handlers = [Handler ah, Handler oh, Handler tlsh, Handler th, 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 - - 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 deleted file mode 100644 --- a/src/Web/Postie/Types.hs +++ /dev/null @@ -1,29 +0,0 @@ - -module Web.Postie.Types( - HandlerResponse(..) - , Mail(..) - , Application - ) where - -import Web.Postie.Address -import Web.Postie.SessionID (SessionID) - -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 { - mailSessionID :: SessionID - , 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