Including Yesod.Mail

Yesod/Mail.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Support for sending email.
+--
+-- This could be released completely separately from yesod/yesod-auth. If this
+-- would be useful for anyone, please let me know.
+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'

yesod-auth.cabal

@@ -23,11 +23,15 @@ library
                    , data-object             >= 0.3.1.3   && < 0.4
                    , control-monad-attempt   >= 0.3.0     && < 0.4
                    , utf8-string             >= 0.3.4     && < 0.4
+                   , process                 >= 1.0       && < 1.1
+                   , blaze-builder           >= 0.1       && < 0.2
+                   , dataenc                 >= 0.13      && < 0.14
     exposed-modules: Yesod.Helpers.Auth
                      Yesod.Helpers.Auth.Email
                      Yesod.Helpers.Auth.Facebook
                      Yesod.Helpers.Auth.OpenId
                      Yesod.Helpers.Auth.Rpxnow
+                     Yesod.Mail
     ghc-options:     -Wall
 
 source-repository head