Feature/suspend team

libs/cassandra-util/cassandra-util.cabal

@@ -21,6 +21,7 @@ library
       , Cassandra.Exec
       , Cassandra.Schema
       , Cassandra.Settings
+      , Cassandra.Util
 
     build-depends:
         aeson                >= 0.7

libs/cassandra-util/src/Cassandra/Util.hs

@@ -0,0 +1,10 @@
+module Cassandra.Util where
+
+import Data.Time (UTCTime)
+import Data.Time.Clock.POSIX(posixSecondsToUTCTime)
+import Data.Int (Int64)
+
+type Writetime a = Int64
+
+writeTimeToUTC :: Writetime a -> UTCTime
+writeTimeToUTC = posixSecondsToUTCTime . fromIntegral . (`div` 1000000)

libs/galley-types/galley-types.cabal

@@ -22,6 +22,7 @@ library
         Galley.Types.Proto
         Galley.Types.Swagger
         Galley.Types.Teams
+        Galley.Types.Teams.Intra
         Galley.Types.Teams.Swagger
 
     build-depends:

libs/galley-types/src/Galley/Types/Teams.hs

@@ -9,7 +9,6 @@
 module Galley.Types.Teams
     ( Team
     , TeamBinding (..)
-    , TeamStatus (..)
     , newTeam
     , teamId
     , teamCreator
@@ -112,12 +111,6 @@ import Data.Word
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Set as Set
 
-data TeamStatus
-    = Alive
-    | PendingDelete
-    | Deleted
-    deriving (Eq, Show)
-
 data TeamBinding =
       Binding
     | NonBinding

libs/galley-types/src/Galley/Types/Teams/Intra.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Galley.Types.Teams.Intra where
+
+import Data.Aeson
+import Data.Json.Util
+import Data.Monoid
+import Data.Time (UTCTime)
+import Galley.Types.Teams (Team)
+
+data TeamStatus
+    = Active
+    | PendingDelete
+    | Deleted
+    | Suspended
+    deriving (Eq, Show)
+
+instance ToJSON TeamStatus where
+    toJSON Active        = String "active"
+    toJSON PendingDelete = String "pending_delete"
+    toJSON Deleted       = String "deleted"
+    toJSON Suspended     = String "suspended"
+
+instance FromJSON TeamStatus where
+    parseJSON (String "active")         = pure Active
+    parseJSON (String "pending_delete") = pure PendingDelete
+    parseJSON (String "deleted")        = pure Deleted
+    parseJSON (String "suspended")      = pure Suspended
+    parseJSON other                     = fail $ "Unknown TeamStatus: " <> show other
+
+data TeamData = TeamData
+    { tdTeam       :: !Team
+    , tdStatus     :: !TeamStatus
+    , tdStatusTime :: !(Maybe UTCTime) -- This needs to be a Maybe due to backwards compatibility
+    }
+
+instance ToJSON TeamData where
+    toJSON (TeamData t s st) = object
+        $ "team"        .= t
+        # "status"      .= s
+        # "status_time" .= (UTCTimeMillis <$> st)
+        # []
+
+instance FromJSON TeamData where
+    parseJSON = withObject "team-data" $ \o -> do
+        TeamData <$> o .:  "team"
+                 <*> o .:  "status"
+                 <*> o .:? "status_time"
+
+newtype TeamStatusUpdate = TeamStatusUpdate
+    { tuStatus :: TeamStatus }
+
+instance FromJSON TeamStatusUpdate where
+    parseJSON = withObject "team-status-update" $ \o ->
+        TeamStatusUpdate <$> o .: "status"
+
+instance ToJSON TeamStatusUpdate where
+    toJSON s = object ["status" .= tuStatus s]

services/brig/src/Brig/API.hs

@@ -46,6 +46,7 @@ import Network.Wai.Utilities.Swagger (document, mkSwaggerApi)
 import Prelude hiding (head)
 
 import qualified Data.Text.Ascii               as Ascii
+import qualified Data.List1                    as List1
 import qualified Control.Concurrent.Async      as Async
 import qualified Brig.API.Client               as API
 import qualified Brig.API.Connection           as API
@@ -1219,7 +1220,7 @@ updateUser (_ ::: uid ::: conn ::: req) = do
 changeAccountStatus :: JSON ::: UserId ::: Request -> Handler Response
 changeAccountStatus (_ ::: usr ::: req) = do
     status <- suStatus <$> parseJsonBody req
-    API.changeAccountStatus usr status !>> accountStatusError
+    API.changeAccountStatus (List1.singleton usr) status !>> accountStatusError
     return empty
 
 getAccountStatus :: JSON ::: UserId -> Handler Response

services/brig/src/Brig/API/Error.hs

@@ -330,6 +330,9 @@ incorrectPermissions = Wai.Error status403 "invalid-permissions" "Copy permissio
 insufficientTeamPermissions :: Wai.Error
 insufficientTeamPermissions = Wai.Error status403 "insufficient-permissions" "Insufficient team permissions"
 
+noBindingTeam :: Wai.Error
+noBindingTeam = Wai.Error status403 "no-binding-team" "Operation allowed only on binding teams"
+
 loginsTooFrequent :: Wai.Error
 loginsTooFrequent = Wai.Error status429 "client-error" "Logins too frequent"
 

services/brig/src/Brig/API/User.hs

@@ -79,16 +79,18 @@ import Brig.User.Handle.Blacklist
 import Brig.User.Phone
 import Control.Applicative ((<|>))
 import Control.Arrow ((&&&))
+import Control.Concurrent.Async (mapConcurrently, mapConcurrently_)
 import Control.Error
 import Control.Lens (view)
 import Control.Monad (mfilter, when, unless, void, join)
 import Control.Monad.Catch
 import Control.Monad.IO.Class
-import Control.Monad.Trans.Class
+import Control.Monad.Reader
 import Data.ByteString.Conversion
 import Data.Foldable
 import Data.Id
 import Data.List (nub)
+import Data.List1 (List1)
 import Data.Misc (PlainTextPassword (..))
 import Data.Traversable (for)
 import Network.Wai.Utilities
@@ -416,14 +418,19 @@ revokeIdentity key = do
 -------------------------------------------------------------------------------
 -- Change Account Status
 
-changeAccountStatus :: UserId -> AccountStatus -> ExceptT AccountStatusError AppIO ()
-changeAccountStatus usr status = do
+changeAccountStatus :: List1 UserId -> AccountStatus -> ExceptT AccountStatusError AppIO ()
+changeAccountStatus usrs status = do
+    e <- ask
     ev <- case status of
-        Active    -> return (UserResumed usr)
-        Suspended -> lift $ revokeAllCookies usr >> return (UserSuspended usr)
+        Active    -> return UserResumed
+        Suspended -> liftIO $ mapConcurrently (runAppT e . revokeAllCookies) usrs >> return UserSuspended
         Deleted   -> throwE InvalidAccountStatus
-    lift $ Data.updateStatus usr status
-    lift $ Intra.onUserEvent usr Nothing ev
+    liftIO $ mapConcurrently_ (runAppT e . (update ev)) usrs
+  where
+    update :: (UserId -> UserEvent) -> UserId -> AppIO ()
+    update ev u = do
+        Data.updateStatus u status
+        Intra.onUserEvent u Nothing (ev u)
 
 -------------------------------------------------------------------------------
 -- Activation

services/brig/src/Brig/IO/Intra.hs

@@ -34,7 +34,9 @@ module Brig.IO.Intra
     , addTeamMember
     , createTeam
     , getTeamMember
+    , getTeamMembers
     , getTeam
+    , changeTeamStatus
     ) where
 
 import Bilge hiding (head, options, requestId)
@@ -74,6 +76,7 @@ import qualified Data.HashMap.Strict         as M
 import qualified Data.Set                    as Set
 import qualified Gundeck.Types.Push.V2       as Push
 import qualified Galley.Types.Teams          as Team
+import qualified Galley.Types.Teams.Intra    as Team
 
 -----------------------------------------------------------------------------
 -- Event Handlers
@@ -529,12 +532,29 @@ getTeamMember u tid = do
         . zUser u
         . expect [status200, status404]
 
-getTeam :: UserId -> TeamId -> AppIO Team.Team
-getTeam u tid = do
-    debug $ remote "galley"
-            . msg (val "Get team info")
+getTeamMembers :: TeamId -> AppIO Team.TeamMemberList
+getTeamMembers tid = do
+    debug $ remote "galley" . msg (val "Get team members")
     galleyRequest GET req >>= decodeBody "galley"
   where
-    req = paths ["teams", toByteString' tid]
-        . zUser u
+    req = paths ["i", "teams", toByteString' tid, "members"]
+        . expect2xx
+
+getTeam :: TeamId -> AppIO Team.TeamData
+getTeam tid = do
+    debug $ remote "galley" . msg (val "Get team info")
+    galleyRequest GET req >>= decodeBody "galley"
+  where
+    req = paths ["i", "teams", toByteString' tid]
+        . expect2xx
+
+changeTeamStatus :: TeamId -> Team.TeamStatus -> AppIO ()
+changeTeamStatus tid s = do
+    debug $ remote "galley"
+            . msg (val "Change Team status")
+    void $ galleyRequest PUT req
+  where
+    req = paths ["i", "teams", toByteString' tid, "status"]
+        . header "Content-Type" "application/json"
         . expect2xx
+        . lbytes (encode $ Team.TeamStatusUpdate s)

services/brig/src/Brig/Team/API.hs

@@ -16,10 +16,12 @@ import Brig.Email
 import Brig.Team.Email
 import Brig.Types.Team.Invitation
 import Brig.Types.User (InvitationCode)
+import Brig.Types.Intra (AccountStatus (..))
 import Control.Error
 import Control.Lens (view, (^.))
 import Control.Monad (when, void, unless)
 import Control.Monad.Trans
+import Control.Monad.Reader
 import Data.Aeson hiding (json)
 import Data.ByteString.Conversion
 import Data.Id
@@ -29,19 +31,22 @@ import Data.Range
 import Network.HTTP.Types.Status
 import Network.Wai (Request, Response)
 import Network.Wai.Predicate hiding (setStatus, result, and)
-import Network.Wai.Routing
+import Network.Wai.Routing hiding (head)
 import Network.Wai.Utilities hiding (message, code)
 import Network.Wai.Utilities.Swagger (document)
-import Prelude hiding (head)
+import Prelude
 
+import qualified Brig.API.User                 as API
 import qualified Brig.Blacklist                as Blacklist
 import qualified Brig.Data.UserKey             as Data
 import qualified Brig.Team.DB                  as DB
 import qualified Brig.Types.Swagger            as Doc
 import qualified Network.Wai.Utilities.Swagger as Doc
+import qualified Data.List1                    as List1
 import qualified Data.Swagger.Build.Api        as Doc
 import qualified Brig.IO.Intra                 as Intra
 import qualified Galley.Types.Teams            as Team
+import qualified Galley.Types.Teams.Intra      as Team
 
 routes :: Routes Doc.ApiBuilder Handler ()
 routes = do
@@ -132,11 +137,21 @@ routes = do
         Doc.response 200 "Invitation successful." Doc.end
         Doc.errorResponse invalidInvitationCode
 
+    --- Internal
+
     get "/i/teams/invitation-code" (continue getInvitationCode) $
         accept "application" "json"
         .&. param "team"
         .&. param "invitation_id"
 
+    post "/i/teams/:tid/suspend" (continue suspendTeam) $
+        accept "application" "json"
+        .&. capture "tid"
+
+    post "/i/teams/:tid/unsuspend" (continue unsuspendTeam) $
+        accept "application" "json"
+        .&. capture "tid"
+
 getInvitationCode :: JSON ::: TeamId ::: InvitationId -> Handler Response
 getInvitationCode (_ ::: t ::: r) = do
     code <- lift $ DB.lookupInvitationCode t r
@@ -162,7 +177,7 @@ createInvitation (_ ::: uid ::: _ ::: tid ::: req) = do
         Nothing -> doInvite email (irName body) (irLocale body)
   where
     doInvite email nm lc = lift $ do
-        team <- Intra.getTeam uid tid
+        team <- Team.tdTeam <$> Intra.getTeam tid
         now  <- liftIO =<< view currentTime
         (newInv, code) <- DB.insertInvitation tid email now
         void $ sendInvitationMail email tid nm (team^.Team.teamName) code lc
@@ -196,9 +211,33 @@ getInvitationByCode (_ ::: c) = do
     inv <- lift $ DB.lookupInvitationByCode c
     maybe (throwStd invalidInvitationCode) (return . json) inv
 
+suspendTeam :: JSON ::: TeamId -> Handler Response
+suspendTeam (_ ::: tid) = do
+    changeTeamAccountStatuses tid Suspended
+    DB.deleteInvitations tid
+    lift $ Intra.changeTeamStatus tid Team.Suspended
+    return empty
+
+unsuspendTeam :: JSON ::: TeamId -> Handler Response
+unsuspendTeam (_ ::: tid) = do
+    changeTeamAccountStatuses tid Active
+    lift $ Intra.changeTeamStatus tid Team.Active
+    return empty
+
 -------------------------------------------------------------------------------
 -- Internal
 
+changeTeamAccountStatuses :: TeamId -> AccountStatus -> Handler ()
+changeTeamAccountStatuses tid s = do
+    team <- Team.tdTeam <$> (lift $ Intra.getTeam tid)
+    unless (team^.Team.teamBinding == Team.Binding) $
+        throwStd noBindingTeam
+    uids <- toList1 =<< lift (fmap (view Team.userId) . view Team.teamMembers <$> Intra.getTeamMembers tid)
+    API.changeAccountStatus uids s !>> accountStatusError
+  where
+    toList1 (x:xs) = return $ List1.list1 x xs
+    toList1 []     = throwStd (notFound "Team not found or no members")
+
 ensurePermissions :: UserId -> TeamId -> [Team.Perm] -> Handler ()
 ensurePermissions u t perms = do
     m <- lift $ Intra.getTeamMember u t

services/brig/src/Brig/Team/DB.hs

@@ -8,6 +8,7 @@ module Brig.Team.DB
     ( module T
     , insertInvitation
     , deleteInvitation
+    , deleteInvitations
     , lookupInvitation
     , lookupInvitationCode
     , lookupInvitations
@@ -26,8 +27,10 @@ import Brig.Types.Common
 import Brig.Types.User
 import Brig.Types.Team.Invitation
 import Cassandra
+import Control.Concurrent.Async.Lifted.Safe (mapConcurrently_)
 import Control.Lens
 import Control.Monad.IO.Class
+import Control.Monad (when)
 import Data.Id
 import Data.Int
 import Data.Range
@@ -97,7 +100,7 @@ lookupInvitations team start (fromRange -> size) = do
                                                          , hasMore = more
                                                          }
     cqlSelect :: PrepQuery R (Identity TeamId) (TeamId, InvitationId, Email, UTCTime)
-    cqlSelect = "SELECT team, id, email, created_at FROM team_invitation WHERE team = ?"
+    cqlSelect = "SELECT team, id, email, created_at FROM team_invitation WHERE team = ? ORDER BY id ASC"
 
     cqlSelectFrom :: PrepQuery R (TeamId, InvitationId) (TeamId, InvitationId, Email, UTCTime)
     cqlSelectFrom = "SELECT team, id, email, created_at FROM team_invitation WHERE team = ? AND id > ? ORDER BY id ASC"
@@ -120,6 +123,19 @@ deleteInvitation t i = do
     cqlInvitationInfo :: PrepQuery W (Identity InvitationCode) ()
     cqlInvitationInfo = "DELETE FROM team_invitation_info WHERE code = ?"
 
+deleteInvitations :: MonadClient m => TeamId -> m ()
+deleteInvitations t = do
+    page <- retry x1 $ paginate cqlSelect (paramsP Quorum (Identity t) 100)
+    deleteAll page
+  where
+    deleteAll page = do
+        liftClient $ mapConcurrently_ (deleteInvitation t . runIdentity) (result page)
+        when (hasMore page) $
+            liftClient (nextPage page) >>= deleteAll
+
+    cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId)
+    cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC"
+
 lookupInvitationInfo :: MonadClient m => InvitationCode -> m (Maybe InvitationInfo)
 lookupInvitationInfo ic@(InvitationCode c)
     | c == mempty = return Nothing