{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module DanglingUserKeys where

import Cassandra
import Cassandra.Util
import Conduit
import Data.Aeson qualified as Aeson
import Data.ByteString qualified as BS
import Data.Conduit.Internal (zipSources)
import Data.Conduit.List qualified as C
import Data.Id
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Imports
import System.Logger
import System.Logger qualified as Log
import UnliftIO.Async
import Wire.API.User hiding (userEmail)
import Wire.UserKeyStore

runCommand :: Logger -> ClientState -> FilePath -> IO ()
runCommand l brig inconsistenciesFile = do
  runResourceT $
    runConduit $
      zipSources
        (C.sourceList [(1 :: Int32) ..])
        (transPipe (runClient brig) getKeys)
        .| C.mapM
          ( \(i, userKeys) -> do
              Log.info l (Log.field "keys" (show ((i - 1) * pageSize + fromIntegral (length userKeys))))
              pure userKeys
          )
        .| C.mapM (liftIO . pooledMapConcurrentlyN 48 (\(key, uid, claimTime) -> checkUser l brig key uid claimTime False))
        .| C.map ((<> "\n") . BS.intercalate "\n" . map (BS.toStrict . Aeson.encode) . catMaybes)
        .| sinkFile inconsistenciesFile

runRepair :: Logger -> ClientState -> FilePath -> FilePath -> Bool -> IO ()
runRepair l brig inputFile outputFile repairData = do
  keys <- mapMaybe parseKey . Text.lines <$> Text.readFile inputFile
  runResourceT $
    runConduit $
      zipSources
        (C.sourceList [(1 :: Int32) ..])
        (C.sourceList keys)
        .| C.mapM
          ( \(i, key) -> do
              when (i `mod` 100 == 0) $
                Log.info l (Log.field "keysProcesses" i)
              liftIO $ checkKey l brig key repairData
          )
        .| C.map ((<> "\n") . BS.toStrict . Aeson.encode)
        .| sinkFile outputFile

pageSize :: Int32
pageSize = 1000

data Inconsistency = Inconsistency
  { -- | Key in the user_keys table
    key :: EmailKey,
    userId :: UserId,
    time :: Writetime UserId,
    status :: Maybe (WithWritetime AccountStatus),
    userEmail :: Maybe (WithWritetime EmailAddress),
    inconsistencyCase :: Text
  }
  deriving (Generic)

instance Aeson.ToJSON Inconsistency

data WithWritetime a = WithWritetime
  { value :: a,
    writetime :: Writetime a
  }
  deriving (Generic)

instance (Aeson.ToJSON a) => Aeson.ToJSON (WithWritetime a)

----------------------------------------------------------------------------
-- Queries

getKey :: EmailKey -> Client (Maybe (UserId, Writetime UserId))
getKey key = retry x5 $ query1 cql (params LocalQuorum (Identity key))
  where
    cql :: PrepQuery R (Identity EmailKey) (UserId, Writetime UserId)
    cql = "SELECT user, writetime(user) from user_keys where key = ?"

getKeys :: ConduitM () [(EmailKey, UserId, Writetime UserId)] Client ()
getKeys = paginateC cql (paramsP LocalQuorum () pageSize) x5
  where
    cql :: PrepQuery R () (EmailKey, UserId, Writetime UserId)
    cql = "SELECT key, user, writetime(user) from user_keys"

parseKey :: Text -> Maybe EmailKey
parseKey t = mkEmailKey <$> emailAddressText t

instance Cql EmailKey where
  ctype = Tagged TextColumn

  fromCql (CqlText t) =
    maybe
      (Left $ "invalid userkey: " <> show t)
      Right
      (parseKey t)
  fromCql _ = Left "userkey: expected text"

  toCql k = toCql $ emailKeyUniq k

instance Aeson.ToJSON EmailKey where
  toJSON = Aeson.toJSON . emailKeyUniq

type UserDetailsRow = (Maybe AccountStatus, Maybe (Writetime AccountStatus), Maybe EmailAddress, Maybe (Writetime EmailAddress))

getUserDetails :: UserId -> Client (Maybe UserDetailsRow)
getUserDetails uid = retry x5 $ query1 cql (params LocalQuorum (Identity uid))
  where
    cql :: PrepQuery R (Identity UserId) UserDetailsRow
    cql = "SELECT status, writetime(status), email, writetime(email) from user where id = ?"

checkKey :: Logger -> ClientState -> EmailKey -> Bool -> IO (Maybe Inconsistency)
checkKey l brig key repairData = do
  mUser <- runClient brig $ getKey key
  case mUser of
    Nothing -> do
      Log.warn l (Log.msg (Log.val "No user found for key") . Log.field "key" (emailKeyUniq key))
      pure Nothing
    Just (uid, writeTime) -> checkUser l brig key uid writeTime repairData

-- mostly copied from Brig to not need a Brig Env/ReaderT
freeEmailKey :: Logger -> EmailKey -> Client ()
freeEmailKey l k = do
  Log.info l $ Log.msg (Log.val "Freeing key") . Log.field "key" (emailKeyUniq k)
  retry x5 $ write keyDelete (params LocalQuorum (Identity $ emailKeyUniq k))
  where
    keyDelete :: PrepQuery W (Identity Text) ()
    keyDelete = "DELETE FROM user_keys WHERE key = ?"

insertKey :: Logger -> UserId -> EmailKey -> Client ()
insertKey l u k = do
  Log.info l $ Log.msg (Log.val "Inserting key") . Log.field "key" (emailKeyUniq k) . Log.field "userId" (show u)
  retry x5 $ write keyInsert (params LocalQuorum (emailKeyUniq k, u))
  where
    keyInsert :: PrepQuery W (Text, UserId) ()
    keyInsert = "INSERT INTO user_keys (key, user) VALUES (?, ?)"

-- repair these inconsistent data cases:
-- - 1. user deleted (or with status=null) in user table, data left in user_keys -> delete records in user_keys
-- - 2. user not found in user table, data left in user_keys -> delete records in user_keys
-- - 3. the user to which this key points to has a different email in the user table, and
--     3.a. this user *also* has a correct entry in the user_keys table -> delete record of the wrong pointer inside user_keys
--     3.b. this user's email, when searched for points to another user -> do nothing; log this issue
--     3.c  this user's email, when searched for does not exist in user_keys. Do nothing, let this be handled by the other module EmailLessUsers.hs
--   4. user has an email in user_keys but no email inside user table -> do nothing. How to resolve?
checkUser :: Logger -> ClientState -> EmailKey -> UserId -> Writetime UserId -> Bool -> IO (Maybe Inconsistency)
checkUser l brig key uid time repairData = do
  maybeDetails <- runClient brig $ getUserDetails uid
  case maybeDetails of
    Nothing -> do
      let status = Nothing
          userEmail = Nothing
          inconsistencyCase = "2."
      when repairData $ -- case 2.
        runClient brig $
          freeEmailKey l key
      pure . Just $ Inconsistency {userId = uid, ..}
    Just (mStatus, mStatusWriteTime, mEmail, mEmailWriteTime) -> do
      let status = WithWritetime <$> mStatus <*> mStatusWriteTime
          userEmail = WithWritetime <$> mEmail <*> mEmailWriteTime
          statusError = case mStatus of
            Nothing -> True
            Just Deleted -> True
            _ -> False
          compareEmail e = (emailKeyUniq . mkEmailKey <$> mEmail) /= Just (fromEmail e)
          keyError = compareEmail (emailKeyOrig key)
      if statusError
        then do
          let inconsistencyCase = "1."
          when repairData $ runClient brig (freeEmailKey l key)
          pure . Just $ Inconsistency {userId = uid, ..}
        else
          if keyError
            then do
              case mEmail of
                Nothing -> do
                  Log.warn l (Log.msg (Log.val "Subcase 4: user has no email") . Log.field "userId" (show uid))
                  let inconsistencyCase = "4."
                  pure . Just $ Inconsistency {userId = uid, ..}
                Just email -> do
                  validKeysEntry <- runClient brig $ getKey (mkEmailKey email)
                  case validKeysEntry of
                    Just (keyEntryUserId, _) ->
                      if keyEntryUserId == uid
                        then do
                          -- there is a valid matching user_key entry for a user in the user table; just *also* an extra entry that can be cleaned up (case 3.a.)
                          Log.warn l (Log.msg (Log.val "Subcase 3a: entry can be repaired by removing entry") . Log.field "key" (emailKeyUniq key))
                          let inconsistencyCase = "3.a."
                          when repairData $
                            runClient brig $
                              freeEmailKey l key
                          pure . Just $ Inconsistency {userId = uid, ..}
                        else do
                          let inconsistencyCase = "3.b."
                          Log.warn l (Log.msg (Log.val "Subcase 3b: double mismatch entry in user_keys") . Log.field "userId" (show uid))
                          pure . Just $ Inconsistency {userId = uid, ..}
                    Nothing -> do
                      let inconsistencyCase = "3.c."
                      Log.warn l (Log.msg (Log.val "Subcase 3c: missing entry in user_keys") . Log.field "userId" (show uid))
                      pure . Just $ Inconsistency {userId = uid, ..}
            else pure Nothing
