attomail (empty) → 0.1.0.1

raw patch · 11 files changed

+934/−0 lines, 11 filesdep +ConfigFiledep +Globdep +MissingH

Dependencies added: ConfigFile, Glob, MissingH, QuickCheck, base, bytestring, directory, doctest, email-validate, hsemail-ns, mtl, network, optparse-applicative, parsec, random, text, time, transformers, unix, unix-time

Files

• ChangeLog.md +5/−0
• LICENSE +25/−0
• README.md +116/−0
• attomail.cabal +69/−0
• src-doctest/Main.hs +5/−0
• src/CmdArgs.hs +156/−0
• src/ConfigLocation.hs +27/−0
• src/DeliveryHeaders.hs +111/−0
• src/EmailAddress.hs +116/−0
• src/Main.hs +289/−0
• stack.yaml +15/−0

@@ -0,0 +1,5 @@+## 0.1.0.1++* Unleashed on the world.++

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

@@ -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](<https://git.lekensteyn.nl/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+    ~~~++    *`<ctrl-d>`*++## 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.+

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

@@ -0,0 +1,5 @@+import System.FilePath.Glob+import Test.DocTest++main :: IO ()+main = glob "src/**/*.hs" >>= doctest

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

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

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

@@ -0,0 +1,116 @@++{-|++Adapted from Text.EmailAddress by Dennis Gosnell (see+<https://hackage.haskell.org/package/emailaddress>)+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+

@@ -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 <unistd.h>+--+--       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 <time> <random num> <hostname>.+--+-- from https://hackage.haskell.org/package/imm-0.5.1.0/+getUniqueName :: IO String+getUniqueName = do+    time     <- show <$> getPOSIXTime+    hostname <- getHostName+    rand     <- show <$> (getStdRandom $ randomR (1,100000) :: IO Int)+    return . concat $ [time, ".", rand, ".", hostname]+++-- * utility functions++-- | force either+forceEitherMsg :: Either err t -> (err -> String) -> t+forceEitherMsg x f = case+  x of+    Left err -> throw $ userError $ f err+    Right val -> val++-- | emit warning to stderr+warning :: String -> IO ()+warning str =+  hPutStrLn stderr $ "attomail: warning: " <> str++-- | for use with Either+mkError :: Error a => (t -> String) -> Either t b -> Either a b+mkError f = left (strMsg . f)+++-- * Program config    ++-- | Configuration, as read from the config file.+data Config = Config { mailDir :: String, userName :: String }+  deriving (Show, Eq)++-- | @getConfig filename@ reads the config file at @filename@.+getConfig :: String -> IO Config+getConfig confFile = do+  cp <- readfile ( emptyCP { optionxform = id } ) (confFile:: String)+  cp <- return $ let f err = "Error reading config file '" <> confFile <> "': " +                             <> show err+                 in forceEitherMsg cp f++  let mailDir = let f err = "Error getting option 'mailDir': " <> show err+                 in  forceEitherMsg (get cp "DEFAULT" "mailDir") f+  let userName = let f err = "Error getting option 'userName': " <> show err+                 in  forceEitherMsg (get cp "DEFAULT" "userName") f+  return $ Config mailDir userName++-- * deal with addresses++-- | the 'Addr' type is simply something that _might_ be an address,+-- this validates it.+validateAddr+  :: Maybe Addr -> Either String (Maybe EmailAddress.EmailAddress)+validateAddr addr = +  runMaybeT $ do+    (Addr addrStr) <- MaybeT $ return addr+    lift $ EmailAddress.validateFromString addrStr    +++-- | wrapper around validateAddr. Pass in a func that+-- takes in a (presumably bad) address and an error message, and spits+-- out a string+--+-- And then, the Maybe/Either result of validation will+-- get turned into an appropriate MonadError action we can just+-- execute in IO.+handleAddr+  :: (MonadError e m, Error e) =>+     (Addr -> String -> String)+     -> Maybe Addr -> m (Maybe EmailAddress.EmailAddress)+handleAddr f addr = +  eitherToMonadError $ mkError (f $ fromJust addr) $ validateAddr addr++-- * whopping big monolithic funcs++-- | deliver mail to the maildir directory mailDir,+-- owned by userName, with command-line args cmdArgs.+--+-- Creates a unique file name w/ getUniqueName. If something creates+-- the file in between generating the name and delivering mail,+-- an IOError will get thrown. +--+-- AttCmdArgs should never have 0 recipients+deliverMail :: FilePath -> String -> AttCmdArgs -> IO ()+deliverMail mailDir userName cmdArgs = do+  let (!AttCmdArgs !fromAddress !_nm !recipients) = cmdArgs++  !fromAddress <- flip handleAddr fromAddress (\badAddr err -> +                          "bad from address " <> show (unAddr badAddr) <>+                           ", err was: " <> show err)+  fromAddress <- return $ (Addr . show) <$> fromAddress++  (uid, gid) <- flip modifyIOError +                 (getUserIDs userName)+                 (\ioErr -> userError $ "couldn't get gid and uid for user '"+                    <> userName <> "', err was: " <> show ioErr)++  setResGid gid gid gid+  setResUid uid uid uid++  flip modifyIOError+        (setCurrentDirectory =<< makeAbsolute mailDir)+        (\ioErr -> userError $ "couldn't change to mail dir '" +                    <> mailDir <> "', err was: " <> show ioErr)++  fileName <- getUniqueName+  tm <- DH.getMailTime++  withMailFile fileName $ \outHdl -> do+    --print "in withMailFile"+    mesgConts <- getContents+    when (length recipients > 1) $+      warning "multiple recipients found, ignoring all but first"+    -- if the command-line parser works correctly, there should be+    -- no possibility of an empty list+    !_ <- return $! assert (not (null recipients))+    let toAddr = head recipients+        possHeadered = DH.addHeaders tm mesgConts fromAddress toAddr +        res2X = eitherToMonadError $ flip mkError possHeadered (\err -> +                    "error parsing stdin as mail message. err was: "+                    <> show err <> "\n"+                    <> "fileconts: " <> show mesgConts)++    headeredMesg <- res2X                    ++    -- putStrLn $ "res: " <> show res+    !_ <- hPutStr outHdl headeredMesg+    --print "done withMailFile"+    return ()++++-- | process args as for sendmail.+--+-- @+--   sendmail [flags] [receipients] < message+--    -f = envelop sender address+--    -F = full name of sender+--    -bm = read mail from stdin (default)+--    -bp, -bs = we ignore these+-- @+main :: IO ()+main = do+  --args <- getArgs+  --hPutStrLn stderr $ "args: " ++ show args+  (Config !mailDir !userName) <- flip modifyIOError+                                (getConfig ConfigLocation.configFileLocn)+                                (\ioErr -> userError $ +                                   "couldn't open config"+                                   <> "file, error was: " <> show ioErr)+  withCmdArgs (deliverMail mailDir userName)++-- * testing++-- | here for testing purposes  +test :: IO AttCmdArgs  +test =+  withArgs [+              "-f", "auditor@auditrix"+             , "-F", "Joe Bloggs"+             , "-bm"+             , "john@john.com"+           ] +           (withCmdArgs return)++

@@ -0,0 +1,15 @@+resolver: lts-7.24++packages:+- .++extra-deps:+- hsemail-ns-1.7.7++# Override default flag values for local packages and extra-deps+flags: {}++# Extra package databases containing global packages+extra-package-dbs: []++