{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- 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 Test.Spar.DataSpec
  ( spec,
  )
where

import Cassandra
import Control.Lens
import Imports
import SAML2.WebSSO as SAML
import Spar.App as App
import Spar.Error (IdpDbError (IdpNotFound), SparCustomError (IdpDbError))
import Spar.Intra.RpcApp (veidFromUserSSOId)
import Spar.Options
import qualified Spar.Sem.AReqIDStore as AReqIDStore
import qualified Spar.Sem.AssIDStore as AssIDStore
import qualified Spar.Sem.SAMLUserStore as SAMLUserStore
import qualified Spar.Sem.ScimTokenStore as ScimTokenStore
import Type.Reflection (typeRep)
import URI.ByteString.QQ (uri)
import Util.Core
import Util.Scim
import Util.Types
import Web.Scim.Schema.Common as Scim.Common
import Web.Scim.Schema.Meta as Scim.Meta
import Wire.API.User.IdentityProvider
import Wire.API.User.Saml
import qualified Wire.IdPConfigStore as IdPEffect
import qualified Wire.VerdictFormatStore as VerdictFormatStore

spec :: SpecWith TestEnv
spec = do
  describe "Cql rountrip" $ do
    let check ::
          forall a.
          (Cql a, Typeable a, Show a, Eq a) =>
          a ->
          SpecWith TestEnv
        check x = it (show (typeRep @a)) . liftIO $ do
          (fromCql . toCql) x `shouldBe` Right x
    check ("<>%&'\"" :: Text)
  -- FUTUREWORK: collect all Cql instance, make them Arbitrary instances, and do this right.

  describe "TTL" $ do
    it "works in seconds" $ do
      env <- ask
      (owner, _teamid) <- call $ createUserWithTeam (env ^. teBrig) (env ^. teGalley)
      ((^. SAML.idpId) -> idpid) <- registerTestIdP owner
      (_, req) <- call $ callAuthnReq (env ^. teSpar) idpid
      let probe :: (MonadIO m, MonadReader TestEnv m) => m Bool
          probe = runSpar $ isJust <$> AReqIDStore.getIdpIssuer (req ^. SAML.rqID)
          maxttl :: Int -- musec
          maxttl = (fromIntegral . fromTTL $ env ^. teOpts . to maxttlAuthreq) * 1000 * 1000
      liftIO $ maxttl `shouldSatisfy` (< 60 * 1000 * 1000) -- otherwise the test will be really slow.
      p1 <- probe
      liftIO $ p1 `shouldBe` True
      liftIO $ threadDelay (maxttl `div` 2)
      p2 <- probe
      liftIO $ p2 `shouldBe` True -- 0.5 lifetimes after birth
      liftIO $ threadDelay maxttl
      p3 <- probe
      liftIO $ p3 `shouldBe` False -- 1.5 lifetimes after birth
  describe "cql binding" $ do
    describe "SPStoreRequest" $ do
      let idpiss = Issuer [uri|https://idp.io/|]
      context "within TTL" $ do
        it "issuer can be found" $ do
          xid :: SAML.ID a <- nextSAMLID
          eol :: Time <- addTime 5 <$> runSimpleSP getNow
          () <- runSpar $ AReqIDStore.store xid idpiss eol
          isit <- runSpar $ isJust <$> AReqIDStore.getIdpIssuer xid
          liftIO $ isit `shouldBe` True
      context "after TTL" $ do
        it "issuer cannot be found" $ do
          xid :: SAML.ID a <- nextSAMLID
          eol :: Time <- addTime 2 <$> runSimpleSP getNow
          () <- runSpar $ AReqIDStore.store xid idpiss eol
          liftIO $ threadDelay 3000000
          isit <- runSpar $ isJust <$> AReqIDStore.getIdpIssuer xid
          liftIO $ isit `shouldBe` False
      context "after call to unstore" $ do
        it "issuer cannot be found" $ do
          xid :: SAML.ID a <- nextSAMLID
          eol :: Time <- addTime 5 <$> runSimpleSP getNow
          () <- runSpar $ AReqIDStore.store xid idpiss eol
          () <- runSpar $ AReqIDStore.unStore xid
          isit <- runSpar $ isJust <$> AReqIDStore.getIdpIssuer xid
          liftIO $ isit `shouldBe` False
    describe "SPStoreAssertion" $ do
      context "within TTL" $ do
        it "isAlive is True" $ do
          xid :: SAML.ID a <- nextSAMLID
          eol :: Time <- addTime 5 <$> runSimpleSP getNow
          () <- runSpar $ AssIDStore.store xid eol
          isit <- runSpar $ AssIDStore.isAlive xid
          liftIO $ isit `shouldBe` True
      context "after TTL" $ do
        it "isAlive returns False" $ do
          xid :: SAML.ID a <- nextSAMLID
          eol :: Time <- addTime 2 <$> runSimpleSP getNow
          () <- runSpar $ AssIDStore.store xid eol
          liftIO $ threadDelay 3000000
          isit <- runSpar $ AssIDStore.isAlive xid
          liftIO $ isit `shouldBe` False
      context "after call to unstore" $ do
        it "isAlive returns False" $ do
          xid :: SAML.ID a <- nextSAMLID
          eol :: Time <- addTime 5 <$> runSimpleSP getNow
          () <- runSpar $ AssIDStore.store xid eol
          () <- runSpar $ AssIDStore.unStore xid
          isit <- runSpar $ AssIDStore.isAlive xid
          liftIO $ isit `shouldBe` False
    describe "VerdictFormat" $ do
      context "insert and get are \"inverses\"" $ do
        let check vf = it (show vf) $ do
              vid <- nextSAMLID
              () <- runSpar $ VerdictFormatStore.store 1 vid vf
              mvf <- runSpar $ VerdictFormatStore.get vid
              liftIO $ mvf `shouldBe` Just vf
        check
          `mapM_` [ VerdictFormatWeb Nothing,
                    VerdictFormatMobile [uri|https://fw/ooph|] [uri|https://lu/gn|] Nothing
                  ]
      context "has timed out" $ do
        it "VerdictFormatStore.get returns Nothing" $ do
          vid <- nextSAMLID
          () <- runSpar $ VerdictFormatStore.store 1 vid (VerdictFormatWeb Nothing)
          liftIO $ threadDelay 2000000
          mvf <- runSpar $ VerdictFormatStore.get vid
          liftIO $ mvf `shouldBe` Nothing
      context "does not exist" $ do
        it "VerdictFormatStore.get returns Nothing" $ do
          vid <- nextSAMLID
          mvf <- runSpar $ VerdictFormatStore.get vid
          liftIO $ mvf `shouldBe` Nothing
    describe "User" $ do
      context "user is new" $ do
        it "getUser returns Nothing" $ do
          uref <- nextUserRef
          muid <- runSpar $ SAMLUserStore.get uref
          liftIO $ muid `shouldBe` Nothing
        it "inserts new user and responds with 201 / returns new user" $ do
          uref <- nextUserRef
          uid <- nextWireId
          () <- runSpar $ SAMLUserStore.insert uref uid
          muid <- runSpar $ SAMLUserStore.get uref
          liftIO $ muid `shouldBe` Just uid
      context "user already exists (idempotency)" $ do
        it "inserts new user and responds with 201 / returns new user" $ do
          uref <- nextUserRef
          uid <- nextWireId
          uid' <- nextWireId
          () <- runSpar $ SAMLUserStore.insert uref uid
          () <- runSpar $ SAMLUserStore.insert uref uid'
          muid <- runSpar $ SAMLUserStore.get uref
          liftIO $ muid `shouldBe` Just uid'
      describe "DELETE" $ do
        it "works" $ do
          uref <- nextUserRef
          uid <- nextWireId
          do
            () <- runSpar $ SAMLUserStore.insert uref uid
            muid <- runSpar $ SAMLUserStore.get uref
            liftIO $ muid `shouldBe` Just uid
          do
            () <- runSpar $ SAMLUserStore.delete uid uref
            muid <- runSpar (SAMLUserStore.get uref) `aFewTimes` isNothing
            liftIO $ muid `shouldBe` Nothing
    describe "Team" $ do
      testDeleteTeam
    describe "IdPConfig" $ do
      it "insertIdPConfig, getIdPConfig are \"inverses\"" $ do
        idp <- makeTestIdP
        () <- runSpar $ IdPEffect.insertConfig idp
        midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId)
        liftIO $ midp `shouldBe` idp
      it "getIdPByIssuer works" $ do
        idp <- makeTestIdP
        () <- runSpar $ IdPEffect.insertConfig idp
        midp <- getIdPByIssuer (idp ^. idpMetadata . edIssuer) (idp ^. SAML.idpExtraInfo . team)
        liftIO $ midp `shouldBe` Just idp
      it "getIdPConfigsByTeam works" $ do
        skipIdPAPIVersions [WireIdPAPIV1]
        teamid <- nextWireId
        idp <- makeTestIdP <&> idpExtraInfo .~ WireIdP teamid Nothing [] Nothing (IdPHandle "IdP 1") Nothing
        () <- runSpar $ IdPEffect.insertConfig idp
        idps <- runSpar $ IdPEffect.getConfigsByTeam teamid
        liftIO $ idps `shouldBe` [idp]
      it "deleteIdPConfig works" $ do
        teamid <- nextWireId
        idpApiVersion <- asks (^. teWireIdPAPIVersion)
        idp <- makeTestIdP <&> idpExtraInfo .~ WireIdP teamid (Just idpApiVersion) [] Nothing (IdPHandle "IdP 1") Nothing
        () <- runSpar $ IdPEffect.insertConfig idp
        do
          midp <- runSpar $ IdPEffect.getConfig (idp ^. idpId)
          liftIO $ midp `shouldBe` idp
        () <- runSpar $ IdPEffect.deleteConfig idp
        do
          idpOrError <- runSparE $ IdPEffect.getConfig (idp ^. idpId)
          liftIO $ idpOrError `shouldBe` Left (SAML.CustomError $ IdpDbError IdpNotFound)
        do
          midp <- getIdPByIssuer (idp ^. idpMetadata . edIssuer) (idp ^. SAML.idpExtraInfo . team)
          liftIO $ midp `shouldBe` Nothing
        do
          midp <- getIdPByIssuer (idp ^. idpMetadata . edIssuer) (idp ^. SAML.idpExtraInfo . team)
          liftIO $ midp `shouldBe` Nothing
        do
          idps <- runSpar $ IdPEffect.getConfigsByTeam teamid
          liftIO $ idps `shouldBe` []

-- | Test that when a team is deleted, all relevant data is pruned from the
-- Spar database.
testDeleteTeam :: SpecWith TestEnv
testDeleteTeam = it "cleans up all the right tables after deletion" $ do
  -- Create a team with two users and a SCIM token
  (tok, (_uid, tid, idp)) <- registerIdPAndScimToken
  user1 <- randomScimUser
  user2 <- randomScimUser
  storedUser1 <- createUser tok user1
  storedUser2 <- createUser tok user2
  -- Resolve the users' SSO ids
  let getUid = Scim.Common.id . Scim.Meta.thing
  ssoid1 <- getSsoidViaSelf (getUid storedUser1)
  ssoid2 <- getSsoidViaSelf (getUid storedUser2)
  -- Delete the team
  runSpar $ App.deleteTeam tid
  -- See that everything got cleaned up.
  --
  -- The token from 'team_provisioning_by_token':
  do
    tokenInfo <- runSpar $ ScimTokenStore.lookup tok
    liftIO $ tokenInfo `shouldBe` Nothing
  -- The team from 'team_provisioning_by_team':
  do
    tokens <- runSpar $ ScimTokenStore.lookupByTeam tid
    liftIO $ tokens `shouldBe` []
  -- The users from 'user':
  do
    mbUser1 <- case veidFromUserSSOId ssoid1 Nothing of
      Right veid ->
        runSpar $
          runValidScimIdEither
            SAMLUserStore.get
            undefined -- could be @Data.lookupScimExternalId@, but we don't hit that path.
            veid
      Left _email -> undefined -- runSparCass . Data.lookupScimExternalId . fromEmail $ _email
    liftIO $ mbUser1 `shouldBe` Nothing
  do
    mbUser2 <- case veidFromUserSSOId ssoid2 Nothing of
      Right veid ->
        runSpar $
          runValidScimIdEither
            SAMLUserStore.get
            undefined
            veid
      Left _email -> undefined
    liftIO $ mbUser2 `shouldBe` Nothing
  -- The config from 'idp':
  do
    idpOrError <- runSparE $ IdPEffect.getConfig (idp ^. SAML.idpId)
    liftIO $ idpOrError `shouldBe` Left (SAML.CustomError $ IdpDbError IdpNotFound)
  -- The config from 'issuer_idp':
  do
    let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer
    mbIdp <- getIdPByIssuer issuer (idp ^. SAML.idpExtraInfo . team)
    liftIO $ mbIdp `shouldBe` Nothing
  -- The config from 'team_idp':
  do
    idps <- runSpar $ IdPEffect.getConfigsByTeam tid
    liftIO $ idps `shouldBe` []
