---------------------------------------------------------------
-- Copyright (c) 2013, Enzo Haussecker. All rights reserved. --
---------------------------------------------------------------

{-# LANGUAGE OverloadedStrings       #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# OPTIONS -Wall                    #-}
{-# OPTIONS -fno-warn-name-shadowing #-}

module Network.SMTPS.Gmail (sendGmail) where

import Codec.Binary.Base64.String (encode)
import Control.Exception
import Control.Monad
import Crypto.Random.AESCtr (makeSystem)
import Data.ByteString.Char8 as Strict
import Data.ByteString.Lazy.Char8 as Lazy
import Data.ByteString.Lazy.UTF8 (fromString)
import Data.List as List
import Data.Monoid ((<>))
import Network
import Network.TLS
import Network.TLS.Extra
import System.IO as IO
import Text.Printf

-- | Send an email from your Gmail account using the simple 
--   message transfer protocol with transport layer security.
sendGmail
  :: Handle   -- ^ log
  -> String   -- ^ username
  -> String   -- ^ password
  -> [String] -- ^ to
  -> [String] -- ^ cc
  -> [String] -- ^ bcc
  -> String   -- ^ subject
  -> String   -- ^ body
  -> IO ()
sendGmail log user pass to cc bcc sub body = ( do
  let params = defaultParamsClient { pCiphers  = ciphers }
      recips = nub $ bcc <> cc <> to
      from   = user <> "@gmail.com"
  gen <- makeSystem
  hdl <- connectTo "smtp.gmail.com" $ PortNumber 587
  ctx <- contextNewOnHandle hdl params gen
  hSetBuffering hdl LineBuffering
  let f str = send hdl log str >> recv hdl log
  mapM_ f ["EHLO","STARTTLS"]
  handshake ctx
  let g lbs = sendTLS ctx log lbs >> recvTLS ctx log
  mapM_ g [
    "EHLO",
    "AUTH LOGIN",
    fromString $ encode user,
    fromString $ encode pass,
    fromString $ "MAIL FROM:<" <>                        from   <> ">",
    fromString $ "RCPT TO:<"   <> List.intercalate ">,<" recips <> ">",
    "DATA",
    fromString $ "To:<"        <> List.intercalate ">,<" to     <> ">"
          <> "\r\nCC:<"        <> List.intercalate ">,<" cc     <> ">"
          <> "\r\nBCC:<"       <> List.intercalate ">,<" bcc    <> ">"
          <> "\r\nFrom:<"      <>                        from   <> ">"
          <> "\r\nSubject:"    <>                        sub
          <> "\r\n"            <>                        body
          <> "\r\n.",
    "QUIT"]
  bye ctx
  contextClose ctx
  hClose hdl )
   `catch` \ (err :: SomeException) ->
    IO.hPutStrLn log $ show err

send :: Handle -> Handle -> String -> IO ()
send socket log message = do
  void $ hPrintf socket "%s\r\n" message
  IO.hPutStrLn log $ "> " <> message

recv :: Handle -> Handle -> IO ()
recv socket log = do
  imput <- hWaitForInput socket 300
  when imput $ do
    line <- IO.hGetLine socket
    IO.hPutStrLn log line
    recv socket log

sendTLS :: Context -> Handle -> Lazy.ByteString -> IO ()
sendTLS ctx log message = do
  sendData ctx $ message <> "\r\n"
  Lazy.hPutStrLn log $ "> " <> message

recvTLS :: Context -> Handle -> IO ()
recvTLS ctx log = do
  messages <- recvData ctx
  mapM_ (Strict.hPutStrLn log) $ Strict.lines messages

ciphers :: [Cipher]
ciphers =
  [ cipher_AES128_SHA1
  , cipher_AES256_SHA1
  , cipher_RC4_128_MD5
  , cipher_RC4_128_SHA1
  ]