Permalink
Browse files

Replaced YesodMail with Network.SMTP.Client as a mail module.

デフォルトの mime-mail から SMTPClient にメールモジュールを変更.
メールサーバを動作環境に同居させなくても大丈夫にするため.
SmtpProperties は環境に応じて設定する設定ファイル.
Foundation.hs の deliver がバグっているはずなので修正必要.
  • Loading branch information...
1 parent 2d9e055 commit d65fde3f4eb9d06e47d2347b85a0998b604a0225 @seizans committed Apr 1, 2012
Showing with 60 additions and 37 deletions.
  1. +7 −37 src/Foundation.hs
  2. +41 −0 src/Smtp/SmtpClient.hs
  3. +6 −0 src/Smtp/SmtpProperties.hs
  4. +6 −0 src/happiage.cabal
View
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
module Foundation
( Happiage (..)
, Route (..)
@@ -41,14 +42,12 @@ import Text.Shakespeare.Text(stext) -- This is for authEmail. Delete later
import Text.Hamlet (shamlet)
import Data.Maybe (isJust)
import Control.Monad (join)
-import Network.Mail.Mime
+import qualified Smtp.SmtpClient as SMTP
import Text.Blaze.Renderer.Utf8 (renderHtml)
import qualified Data.Text.Lazy.Encoding
import qualified Data.Map as Map
import Data.Map ((!))
-#ifndef DEVELOPMENT
-import Network.Mail.Mime (sendmail)
-#endif
+import qualified Data.Text as DT
-- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
@@ -176,38 +175,9 @@ instance YesodAuthMail Happiage where
type AuthEmailId Happiage = UserAuthId
addUnverified email verkey =
runDB $ insert $ UserAuth email Nothing (Just verkey) False
- sendVerifyEmail email _ verurl =
- liftIO $ renderSendMail (emptyMail $ Address Nothing "noreply")
- { mailTo = [Address Nothing email]
- , mailHeaders = [("Subject", "Verify your email address")]
- , mailParts = [[textPart, htmlPart]]
- }
- where
- textPart = Part
- { partType = "text/plain charset=utf-8"
- , partEncoding = None
- , partFilename = Nothing
- , partContent = Data.Text.Lazy.Encoding.encodeUtf8 [stext|
-Please confirm your email address by clicking on the link below.
-
-\#{verurl}
-
-Thank you
-|]
- , partHeaders = []
- }
- htmlPart = Part
- { partType = "text/html; charset=utf-8"
- , partEncoding = None
- , partFilename = Nothing
- , partContent = renderHtml [shamlet|
-<p>Please confirm your email address by clicking on the link below.
-<p>
- <a href=#{verurl}>#{verurl}
-<p>Thank you
-|]
- , partHeaders = []
- }
+ sendVerifyEmail email _ verurl = do
+ liftIO $ print verurl
+ liftIO $ SMTP.send (DT.unpack email) "subject" (DT.unpack $ "mailBody\n" `DT.append` verurl `DT.append` "\nend.")
getVerifyKey = runDB . fmap (join . fmap userAuthVerkey) . get
setVerifyKey uid key = runDB $ update uid [UserAuthVerkey =. Just key]
verifyAccount uid = runDB $ do
@@ -237,7 +207,7 @@ deliver :: Happiage -> L.ByteString -> IO ()
#ifdef DEVELOPMENT
deliver y = logLazyText (getLogger y) . Data.Text.Lazy.Encoding.decodeUtf8
#else
-deliver _ = sendmail
+deliver _ _ = SMTP.send -- TODO:fix this bug.
#endif
--user_authからuserを引いてくる
View
@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Smtp.SmtpClient (send) where
+
+import Prelude
+-- import qualified Network.SMTP.ClientSession as CS
+import qualified Network.SMTP.Client as C
+import qualified Network.Socket as S
+--import qualified Network.Socket.Internal as SI
+import qualified System.Time as T
+import qualified System.IO as IO
+-- import qualified Data.Bits as BITS
+import qualified Data.IORef as IOR
+import qualified Smtp.SmtpProperties as PROP
+
+send :: String -> String -> String -> IO ()
+send mailTo subject mailBody = do
+ now <- T.getClockTime
+ nowCT <- T.toCalendarTime now
+ -- Check Network.SMTP.Client.Message property. How do I write text/part, encoding etc.?
+ let message = C.Message [
+ C.From [C.NameAddr (Just PROP.fromName) PROP.fromAddr],
+ --C.To [C.NameAddr (Just "ToName") mailTo], -- TODO: fix "ToName"
+ C.To [C.NameAddr (Just "ToName") mailTo],
+ C.Subject subject,
+ C.Date nowCT
+ ]
+ mailBody
+ addrs <- S.getAddrInfo Nothing (Just PROP.smtpHost) Nothing
+ let S.SockAddrInet _ hostAddr = S.addrAddress (head addrs)
+ sockAddr = S.SockAddrInet 587 hostAddr -- 587 is the relation port.
+ --sockAddr = S.SockAddrInet (fromIntegral 25) hostAddr
+ putStrLn $ "connecting to " ++ show sockAddr -- TODO:Logging
+ sentRef <- IOR.newIORef []
+ C.sendSMTP' (IO.hPutStrLn IO.stderr) (Just sentRef) PROP.myDomain
+ sockAddr [message]
+ statuses <- IOR.readIORef sentRef
+ -- If no exception was caught, statuses is guaranteed to be
+ -- the same length as the list of input messages, therefore head won't fail here.
+ case head statuses of
+ Nothing -> putStrLn "Message successfully sent"
+ Just status -> putStrLn $ "Message send failed with status "++show status
@@ -0,0 +1,6 @@
+module Smtp.SmtpProperties where
+
+myDomain = "DomainName"
+smtpHost = "SmtpHostName"
+fromName = "FromName"
+fromAddr = "FromAddr"
View
@@ -37,6 +37,8 @@ library
Handler.Message
Handler.Intro
Handler.Album
+ Smtp.SmtpClient
+ Smtp.SmtpProperties
ghc-options: -Wall -threaded -O0
cpp-options: -DDEVELOPMENT
@@ -109,3 +111,7 @@ executable happiage
, http-conduit >= 1.2 && < 1.3
, blaze-html >= 0.0 && < 99
+ -- for SMTP Client
+ , old-time
+ , network
+ , SMTPClient

0 comments on commit d65fde3

Please sign in to comment.