-- 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 Brig.API.OAuth
  ( internalOauthAPI,
    oauthAPI,
    lookupOAuthRefreshTokens,
    verifyRefreshToken,
  )
where

import Brig.API.Error (throwStd)
import Brig.API.Handler (Handler)
import Brig.App
import Brig.Options qualified as Opt
import Cassandra hiding (Set)
import Cassandra qualified as C
import Control.Error
import Control.Lens ((?~), (^?))
import Crypto.JWT hiding (params, uri)
import Data.ByteString.Conversion
import Data.Domain
import Data.Id
import Data.Json.Util (toUTCTimeMillis)
import Data.Map qualified as Map
import Data.Misc
import Data.Qualified
import Data.Set qualified as Set
import Data.Text.Ascii
import Data.Text.Encoding qualified as T
import Data.Time
import Imports hiding (exp)
import OpenSSL.Random (randBytes)
import Polysemy (Member)
import Servant hiding (Handler, Tagged)
import Wire.API.Error
import Wire.API.Error.Brig (BrigError (AccessDenied))
import Wire.API.OAuth as OAuth
import Wire.API.Password
import Wire.API.Routes.Internal.Brig.OAuth qualified as I
import Wire.API.Routes.Named (Named (Named))
import Wire.API.Routes.Public.Brig.OAuth
import Wire.AuthenticationSubsystem (AuthenticationSubsystem)
import Wire.AuthenticationSubsystem qualified as Authentication
import Wire.AuthenticationSubsystem.Error
import Wire.Error
import Wire.HashPassword (HashPassword)
import Wire.HashPassword qualified as HashPassword
import Wire.RateLimit
import Wire.Sem.Jwk
import Wire.Sem.Jwk qualified as Jwk
import Wire.Sem.Now (Now)
import Wire.Sem.Now qualified as Now

--------------------------------------------------------------------------------
-- API Internal

internalOauthAPI :: (Member HashPassword r, Member RateLimit r) => ServerT I.OAuthAPI (Handler r)
internalOauthAPI =
  Named @"create-oauth-client" registerOAuthClient
    :<|> Named @"i-get-oauth-client" getOAuthClientById
    :<|> Named @"update-oauth-client" updateOAuthClient
    :<|> Named @"delete-oauth-client" deleteOAuthClient

--------------------------------------------------------------------------------
-- API Public

oauthAPI ::
  ( Member Now r,
    Member Jwk r,
    Member AuthenticationSubsystem r
  ) =>
  ServerT OAuthAPI (Handler r)
oauthAPI =
  Named @"get-oauth-client" getOAuthClient
    :<|> Named @"create-oauth-auth-code" createNewOAuthAuthorizationCode
    :<|> Named @"create-oauth-access-token" createAccessTokenWith
    :<|> Named @"revoke-oauth-refresh-token" revokeRefreshToken
    :<|> Named @"get-oauth-applications" getOAuthApplications
    :<|> Named @"revoke-oauth-account-access-v6" revokeOAuthAccountAccessV6
    :<|> Named @"revoke-oauth-account-access" revokeOAuthAccountAccess
    :<|> Named @"delete-oauth-refresh-token" deleteOAuthRefreshTokenById

--------------------------------------------------------------------------------
-- Handlers

registerOAuthClient :: forall r. (Member HashPassword r, Member RateLimit r) => OAuthClientConfig -> (Handler r) OAuthClientCredentials
registerOAuthClient (OAuthClientConfig name uri) = do
  guardOAuthEnabled
  credentials@(OAuthClientCredentials cid secret) <- OAuthClientCredentials <$> randomId <*> createSecret
  safeSecret <- hashClientSecret secret
  lift $ wrapClient $ insertOAuthClient cid name uri safeSecret
  pure credentials
  where
    createSecret :: (MonadIO m) => m OAuthClientPlainTextSecret
    createSecret = OAuthClientPlainTextSecret <$> rand32Bytes

    hashClientSecret :: OAuthClientPlainTextSecret -> (Handler r) Password
    hashClientSecret =
      lift
        . liftSem
        . HashPassword.hashPassword8 RateLimitInternal
        . plainTextPassword8Unsafe
        . toText
        . unOAuthClientPlainTextSecret

rand32Bytes :: (MonadIO m) => m AsciiBase16
rand32Bytes = liftIO . fmap encodeBase16 $ randBytes 32

getOAuthClientById :: OAuthClientId -> (Handler r) OAuthClient
getOAuthClientById cid = do
  guardOAuthEnabled
  mClient <- lift $ wrapClient $ lookupOauthClient cid
  maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure mClient

updateOAuthClient :: OAuthClientId -> OAuthClientConfig -> (Handler r) OAuthClient
updateOAuthClient cid config = do
  void $ getOAuthClientById cid
  lift $ wrapClient $ updateOAuthClient' cid config.applicationName config.redirectUrl
  getOAuthClientById cid

deleteOAuthClient :: OAuthClientId -> (Handler r) ()
deleteOAuthClient cid = do
  void $ getOAuthClientById cid
  lift $ wrapClient $ deleteOAuthClient' cid

getOAuthClient :: Local UserId -> OAuthClientId -> (Handler r) (Maybe OAuthClient)
getOAuthClient _ cid = do
  guardOAuthEnabled
  lift $ wrapClient $ lookupOauthClient cid

guardOAuthEnabled :: Handler r ()
guardOAuthEnabled = do
  settings <- asks (.settings)
  unless (Opt.oAuthEnabled settings) do
    throwStd (errorToWai @'OAuthFeatureDisabled)

createNewOAuthAuthorizationCode :: Local UserId -> CreateOAuthAuthorizationCodeRequest -> (Handler r) CreateOAuthCodeResponse
createNewOAuthAuthorizationCode luid code = do
  runExceptT (validateAndCreateAuthorizationCode luid code) >>= \case
    Right oauthCode ->
      pure $
        CreateOAuthCodeSuccess $
          code.redirectUri
            & addParams
              [ ("code", toByteString' oauthCode),
                ("state", T.encodeUtf8 code.state)
              ]
    Left CreateNewOAuthCodeErrorFeatureDisabled ->
      pure $
        CreateOAuthCodeFeatureDisabled $
          code.redirectUri
            & addParams
              [ ("error", "access_denied"),
                ("error_description", "OAuth is not enabled"),
                ("state", T.encodeUtf8 code.state)
              ]
    Left CreateNewOAuthCodeErrorClientNotFound ->
      pure $
        CreateOAuthCodeClientNotFound $
          code.redirectUri
            & addParams
              [ ("error", "access_denied"),
                ("error_description", "The client ID was not found"),
                ("state", T.encodeUtf8 code.state)
              ]
    Left CreateNewOAuthCodeErrorUnsupportedResponseType ->
      pure $
        CreateOAuthCodeUnsupportedResponseType $
          code.redirectUri
            & addParams
              [ ("error", "access_denied"),
                ("error_description", "The client ID was not found"),
                ("state", T.encodeUtf8 code.state)
              ]
    Left CreateNewOAuthCodeErrorRedirectUrlMissMatch ->
      pure CreateOAuthCodeRedirectUrlMissMatch

data CreateNewOAuthCodeError
  = CreateNewOAuthCodeErrorFeatureDisabled
  | CreateNewOAuthCodeErrorClientNotFound
  | CreateNewOAuthCodeErrorUnsupportedResponseType
  | CreateNewOAuthCodeErrorRedirectUrlMissMatch

validateAndCreateAuthorizationCode :: Local UserId -> CreateOAuthAuthorizationCodeRequest -> ExceptT CreateNewOAuthCodeError (Handler r) OAuthAuthorizationCode
validateAndCreateAuthorizationCode luid@(tUnqualified -> uid) (CreateOAuthAuthorizationCodeRequest cid scope responseType redirectUrl _state _ chal) = do
  failWithM CreateNewOAuthCodeErrorFeatureDisabled (assertMay . Opt.oAuthEnabled <$> asks (.settings))
  failWith CreateNewOAuthCodeErrorUnsupportedResponseType (assertMay $ responseType == OAuthResponseTypeCode)
  client <- failWithM CreateNewOAuthCodeErrorClientNotFound $ getOAuthClient luid cid
  failWith CreateNewOAuthCodeErrorRedirectUrlMissMatch (assertMay $ client.redirectUrl == redirectUrl)
  lift mkAuthorizationCode
  where
    mkAuthorizationCode :: (Handler r) OAuthAuthorizationCode
    mkAuthorizationCode = do
      oauthCode <- OAuthAuthorizationCode <$> rand32Bytes
      ttl <- Opt.oAuthAuthorizationCodeExpirationTimeSecs <$> asks (.settings)
      lift $ wrapClient $ insertOAuthAuthorizationCode ttl oauthCode cid uid scope redirectUrl chal
      pure oauthCode

createAccessTokenWith :: (Member Now r, Member Jwk r) => Either OAuthAccessTokenRequest OAuthRefreshAccessTokenRequest -> (Handler r) OAuthAccessTokenResponse
createAccessTokenWith req = do
  guardOAuthEnabled
  case req of
    Left reqAC -> createAccessTokenWithAuthorizationCode reqAC
    Right reqRT -> createAccessTokenWithRefreshToken reqRT

createAccessTokenWithRefreshToken :: (Member Now r, Member Jwk r) => OAuthRefreshAccessTokenRequest -> (Handler r) OAuthAccessTokenResponse
createAccessTokenWithRefreshToken req = do
  unless (req.grantType == OAuthGrantTypeRefreshToken) $ throwStd $ errorToWai @'OAuthInvalidGrantType
  key <- signingKey
  (OAuthRefreshTokenInfo _ cid uid scope _) <- lookupVerifyAndDeleteToken key req.refreshToken
  luid <- qualifyLocal uid
  void $ getOAuthClient luid cid >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure
  unless (cid == req.clientId) $ throwStd $ errorToWai @'OAuthInvalidClientCredentials
  createAccessToken key uid cid scope

lookupVerifyAndDeleteToken :: JWK -> OAuthRefreshToken -> (Handler r) OAuthRefreshTokenInfo
lookupVerifyAndDeleteToken key =
  verifyRefreshToken key
    >=> lift
    . wrapClient
    . lookupAndDeleteOAuthRefreshToken
    >=> maybe (throwStd $ errorToWai @'OAuthInvalidRefreshToken) pure

verifyRefreshToken :: JWK -> OAuthRefreshToken -> (Handler r) OAuthRefreshTokenId
verifyRefreshToken key rt = do
  eClaims <- liftIO (OAuth.verify' key (unOAuthToken rt))
  case eClaims of
    Left _ -> throwStd $ errorToWai @'OAuthInvalidRefreshToken
    Right claims -> maybe (throwStd $ errorToWai @'OAuthInvalidRefreshToken) pure $ hcsSub claims

createAccessTokenWithAuthorizationCode :: (Member Now r, Member Jwk r) => OAuthAccessTokenRequest -> (Handler r) OAuthAccessTokenResponse
createAccessTokenWithAuthorizationCode req = do
  unless (req.grantType == OAuthGrantTypeAuthorizationCode) $ throwStd $ errorToWai @'OAuthInvalidGrantType
  (cid, uid, scope, uri, mChal) <-
    lift (wrapClient $ lookupAndDeleteByOAuthAuthorizationCode req.code)
      >>= maybe (throwStd $ errorToWai @'OAuthAuthorizationCodeNotFound) pure
  luid <- qualifyLocal uid
  oauthClient <- getOAuthClient luid req.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure

  unless (uri == req.redirectUri) $ throwStd $ errorToWai @'OAuthRedirectUrlMissMatch
  unless (oauthClient.redirectUrl == req.redirectUri) $ throwStd $ errorToWai @'OAuthRedirectUrlMissMatch
  unless (maybe False (verifyCodeChallenge req.codeVerifier) mChal) $ throwStd $ errorToWai @'OAuthInvalidGrant

  key <- signingKey
  createAccessToken key uid cid scope

signingKey :: (Member Jwk r) => (Handler r) JWK
signingKey = do
  fp <- maybe (throwStd $ errorToWai @'OAuthJwtError) pure =<< asks (.settings.oAuthJwkKeyPair)
  lift (liftSem $ Jwk.get fp) >>= maybe (throwStd $ errorToWai @'OAuthJwtError) pure

createAccessToken :: (Member Now r) => JWK -> UserId -> OAuthClientId -> OAuthScopes -> (Handler r) OAuthAccessTokenResponse
createAccessToken key uid cid scope = do
  exp <- fromIntegral . Opt.oAuthAccessTokenExpirationTimeSecs <$> asks (.settings)
  accessToken <- mkAccessToken
  (rid, refreshToken) <- mkRefreshToken
  now <- lift (liftSem Now.get)
  let refreshTokenInfo = OAuthRefreshTokenInfo rid cid uid scope now
  refreshTokenExpiration <- Opt.oAuthRefreshTokenExpirationTimeSecs <$> asks (.settings)
  maxActiveTokens <- Opt.oAuthMaxActiveRefreshTokens <$> asks (.settings)
  lift $ wrapClient $ insertOAuthRefreshToken maxActiveTokens refreshTokenExpiration refreshTokenInfo
  pure $ OAuthAccessTokenResponse accessToken OAuthAccessTokenTypeBearer exp refreshToken
  where
    mkRefreshToken :: (Handler r) (OAuthRefreshTokenId, OAuthRefreshToken)
    mkRefreshToken = do
      rid :: OAuthRefreshTokenId <- randomId
      sub <- maybe (throwStd $ errorToWai @'OAuthJwtError) pure $ idToText rid ^? stringOrUri
      let claims = emptyClaimsSet & claimSub ?~ sub
      (rid,) . OAuthToken <$> signRefreshToken claims

    mkAccessToken :: (Member Now r) => (Handler r) OAuthAccessToken
    mkAccessToken = do
      domain <- asks (.settings.federationDomain)
      exp <- fromIntegral . Opt.oAuthAccessTokenExpirationTimeSecs <$> asks (.settings)
      claims <- mkAccessTokenClaims uid domain scope exp
      OAuthToken <$> signAccessToken claims

    mkAccessTokenClaims :: (Member Now r) => UserId -> Domain -> OAuthScopes -> NominalDiffTime -> (Handler r) OAuthClaimsSet
    mkAccessTokenClaims u domain scopes ttl = do
      iat <- lift (liftSem Now.get)
      uri <- maybe (throwStd $ errorToWai @'OAuthJwtError) pure $ domainText domain ^? stringOrUri
      sub <- maybe (throwStd $ errorToWai @'OAuthJwtError) pure $ idToText u ^? stringOrUri
      let exp = addUTCTime ttl iat
      let claimSet =
            emptyClaimsSet
              & claimIss ?~ uri
              & claimAud ?~ Audience [uri]
              & claimIat ?~ NumericDate iat
              & claimSub ?~ sub
              & claimExp ?~ NumericDate exp
      pure $ OAuthClaimsSet claimSet scopes

    signAccessToken :: OAuthClaimsSet -> (Handler r) SignedJWT
    signAccessToken claims = do
      jwtOrError <- liftIO $ doSignClaims
      either (const $ throwStd $ errorToWai @'OAuthJwtError) pure jwtOrError
      where
        doSignClaims :: IO (Either JWTError SignedJWT)
        doSignClaims = runJOSE $ do
          algo <- bestJWSAlg key
          signJWT key (newJWSHeaderProtected algo) claims

    signRefreshToken :: ClaimsSet -> (Handler r) SignedJWT
    signRefreshToken claims = do
      jwtOrError <- liftIO $ doSignClaims
      either (const $ throwStd $ errorToWai @'OAuthJwtError) pure jwtOrError
      where
        doSignClaims :: IO (Either JWTError SignedJWT)
        doSignClaims = runJOSE $ do
          algo <- bestJWSAlg key
          signClaims key (newJWSHeaderProtected algo) claims

revokeRefreshToken :: (Member Jwk r) => OAuthRevokeRefreshTokenRequest -> (Handler r) ()
revokeRefreshToken req = do
  key <- signingKey
  info <- lookupAndVerifyToken key req.refreshToken
  luid <- qualifyLocal info.userId
  void $ getOAuthClient luid info.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure
  lift $ wrapClient $ deleteOAuthRefreshToken info.userId info.refreshTokenId

lookupAndVerifyToken :: JWK -> OAuthRefreshToken -> (Handler r) OAuthRefreshTokenInfo
lookupAndVerifyToken key =
  verifyRefreshToken key
    >=> lift
    . wrapClient
    . lookupOAuthRefreshTokenInfo
    >=> maybe (throwStd $ errorToWai @'OAuthInvalidRefreshToken) pure

getOAuthApplications :: Local UserId -> (Handler r) [OAuthApplication]
getOAuthApplications (tUnqualified -> uid) = do
  activeRefreshTokens <- lift $ wrapClient $ lookupOAuthRefreshTokens uid
  toApplications activeRefreshTokens
  where
    toApplications :: [OAuthRefreshTokenInfo] -> (Handler r) [OAuthApplication]
    toApplications infos = do
      let grouped = Map.fromListWith (<>) $ (\info -> (info.clientId, [info])) <$> infos
      mApps <- for (Map.toList grouped) $ \(cid, tokens) -> do
        let luid = undefined uid
        mClient <- getOAuthClient luid cid
        pure $ (\client -> OAuthApplication cid client.name ((\i -> OAuthSession i.refreshTokenId (toUTCTimeMillis i.createdAt)) <$> tokens)) <$> mClient
      pure $ catMaybes mApps

revokeOAuthAccountAccessV6 :: Local UserId -> OAuthClientId -> (Handler r) ()
revokeOAuthAccountAccessV6 (tUnqualified -> uid) cid = do
  rts <- lift $ wrapClient $ lookupOAuthRefreshTokens uid
  for_ rts $ \rt -> when (rt.clientId == cid) $ lift $ wrapClient $ deleteOAuthRefreshToken uid rt.refreshTokenId

revokeOAuthAccountAccess ::
  (Member AuthenticationSubsystem r) =>
  Local UserId ->
  OAuthClientId ->
  PasswordReqBody ->
  (Handler r) ()
revokeOAuthAccountAccess luid@(tUnqualified -> uid) cid req = do
  (lift . liftSem $ Authentication.reauthenticateEither uid req.fromPasswordReqBody)
    >>= either (throwE . toAccessDenied) (const $ pure ())
  revokeOAuthAccountAccessV6 luid cid
  where
    toAccessDenied :: ReAuthError -> HttpError
    toAccessDenied _ = StdError $ errorToWai @'AccessDenied

deleteOAuthRefreshTokenById ::
  (Member AuthenticationSubsystem r) =>
  Local UserId ->
  OAuthClientId ->
  OAuthRefreshTokenId ->
  PasswordReqBody ->
  (Handler r) ()
deleteOAuthRefreshTokenById (tUnqualified -> uid) cid tokenId req = do
  (lift . liftSem $ Authentication.reauthenticateEither uid req.fromPasswordReqBody)
    >>= either (throwE . toAccessDenied) (const $ pure ())
  mInfo <- lift $ wrapClient $ lookupOAuthRefreshTokenInfo tokenId
  case mInfo of
    Nothing -> pure ()
    Just info -> do
      when (info.clientId /= cid) $ throwStd $ errorToWai @'OAuthClientNotFound
      lift $ wrapClient $ deleteOAuthRefreshToken uid tokenId
  where
    toAccessDenied :: ReAuthError -> HttpError
    toAccessDenied _ = StdError $ errorToWai @'AccessDenied

--------------------------------------------------------------------------------
-- DB

deleteOAuthClient' :: (MonadClient m) => OAuthClientId -> m ()
deleteOAuthClient' cid = retry x5 . write q $ params LocalQuorum (Identity cid)
  where
    q :: PrepQuery W (Identity OAuthClientId) ()
    q = "DELETE FROM oauth_client WHERE id = ?"

updateOAuthClient' :: (MonadClient m) => OAuthClientId -> OAuthApplicationName -> RedirectUrl -> m ()
updateOAuthClient' cid name uri = retry x5 . write q $ params LocalQuorum (name, uri, cid)
  where
    q :: PrepQuery W (OAuthApplicationName, RedirectUrl, OAuthClientId) ()
    q = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE oauth_client SET name = ?, redirect_uri = ? WHERE id = ?"

insertOAuthClient :: (MonadClient m) => OAuthClientId -> OAuthApplicationName -> RedirectUrl -> Password -> m ()
insertOAuthClient cid name uri pw = retry x5 . write q $ params LocalQuorum (cid, name, uri, pw)
  where
    q :: PrepQuery W (OAuthClientId, OAuthApplicationName, RedirectUrl, Password) ()
    q = "INSERT INTO oauth_client (id, name, redirect_uri, secret) VALUES (?, ?, ?, ?)"

lookupOauthClient :: (MonadClient m) => OAuthClientId -> m (Maybe OAuthClient)
lookupOauthClient cid = do
  mNameUrl <- retry x5 . query1 q $ params LocalQuorum (Identity cid)
  pure $ mNameUrl <&> uncurry (OAuthClient cid)
  where
    q :: PrepQuery R (Identity OAuthClientId) (OAuthApplicationName, RedirectUrl)
    q = "SELECT name, redirect_uri FROM oauth_client WHERE id = ?"

insertOAuthAuthorizationCode :: (MonadClient m) => Word64 -> OAuthAuthorizationCode -> OAuthClientId -> UserId -> OAuthScopes -> RedirectUrl -> OAuthCodeChallenge -> m ()
insertOAuthAuthorizationCode ttl code cid uid scope uri chal = do
  let cqlScope = C.Set (Set.toList (unOAuthScopes scope))
  retry x5 . write q $ params LocalQuorum (code, cid, uid, cqlScope, uri, chal, fromIntegral ttl)
  where
    q :: PrepQuery W (OAuthAuthorizationCode, OAuthClientId, UserId, C.Set OAuthScope, RedirectUrl, OAuthCodeChallenge, Int32) ()
    q = fromString $ "INSERT INTO oauth_auth_code (code, client, user, scope, redirect_uri, code_challenge) VALUES (?, ?, ?, ?, ?, ?) USING TTL ?"

lookupAndDeleteByOAuthAuthorizationCode :: (MonadClient m) => OAuthAuthorizationCode -> m (Maybe (OAuthClientId, UserId, OAuthScopes, RedirectUrl, Maybe OAuthCodeChallenge))
lookupAndDeleteByOAuthAuthorizationCode code = lookupOAuthAuthorizationCode <* deleteOAuthAuthorizationCode
  where
    lookupOAuthAuthorizationCode :: (MonadClient m) => m (Maybe (OAuthClientId, UserId, OAuthScopes, RedirectUrl, Maybe OAuthCodeChallenge))
    lookupOAuthAuthorizationCode = do
      mTuple <- retry x5 . query1 q $ params LocalQuorum (Identity code)
      pure $ mTuple <&> \(cid, uid, C.Set scope, uri, mChal) -> (cid, uid, OAuthScopes (Set.fromList scope), uri, mChal)
      where
        q :: PrepQuery R (Identity OAuthAuthorizationCode) (OAuthClientId, UserId, C.Set OAuthScope, RedirectUrl, Maybe OAuthCodeChallenge)
        q = "SELECT client, user, scope, redirect_uri, code_challenge FROM oauth_auth_code WHERE code = ?"

    deleteOAuthAuthorizationCode :: (MonadClient m) => m ()
    deleteOAuthAuthorizationCode = retry x5 . write q $ params LocalQuorum (Identity code)
      where
        q :: PrepQuery W (Identity OAuthAuthorizationCode) ()
        q = "DELETE FROM oauth_auth_code WHERE code = ?"

insertOAuthRefreshToken :: (MonadClient m) => Word32 -> Word64 -> OAuthRefreshTokenInfo -> m ()
insertOAuthRefreshToken maxActiveTokens ttl info = do
  let rid = info.refreshTokenId
  oldTokes <- determineOldestTokensToBeDeleted <$> lookupOAuthRefreshTokens info.userId
  for_ oldTokes (\t -> deleteOAuthRefreshToken t.userId t.refreshTokenId)
  retry x5 . write qInsertId $ params LocalQuorum (info.userId, rid, fromIntegral ttl)
  retry x5 . write qInsertInfo $ params LocalQuorum (rid, info.clientId, info.userId, C.Set (Set.toList (unOAuthScopes info.scopes)), info.createdAt, fromIntegral ttl)
  where
    qInsertInfo :: PrepQuery W (OAuthRefreshTokenId, OAuthClientId, UserId, C.Set OAuthScope, UTCTime, Int32) ()
    qInsertInfo = fromString $ "INSERT INTO oauth_refresh_token (id, client, user, scope, created_at) VALUES (?, ?, ?, ?, ?) USING TTL ?"

    qInsertId :: PrepQuery W (UserId, OAuthRefreshTokenId, Int32) ()
    qInsertId = fromString $ "INSERT INTO oauth_user_refresh_token (user, token_id) VALUES (?, ?) USING TTL ?"

    determineOldestTokensToBeDeleted :: [OAuthRefreshTokenInfo] -> [OAuthRefreshTokenInfo]
    determineOldestTokensToBeDeleted tokens =
      take (length sorted - fromIntegral maxActiveTokens + 1) sorted
      where
        sorted = sortOn (.createdAt) tokens

lookupOAuthRefreshTokens :: (MonadClient m) => UserId -> m [OAuthRefreshTokenInfo]
lookupOAuthRefreshTokens uid = do
  ids <- runIdentity <$$> (retry x5 . query q $ params LocalQuorum (Identity uid))
  catMaybes <$> for ids lookupOAuthRefreshTokenInfo
  where
    q :: PrepQuery R (Identity UserId) (Identity OAuthRefreshTokenId)
    q = "SELECT token_id FROM oauth_user_refresh_token WHERE user = ?"

lookupOAuthRefreshTokenInfo :: (MonadClient m) => OAuthRefreshTokenId -> m (Maybe OAuthRefreshTokenInfo)
lookupOAuthRefreshTokenInfo rid = do
  mTuple <- retry x5 . query1 q $ params LocalQuorum (Identity rid)
  pure $ mTuple <&> \(cid, uid, C.Set scope, createdAt) -> OAuthRefreshTokenInfo rid cid uid (OAuthScopes (Set.fromList scope)) createdAt
  where
    q :: PrepQuery R (Identity OAuthRefreshTokenId) (OAuthClientId, UserId, C.Set OAuthScope, UTCTime)
    q = "SELECT client, user, scope, created_at FROM oauth_refresh_token WHERE id = ?"

deleteOAuthRefreshToken :: (MonadClient m) => UserId -> OAuthRefreshTokenId -> m ()
deleteOAuthRefreshToken uid rid = do
  retry x5 . write qDeleteId $ params LocalQuorum (uid, rid)
  retry x5 . write qDeleteInfo $ params LocalQuorum (Identity rid)
  where
    qDeleteId :: PrepQuery W (UserId, OAuthRefreshTokenId) ()
    qDeleteId = "DELETE FROM oauth_user_refresh_token WHERE user = ? AND token_id = ?"

    qDeleteInfo :: PrepQuery W (Identity OAuthRefreshTokenId) ()
    qDeleteInfo = "DELETE FROM oauth_refresh_token WHERE id = ?"

lookupAndDeleteOAuthRefreshToken :: (MonadClient m) => OAuthRefreshTokenId -> m (Maybe OAuthRefreshTokenInfo)
lookupAndDeleteOAuthRefreshToken rid = do
  mInfo <- lookupOAuthRefreshTokenInfo rid
  for_ mInfo (\info -> deleteOAuthRefreshToken info.userId info.refreshTokenId) $> mInfo
