postie 0.1.0.0 → 0.2.0.0
raw patch · 9 files changed
+145/−82 lines, 9 filesdep ~bytestringdep ~data-default-classdep ~pipesnew-component:exe:postie-example-simple
Dependency ranges changed: bytestring, data-default-class, pipes, pipes-bytestring, tls
Files
- examples/Simple.hs +8/−1
- postie.cabal +38/−13
- src/Web/Postie.hs +5/−14
- src/Web/Postie/Connection.hs +4/−2
- src/Web/Postie/Pipes.hs +1/−1
- src/Web/Postie/Protocol.hs +2/−2
- src/Web/Postie/Session.hs +4/−0
- src/Web/Postie/Settings.hs +78/−45
- src/Web/Postie/Types.hs +5/−4
examples/Simple.hs view
@@ -5,9 +5,16 @@ import Pipes.ByteString (stdout) +settings :: Settings+settings = defaultSettings {+ settingsTLS = Just $ (tlsSettings "server.crt" "server.key") {+ security = DemandStartTLS+ }+ }+ main :: IO () main = do- run 8080 app+ runSettings settings app where app (Mail _ _ body) = do runEffect $ body >-> stdout
postie.cabal view
@@ -1,23 +1,43 @@ name: postie-version: 0.1.0.0+version: 0.2.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3 license-file: LICENSE maintainer: alex.biehl@gmail.com+description: `postie` is a little smtp server library for receiving emails. It is currently+ in a very early stage and not yet fully standard compatible although the standard+ protocol is already supported.+ - At the time of writing parameters on smtp commands can not be parsed.+ - Handler functions need to return more detailed information to cancel a transaction.+ `postie` supportes hooks on key commands in an smtp session like+ - on connection open and close+ - on `MAIL FROM` command e.g. to intercept transaction if sender is blacklisted+ - on `RCPT TO` command e.g. to check if recipient is existent on your server+ - and many more+ To run `postie` you only need to supply a function which takes a `Mail` and+ return `Accepted` or `Rejected`. `mailBody` is a `pipes` `Producer` which+ streams the encoded body directly to your application code. The body is not+ parsed by `postie` since it depends on what the application wants to do with+ 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 data-dir: ""-description:- `postie` is a little smtp server library for receiving emails. It is currently- in a very early stage and not yet standard compatible although the standard- use cases, e.g. receiving emails already work. +source-repository head+ type: git+ location: https://bitbucket.org/alexbiehl/postie++flag examples+ 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.2, pipes >=4.1.0,+ build-depends: base >=4 && <=5, network >=2.4.1.2,+ bytestring >=0.10.0.2, tls >=1.2.3, 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+ mtl >=2.1.2, cprng-aes >=0.5.2, data-default-class >=0.0.1 exposed-modules: Web.Postie Web.Postie.Types Web.Postie.Settings exposed: True buildable: True@@ -28,10 +48,15 @@ Web.Postie.Protocol Web.Postie.Pipes Web.Postie.Address ghc-options: -O2 -Wall -executable simple- build-depends: base -any, bytestring >=0.10.0.2, tls >=1.2.2,- data-default-class >=0.0.1, pipes >=4.1.0,- pipes-bytestring >=2.0.1, postie -any+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 buildable: True default-language: Haskell2010
src/Web/Postie.hs view
@@ -6,10 +6,6 @@ , runSettings -- | Runs server with a given application and settings , runSettingsSocket- -- | Runs server with a given application, settings and socket- , runSettingsConnection- -- | Runs server with a given application, settings and an action to open new connections- , runSettingsConnectionMaker -- * Application , module Web.Postie.Types@@ -62,16 +58,9 @@ runSettingsSocket :: Settings -> Socket -> Application -> IO () runSettingsSocket settings socket app = do- policy <- startTlsPolicy+ policy <- settingsStartTLSPolicy settings runSettingsConnection settings (getConn policy) app where- startTlsPolicy = do- tlsServerParams <- settingsServerParams settings- return $ case tlsServerParams of- (Just params) | settingsDemandSecure settings -> Demand params- | settingsAllowSecure settings -> Allow params- _ -> NotAvailable- getConn policy = do (s, sa) <- accept socket conn <- socketConnection s policy@@ -83,7 +72,10 @@ getConnMaker = do (conn, sa) <- getConn let mkConn = do- return conn+ case connStartTlsPolicy conn of+ (Always _) -> connStartTls conn+ _ -> return conn+ return (mkConn, sa) runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()@@ -105,7 +97,6 @@ onE (toException e) threadDelay 1000000 getConnLoop- onE = settingsOnException settings onOpen = settingsOnOpen settings
src/Web/Postie/Connection.hs view
@@ -7,6 +7,7 @@ connClose, connIsSecure, + connStartTlsPolicy, connStartTls, connAllowStartTLS, connDemandStartTLS,@@ -42,11 +43,11 @@ , connStartTls :: IO Connection -- ^Creates new connection which is secured by TLS. } -data StartTLSPolicy = Allow ServerParams | Demand ServerParams | NotAvailable+data StartTLSPolicy = Always ServerParams | Allow ServerParams | Demand ServerParams | NotAvailable -- | Upgradeable connection from Socket socketConnection :: Socket -> StartTLSPolicy -> IO Connection-socketConnection socket policy = return connection+socketConnection socket policy = return connection where connection = Connection { connRecv = recv socket defaultChunkSize@@ -73,6 +74,7 @@ params = case policy of (Allow p) -> p (Demand p) -> p+ (Always p) -> p _ -> error "no upgrade allowed" connAllowStartTLS :: Connection -> Bool
src/Web/Postie/Pipes.hs view
@@ -43,7 +43,7 @@ dataChunks :: Int -> Producer BS.ByteString IO () -> Producer BS.ByteString IO () dataChunks n p = lines p >-> go n where- go remaining | remaining <= 0 = throw UnexpectedEndOfInputException+ go remaining | remaining <= 0 = throw TooMuchDataException go remaining = do bs <- await unless (bs == ".") $ do
src/Web/Postie/Protocol.hs view
@@ -155,10 +155,10 @@ parser = stringCI s *> char ' ' *> takeWhile (notInClass "\r ") parseHelo :: Parser Command-parseHelo = parseHello Helo "HELO"+parseHelo = parseHello Helo "helo" parseEhlo :: Parser Command-parseEhlo = parseHello Ehlo "EHLO"+parseEhlo = parseHello Ehlo "ehlo" parseMailFrom :: Parser Command parseMailFrom = stringCI "mail from:<" *> (MailFrom `fmap` addrSpec) <* char '>'
src/Web/Postie/Session.hs view
@@ -111,6 +111,7 @@ 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 _ -> sendReply reject@@ -139,6 +140,7 @@ modify (\ss -> ss { sessionConnection = conn' , sessionConnectionInput = connectionP conn'+ , sessionTransaction = TxnInitial }) handleEvent WantReset = do@@ -162,6 +164,8 @@ handleEvent NeedRcptToFirst = do sendReply $ reply 503 "Need RCPT TO first"++handleEvent _ = error "impossible" getCommand :: StateT SessionState IO SMTP.Command getCommand = do
src/Web/Postie/Settings.hs view
@@ -3,20 +3,21 @@ Settings(..) , defaultSettings , TLSSettings(..)+ , StartTLSPolicy(..) , tlsSettings , defaultTLSSettings , defaultExceptionHandler- , settingsServerParams- , settingsAllowSecure- , settingsDemandSecure+ , settingsStartTLSPolicy+ , settingsConnectWithTLS+ , settingsAllowStartTLS+ , settingsDemandStartTLS ) where import Web.Postie.Types import Web.Postie.Address+import qualified Web.Postie.Connection as Connection import Network (HostName, PortID(..))-import Control.Exception-import GHC.IO.Exception (IOErrorType(..)) import System.IO (hPrint, stderr) import System.IO.Error (ioeGetErrorType) import Data.ByteString (ByteString)@@ -25,7 +26,12 @@ import qualified Network.TLS.Extra.Cipher as TLS import Data.Default.Class+import Data.Maybe (fromMaybe) +import Control.Exception+import GHC.IO.Exception (IOErrorType(..))+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe import Control.Applicative ((<$>)) -- | Settings to configure posties behaviour.@@ -39,12 +45,13 @@ , settingsOnOpen :: IO () -- ^ Action will be performed when connection has been opened. , settingsOnClose :: IO () -- ^ Action will be performed when connection has been closed. , settingsBeforeMainLoop :: IO () -- ^ Action will be performed before main processing begins.- , settingsOnStartTLS :: IO ()- , settingsOnHello :: ByteString -> IO HandlerResponse- , settingsOnMailFrom :: Address -> IO HandlerResponse- , settingsOnRecipient :: Address -> IO HandlerResponse+ , settingsOnStartTLS :: IO () -- ^ Action will be performend on STARTTLS command.+ , settingsOnHello :: ByteString -> IO HandlerResponse -- ^ Performed when client says hello+ , settingsOnMailFrom :: Address -> IO HandlerResponse -- ^ Performed when client starts mail transaction+ , settingsOnRecipient :: Address -> IO HandlerResponse -- ^ Performed when client adds recipient to mail transaction. } +-- | Default settings for postie defaultSettings :: Settings defaultSettings = Settings { settingsPort = PortNumber 3001@@ -62,69 +69,83 @@ , settingsOnRecipient = const $ return Accepted } +-- | Settings for TLS handling data TLSSettings = TLSSettings {- certFile :: FilePath- , keyFile :: FilePath- , security :: ConnectionSecurity- , tlsLogging :: TLS.Logging- , tlsAllowedVersions :: [TLS.Version]- , tlsCiphers :: [TLS.Cipher]+ 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 } -data ConnectionSecurity = AllowSecure- | DemandSecure- deriving (Eq, Show)+-- | 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 = DemandSecure+ , security = DemandStartTLS , tlsLogging = def , tlsAllowedVersions = [TLS.SSL3,TLS.TLS10,TLS.TLS11,TLS.TLS12] , tlsCiphers = TLS.ciphersuite_all } +-- | Convenience function for creation of TLSSettings taking certificate and key file paths as parameters. tlsSettings :: FilePath -> FilePath -> TLSSettings tlsSettings cert key = defaultTLSSettings { certFile = cert , keyFile = key } -settingsAllowSecure :: Settings -> Bool-settingsAllowSecure settings =- maybe False (== AllowSecure) $ settingsTLS settings >>= return . security+settingsConnectWithTLS :: Settings -> Bool+settingsConnectWithTLS = checkSecurity ConnectWithTLS -settingsDemandSecure :: Settings -> Bool-settingsDemandSecure settings =- maybe False (== DemandSecure) $ settingsTLS settings >>= return . security+settingsAllowStartTLS :: Settings -> Bool+settingsAllowStartTLS = checkSecurity AllowStartTLS -settingsServerParams :: Settings -> IO (Maybe TLS.ServerParams)-settingsServerParams settings = do- case settingsTLS settings of- Just ts -> do- params <- mkServerParams ts- return $ Just params- _ -> return Nothing- where- mkServerParams tls = do- credential <- either (throw . TLS.Error_Certificate) id <$>- TLS.credentialLoadX509 (certFile tls) (keyFile tls)+settingsDemandStartTLS :: Settings -> Bool+settingsDemandStartTLS = checkSecurity DemandStartTLS - return def {- TLS.serverShared = def {- TLS.sharedCredentials = TLS.Credentials [credential]- },- TLS.serverSupported = def {- TLS.supportedCiphers = (tlsCiphers tls)- , TLS.supportedVersions = (tlsAllowedVersions tls)- }+checkSecurity :: StartTLSPolicy -> Settings -> Bool+checkSecurity p s = fromMaybe False $ do+ tlss <- settingsTLS s+ return (security tlss == p)++settingsStartTLSPolicy :: Settings -> IO Connection.StartTLSPolicy+settingsStartTLSPolicy settings = do+ mserverParams <- settingsServerParams settings+ return $ case mserverParams of+ (Just params) | settingsDemandStartTLS settings -> Connection.Demand params+ | settingsAllowStartTLS settings -> Connection.Allow params+ | settingsConnectWithTLS settings -> Connection.Always params+ _ -> Connection.NotAvailable++settingsServerParams :: Settings -> IO (Maybe TLS.ServerParams)+settingsServerParams settings = runMaybeT $ do+ tlss <- MaybeT . return $ settingsTLS settings+ credential <- lift $ loadCredentials tlss+ return def {+ TLS.serverShared = def {+ TLS.sharedCredentials = TLS.Credentials [credential]+ },+ TLS.serverSupported = def {+ TLS.supportedCiphers = (tlsCiphers tlss)+ , TLS.supportedVersions = (tlsAllowedVersions tlss) }+ }+ where+ loadCredentials tlss = either (throw . TLS.Error_Certificate) id <$>+ TLS.credentialLoadX509 (certFile tlss) (keyFile tlss) defaultExceptionHandler :: SomeException -> IO () defaultExceptionHandler e = throwIO e `catches` handlers where- handlers = [Handler ah, Handler oh, Handler sh]+ handlers = [Handler ah, Handler oh, Handler tlsh, Handler th, Handler sh] ah :: AsyncException -> IO () ah ThreadKilled = return ()@@ -136,6 +157,18 @@ | 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
src/Web/Postie/Types.hs view
@@ -12,14 +12,15 @@ -- | Handler response indicating validity of email transaction. data HandlerResponse = Accepted -- ^ Accepted, allow further processing.- | Rejected -- ^ Rejected, stop transaction.+ | Rejected -- ^ Rejected, stop transaction. -- | Received email data Mail = Mail {- mailSender :: Address -- ^ Sender of email- , mailRecipients :: [Address] -- ^ Recipients of email- , mailBody :: Producer ByteString IO () -- ^ Producer of mail content+ 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