{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# 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/>.

-- | This module contains the analog of some of the team-level roles & permissions types in
-- "Wire.API.Team".
module Wire.API.Conversation.Role
  ( -- * Role
    ConversationRole,
    wireConvRoles,
    convRoleWireAdmin,
    convRoleWireMember,
    ConversationRolesList (..),

    -- * RoleName
    RoleName,
    fromRoleName,
    parseRoleName,
    roleNameWireAdmin,
    roleNameWireMember,

    -- * Action
    Action (..),
    SAction (..),
    Actions (..),
    ActionName,
    AddConversationMemberSym0,
    RemoveConversationMemberSym0,
    ModifyConversationNameSym0,
    ModifyConversationMessageTimerSym0,
    ModifyConversationReceiptModeSym0,
    ModifyConversationAccessSym0,
    ModifyOtherConversationMemberSym0,
    LeaveConversationSym0,
    DeleteConversationSym0,
    ModifyAddPermissionSym0,

    -- * helpers
    isValidRoleName,
    roleActions,
    toConvRole,
    ToUserRole (..),
  )
where

import Cassandra.CQL hiding (Set)
import Control.Applicative (optional)
import Control.Lens (at, (?~))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson qualified as A
import Data.Aeson.TH qualified as A
import Data.Attoparsec.Text
import Data.ByteString.Conversion
import Data.Hashable
import Data.Id
import Data.OpenApi qualified as S
import Data.Range (fromRange, genRangeText)
import Data.Schema
import Data.Set qualified as Set
import Data.Singletons.TH
import Deriving.Swagger qualified as S
import GHC.TypeLits
import Imports
import Test.QuickCheck qualified as QC
import Wire.API.PostgresMarshall
import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..))

--------------------------------------------------------------------------------
-- Action

newtype Actions = Actions
  { allowedActions :: Set Action
  }
  deriving stock (Eq, Show, Generic)
  deriving newtype (Arbitrary)

allActions :: Actions
allActions = Actions $ Set.fromList [minBound .. maxBound]

-- | These conversation-level permissions.  Analogous to the team-level permissions called
-- 'Perm' (or 'Permissions').
data Action
  = AddConversationMember
  | RemoveConversationMember
  | ModifyConversationName
  | ModifyConversationMessageTimer
  | ModifyConversationReceiptMode
  | ModifyConversationAccess
  | ModifyOtherConversationMember
  | LeaveConversation
  | DeleteConversation
  | ModifyAddPermission
  deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
  deriving (Arbitrary) via (GenericUniform Action)
  deriving (S.ToSchema) via (S.CustomSwagger '[S.ConstructorTagModifier S.CamelToSnake] Action)

type family ActionName (a :: Action) :: Symbol where
  ActionName 'AddConversationMember = "add_conversation_member"
  ActionName 'RemoveConversationMember = "remove_conversation_member"
  ActionName 'ModifyConversationName = "modify_conversation_name"
  ActionName 'ModifyConversationMessageTimer = "modify_conversation_message_timer"
  ActionName 'ModifyConversationReceiptMode = "modify_conversation_receipt_mode"
  ActionName 'ModifyConversationAccess = "modify_conversation_access"
  ActionName 'ModifyOtherConversationMember = "modify_other_conversation_member"
  ActionName 'LeaveConversation = "leave_conversation"
  ActionName 'DeleteConversation = "delete_conversation"
  ActionName 'ModifyAddPermission = "modify_add_permissions"

A.deriveJSON A.defaultOptions {A.constructorTagModifier = A.camelTo2 '_'} ''Action

$(genSingletons [''Action])

--------------------------------------------------------------------------------
-- Role

-- | A conversation role is associated to a user in the scope of a conversation and implies
-- with a set of 'Action's.  Conversation-level analog to what 'Role' is on the team-level.
--
-- Do not expose the constructors directly,
-- use smart constructors instead to ensure that all validation is performed.
data ConversationRole
  = ConvRoleWireAdmin
  | ConvRoleWireMember
  | ConvRoleCustom RoleName Actions
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform ConversationRole)

instance S.ToSchema ConversationRole where
  declareNamedSchema _ = do
    conversationRoleSchema <-
      S.declareSchemaRef (Proxy @RoleName)
    actionsSchema <- S.declareSchema (Proxy @[Action])
    let convRoleSchema :: S.Schema =
          mempty
            & S.properties . at "conversation_role" ?~ conversationRoleSchema
            & S.properties . at "actions"
              ?~ S.Inline
                ( actionsSchema
                    & description ?~ "The set of actions allowed for this role"
                )
    pure (S.NamedSchema (Just "ConversationRole") convRoleSchema)

instance ToJSON ConversationRole where
  toJSON cr =
    A.object
      [ "conversation_role" A..= roleToRoleName cr,
        "actions" A..= roleActions cr
      ]

roleActions :: ConversationRole -> Set Action
roleActions ConvRoleWireAdmin = allowedActions allActions
roleActions ConvRoleWireMember =
  Set.fromList
    [ LeaveConversation
    ]
roleActions (ConvRoleCustom _ (Actions actions)) = actions

roleToRoleName :: ConversationRole -> RoleName
roleToRoleName ConvRoleWireAdmin = roleNameWireAdmin
roleToRoleName ConvRoleWireMember = roleNameWireMember
roleToRoleName (ConvRoleCustom l _) = l

instance FromJSON ConversationRole where
  parseJSON = A.withObject "conversationRole" $ \o -> do
    role <- o A..: "conversation_role"
    actions <- o A..: "actions"
    case toConvRole role (Just $ Actions actions) of
      Just cr -> pure cr
      Nothing -> fail ("Failed to parse: " ++ show o)

toConvRole :: RoleName -> Maybe Actions -> Maybe ConversationRole
toConvRole (RoleName "wire_admin") _ = Just ConvRoleWireAdmin
toConvRole (RoleName "wire_member") _ = Just ConvRoleWireMember
toConvRole x (Just as) = Just (ConvRoleCustom x as)
toConvRole _ _ = Nothing

wireConvRoles :: [ConversationRole]
wireConvRoles = [ConvRoleWireAdmin, ConvRoleWireMember]

convRoleWireAdmin :: ConversationRole
convRoleWireAdmin = ConvRoleWireAdmin

convRoleWireMember :: ConversationRole
convRoleWireMember = ConvRoleWireMember

data ConversationRolesList = ConversationRolesList
  { convRolesList :: [ConversationRole]
  }
  deriving stock (Eq, Show, Generic)
  deriving (Arbitrary) via (GenericUniform ConversationRolesList)
  deriving (S.ToSchema) via (S.CustomSwagger '[S.FieldLabelModifier (S.LabelMappings '["convRolesList" 'S.:-> "conversation_roles"])] ConversationRolesList)

instance ToJSON ConversationRolesList where
  toJSON (ConversationRolesList r) =
    A.object
      [ "conversation_roles" A..= r
      ]

instance FromJSON ConversationRolesList where
  parseJSON = A.withObject "ConversationRolesList" $ \o ->
    ConversationRolesList
      <$> o A..: "conversation_roles"

--------------------------------------------------------------------------------
-- RoleName

-- RoleNames with `wire_` prefix are reserved
-- and cannot be created by externals. Therefore, never
-- expose this constructor outside of this module.
newtype RoleName = RoleName {fromRoleName :: Text}
  deriving stock (Eq, Ord, Show, Generic)
  deriving newtype (ToByteString, Hashable, Cql, PostgresUnmarshall Text, PostgresMarshall Text)
  deriving (FromJSON, ToJSON, S.ToSchema) via Schema RoleName

instance ToSchema RoleName where
  schema =
    (S.schema . description ?~ desc) $
      RoleName <$> fromRoleName .= text "RoleName"
    where
      desc =
        "Role name, between 2 and 128 chars, 'wire_' prefix \
        \is reserved for roles designed by Wire (i.e., no \
        \custom roles can have the same prefix)"

instance FromByteString RoleName where
  parser = parser >>= maybe (fail "Invalid RoleName") pure . parseRoleName

instance Arbitrary RoleName where
  arbitrary =
    RoleName . fromRange
      <$> genRangeText @2 @128 genChar
    where
      genChar = QC.elements $ ['a' .. 'z'] <> ['0' .. '9'] <> ['_']

roleNameWireAdmin :: RoleName
roleNameWireAdmin = RoleName "wire_admin"

roleNameWireMember :: RoleName
roleNameWireMember = RoleName "wire_member"

parseRoleName :: Text -> Maybe RoleName
parseRoleName t
  | isValidRoleName t = Just (RoleName t)
  | otherwise = Nothing

-- All RoleNames should have 2-128 chars
isValidRoleName :: Text -> Bool
isValidRoleName =
  either (const False) (const True)
    . parseOnly customRoleName
  where
    customRoleName =
      count 2 (satisfy chars)
        *> count 126 (optional (satisfy chars))
        *> endOfInput
    chars = inClass "a-z0-9_"

class ToUserRole a where
  toUserRole :: a -> (UserId, RoleName)

instance ToUserRole (UserId, RoleName) where
  toUserRole x = x

instance ToUserRole UserId where
  toUserRole uid = (uid, roleNameWireAdmin)
