{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
-- 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/>.
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

-- The above pragma is to ignore unused `genSingletons` definitions of promoted
-- constructors

module Wire.API.Team.Permission
  ( -- * Permissions
    Permissions (..),
    newPermissions,
    fullPermissions,
    noPermissions,
    serviceWhitelistPermissions,

    -- * Permissions
    Perm (..),
    SPerm (..),
    permsToInt,
    intToPerms,
    permToInt,
    intToPerm,
  )
where

import Cassandra qualified as Cql
import Control.Error.Util qualified as Err
import Control.Lens ((?~))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Bits (testBit, (.|.))
import Data.OpenApi qualified as S
import Data.Schema
import Data.Set qualified as Set
import Data.Singletons.Base.TH
import Imports
import Test.QuickCheck (oneof)
import Wire.API.Util.Aeson (CustomEncoded (..))
import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..))

--------------------------------------------------------------------------------
-- Permissions

data Permissions = Permissions
  { -- | User's permissions
    self :: Set Perm,
    -- | Permissions this user is allowed to grant others
    copy :: Set Perm
  }
  deriving stock (Eq, Ord, Show, Generic)
  deriving (FromJSON, ToJSON, S.ToSchema) via (Schema Permissions)

permissionsSchema :: ValueSchema NamedSwaggerDoc Permissions
permissionsSchema =
  objectWithDocModifier (description ?~ docs) $
    Permissions
      <$> (permsToInt . self) .= fieldWithDocModifier "self" selfDoc (intToPerms <$> schema)
      <*> (permsToInt . copy) .= fieldWithDocModifier "copy" copyDoc (intToPerms <$> schema)
  where
    selfDoc = S.description ?~ "Permissions that the user has"
    copyDoc = S.description ?~ "Permissions that this user is able to grant others"
    docs =
      "This is just a complicated way of representing a team role.  self and copy \
      \always have to contain the same integer, and only the following integers \
      \are allowed: 1025 (partner), 1587 (member), 5951 (admin), 8191 (owner). \
      \Unit tests of the galley-types package in wire-server contain an authoritative \
      \list."

instance ToSchema Permissions where
  schema = withParser permissionsSchema $ \(Permissions s d) ->
    case newPermissions s d of
      Nothing -> fail "invalid permissions"
      Just ps -> pure ps

instance Arbitrary Permissions where
  arbitrary =
    maybe (error "instance Arbitrary Permissions") pure =<< do
      selfperms <- oneof $ map (pure . intToPerms) [1025, 1587, 5951, 8191]
      copyperms <- Set.intersection selfperms <$> arbitrary
      pure $ newPermissions selfperms copyperms

newPermissions ::
  -- | User's permissions
  Set Perm ->
  -- | Permissions that the user will be able to
  --   grant to other users (must be a subset)
  Set Perm ->
  Maybe Permissions
newPermissions a b
  | b `Set.isSubsetOf` a = Just (Permissions a b)
  | otherwise = Nothing

fullPermissions :: Permissions
fullPermissions = let p = intToPerms maxBound in Permissions p p

noPermissions :: Permissions
noPermissions = Permissions mempty mempty

-- | Permissions that a user needs to be considered a "service whitelist
-- admin" (can add and remove services from the whitelist).
serviceWhitelistPermissions :: Set Perm
serviceWhitelistPermissions =
  Set.fromList
    [ AddTeamMember,
      RemoveTeamMember,
      AddRemoveConvMember,
      SetTeamData
    ]

--------------------------------------------------------------------------------
-- Perm

-- | Team-level permission.  Analog to conversation-level 'Action'.
--
-- If you ever think about adding a new permission flag, read Note
-- [team roles] first.
data Perm
  = CreateConversation
  | -- NOTE: This may get overruled by conv level checks in case those are more restrictive
    -- We currently cannot get rid of this team-level permission in favor of the conv-level action
    -- because it is used for e.g. for the team role 'RoleExternalPartner'
    DeleteConversation
  | AddTeamMember
  | RemoveTeamMember
  | -- NOTE: This may get overruled by conv level checks in case those are more restrictive
    -- We currently cannot get rid of this team-level permission in favor of the conv-level action
    -- because it is used for e.g. for the team role 'RoleExternalPartner'
    AddRemoveConvMember
  | -- NOTE: This may get overruled by conv level checks in case those are more restrictive
    -- We currently cannot get rid of this team-level permission in favor of the conv-level action
    -- because it is used for e.g. for the team role 'RoleExternalPartner'
    ModifyConvName
  | GetBilling
  | SetBilling
  | SetTeamData
  | GetMemberPermissions
  | SetMemberPermissions
  | GetTeamConversations
  | DeleteTeam
  -- FUTUREWORK: make the verbs in the roles more consistent
  -- (CRUD vs. Add,Remove vs; Get,Set vs. Create,Delete etc).
  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
  deriving (Arbitrary) via (GenericUniform Perm)
  deriving (FromJSON, ToJSON) via (CustomEncoded Perm)

instance S.ToSchema Perm

permsToInt :: Set Perm -> Word64
permsToInt = Set.foldr' (\p n -> n .|. permToInt p) 0

intToPerms :: Word64 -> Set Perm
intToPerms n =
  let perms = [2 ^ i | i <- [0 .. 62], n `testBit` i]
   in Set.fromList (mapMaybe intToPerm perms)

permToInt :: Perm -> Word64
permToInt CreateConversation = 0x0001
permToInt DeleteConversation = 0x0002
permToInt AddTeamMember = 0x0004
permToInt RemoveTeamMember = 0x0008
permToInt AddRemoveConvMember = 0x0010
permToInt ModifyConvName = 0x0020
permToInt GetBilling = 0x0040
permToInt SetBilling = 0x0080
permToInt SetTeamData = 0x0100
permToInt GetMemberPermissions = 0x0200
permToInt GetTeamConversations = 0x0400
permToInt DeleteTeam = 0x0800
permToInt SetMemberPermissions = 0x1000

intToPerm :: Word64 -> Maybe Perm
intToPerm 0x0001 = Just CreateConversation
intToPerm 0x0002 = Just DeleteConversation
intToPerm 0x0004 = Just AddTeamMember
intToPerm 0x0008 = Just RemoveTeamMember
intToPerm 0x0010 = Just AddRemoveConvMember
intToPerm 0x0020 = Just ModifyConvName
intToPerm 0x0040 = Just GetBilling
intToPerm 0x0080 = Just SetBilling
intToPerm 0x0100 = Just SetTeamData
intToPerm 0x0200 = Just GetMemberPermissions
intToPerm 0x0400 = Just GetTeamConversations
intToPerm 0x0800 = Just DeleteTeam
intToPerm 0x1000 = Just SetMemberPermissions
intToPerm _ = Nothing

instance Cql.Cql Permissions where
  ctype = Cql.Tagged $ Cql.UdtColumn "permissions" [("self", Cql.BigIntColumn), ("copy", Cql.BigIntColumn)]

  toCql p =
    let f = Cql.CqlBigInt . fromIntegral . permsToInt
     in Cql.CqlUdt [("self", f p.self), ("copy", f p.copy)]

  fromCql (Cql.CqlUdt p) = do
    let f = intToPerms . fromIntegral :: Int64 -> Set.Set Perm
    s <- Err.note "missing 'self' permissions" ("self" `lookup` p) >>= Cql.fromCql
    d <- Err.note "missing 'copy' permissions" ("copy" `lookup` p) >>= Cql.fromCql
    Err.note "invalid permissions" (newPermissions (f s) (f d))
  fromCql _ = Left "permissions: udt expected"

$(genSingletons [''Perm])

$(promoteShowInstances [''Perm])
