module Yesod.Mail
( Boundary (..)
, Mail (..)
, Part (..)
, Encoding (..)
, renderMail
, renderMail'
, sendmail
, Disposition (..)
, renderSendMail
, randomString
) where
import qualified Data.ByteString.Lazy as L
import Text.Blaze.Builder.Utf8
import Text.Blaze.Builder.Core
import Data.Monoid
import System.Random
import Control.Arrow
import System.Process
import System.IO
import System.Exit
import Codec.Binary.Base64 (encode)
import Control.Monad ((<=<))
randomString :: RandomGen d => Int -> d -> (String, d)
randomString len =
first (map toChar) . sequence' (replicate len (randomR (0, 61)))
where
sequence' [] g = ([], g)
sequence' (f:fs) g =
let (f', g') = f g
(fs', g'') = sequence' fs g'
in (f' : fs', g'')
toChar i
| i < 26 = toEnum $ i + fromEnum 'A'
| i < 52 = toEnum $ i + fromEnum 'a' 26
| otherwise = toEnum $ i + fromEnum '0' 52
newtype Boundary = Boundary { unBoundary :: String }
instance Random Boundary where
randomR = const random
random = first Boundary . randomString 10
data Mail = Mail
{ mailHeaders :: [(String, String)]
, mailPlain :: String
, mailParts :: [Part]
}
data Encoding = None | Base64
data Part = Part
{ partType :: String
, partEncoding :: Encoding
, partDisposition :: Disposition
, partContent :: L.ByteString
}
data Disposition = Inline | Attachment String
renderMail :: Boundary -> Mail -> L.ByteString
renderMail (Boundary b) (Mail headers plain parts) = toLazyByteString $ mconcat
[ mconcat $ map showHeader headers
, mconcat $ map showHeader
[ ("MIME-Version", "1.0")
, ("Content-Type", "multipart/mixed; boundary=\""
++ b ++ "\"")
]
, fromByteString "\n"
, fromString plain
, mconcat $ map showPart parts
, fromByteString "\n--"
, fromString b
, fromByteString "--"
]
where
showHeader (k, v) = mconcat
[ fromString k
, fromByteString ": "
, fromString v
, fromByteString "\n"
]
showPart (Part contentType encoding disposition content) = mconcat
[ fromByteString "\n--"
, fromString b
, fromByteString "\n"
, showHeader ("Content-Type", contentType)
, case encoding of
None -> mempty
Base64 -> showHeader ("Content-Transfer-Encoding", "base64")
, case disposition of
Inline -> mempty
Attachment filename ->
showHeader ("Content-Disposition", "attachment; filename=" ++ filename)
, fromByteString "\n"
, case encoding of
None -> writeList writeByteString $ L.toChunks content
Base64 -> writeList writeByte $ map (toEnum . fromEnum) $ encode $ L.unpack content
]
renderMail' :: Mail -> IO L.ByteString
renderMail' m = do
b <- randomIO
return $ renderMail b m
sendmail :: L.ByteString -> IO ()
sendmail lbs = do
(Just hin, _, _, phandle) <- createProcess $ (proc
"/usr/sbin/sendmail" ["-t"]) { std_in = CreatePipe }
L.hPut hin lbs
hClose hin
exitCode <- waitForProcess phandle
case exitCode of
ExitSuccess -> return ()
_ -> error $ "sendmail exited with error code " ++ show exitCode
renderSendMail :: Mail -> IO ()
renderSendMail = sendmail <=< renderMail'