{-# LANGUAGE DataKinds     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes    #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Network.Mail.Newsletter.Web.API
 ( HasApiRoot(..)
 , DedupSubscriptions(..)
 , HasClientSessionKey(..)
 , HasAllowedOrigins(..)
 , NewsletterTimeouts(..)
 , HasNewsletterTimeouts(..)
 , RefPolicy(..)
 , NewsletterAPI, newsletterApi
 , genUnsubLink
 , genSubConfirmLink
 , NewsletterUnsub, NewsletterUnsubGet, NewsletterUnsubPost
 , NewsletterSub, NewsletterSubGet, NewsletterSubPost
 , NewsletterSubConfirm, NewsletterSubConfirmGet, NewsletterSubConfirmPost
 , decodeCS
 , SignupReq(..)
 , encSignup, decSignup
 ) where

import           Control.Lens
import           Control.Monad.Trans
import           Control.Monad.Reader
import           Data.ByteString (ByteString)
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Data.Time
import           Data.Proxy (Proxy(..))
import           Network.Mail.Mime (Address(..))
import           Network.URI
import           Servant
import           Servant.HTML.Blaze
import           Text.Blaze.Html
import           Text.Printf
import qualified Web.ClientSession as CS
import           Web.FormUrlEncoded

data RefPolicy
 = NoRef
 | SameOrigin
 | StrictOrigin
 | StrictOriginCross

instance Show RefPolicy where
  show NoRef             = "no-referrer"
  show SameOrigin        = "same-origin"
  show StrictOrigin      = "strict-origin"
  show StrictOriginCross = "strict-origin-when-cross-origin"

instance ToHttpApiData RefPolicy where
  toHeader = TE.encodeUtf8 . T.pack . show
  toQueryParam = T.pack . show

class HasApiRoot m where
  type ApiRoot m
  apiRoot :: m (Proxy (ApiRoot m))
  apiBase :: m URI

-- | A class to avoid repeated emailing someone even if they sign up multiple times.
class DedupSubscriptions m where
  recentlySubscribed :: Address -> m Bool

class HasClientSessionKey k where
  clientSessionKey :: Lens' k CS.Key

instance HasClientSessionKey CS.Key where
  clientSessionKey = id

class HasAllowedOrigins t where
  allowedOrigins :: Lens' t [URIAuth]

data NewsletterTimeouts
 = NewsletterTimeouts
   { _nltSubTimeout :: Integer
     -- ^ How long subsription confirmation links are valid for
   , _nltGrace      :: Integer
     -- ^ How much extra time they have to POST the confirmation
   }
 deriving (Show)

makeClassy ''NewsletterTimeouts

type NewsletterUnsubGet =
  "unsubscribe" :> Capture "unsub" Text :> Get    '[HTML] (Headers '[Header "Referrer-Policy" RefPolicy]Html)

type NewsletterUnsubPost =
  "unsubscribe" :> Capture "unsub" Text :> Post   '[HTML] (Headers '[Header "Referrer-Policy" RefPolicy]Html)

type NewsletterUnsub =
       NewsletterUnsubGet
  :<|> NewsletterUnsubPost

type NewsletterSubGet =
  Get  '[HTML] Html

type NewsletterSubPost =
  Header "Origin" String :> Header "Referer" String :> ReqBody '[FormUrlEncoded] Form :> Post '[HTML] Html

type NewsletterSubConfirmGet =
  "confirm" :> Capture "sub" Text              :> Get  '[HTML] (Headers '[Header "Referrer-Policy" RefPolicy]Html)

type NewsletterSubConfirmPost =
  "confirm" :> Capture "sub" Text :> Post  '[HTML] (Headers '[Header "Referrer-Policy" RefPolicy] Html)

type NewsletterSub =
      NewsletterSubGet
 :<|> NewsletterSubPost

type NewsletterSubConfirm =
      NewsletterSubConfirmGet
 :<|> NewsletterSubConfirmPost

type NewsletterAPI =
      NewsletterUnsub
 :<|> NewsletterSub
 :<|> NewsletterSubConfirm

newsletterApi :: Proxy NewsletterAPI
newsletterApi = Proxy

genUnsubLink :: (HasClientSessionKey k, MonadIO m, MonadReader k m, HasApiRoot m
               ,IsElem NewsletterUnsubGet (ApiRoot m))
             => Address -> m URI
genUnsubLink (Address _ email) = do
  k <- view clientSessionKey
  e <- liftIO $ CS.encryptIO k (TE.encodeUtf8 email)
  u <- apiBase
  ((`relativeTo` u) . linkURI)  <$> (safeLink <$> apiRoot
                                              <*> pure (Proxy @NewsletterUnsubGet)
                                              <*> pure (TE.decodeUtf8 e))

genSubConfirmLink :: (HasClientSessionKey k, MonadIO m, MonadReader k m, HasApiRoot m
                    ,IsElem NewsletterSubConfirmGet (ApiRoot m))
                  => Address -> m URI
genSubConfirmLink (Address _ email) = do
  now <- utctDay <$> liftIO getCurrentTime
  u <- apiBase
  ((`relativeTo` u) . linkURI) <$> (safeLink <$> apiRoot
                                             <*> pure (Proxy @NewsletterSubConfirmGet)
                                             <*> encSignup (SignupReq now email))

encSignup :: (HasClientSessionKey k, MonadIO m, MonadReader k m)
          => SignupReq -> m Text
encSignup (SignupReq now email) = do
  k <- view clientSessionKey
  let ts = formatTime defaultTimeLocale (iso8601DateFormat Nothing) now
  let st = T.pack $ printf "1%s:%s" ts email
  TE.decodeUtf8 <$> liftIO (CS.encryptIO k (TE.encodeUtf8 st))

decSignup :: (HasClientSessionKey k, MonadReader k m)
          => Text -> m (Maybe SignupReq)
decSignup t = do
  k <- view clientSessionKey
  return $ do
    dt <- TE.decodeUtf8 <$> CS.decrypt k (TE.encodeUtf8 t)
    case T.splitAt 1 dt of
      ("1", r) -> do
         let (dayStr, email) = T.drop 1 <$> T.breakOn ":" r
         SignupReq <$> (parseTimeM False defaultTimeLocale (iso8601DateFormat Nothing) $
                                   T.unpack dayStr)
                   <*> pure email
      _ -> Nothing

decodeCS :: (HasClientSessionKey k, MonadReader k m)
         => (ByteString -> Maybe b) -> Text -> m (Maybe b)
decodeCS f t =
  (join . fmap f) <$> (CS.decrypt <$> view clientSessionKey <*> pure (TE.encodeUtf8 t))

data SignupReq
 = SignupReq
   { _signupTime :: Day
     -- ^ Makes sure a singup isn't value forever
   , _signupAddress :: Text
   }
 deriving (Show, Eq, Ord)