{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
module Main (main) where

--------------------------------------------------------------------------------
import Control.Applicative ((<$>), (<*>))
import Control.Exception (bracket)
import Control.Monad (replicateM)
import Control.Monad.IO.Class (liftIO)
import qualified Control.Concurrent.STM.TChan as TChan
import Data.Monoid (mempty)
import System.IO.Error (catchIOError, isDoesNotExistError)

import Database.PostgreSQL.Simple.SqlQQ (sql)


--------------------------------------------------------------------------------
import qualified Control.Error as Error
import qualified Control.Concurrent.STM as STM
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Configurator as Configurator
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Encoding
import qualified Data.Time as Time
import qualified Database.PostgreSQL.Simple as PG
import qualified Heist
import qualified Network.AMQP as AMQP
import qualified Network.HTTP as HTTP
import qualified Network.Mail.Mime as Mail
import qualified Test.SmallCheck.Series as SmallCheck
import qualified Test.Framework as Tests
import qualified Test.Framework.Providers.HUnit as Tests
import qualified Test.Framework.Providers.SmallCheck as Tests

import Data.Aeson ((.=))
import Test.HUnit ((@?=), (@?))

--------------------------------------------------------------------------------
import qualified Enqueue
import qualified Mailer
import qualified RateLimit

import qualified MusicBrainz.Email as Email
import qualified MusicBrainz.Messaging as Messaging

--------------------------------------------------------------------------------
main :: IO ()
main = do
  testConfig <- Configurator.load [ Configurator.Required "test.cfg" ]
                 `catchIOError`
                  (\e -> if isDoesNotExistError e
                           then error "test.cfg not found. Please add a test.cfg file, see test.cfg.example for more information."
                           else ioError e)

  let opt key def = Configurator.lookupDefault (def PG.defaultConnectInfo) testConfig key
  pgConf <- PG.ConnectInfo
    <$> opt "db.host" PG.connectHost
    <*> opt "db.port" PG.connectPort
    <*> opt "db.user" PG.connectUser
    <*> opt "db.password" PG.connectPassword
    <*> opt "db.database" PG.connectDatabase

  rabbitMqConf <- Messaging.RabbitMQConnection
    <$> Configurator.require testConfig "rabbitmq.host"
    <*> Configurator.require testConfig "rabbitmq.vhost"
    <*> Configurator.require testConfig "rabbitmq.user"
    <*> Configurator.require testConfig "rabbitmq.password"

  Tests.defaultMain $ map withTimeOut $
    [ enqueuePasswordResets pgConf rabbitMqConf
    , expandTemplates
    , messagesAreSent rabbitMqConf
    , invalidMessageRouting rabbitMqConf
    , sendMailFailureRouting rabbitMqConf
    , heistFailureRouting rabbitMqConf
    , rateLimitTests
    ]


--------------------------------------------------------------------------------
enqueuePasswordResets :: PG.ConnectInfo -> Messaging.RabbitMQConnection -> Tests.Test
enqueuePasswordResets pgConf rabbitConf = withTimeOut $
  Tests.testGroup "Enqueueing password reset emails"
    [ Tests.testCase "Will send password reset emails to editors with old login date and confirmed email address" $
        withRabbitMq rabbitConf $ \(rabbitMq, _) -> do
          pg <- emptyPg

          PG.execute pg
            [sql| INSERT INTO editor (name, password, email, email_confirm_date, last_login_date)
                  VALUES (?, 'ignored', ?, '2010-01-01', '2010-01-01') |]
            ( Email.passwordResetEditor $ Email.emailTemplate expected
            , Mail.addressEmail $ Email.emailTo expected
            )

          sentMessages <- spyQueue rabbitMq Email.outboxQueue

          liftIO (Enqueue.run (Enqueue.Options (Enqueue.PasswordReset pgConf) rabbitConf))

          sentMessage <- STM.atomically $ TChan.readTChan sentMessages
          (Aeson.decode (AMQP.msgBody sentMessage)) @?= Just expected

    , Tests.testCase "Will not send to editors with unconfirmed email address" $
        withRabbitMq rabbitConf $ \(rabbitMq, _) -> do
          pg <- emptyPg

          PG.execute pg
            [sql| INSERT INTO editor (name, password, email, email_confirm_date, last_login_date)
                  VALUES (?, 'ignored', ?, null, '2010-01-01') |]
            ( Email.passwordResetEditor $ Email.emailTemplate expected
            , Mail.addressEmail $ Email.emailTo expected
            )

          expectNoSentMessages rabbitMq

    , Tests.testCase "Will not send to editors who logged in recently" $
        withRabbitMq rabbitConf $ \(rabbitMq, _) -> do
          pg <- emptyPg

          PG.execute pg
            [sql| INSERT INTO editor (name, password, email, email_confirm_date, last_login_date)
                  VALUES (?, 'ignored', ?, now(), '2013-04-29') |]
            ( Email.passwordResetEditor $ Email.emailTemplate expected
            , Mail.addressEmail $ Email.emailTo expected
            )

          expectNoSentMessages rabbitMq
    ]

 where

  expectNoSentMessages rabbitMq = do
    sentMessages <- spyQueue rabbitMq Email.outboxQueue

    liftIO (Enqueue.run (Enqueue.Options (Enqueue.PasswordReset pgConf) rabbitConf))

    (STM.atomically $ TChan.isEmptyTChan sentMessages)
      @? "No emails should have been sent"

  emptyPg = do
    pg <- PG.connect pgConf
    PG.execute_ pg "TRUNCATE editor CASCADE"
    return pg

  expected = Email.Email
    { Email.emailTo = Mail.Address { Mail.addressEmail = "ollie@ocharles.org.uk"
                                   , Mail.addressName = Just "ocharles"
                                   }
    , Email.emailFrom = Mail.Address { Mail.addressEmail = "noreply@musicbrainz.org"
                                     , Mail.addressName = Just "MusicBrainz"
                                     }
    , Email.emailTemplate =
        Email.PasswordReset { Email.passwordResetEditor = "ocharles" }
    }


--------------------------------------------------------------------------------
instance Monad m => SmallCheck.Serial m Text.Text where
  series = SmallCheck.cons1 Text.pack

instance Monad m => SmallCheck.Serial m Mail.Address

expandTemplates :: Tests.Test
expandTemplates = Tests.buildTest $ do
  heist <- Mailer.loadTemplates
  return $ Tests.testGroup "Can expand templates into real emails"
    [ Tests.withDepth 4 $ Tests.testProperty "Password reset emails" $
        \editor emailAddress emailFrom ->
           let emailTo = Mail.Address { Mail.addressEmail = emailAddress
                                      , Mail.addressName = Just editor
                                      }
               Just mail = Mailer.emailToMail
                 Email.Email { Email.emailTemplate = Email.PasswordReset editor
                             , Email.emailTo = emailTo
                             , Email.emailFrom = emailFrom
                             }
                 heist
               emailBody = Encoding.decodeUtf8 . BS.concat . LBS.toChunks .
                 Mail.partContent . head . head . Mail.mailParts $ mail
           in and $ [ Mail.mailTo mail == [ emailTo ]
                    , Mail.mailFrom mail == emailFrom
                    ] ++
                    map (flip Text.isInfixOf emailBody)
                      [ changePasswordUrl editor
                      , greeting editor
                      , "https://musicbrainz.org/lost-password"
                      ]
    ]

 where

  changePasswordUrl =
    Text.append "https://musicbrainz.org/account/change-password?mandatory=1&username=" .
      Text.pack . HTTP.urlEncode . Text.unpack

  greeting = Text.append "Dear "


--------------------------------------------------------------------------------
deriving instance Eq Mail.Encoding
deriving instance Show Mail.Encoding

deriving instance Eq Mail.Mail
deriving instance Show Mail.Mail

deriving instance Eq Mail.Part
deriving instance Show Mail.Part

messagesAreSent :: Messaging.RabbitMQConnection -> Tests.Test
messagesAreSent rabbitConf = withTimeOut $
  Tests.testCase "Emails in outbox are sent by outbox consumer" $ do
    withRabbitMq rabbitConf $ \(rabbitMq, rabbitMqConn) -> do
      heist <- Mailer.loadTemplates

      sentEmails <- STM.atomically $ TChan.newTChan
      Mailer.consumeOutbox rabbitMqConn heist $
        STM.atomically . TChan.writeTChan sentEmails

      AMQP.publishMsg rabbitMq Email.outboxExchange ""
        AMQP.newMsg { AMQP.msgBody = Aeson.encode testEmail }

      sentEmail <- STM.atomically $ TChan.readTChan sentEmails
      Just sentEmail @?= Mailer.emailToMail testEmail heist


--------------------------------------------------------------------------------
testEmail :: Email.Email
testEmail = Email.Email
    { Email.emailTemplate = Email.PasswordReset "ocharles"
    , Email.emailTo =
        Mail.Address { Mail.addressName = Nothing
                     , Mail.addressEmail = "foo@example.com"
                     }
    , Email.emailFrom =
        Mail.Address { Mail.addressName = Just "MusicBrainz"
                     , Mail.addressEmail = "noreply@musicbrainz.org"
                     }
    }


--------------------------------------------------------------------------------
invalidMessageRouting :: Messaging.RabbitMQConnection -> Tests.Test
invalidMessageRouting rabbitConf = withTimeOut $
  Tests.testCase "Unparsable emails are forwarded to outbox.invalid" $ do
    withRabbitMq rabbitConf $ \(rabbitMq, rabbitMqConn) -> do
      invalidMessages <- spyQueue rabbitMq Email.invalidQueue

      heist <- Mailer.loadTemplates
      Mailer.consumeOutbox rabbitMqConn heist (const $ return ())

      AMQP.publishMsg rabbitMq Email.outboxExchange ""
        AMQP.newMsg { AMQP.msgBody = invalidRequest }

      invalidMessage <- STM.atomically $ TChan.readTChan invalidMessages
      Aeson.decode (AMQP.msgBody invalidMessage) @?=
        Just (Aeson.object [ "error" .= ("Could not decode JSON" :: String)
                           , "json" .= invalidRequest
                           ])

 where

  invalidRequest = LBS.fromChunks [Encoding.encodeUtf8 "Ceci n'est pas une JSON-request"]


--------------------------------------------------------------------------------
sendMailFailureRouting :: Messaging.RabbitMQConnection -> Tests.Test
sendMailFailureRouting rabbitConf = withTimeOut $
  Tests.testCase "If sendmail doesn't exit cleanly, messages are forwarded to outbox.unroutable" $ do
    withRabbitMq rabbitConf $ \(rabbitMq, rabbitMqConn) -> do
      unroutableMessages <- spyQueue rabbitMq Email.unroutableQueue

      heist <- Mailer.loadTemplates
      Mailer.consumeOutbox rabbitMqConn heist (const $ error errorMessage)

      AMQP.publishMsg rabbitMq Email.outboxExchange ""
        AMQP.newMsg { AMQP.msgBody = Aeson.encode testEmail }

      unroutableMessage <- STM.atomically $ TChan.readTChan unroutableMessages
      Aeson.decode (AMQP.msgBody unroutableMessage)
        @?= Just (Aeson.object [ "error" .= errorMessage
                               , "email" .= testEmail
                               ])

 where

  errorMessage = "Kaboom!"


--------------------------------------------------------------------------------
heistFailureRouting :: Messaging.RabbitMQConnection -> Tests.Test
heistFailureRouting rabbitConf = withTimeOut $
  Tests.testCase "If Heist can't expand the template, messages are forwarded to outbox.unroutable" $ do
    withRabbitMq rabbitConf $ \(rabbitMq, rabbitMqConn) -> do
      unroutableMessages <- spyQueue rabbitMq Email.unroutableQueue

      -- A 'Heist' that doesn't know about any of the templates
      Right emptyHeist <- Error.runEitherT (Heist.initHeist mempty)
      Mailer.consumeOutbox rabbitMqConn emptyHeist (const $ return ())

      AMQP.publishMsg rabbitMq Email.outboxExchange ""
        AMQP.newMsg { AMQP.msgBody = Aeson.encode testEmail }

      unroutableMessage <- STM.atomically $ TChan.readTChan unroutableMessages
      Aeson.decode (AMQP.msgBody unroutableMessage)
        @?= Just (Aeson.object
                    [ "email" .= testEmail
                    , "error" .= ("Couldn't render template" :: String)
                    ])


--------------------------------------------------------------------------------
withRabbitMq :: Messaging.RabbitMQConnection -> ((AMQP.Channel, AMQP.Connection) -> IO a) -> IO a
withRabbitMq rabbitConf = bracket acquire release
 where

  acquire = do
    rabbitMqConn <- Messaging.connect rabbitConf
    rabbitMq <- AMQP.openChannel rabbitMqConn
    Email.establishRabbitMqConfiguration rabbitMq

    AMQP.purgeQueue rabbitMq Email.outboxQueue

    return (rabbitMq, rabbitMqConn)

  release (_, conn) = AMQP.closeConnection conn


--------------------------------------------------------------------------------
withTimeOut :: Tests.Test -> Tests.Test
withTimeOut =
  Tests.plusTestOptions mempty { Tests.topt_timeout = Just (Just 50000000) }


--------------------------------------------------------------------------------
spyQueue :: AMQP.Channel
         -> String
         -> IO (TChan.TChan AMQP.Message)
spyQueue rabbitMq queue = do
  sentMessages <- STM.atomically $ TChan.newTChan

  AMQP.consumeMsgs rabbitMq queue AMQP.NoAck $ \(message, _) ->
    STM.atomically $ TChan.writeTChan sentMessages message

  return sentMessages


--------------------------------------------------------------------------------
rateLimitTests :: Tests.Test
rateLimitTests = Tests.testCase "Fast requests are rate limited" $ do
  let limit = 50
      requests = 10
      expected = (fromIntegral requests) / limit

  limitedFunction <- RateLimit.rateLimit limit (const $ return ())

  startTime <- Time.getCurrentTime

  replicateM requests (limitedFunction ())

  duration <- (`Time.diffUTCTime` startTime) <$> Time.getCurrentTime
  duration >= expected @?
    (show requests ++ " requests should take at least 1/5 second, took " ++
     show duration ++ " expected " ++ show expected)