diff --git a/.ghci b/.ghci deleted file mode 100644 --- a/.ghci +++ /dev/null @@ -1,1 +0,0 @@ -:set -Wall diff --git a/Postmaster/Base.hs b/Postmaster/Base.hs --- a/Postmaster/Base.hs +++ b/Postmaster/Base.hs @@ -17,7 +17,6 @@ import Prelude hiding ( catch ) import Foreign -import System.IO import Network.Socket hiding ( listen, shutdown ) import Control.Exception import Control.Monad.State @@ -135,7 +134,7 @@ | AcceptConn SockAddr | DropConn SockAddr | UserShutdown - | CaughtException Exception + | CaughtException SomeException | CaughtIOError IOException | StartEventHandler String Event | EventHandlerResult String Event SmtpCode @@ -162,47 +161,3 @@ tell w put st' return r - --- |Like bracket, but only performs the final action if --- there was an exception raised by the in-between --- computation. GHC 6.5 provides this function in --- "Control.Exception". - -bracketOnError - :: IO a -- ^ computation to run first (\"acquire resource\") - -> (a -> IO b) -- ^ computation to run last (\"release resource\") - -> (a -> IO c) -- ^ computation to run in-between - -> IO c -- returns the value from the in-between computation -bracketOnError before after thing = - block (do - a <- before - catch - (unblock (thing a)) - (\e -> do { after a; throw e }) - ) - --- * Resource Management - --- |Convert 'bracket'-style resource management to --- allocate\/free style. We need this, because we have to --- acquire resources that leave the scope in which they were --- allocated. Yeah, callback-driven I\/O does that to --- functional programs. Anyway, the resource will be /gone/ --- once you empty the 'MVar' (or when it falls out of --- scope). So use only 'withMVar' and friends to access the --- value. - -acquire :: ((a -> IO b) -> IO b) -> IO (MVar a) -acquire f = do - sync <- newEmptyMVar - let hold r = do putMVar sync r - yield - putMVar sync r - return undefined - forkIO (f hold >> return ()) - return sync - --- |Let go of a resource allocated with 'acquire'. - -release :: MVar a -> IO () -release a = takeMVar a >> yield >> return () diff --git a/Postmaster/Env.hs b/Postmaster/Env.hs --- a/Postmaster/Env.hs +++ b/Postmaster/Env.hs @@ -13,7 +13,6 @@ module Postmaster.Env where import Control.Monad.State -import Control.Monad.Reader import Data.Char import Data.Dynamic import Data.ByteString.Char8 ( ByteString, pack ) diff --git a/Postmaster/FSM.hs b/Postmaster/FSM.hs --- a/Postmaster/FSM.hs +++ b/Postmaster/FSM.hs @@ -98,7 +98,7 @@ say 5 0 4 "I don't implement HELP with parameters." event (SayHelo _) = do - trigger ResetState + _ <- trigger ResetState whoami <- myHeloName say 2 5 0 (showString whoami " Postmaster; pleased to meet you.") @@ -107,7 +107,7 @@ event (SayEhloAgain peer) = event (SayHelo peer) event (SetMailFrom mbox) = do - trigger ResetState + _ <- trigger ResetState say 2 5 0 (mbox `shows` " ... sender ok") event (AddRcptTo mbox) = diff --git a/Postmaster/FSM/DNSResolver.hs b/Postmaster/FSM/DNSResolver.hs --- a/Postmaster/FSM/DNSResolver.hs +++ b/Postmaster/FSM/DNSResolver.hs @@ -15,7 +15,6 @@ import ADNS import Data.Typeable import Postmaster.Base -import Control.Monad.Trans newtype DNSR = DNSR Resolver deriving (Typeable) diff --git a/Postmaster/FSM/PeerHelo.hs b/Postmaster/FSM/PeerHelo.hs --- a/Postmaster/FSM/PeerHelo.hs +++ b/Postmaster/FSM/PeerHelo.hs @@ -10,7 +10,6 @@ module Postmaster.FSM.PeerHelo where -import Control.Monad import Network ( HostName ) import Postmaster.Base import Text.ParserCombinators.Parsec.Rfc2821 diff --git a/Postmaster/FSM/Spooler.hs b/Postmaster/FSM/Spooler.hs --- a/Postmaster/FSM/Spooler.hs +++ b/Postmaster/FSM/Spooler.hs @@ -57,10 +57,10 @@ assert (p' == Nothing) $ assert (h' == Nothing) $ assert (c' == nullPtr) $ - Postmaster.Base.bracketOnError + bracketOnError (openBinaryFile path WriteMode) (hClose) - (\h -> Postmaster.Base.bracketOnError ctxCreate ctxDestroy $ \ctx -> do + (\h -> bracketOnError ctxCreate ctxDestroy $ \ctx -> do hSetBuffering h NoBuffering when (ctx == nullPtr) (fail "can't initialize SHA1 digest context") md <- toMDEngine SHA1 @@ -103,12 +103,12 @@ buf' <- liftIO . withMVar st $ \(S _ (Just h) ctx@(DST c)) -> assert (c /= nullPtr) $ do hPutBuf h ptr i' - execStateT (update' (ptr, i')) ctx + _ <- execStateT (update' (ptr, i')) ctx flush i buf if not eod then return (Nothing, buf') else do r <- trigger Deliver - trigger ResetState -- TODO: this doesn't really - setSessionState HaveHelo -- belong here + _ <- trigger ResetState -- TODO: this doesn't really + setSessionState HaveHelo -- belong here return (Just r, buf') clearState :: Smtpd () @@ -116,7 +116,7 @@ st <- getState liftIO . modifyMVar_ st $ \(S path h (DST ctx)) -> do let clean Nothing _ = return () - clean (Just x) f = try (f x) >> return () + clean (Just x) f = (try (f x) :: IO (Either SomeException ())) >> return () clean h hClose clean path removeFile when (ctx /= nullPtr) (ctxDestroy ctx) diff --git a/Postmaster/IO.hs b/Postmaster/IO.hs --- a/Postmaster/IO.hs +++ b/Postmaster/IO.hs @@ -12,7 +12,6 @@ module Postmaster.IO where import Data.List -import Data.Maybe import Data.Dynamic ( Typeable ) import Control.Concurrent ( forkIO ) import Control.Exception @@ -59,14 +58,14 @@ -- |If there is space, read and append more octets; then -- return the modified buffer. In case of 'hIsEOF', -- 'Nothing' is returned. If the buffer is full already, --- 'throwDyn' a 'BufferOverflow' exception. When the timeout +-- 'throw' a 'BufferOverflow' exception. When the timeout -- exceeds, 'ReadTimeout' is thrown. slurp :: Timeout -> ReadHandle -> Buffer -> IO (Maybe Buffer) slurp to h b@(Buf cap ptr len) = do - when (cap <= len) (throwDyn (BufferOverflow h b)) + when (cap <= len) (throw (BufferOverflow h b)) timeout to (handleEOF wrap) >>= - maybe (throwDyn (ReadTimeout to h b)) return + maybe (throw (ReadTimeout to h b)) return where wrap = do let ptr' = ptr `plusPtr` (fromIntegral len) n = cap - len @@ -87,13 +86,13 @@ -- |Our main I\/O driver. runLoopNB - :: (st -> Timeout) -- ^ user state provides timeout - -> (Exception -> st -> IO st) -- ^ user provides I\/O error handler - -> ReadHandle -- ^ the input source - -> Capacity -- ^ I\/O buffer size - -> BlockHandler st -- ^ callback - -> st -- ^ initial callback state - -> IO st -- ^ return final callback state + :: (st -> Timeout) -- ^ user state provides timeout + -> (SomeException -> st -> IO st) -- ^ user provides I\/O error handler + -> ReadHandle -- ^ the input source + -> Capacity -- ^ I\/O buffer size + -> BlockHandler st -- ^ callback + -> st -- ^ initial callback state + -> IO st -- ^ return final callback state runLoopNB mkTO errH hIn cap f initST = withBuffer cap (flip ioloop $ initST) where ioloop buf st = buf `seq` st `seq` @@ -129,11 +128,14 @@ data BufferOverflow = BufferOverflow ReadHandle Buffer deriving (Show, Typeable) +instance Exception BufferOverflow where + -- |Thrown by 'slurp'. data ReadTimeout = ReadTimeout Timeout ReadHandle Buffer deriving (Show, Typeable) +instance Exception ReadTimeout where -- * Internal Helper Functions @@ -142,7 +144,7 @@ handleEOF :: IO a -> IO (Maybe a) handleEOF f = - catchJust ioErrors + catchJust fromException (fmap Just f) (\e -> if isEOFError e then return Nothing else ioError e) @@ -183,7 +185,7 @@ acceptor :: SocketHandler -> Socket -> IO () acceptor h ls = do - Postmaster.Base.bracketOnError + bracketOnError (accept ls) (sClose . fst) (\peer@(s,_) -> fork $ h peer `finally` sClose s) @@ -206,6 +208,8 @@ data WriteTimeout = WriteTimeout Timeout deriving (Typeable, Show) +instance Exception WriteTimeout where + setReadTimeout :: Timeout -> Smtpd () setReadTimeout = local . setVar (mkVar "ReadTimeout") @@ -221,7 +225,7 @@ safeWrite :: IO a -> Smtpd a safeWrite f = do to <- getWriteTimeout - liftIO $ timeout to f >>= maybe (throwDyn (WriteTimeout to)) return + liftIO $ timeout to f >>= maybe (throw (WriteTimeout to)) return safeReply :: WriteHandle -> SmtpReply -> Smtpd () safeReply hOut r = safeWrite (hPutStr hOut (show r)) diff --git a/Postmaster/Main.hs b/Postmaster/Main.hs --- a/Postmaster/Main.hs +++ b/Postmaster/Main.hs @@ -154,8 +154,8 @@ main' :: Capacity -> PortID -> EventT -> IO () main' cap port eventT = do - installHandler sigPIPE Ignore Nothing - installHandler sigCHLD (Catch (return ())) Nothing + _ <- installHandler sigPIPE Ignore Nothing + _ <- installHandler sigCHLD (Catch (return ())) Nothing whoami <- getHostName withSocketsDo $ withSyslog "postmaster" [PID, PERROR] MAIL $ diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,205 +0,0 @@ -Postmaster ESMTP Server -======================= - -:Latest Release: postmaster-0.1.tar.gz_ -:Darcs: darcs_ get http://postmaster.cryp.to/ postmaster - -.. contents:: - -The Sales Pitch ---------------- - - Postmaster is the mail transport agent of choice for the - discriminating hacker. Or, to be more accurate: for the - discriminating Haskell_ hacker, because if you don't know - any Haskell, you have about zero chance of running this - software right now. I plan on turning Postmaster into - something an end-user can run, but that's a long road. - - So why yet *another* MTA? Aren't Sendmail, Qmail, Postfix, - and Exim enough already? - - No, unfortunately they are not, because none of those - programs comes even close to the degree of configurability - I need. Postmaster allows you to configure *anything*. I - really mean it. You'd like to configure your MTA to do - mail relaying for the site ``example.org`` only on - Saturdays in a leap year? No problem at all. You'd like to - put your entire mail configuration into a DNS zone and - distribute it through the domain name system to your mail - exchangers? Be my guest. You'd like to rewrite the word - "no" to "yes" in any e-mail you receive which has - "Michelle" in the ``From:`` header and was sent between - 8am and 10am CET? Sure thing. - - Postmaster is not really an MTA, it is a framework in - which you can easily write your own, custom-built MTA! - This means that Postmaster contains everything *except - for* the routine ``main``. That's what you have to write. - -What can it do? -''''''''''''''' - - Postmaster implements an ESMTP server. Given a - configuration, it starts up and listens for incoming SMTP - connections, handles them, and pipes the accepted e-mail - messages into an arbitrary local mailer of your choice. A - good local mailer is Procmail_. - - Beyond that, you can configure and modify every little - step of the SMTP transaction. All the real work is done - through a call-back function. Postmaster triggers an - "event" every time a state change is required, and hopes - that the call-back does whatever is necessary. Among the - known events, this one is popular:: - - AddRcptTo Mailbox - - So by writing a handler function for this event, you can - configure what user addresses the server will accept. For - example:: - - joe, jane :: Mailbox - joe = Mailbox [] "joe" "example.net" - jane = Mailbox [] "jane" "example.net" - - admin :: Mailbox - admin = Mailbox [] "janes.husband" "example.com" - - event :: Event -> Smtpd SmtpReply - event (AddRcptTo mbox) - | mbox == joe = procmail mbox "joe" [] - | mbox == jane = do - from <- gets mailFrom - when (from == joe) - (relay [admin] >> return ()) - procmail mbox "jane" [] - | otherwise = say 5 5 3 "unknown recipient" - - You could also read that configuration from a file, query - the DNS for that recipient, or accept / refuse addresses - randomly. It's entirely up to you. - - Postmaster provides a wealth of SMTP-related functions you - can use. You can (asynchronously) resolve ``A``, ``PTR``, - or ``MX`` records. There is a generic, type-safe Unix-like - environment for each session and a global one for the - entire daemon in which you can store any data your event - handler needs. Postmaster provides a framework for logging - messages through ``syslog(3)``. And, last but not least, - there is a rapidly growing collection of re-usable event - handlers which you can plug together to configure complex - setups in a few lines of code. - -What can it *not* do? -''''''''''''''''''''' - - At the moment, Postmaster has no mail queue. Until that is - implemented, there is no way to deliver outbound messages - via SMTP. If you have to relay e-mail for others, you will - need another MTA installed to do that. Sendmail_ is - particularly well suited for the task. Just modify your - ``sendmail.mc`` file to contain the lines :: - - FEATURE(no_default_msa) - dnl DAEMON_OPTIONS(`Port=25, Name=MTA') - DAEMON_OPTIONS(`Port=587, Name=MSA, M=E') - - and your ``submit.mc`` file to contain:: - - FEATURE(`msp', `', `MSA') - - This configures Sendmail to act as a "mail submission - agent". Meaning that it will not listen on port 25 but on - port 587 instead. Correspondingly, your local mail system - will not inject messages via ``localhost:25`` but - ``localhost:587``. You'll effectively use Postmaster as - your MTA to the outside world, and Sendmail as your MTA on - the inside. It's not beautiful, but it will work very - reliably until Postmaster's own delivery agent is ready. - -Documentation -------------- - - `Postmaster Tutorial`_ - A walk through "Config.hs" -- this is work in progress. - - `Reference Documentation`_ - Haddock-generated reference of all exported functions. - -Building Postmaster -------------------- - - To compile the software, you need GHC_ version 6.6 or - later (only tested with GHC 6.8.x). Furthermore, you'll - need the `GNU adns`_ and OpenSSL_ C libraries installed. - - You can install through your distro, if it provides postmaster, - or from source. The source can be gotten from the Darcs repo or - Hackage. - - Once you've fetched the sources, do the following: - - 1) Build and install through Cabal as for other Haskell packages: - - runhaskell Setup configure --user --prefix=$HOME - runhaskell Setup build - runhaskell Setup install --user - - (You may want to remove the --user flag when installing as root.) - - You can also install via the GNU Autotools. - - 1) Edit ``GNUmakefile`` to fit your system. You'll have to - adapt the variable ``HDI_PATH`` to point to the base - directory where the Haddock interface files for your - compiler are installed or the documentation won't - (re-)build. - - 2) Say ``make``. You need GNU make to build Postmaster, so - if you're running a BSD Unix, ``gmake`` should be used - instead. - - 3) If you get this compiler error:: - - .objs/Digest.o(.text+0x357): In function `spyU_info': - : undefined reference to `EVP_mdc2' - - then your OpenSSL version doesn't contain the MDC2 hash - algorithm yet. That's no problem ... just comment out - the (three or so) references to it in - ``hopenssl/Digest.hs`` -- or upgrade to OpenSSL 0.9.7e - or later. - - -Copyleft --------- - - Copyright (c) 2008 Peter Simons . All - rights reserved. This software is released under the terms - of the `GNU General Public License - `_. - ------------------------------------------------------------------ - -`[Homepage] `_ - -.. _Haskell: http://haskell.org/ - -.. _darcs: http://darcs.net/ - -.. _Reference Documentation: docs/index.html - -.. _Procmail: http://www.procmail.org/ - -.. _Sendmail: http://sendmail.org/ - -.. _postmaster-0.1.tar.gz: http://postmaster.cryp.to/postmaster-0.1.tar.gz - -.. _GHC: http://haskell.org/ghc/ - -.. _GNU adns: http://www.gnu.org/software/adns/ - -.. _OpenSSL: http://www.openssl.org/ - -.. _Postmaster Tutorial: docs/tutorial.html diff --git a/postmaster.cabal b/postmaster.cabal --- a/postmaster.cabal +++ b/postmaster.cabal @@ -1,5 +1,12 @@ Name: postmaster -Version: 0.1 +Version: 0.2 +Copyright: (c) 2004-2010 Peter Simons +License: GPL +License-File: COPYING +Author: Peter Simons +Maintainer: Peter Simons +Homepage: http://gitorious.org/postmaster +Category: Network Synopsis: Postmaster ESMTP Server Description: Postmaster implements an ESMTP server. Given a configuration, it starts up and listens for incoming SMTP connections, handles @@ -8,19 +15,37 @@ Beyond that, you can configure and modify every little step of the SMTP transaction. All the real work is done through call-back functions. -Homepage: http://postmaster.cryp.to/ -Category: Network -License: GPL -License-File: COPYING -Author: Peter Simons -Maintainer: Peter Simons -Data-Files: README +Cabal-Version: >= 1.6 Build-Type: Simple +Tested-With: GHC == 6.12.1 -Executable: postmaster -Main-Is: tutorial.lhs -GHC-Options: -Wall -threaded -Extra-Libraries: adns crypto -Build-Depends: base, haskell98, directory, mtl, network, unix, parsec, +Extra-Source-Files: Postmaster/Base.hs + Postmaster/FSM/HeloName.hs + Postmaster/FSM/PeerAddr.hs + Postmaster/FSM/EhloPeer.hs + Postmaster/FSM/Announce.hs + Postmaster/FSM/DNSResolver.hs + Postmaster/FSM/EventHandler.hs + Postmaster/FSM/MailID.hs + Postmaster/FSM/PeerHelo.hs + Postmaster/FSM/MailFrom.hs + Postmaster/FSM/SessionState.hs + Postmaster/FSM/Spooler.hs + Postmaster/FSM/DataHandler.hs + Postmaster/Env.hs + Postmaster/Main.hs + Postmaster/FSM.hs + Postmaster/IO.hs + Postmaster.hs + +Source-Repository head + Type: git + Location: git://gitorious.org/postmaster/mainline.git + +Executable postmaster + Main-Is: tutorial.lhs + GHC-Options: -Wall -threaded + Extra-Libraries: adns crypto + Build-Depends: base >=3 && <5, haskell98, directory, mtl, network, unix, parsec, containers, bytestring, old-time, hsyslog, hsdns, hsemail, hopenssl diff --git a/tutorial.lhs b/tutorial.lhs --- a/tutorial.lhs +++ b/tutorial.lhs @@ -36,12 +36,10 @@ > module Main where > -> import System.IO > import System.Time > import System.Posix.User > import Network.Socket ( SockAddr(..) ) > import Data.Char -> import Data.List > import Postmaster hiding ( main ) > ioBufferSize :: Capacity