121 lines
3.4 KiB
Haskell
121 lines
3.4 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
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 -- ^ content type
|
|
, 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'
|