{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
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(..))
foreign import ccall "setresgid" setresgid_c :: CGid -> CGid -> CGid -> IO CInt
foreign import ccall "setresuid" setresuid_c :: CUid -> CUid -> CUid -> IO CInt
setResGid :: CGid -> CGid -> CGid -> IO ()
setResGid r e s = throwErrnoIfMinus1_ "setResGid" $ setresgid_c r e s
setResUid :: CUid -> CUid -> CUid -> IO ()
setResUid r e s = throwErrnoIfMinus1_ "setResUid" $ setresuid_c r e s
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
withMailFile :: String -> (Handle -> IO a) -> IO a
withMailFile !filePath !f = do
let open = openIfNExist filePath
let close = hClose
bracket open close f
getUserIDs :: String -> IO (UserID, GroupID)
getUserIDs userName = do
userEntry <- getUserEntryForName userName
let uid = userID userEntry
gid = userGroupID userEntry
return (uid, gid)
getUniqueName :: IO String
getUniqueName = do
time <- show <$> getPOSIXTime
hostname <- getHostName
rand <- show <$> (getStdRandom $ randomR (1,100000) :: IO Int)
return . concat $ [time, ".", rand, ".", hostname]
forceEitherMsg :: Either err t -> (err -> String) -> t
forceEitherMsg x f = case
x of
Left err -> throw $ userError $ f err
Right val -> val
warning :: String -> IO ()
warning str =
hPutStrLn stderr $ "attomail: warning: " <> str
mkError :: Error a => (t -> String) -> Either t b -> Either a b
mkError f = left (strMsg . f)
data Config = Config { mailDir :: String, userName :: String }
deriving (Show, Eq)
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
validateAddr
:: Maybe Addr -> Either String (Maybe EmailAddress.EmailAddress)
validateAddr addr =
runMaybeT $ do
(Addr addrStr) <- MaybeT $ return addr
lift $ EmailAddress.validateFromString addrStr
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
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
mesgConts <- getContents
when (length recipients > 1) $
warning "multiple recipients found, ignoring all but first"
!_ <- 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
!_ <- hPutStr outHdl headeredMesg
return ()
main :: IO ()
main = do
(Config !mailDir !userName) <- flip modifyIOError
(getConfig ConfigLocation.configFileLocn)
(\ioErr -> userError $
"couldn't open config"
<> "file, error was: " <> show ioErr)
withCmdArgs (deliverMail mailDir userName)
test :: IO AttCmdArgs
test =
withArgs [
"-f", "auditor@auditrix"
, "-F", "Joe Bloggs"
, "-bm"
, "john@john.com"
]
(withCmdArgs return)