module Network.Mail.Mime
(
Boundary (..)
, Mail (..)
, Alternatives
, Part (..)
, Encoding (..)
, renderMail
, renderMail'
, sendmail
, renderSendMail
, simpleMail
, 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 ((<=<), forM)
import Data.List (intersperse)
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
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)]
, mailParts :: [Alternatives]
}
data Encoding = None | Base64
type Alternatives = [Part]
data Part = Part
{ partType :: String
, partEncoding :: Encoding
, partFilename :: Maybe String
, partContent :: L.ByteString
}
type Headers = [(String, String)]
type Pair = (Headers, Builder)
partToPair :: Part -> Pair
partToPair (Part contentType encoding disposition content) =
(headers, builder)
where
headers =
((:) ("Content-Type", contentType))
$ (case encoding of
None -> id
Base64 -> (:) ("Content-Transfer-Encoding", "base64"))
$ (case disposition of
Nothing -> id
Just fn ->
(:) ("Content-Disposition", "attachment; filename=" ++ fn))
$ []
builder =
case encoding of
None -> writeList writeByteString $ L.toChunks content
Base64 -> writeList writeByte $ map (toEnum . fromEnum)
$ encode $ L.unpack content
showPairs :: RandomGen g
=> String
-> [Pair]
-> g
-> (Pair, g)
showPairs _ [] _ = error "renderParts called with null parts"
showPairs _ [pair] gen = (pair, gen)
showPairs mtype parts gen =
((headers, builder), gen')
where
(Boundary b, gen') = random gen
headers =
[ ("Content-Type", concat
[ "multipart/"
, mtype
, "; boundary=\""
, b
, "\""
])
]
builder = mconcat
[ mconcat $ intersperse (fromByteString "\n")
$ map (showBoundPart $ Boundary b) parts
, showBoundEnd $ Boundary b
]
renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g)
renderMail g0 (Mail headers parts) =
(toLazyByteString builder, g'')
where
pairs = map (map partToPair) parts
(pairs', g') = helper g0 $ map (showPairs "alternative") pairs
helper :: g -> [g -> (x, g)] -> ([x], g)
helper g [] = ([], g)
helper g (x:xs) =
let (b, g') = x g
(bs, g'') = helper g' xs
in (b : bs, g'')
((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g'
builder = mconcat
[ mconcat $ map showHeader headers
, showHeader ("MIME-Version", "1.0")
, mconcat $ map showHeader finalHeaders
, fromByteString "\n"
, finalBuilder
]
showHeader (k, v) = mconcat
[ fromString k
, fromByteString ": "
, fromString v
, fromByteString "\n"
]
showBoundPart (Boundary b) (headers, content) = mconcat
[ fromByteString "--"
, fromString b
, fromByteString "\n"
, mconcat $ map showHeader headers
, fromByteString "\n"
, content
]
showBoundEnd (Boundary b) = mconcat
[ fromByteString "\n--"
, fromString b
, fromByteString "--"
]
renderMail' :: Mail -> IO L.ByteString
renderMail' m = do
g <- getStdGen
let (lbs, g') = renderMail g m
setStdGen g'
return lbs
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'
simpleMail :: String
-> String
-> String
-> LT.Text
-> LT.Text
-> [(String, FilePath)]
-> IO Mail
simpleMail to from subject plainBody htmlBody attachments = do
as <- forM attachments $ \(ct, fn) -> do
content <- L.readFile fn
return (ct, fn, content)
return Mail {
mailHeaders =
[ ("To", to)
, ("From", from)
, ("Subject", subject)
]
, mailParts =
[ Part "text/plain; charset=utf-8" None Nothing
$ LT.encodeUtf8 plainBody
, Part "text/html; charset=utf-8" None Nothing
$ LT.encodeUtf8 htmlBody
] :
(map (\(ct, fn, content) -> [Part ct Base64 (Just fn) content])
as)
}