diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +## 0.1.0.1 + +* Unleashed on the world. + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +BSD 2-Clause License + +Copyright (c) 2017, phlummox +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,116 @@ +# attomail [![Hackage version](https://img.shields.io/hackage/v/attomail.svg?label=Hackage)](https://hackage.haskell.org/package/attomail) + +Minimal mail delivery agent (MDA) for local mail with maildir support - a Haskell re-implementation of femtomail + +## quick installation + +~~~ +$ stack install attomail && sudo cp ~/.local/bin/attomail /usr/local/bin +$ cat << EOF | sudo tee -a /etc/attomail.conf +mailDir = /path/to/my/home/dir/Maildir/new +userName = myuserid +EOF +mkdir -p /path/to/my/home/dir/Maildir/new +~~~ + +## prerequisites + +- Haskell +- unlikely to work properly on anything but a Linux system + +## purpose + +Acts as a minimal (local delivery only, many features un-implemented) mail +delivery agent, or MDA, delivering mail to a local `maildir` format spool. +Handy when you don't want to install an MTA (Mail Transfer Agent) or +fuller-featured MDA - you just want a program which accepts +`sendmail`-style delivery of messages from local programs, and dumps them +somewhere you can read them. + +It is a port of [femtomail]() to Haskell. +(See this [StackExchange](http://unix.stackexchange.com/questions/82093/minimal-mta-that-delivers-mail-locally-for-cron) posting for femtomail's inception.) + +## configuration + +By default, uses `/etc/attoparse.conf` as a configuration file. + +`/etc/attoparse.conf` needs to contain two lines, specifying the path to +a directory where messages should be delivered, and the userid of the +person who owns that directory. + +e.g.: + +~~~ +mailDir = /path/to/my/home/dir/Maildir/new +userName = myuserid +~~~ + +So that other programs can find it, you probably want to install +`attomail` somewhere on the system path - e.g. in `/usr/local/bin/attomail`. + +`attomail` needs to be either run by the user specified in the config file, or +(more likely, if being called by, say, some cron job) root +(or some other account +with permission to change uid, etc.). +This is because it makes use of the `setresgid` and `setresuid` C functions to change its uid etc to that user, and ability to do that is normally restricted. + +To use some other location for the configuration file, define CONF_PATH as a +macro when running ghc. + +e.g.: + +~~~ +stack build --ghc-options -optP-DCONF_PATH=/some/dir/my.conf +~~~ + +or + +~~~ +cabal build --ghc-option=-optP-DCONF_PATH=/some/dir/tmp.conf +~~~ + +No claims that this program is at all secure, use at your own risk. + +## command-line arguments + +Usage: + +* `attomail [-f ADDRESS] [-F NAME] [-b MODE] [-i] [-o ARG] [-O ARG] [-B ARG] + [-q ARG] [-v] RECIPIENTS...` + +Arguments that are actually processed: + + -bm Read input from stdin, deliver mail in the usual way (default). + -Ffullname Set the full name of the sender. + -fname Sets the name of the `from' person (i.e., the sender of the mail put on the enevelope) + +Various ignored options, included only for compatibility with `sendmail`: `-i`, `-o`, `-O`, `-B`, `-q`, `-v`. + +## testing + +- If you have a `mail` program installed, just use that for testing the + installation. Messages to any address at all, local or remote, should go + to the mail spool specified. + +- Alternatively: + + ~~~ + $ cat | sendmail a@b.com << EOF + To: someone@somewhere + Subject: mysubject + + some body + EOF + ~~~ + + *``* + +## portability + +Probably won't work on anything but Linux systems. + +## API + +None, yet, there's only an executable, not a library. But (*sssh*) take a peek +[here](https://hackage.haskell.org/package/attomail-0.1.0.1/candidate/docs) if you like, there should be some minimal documentation of the internal modules. + diff --git a/attomail.cabal b/attomail.cabal new file mode 100644 --- /dev/null +++ b/attomail.cabal @@ -0,0 +1,69 @@ +name: attomail +version: 0.1.0.1 +category: Network, Email +build-type: Simple +cabal-version: >=1.10 +synopsis: Minimal mail delivery agent (MDA) for local mail with maildir support +description: + Acts as a minimal (local delivery only, many features un-implemented) mail + delivery agent (or MDA), delivering mail to a local @maildir@ format spool. + Handy when you don't want to install an MTA (Mail Transfer Agent) or + fuller-featured MDA - you just want a program which accepts + @sendmail@-style delivery of messages from local programs, and dumps them + somewhere you can read them. +license: BSD2 +license-file: LICENSE +author: phlummox +maintainer: phlummox2@gmail.com +copyright: phlummox 2017 +extra-source-files: README.md, stack.yaml, ChangeLog.md + +source-repository head + type: git + location: https://github.com/phlummox/attomail + +executable attomail + hs-source-dirs: src + main-is: Main.hs + default-language: Haskell2010 + build-depends: + base >= 4.0 && < 5 + , bytestring + , directory + , MissingH + -- used for Data.Either.Utils + , mtl + , network + -- used for getHostName + , parsec + , random + , text + , time + , transformers + , unix + , unix-time + -- + , ConfigFile + , email-validate + , hsemail-ns >= 1.7.7 + , optparse-applicative + other-modules: + CmdArgs + , EmailAddress + , ConfigLocation + , DeliveryHeaders + ghc-options: -Wall + + +test-suite attomail-doctest + type: exitcode-stdio-1.0 + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + hs-source-dirs: src-doctest + main-is: Main.hs + build-depends: base >= 4 && < 5 + , doctest >=0.10 + , Glob >= 0.7 + , QuickCheck >= 2.5 + + diff --git a/src-doctest/Main.hs b/src-doctest/Main.hs new file mode 100644 --- /dev/null +++ b/src-doctest/Main.hs @@ -0,0 +1,5 @@ +import System.FilePath.Glob +import Test.DocTest + +main :: IO () +main = glob "src/**/*.hs" >>= doctest diff --git a/src/CmdArgs.hs b/src/CmdArgs.hs new file mode 100644 --- /dev/null +++ b/src/CmdArgs.hs @@ -0,0 +1,156 @@ + + +{- | + +Process command-line arguments, mimicking sendmail: + +@ + sendmail [flags] [receipients] < message + -f = envelop sender address + -F = full name of sender + -bm = read mail from stdin (default) + -bp, -bs, various others = we ignore these +@ + +TODO: add some fancy validation of addresses. +-} + +module CmdArgs ( + AttCmdArgs(..) + , withCmdArgs +) +where + +import Options.Applicative hiding (helper) +import Options.Applicative.Types (readerAsk) + +import System.Environment + +import DeliveryHeaders ( Addr(..) ) + +-- | A hidden \"helper\" option which always fails. +helper :: Parser (a -> a) +helper = abortOption ShowHelpText $ mconcat + [ long "help" + , help "Show this help text" + , hidden ] + + +-- | Addr option reader +addr :: ReadM (Maybe Addr) +addr = (Just . Addr) <$> str + +-- | name option reader +name :: ReadM (Maybe String) +name = Just <$> str + +-- | combinator thing for the mode of something +-- (e.g. "-bm".) Tell user we only accept one +-- permissible mode. +mode :: Char -> ReadM () +mode validMode = do + x <- readerAsk + if x == [validMode] + then return () + else readerError $ "can only take mode '" <> [validMode] <> "' as arg" + +-- | Data structure for command-line arguments. +data AttCmdArgs = AttCmdArgs + { + senderEnvelopeAddress :: Maybe Addr -- ^ Possible envelope address. + , senderFullName :: Maybe String -- ^ Possible sender full name + , recipients :: [Addr] -- ^ Recipients. (Ignored.) + } + deriving (Eq, Show) + +-- | Parser for command-line args. +-- +-- TODO: +-- +-- add more (ignored) options. +-- see http://www.sendmail.org/~ca/email/man/sendmail.html +attCmdArgs :: Parser AttCmdArgs +attCmdArgs = AttCmdArgs + <$> option addr + ( short 'f' + <> value Nothing + <> metavar "ADDRESS" + <> help "Sender envelope address" ) + + <*> ( option name + ( short 'F' + <> value Nothing + <> metavar "NAME" + <> help "Sender full name" ) + <* option (mode 'm') + ( short 'b' + <> value () + <> metavar "MODE" + <> help "-bm: Read input from stdin" ) + <* switch + ( short 'i' + <> help "(ignored, used only for compatibility with sendmail") + <* many ( strOption + ( short 'o' + <> help "(ignored, used only for compatibility with sendmail")) + <* many ( strOption + ( short 'O' + <> help "(ignored, used only for compatibility with sendmail")) + <* many ( strOption + ( short 'B' + <> help "(ignored, used only for compatibility with sendmail")) + <* many ( strOption + ( short 'q' + <> help "(ignored, used only for compatibility with sendmail")) + <* switch + ( short 'v' + <> help "(ignored, used only for compatibility with sendmail") + ) + <*> some ( argument (Addr <$> str) (metavar "RECIPIENTS...") ) + +-- | program version +version :: String +version = "0.1.0.1" + + +-- | just here for testing +testMain :: IO () +testMain = + withArgs [ + "-f", "someenvddr" + , "-F", "Joe Bloggs" + , "-bm" + , "a@b.com" + ] + main + +-- | local 'main' function, can be used for testing +main :: IO () +main = execParser opts >>= doStuff + where + opts = info (helper <*> attCmdArgs) + ( fullDesc + <> progDesc desc + <> header h ) + + desc = "read a message on stdin and deliver it to user in config file" + h = "attomail v " <> version <> "simple mail delivery to one user" + +-- | just used for testing +doStuff :: AttCmdArgs -> IO () +doStuff x@AttCmdArgs{} = + print x + + +withCmdArgs :: (AttCmdArgs -> IO b) -> IO b +withCmdArgs f = execParser opts >>= f + where + opts = info (helper <*> attCmdArgs) + ( fullDesc + <> progDesc desc + <> header h ) + + desc = "read a message on stdin and deliver it to user in config file" + h = "attomail v " <> version <> "simple mail delivery to one user" + + diff --git a/src/ConfigLocation.hs b/src/ConfigLocation.hs new file mode 100644 --- /dev/null +++ b/src/ConfigLocation.hs @@ -0,0 +1,27 @@ + +{-# LANGUAGE CPP #-} +-- -pgmP options needed because the cpp built in to ghc +-- doesn't support stringification. +{-# OPTIONS_GHC -pgmP cpp #-} + +{- | + +Location of config file. @\/etc\/attomail.conf@ by default, +overridable at compile time - see the README for details. +-} + +module ConfigLocation where + +#define STRINGIFY(x) #x +#define STRINGIFY2(x) STRINGIFY(x) +#define CP STRINGIFY2(CONF_PATH) + +-- | Location of the config file, baked in at compile time. +configFileLocn :: String +configFileLocn = +#ifdef CONF_PATH + CP +#else + "/etc/attomail.conf" +#endif + diff --git a/src/DeliveryHeaders.hs b/src/DeliveryHeaders.hs new file mode 100644 --- /dev/null +++ b/src/DeliveryHeaders.hs @@ -0,0 +1,111 @@ + +{-| + Add delivery headers to an email message. +-} + + +module DeliveryHeaders ( + -- * Data types + + Addr(..) + , MailTime + + -- * header utilities + , isDate + , isFrom + , makeReceived + , addHeaders + + -- * string utilities + , toStr + , rstrip + + -- * time utilities + , getMailTime + +) where + +import Control.Arrow (left) + +import Data.ByteString.Char8 (unpack) +import Data.Char (isSpace) +import Data.List (dropWhileEnd) +import Data.Maybe (fromJust, isJust) +import Data.Monoid +import Data.UnixTime (mailDateFormat, getUnixTime, formatUnixTime) + +import Text.Parsec +import Text.ParserCombinators.Parsec.Rfc2822NS + (Field(..), message, GenericMessage(..) ) + +-- | ... actually, any string at all is considered a valid +-- "time" string we can use. +newtype MailTime = MailTime String + +-- | just a newtype to distinguish address from other strings. +newtype Addr = Addr { unAddr :: String } + deriving (Show, Eq) + +toStr :: MailTime -> String +toStr (MailTime str) = str + +-- | get the unix time +getMailTime :: IO MailTime +getMailTime = do + time <- getUnixTime + MailTime . unpack <$> formatUnixTime mailDateFormat time + +-- | is this a 'Date' field? +isDate :: Field -> Bool +isDate field = case field of + Date _ -> True + _ -> False + +-- | Is this a 'From' field? +isFrom :: Field -> Bool +isFrom field = case field of + From _ -> True + _ -> False + +-- | make up the "@Received:@" header, given a time, +-- a possible "from" address, and a "to" address. +makeReceived :: MailTime -> Maybe Addr -> Addr -> String +makeReceived (MailTime timeStr) fromAddr toAddr = + let toAddrStr = unAddr toAddr + rec = ["Received: for " <> toAddrStr <> " with local (attomail)"] + envelope = if isJust fromAddr + then [" (envelope-from " <> unAddr (fromJust fromAddr) <> ")"] + else [] + end = ["; " <> timeStr <> "\r\n"] -- should end w/ crlf?? + in concat $ rec ++ envelope ++ end + +-- | strip whitespace from right-hand end +rstrip :: String -> String +rstrip = dropWhileEnd isSpace + + +-- | add minimal headers: a "@Received:@" header, a "@Date:@" +-- header if we haven't already been given one, +-- a "@From:@" field if we haven't already been given one. +addHeaders :: MailTime -> String -> Maybe Addr -> Addr -> Either String String +addHeaders time mesgText fromAddr toAddr = do + (Message headers body) <- left show (parse message "stdin" mesgText) + let received = [makeReceived time fromAddr toAddr] + fromStr = case fromAddr of + Nothing -> "" + Just a -> unAddr a + hasDate = any isDate headers + hasFrom = any isFrom headers + dateField = if hasDate + then [] + else ["Date: " <> toStr time <> "\r\n"] + fromField = if hasFrom + then [] + else ["From: " <> fromStr <> "\r\n"] + headBit = [rstrip (take (length mesgText - length body) mesgText) <> "\r\n"] + + newHead = concat $ received ++ headBit ++ dateField ++ fromField ++ ["\r\n"] + return $ newHead ++ body + + + diff --git a/src/EmailAddress.hs b/src/EmailAddress.hs new file mode 100644 --- /dev/null +++ b/src/EmailAddress.hs @@ -0,0 +1,116 @@ + +{-| + +Adapted from Text.EmailAddress by Dennis Gosnell (see +) +but +without all the dependencies (like postgresql-simple ...). Uses the @email-validate@ package, +instead. + +-} + +{-# LANGUAGE InstanceSigs #-} + +module EmailAddress +( -- * Data Type + EmailAddress(EmailAddress, unEmailAddress) + -- * Create EmailAddress + , emailAddress + , emailAddressFromText + , emailAddressFromString + -- * validation + , validate + , validateFromText + , validateFromString + -- * Unsafe creation + , unsafeEmailAddress +) where + +import Text.Read (Read(readPrec), ReadPrec) + +import Data.Text (Text, pack) +import Data.Text.Encoding (encodeUtf8) + +import Data.ByteString hiding (pack,unpack) + + +import qualified Text.Email.Validate as EV + +-- | wrapper around our implementation - 'EV.EmailAddress'. +newtype EmailAddress = EmailAddress + { unEmailAddress :: EV.EmailAddress } + deriving (Eq, Ord) + +-- | +-- >>> (read "\"foo@gmail.com\"") :: EmailAddress +-- "foo@gmail.com" +instance Read EmailAddress where + readPrec :: ReadPrec EmailAddress + readPrec = fmap EmailAddress readPrec + +-- | +-- >>> import qualified Data.ByteString.Char8 as BS +-- >>> :set -XOverloadedStrings +-- >>> show $ unsafeEmailAddress "foo" "gmail.com" +-- "\"foo@gmail.com\"" +instance Show EmailAddress where + show :: EmailAddress -> String + show = show . unEmailAddress + + +-- | Wrapper around 'EV.validate'. +-- +-- >>> validate "foo@gmail.com" +-- Right "foo@gmail.com" +-- >>> import Data.Either (isLeft) +-- >>> isLeft $ validate "not an email address" +-- True +validate :: ByteString -> Either String EmailAddress +validate = fmap EmailAddress . EV.validate + +-- | Wrapper around 'EV.emailAddress'. +-- +-- Similar to 'validate', but returns 'Nothing' if the email address fails to +-- parse. +-- +-- >>> emailAddress "foo@gmail.com" +-- Just "foo@gmail.com" +-- >>> emailAddress "not an email address" +-- Nothing +emailAddress :: ByteString -> Maybe EmailAddress +emailAddress = fmap EmailAddress . EV.emailAddress + +-- | Create an 'EmailAddress' from a 'Text' value. See 'validate'. +validateFromText :: Text -> Either String EmailAddress +validateFromText = validate . encodeUtf8 + +-- | Create an 'EmailAddress' from a 'Text' value. See 'emailAddress'. +emailAddressFromText :: Text -> Maybe EmailAddress +emailAddressFromText = emailAddress . encodeUtf8 + +-- | Create an 'EmailAddress' from a 'String' value. See 'validate'. +validateFromString :: String -> Either String EmailAddress +validateFromString = validateFromText . pack + +-- | Create an 'EmailAddress' from a 'String' value. See 'emailAddress'. +emailAddressFromString :: String -> Maybe EmailAddress +emailAddressFromString = emailAddressFromText . pack + + +-- | Wrapper around 'EV.unsafeEmailAddress'. +-- +-- Unsafely create an 'EmailAddress' from a local part and a domain part. The +-- first argument is the local part, and the second argument is the domain +-- part. +-- +-- For example, in the email address @foo\@gmail.com@, the local part is @foo@ +-- and the domain part is @gmail.com@. +-- +-- >>> unsafeEmailAddress "foo" "gmail.com" +-- "foo@gmail.com" +unsafeEmailAddress + :: ByteString -- ^ Local part + -> ByteString -- ^ Domain part + -> EmailAddress +unsafeEmailAddress = (EmailAddress .) . EV.unsafeEmailAddress + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,289 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing -Wno-deprecations #-} + + +{- | + +Module : Main +Portability : unportable + +Probably not at all portable. Makes use of functions from the +@unistd.h@ header file. + +TODO: + +Tidy this up, shift some of the logic out to another module. +-} + + +module Main +where + +import Control.Arrow (left) +import Control.Exception (bracket, throw, assert) +import Control.Monad (when) +import Control.Monad.Error.Class (Error(..), MonadError(..) ) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT(..)) + + +import Data.ConfigFile (emptyCP, readfile + , optionxform, get ) +import Data.Either.Utils (eitherToMonadError) +import Data.Monoid +import Data.Maybe (fromJust) +import Data.Time.Clock.POSIX (getPOSIXTime) + +import Foreign.C.Types (CInt(..)) +import Foreign.C.Error (throwErrnoIfMinus1_) + +import Network.BSD (getHostName) + +import System.Directory (setCurrentDirectory, makeAbsolute) +import System.Environment (withArgs) +import System.IO (Handle, hClose, stderr, + hPutStrLn, hPutStr) +import System.IO.Error (modifyIOError) +import qualified System.Posix.Files as F +import System.Posix.IO (exclusive, defaultFileFlags, openFd + , OpenMode(..), fdToHandle ) +import System.Posix.User (getUserEntryForName, userID, userGroupID ) +import System.Posix.Types (CGid(..), CUid(..), UserID + , GroupID ) +import System.Random (getStdRandom, randomR) + + +import ConfigLocation (configFileLocn) +import CmdArgs (AttCmdArgs(..), withCmdArgs) +import EmailAddress (EmailAddress(..), validateFromString) +import qualified DeliveryHeaders as DH +import DeliveryHeaders (Addr(..)) + + + +-- * C functions and wrappers around them + +-- | unistd funcs: +-- +-- @ +-- #include +-- +-- int setresuid(uid_t ruid, uid_t euid, uid_t suid); +-- int setresgid(gid_t rgid, gid_t egid, gid_t sgid); +-- @ +foreign import ccall "setresgid" setresgid_c :: CGid -> CGid -> CGid -> IO CInt +foreign import ccall "setresuid" setresuid_c :: CUid -> CUid -> CUid -> IO CInt + +-- | wrapper around C func @setresgid@. +setResGid :: CGid -> CGid -> CGid -> IO () +setResGid r e s = throwErrnoIfMinus1_ "setResGid" $ setresgid_c r e s + +-- | wrapper around C func @setresuid@. +setResUid :: CUid -> CUid -> CUid -> IO () +setResUid r e s = throwErrnoIfMinus1_ "setResUid" $ setresuid_c r e s + +-- * low-level, Posix-specific functions + +-- | opens w/ mode 0644, but gives error if exists +-- +-- i.e. @-rw-r--r--@ +openIfNExist :: String -> IO Handle +openIfNExist !filePath = do + let mode = foldl F.unionFileModes F.nullFileMode + [F.ownerReadMode, F.ownerWriteMode, F.groupReadMode, F.otherReadMode] + openFileFlags = defaultFileFlags { exclusive = True } + !fd <- openFd filePath WriteOnly (Just mode) openFileFlags + !hdl <- fdToHandle fd + return hdl + +-- | opens and closes a file created with openIfNExist, +-- and executes the action f on it in between. +-- +withMailFile :: String -> (Handle -> IO a) -> IO a +withMailFile !filePath !f = do + let open = openIfNExist filePath + let close = hClose + + bracket open close f + + +-- | get the uid and gid for a username +getUserIDs :: String -> IO (UserID, GroupID) +getUserIDs userName = do + userEntry <- getUserEntryForName userName + let uid = userID userEntry + gid = userGroupID userEntry + return (uid, gid) + + +-- | Return an allegedly unique filename; useful to add new mail files in a maildir. Name is of format