postie 0.5.0.0 → 0.6.0.2

raw patch · 23 files changed

+1293/−1166 lines, 23 filesdep −cprng-aesdep −stringsearchdep −transformersdep ~attoparsecdep ~basedep ~bytestringnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies removed: cprng-aes, stringsearch, transformers

Dependency ranges changed: attoparsec, base, bytestring, data-default-class, mtl, network, pipes, pipes-bytestring, pipes-parse, tls, uuid

API changes (from Hackage documentation)

Files

• examples/Simple.hs +15/−24
• examples/TLS.hs +20/−30
• examples/tls/server.crt +20/−0
• examples/tls/server.key +27/−0
• postie.cabal +67/−42
• src/Network/Mail/Postie.hs +123/−0
• src/Network/Mail/Postie/Address.hs +171/−0
• src/Network/Mail/Postie/Connection.hs +84/−0
• src/Network/Mail/Postie/Pipes.hs +80/−0
• src/Network/Mail/Postie/Protocol.hs +193/−0
• src/Network/Mail/Postie/Session.hs +255/−0
• src/Network/Mail/Postie/SessionID.hs +26/−0
• src/Network/Mail/Postie/Settings.hs +177/−0
• src/Network/Mail/Postie/Types.hs +35/−0
• src/Web/Postie.hs +0/−118
• src/Web/Postie/Address.hs +0/−155
• src/Web/Postie/Connection.hs +0/−87
• src/Web/Postie/Pipes.hs +0/−83
• src/Web/Postie/Protocol.hs +0/−180
• src/Web/Postie/Session.hs +0/−246
• src/Web/Postie/SessionID.hs +0/−23
• src/Web/Postie/Settings.hs +0/−149
• src/Web/Postie/Types.hs +0/−29

@@ -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

@@ -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

@@ -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-----

@@ -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-----

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 <CR><LF>.<CR><LF>"+  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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 <CR><LF>.<CR><LF>"--    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)

@@ -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

@@ -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

@@ -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