{-# LANGUAGE DataKinds     #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Network.Mail.Newsletter.Web.Handlers
 ( serveNewsletter
 , serverNewsletterSubGet, serverNewsletterSubPost
 , serverNewsletterSubConfirmGet, serverNewsletterSubConfirmPost
 , serverNewsletterUnsubGet, serverNewsletterUnsubPost
 ) where

import           Control.Lens
import           Control.Monad.Error.Class
import           Control.Monad.Reader
import qualified Data.Aeson as JS
import qualified Data.HashMap.Strict as HM
import           Data.Machine
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Data.Time
import           Network.Mail.Mime (Address(..))
import           Network.Mail.Newsletter.Class
import           Network.Mail.Newsletter.Web.API
import           Network.Mail.Newsletter.Web.Templates
import           Network.URI
import           Servant
import           System.Random
import           Text.Blaze.Html
import qualified Web.ClientSession as CS
import           Web.FormUrlEncoded

-- We can make this auto-batching later.
doUnsub :: (Monad m, Newsletter m) => Address -> m ()
doUnsub addr = runT_ $ source [addr] ~> unsubscribe

serveNewsletter :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m
                  ,IsElem NewsletterUnsubGet (ApiRoot m)
                  ,MonadReader r m, MonadError ServantErr m, Newsletter m
                  ,DedupSubscriptions m, HasNewsletterTimeouts r, HasAllowedOrigins r
                  ,MonadIO m)
                => ServerT NewsletterAPI m
serveNewsletter =
      (serverNewsletterUnsubGet :<|> serverNewsletterUnsubPost)
 :<|> (serverNewsletterSubGet :<|> serverNewsletterSubPost)
 :<|> (serverNewsletterSubConfirmGet :<|> serverNewsletterSubConfirmPost)

serverNewsletterUnsubGet :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m
                           ,MonadReader r m, MonadError ServantErr m, Newsletter m, MonadIO m)
                         => Text -> m (Headers '[Header "Referrer-Policy" RefPolicy] Html)
serverNewsletterUnsubGet csAddr = addHeader StrictOrigin <$> do
  mAddr <- decodeCS (Just . Address Nothing . TE.decodeUtf8) csAddr
  case mAddr of
    Just addr -> join $ view unsubConfirmTempl <*> pure addr
    Nothing -> throwError err400

serverNewsletterUnsubPost :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m
                            ,MonadReader r m, MonadError ServantErr m, Newsletter m, MonadIO m)
                          => Text -> m (Headers '[Header "Referrer-Policy" RefPolicy] Html)
serverNewsletterUnsubPost csAddr = addHeader StrictOrigin <$> do
  maddr <- decodeCS (Just . Address Nothing . TE.decodeUtf8) csAddr
  case maddr of
    Just addr -> do
      doUnsub addr
      join $ view unsubTempl <*> pure addr
    Nothing ->
      throwError err400

serverNewsletterSubGet :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m
                         ,MonadReader r m, MonadError ServantErr m, Newsletter m, MonadIO m)
                       => m Html
serverNewsletterSubGet = do
  dk <- T.pack <$> liftIO (replicateM 5  (randomRIO ('a', 'z')))
  gk <- T.pack <$> liftIO (replicateM 5  (randomRIO ('a', 'z')))
  gv <- T.pack <$> liftIO (replicateM 5  (randomRIO ('a', 'z')))
  k <- view clientSessionKey
  f <- TE.decodeUtf8 <$> liftIO (CS.encryptIO k (TE.encodeUtf8 $ T.intercalate ":" [dk, gk, gv]))
  join $ view subStartPage <*> pure f <*> pure dk <*> pure gk <*> pure gv

serverNewsletterSubPost :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m
                          ,MonadReader r m, MonadError ServantErr m, Newsletter m
                          ,DedupSubscriptions m, HasAllowedOrigins r, MonadIO m)
                        => Maybe String -> Maybe String -> Form -> m Html
serverNewsletterSubPost morig mref frm = do
  asrc <- view allowedOrigins
  k <- view clientSessionKey
  case (join $ uriAuthority <$> maybe (parseAbsoluteURI =<< mref) parseAbsoluteURI morig
       ,checkFormSec k) of
    (Nothing, _) -> throwError err400
    (Just a, Right True) | a `elem` asrc -> do
      case HM.lookup "email" (unForm frm) of
        Just [email] -> do
          let addr = Address Nothing email
          join $ when <$> recentlySubscribed addr
                      <*> pure (sendSubscribe addr =<< join (view optInEmail <*> pure addr))
          join $ view subStartSubmitted <*> pure addr
        _ -> throwError err400
    _ -> throwError err403
  where
    checkFormSec :: CS.Key -> Either Text Bool
    checkFormSec k = do
      f <- parseUnique "f" frm
      case (T.splitOn ":" . TE.decodeUtf8) <$> CS.decrypt k (TE.encodeUtf8 f) of
        Just [dk,gk,gv] -> do
          d <- (==(""::Text))  <$> parseUnique dk frm
          g <- (== gv) <$> parseUnique gk frm
          Right (d&&g)
        _ -> pure False

serverNewsletterSubConfirmGet :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m
                                ,MonadReader r m, MonadError ServantErr m, Newsletter m
                                ,HasNewsletterTimeouts r, MonadIO m)
                              => Text -> m (Headers '[Header "Referrer-Policy" RefPolicy] Html)
serverNewsletterSubConfirmGet csAddr = addHeader StrictOrigin <$> do
  now  <- utctDay <$> liftIO getCurrentTime
  msr  <- decSignup csAddr
  tout <- view nltSubTimeout
  case msr of
    Just (SignupReq day email) | (day `diffDays` now) < tout ->
      join $ view confirmStart <*> pure (Address Nothing email)
    _ -> throwError err400

serverNewsletterSubConfirmPost :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m
                                 ,IsElem NewsletterUnsubGet (ApiRoot m)
                                 ,MonadReader r m, MonadError ServantErr m, Newsletter m
                                 ,HasNewsletterTimeouts r, MonadIO m)
                               => Text -> m (Headers '[Header "Referrer-Policy" RefPolicy] Html)
serverNewsletterSubConfirmPost csAddr = addHeader StrictOrigin <$> do
  now  <- liftIO getCurrentTime
  msr  <- decSignup csAddr
  tout <- (+) <$> view nltSubTimeout <*> view nltGrace
  case msr of
    Just (SignupReq day email) | (day `diffDays` (utctDay now)) < tout -> do
      let addr = Address Nothing email
      unsub <- genUnsubLink addr
      runT_ $ source [(addr, JS.object [("subscribedAt", JS.toJSON now)
                                       ,("unsubscribe", JS.toJSON $ show unsub)])] ~> subscribe
      join $ view confirmConfirmed <*> pure addr
    _ -> throwError err400