diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 00000000000..ad6303e32d4 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,15 @@ +# We need quasi quotes support. +- arguments: [ -XQuasiQuotes, --color ] +# Used to enforce ormolu styling. Can be revisited if we change formatters. +- ignore: { name: Redundant $ } +- ignore: { name: Redundant do } +- ignore: { name: Use newtype instead of data } +# +# Left for the programmer to decide. See discussion at https://github.com/wireapp/wire-server/pull/2382#discussion_r871194424 +- ignore: { name: Avoid lambda } +- ignore: { name: Avoid lambda using `infix` } + +- ignore: { name: Use section } +# custom rules: +- hint: { lhs: (() <$), rhs: void } +- hint: { lhs: return, rhs: pure } diff --git a/Makefile b/Makefile index f32542ca2d1..8ccab6b4837 100644 --- a/Makefile +++ b/Makefile @@ -79,7 +79,7 @@ ci: c # pass target=package:name to specify which target is watched. .PHONY: ghcid ghcid: - ghcid --command "cabal repl $(target)" + ghcid -l=hlint --command "cabal repl $(target)" # reset db using cabal .PHONY: db-reset-package diff --git a/nix/default.nix b/nix/default.nix index 28c3925e498..708ab87a420 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -80,6 +80,7 @@ let pkgs.gnused pkgs.helm pkgs.helmfile + pkgs.hlint pkgs.jq pkgs.kind pkgs.kubectl diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index 70316144196..c4d4859a38d 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -50,7 +50,7 @@ getClients usr = do if isInternal then fromUserClients <$> E.lookupClients [usr] else E.getClients [usr] - return $ clientIds usr clts + pure (clientIds usr clts) addClientH :: Member ClientStore r => @@ -58,7 +58,7 @@ addClientH :: Sem r Response addClientH (usr ::: clt) = do E.createClient usr clt - return empty + pure empty rmClientH :: Member ClientStore r => @@ -66,4 +66,4 @@ rmClientH :: Sem r Response rmClientH (usr ::: clt) = do E.deleteClient usr clt - return empty + pure empty diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index c7b3933743c..d3148350e93 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -426,35 +426,34 @@ createConnectConversation lusr conn j = do update n conv = do let mems = Data.convLocalMembers conv in conversationExisted lusr - =<< if - | (tUnqualified lusr) `isMember` mems -> - -- we already were in the conversation, maybe also other - connect n conv - | otherwise -> do - let lcid = qualifyAs lusr (Data.convId conv) - mm <- E.createMember lcid lusr - let conv' = - conv - { Data.convLocalMembers = Data.convLocalMembers conv <> toList mm - } - if null mems - then do - -- the conversation was empty - connect n conv' - else do - -- we were not in the conversation, but someone else - conv'' <- acceptOne2One lusr conv' conn - if Data.convType conv'' == ConnectConv - then connect n conv'' - else return conv'' + =<< if tUnqualified lusr `isMember` mems + then -- we already were in the conversation, maybe also other + connect n conv + else do + let lcid = qualifyAs lusr (Data.convId conv) + mm <- E.createMember lcid lusr + let conv' = + conv + { Data.convLocalMembers = Data.convLocalMembers conv <> toList mm + } + if null mems + then do + -- the conversation was empty + connect n conv' + else do + -- we were not in the conversation, but someone else + conv'' <- acceptOne2One lusr conv' conn + if Data.convType conv'' == ConnectConv + then connect n conv'' + else pure conv'' connect n conv | Data.convType conv == ConnectConv = do let lcnv = qualifyAs lusr (Data.convId conv) n' <- case n of Just x -> do E.setConversationName (Data.convId conv) x - return . Just $ fromRange x - Nothing -> return $ Data.convName conv + pure . Just $ fromRange x + Nothing -> pure $ Data.convName conv t <- input let e = Event (qUntagged lcnv) (qUntagged lusr) t (EdConnect j) for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> Data.convLocalMembers conv)) $ \p -> @@ -463,7 +462,7 @@ createConnectConversation lusr conn j = do & pushRoute .~ RouteDirect & pushConn .~ conn pure $ Data.convSetName n' conv - | otherwise = return conv + | otherwise = pure conv -------------------------------------------------------------------------------- -- Conversation creation records @@ -525,7 +524,7 @@ notifyCreatedConversation :: Data.Conversation -> Sem r () notifyCreatedConversation dtime lusr conn c = do - now <- maybe (input) pure dtime + now <- maybe input pure dtime -- FUTUREWORK: Handle failures in notifying so it does not abort half way -- through (either when notifying remotes or locals) -- @@ -542,7 +541,7 @@ notifyCreatedConversation dtime lusr conn c = do let lconv = qualifyAs lusr (Data.convId c) c' <- conversationView (qualifyAs lusr (lmId m)) c let e = Event (qUntagged lconv) (qUntagged lusr) t (EdConversation c') - return $ + pure $ newPushLocal1 ListComplete (tUnqualified lusr) (ConvEvent e) (list1 (recipient m) []) & pushConn .~ conn & pushRoute .~ route @@ -564,7 +563,7 @@ toUUIDs :: toUUIDs a b = do a' <- U.fromUUID (toUUID a) & note InvalidUUID4 b' <- U.fromUUID (toUUID b) & note InvalidUUID4 - return (a', b') + pure (a', b') accessRoles :: NewConv -> Set AccessRoleV2 accessRoles b = fromMaybe Data.defRole (newConvAccessRoles b) diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index bbfd6642e85..ec07ebd1fb5 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -299,7 +299,6 @@ leaveConversation requestingDomain lc = do _event <- notifyConversationAction SConversationLeaveTag (qUntagged leaver) Nothing lcnv botsAndMembers action pure $ F.LeaveConversationResponse (Right ()) - where -- FUTUREWORK: report errors to the originating backend -- FUTUREWORK: error handling for missing / mismatched clients diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index f4fdf6f6913..c267fc28462 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -443,7 +443,7 @@ featureAPI = internalSitemap :: Routes a (Sem GalleyEffects) () internalSitemap = do -- Conversation API (internal) ---------------------------------------- - put "/i/conversations/:cnv/channel" (continue $ const (return empty)) $ + put "/i/conversations/:cnv/channel" (continue $ const (pure empty)) $ zauthUserId .&. (capture "cnv" :: HasCaptures r => Predicate r Predicate.Error ConvId) .&. request @@ -581,7 +581,7 @@ rmUser lusr conn = do cc <- getConversations ids now <- input pp <- for cc $ \c -> case Data.convType c of - SelfConv -> return Nothing + SelfConv -> pure Nothing One2OneConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing ConnectConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing RegularConv @@ -598,7 +598,7 @@ rmUser lusr conn = do Intra.newPushLocal ListComplete (tUnqualified lusr) (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) <&> set Intra.pushConn conn . set Intra.pushRoute Intra.RouteDirect - | otherwise -> return Nothing + | otherwise -> pure Nothing for_ (maybeList1 (catMaybes pp)) diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index dc7af811cd0..8e7823ee6e4 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -105,7 +105,7 @@ isLegalHoldEnabledForTeam tid = do FeatureLegalHoldDisabledByDefault -> do statusValue <- Public.tfwoStatus <$$> TeamFeatures.getFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid - return $ case statusValue of + pure $ case statusValue of Just Public.TeamFeatureEnabled -> True Just Public.TeamFeatureDisabled -> False Nothing -> False @@ -471,7 +471,7 @@ requestDevice lzusr tid uid = do LegalHoldData.dropPendingPrekeys (tUnqualified luid) lhDevice <- LHService.requestNewDevice tid (tUnqualified luid) let NewLegalHoldClient prekeys lastKey = lhDevice - return (lastKey, prekeys) + pure (lastKey, prekeys) -- | Approve the adding of a Legal Hold device to the user. -- diff --git a/services/galley/src/Galley/API/Mapping.hs b/services/galley/src/Galley/API/Mapping.hs index aae65f2de30..3481feb6f67 100644 --- a/services/galley/src/Galley/API/Mapping.hs +++ b/services/galley/src/Galley/API/Mapping.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -39,7 +37,7 @@ import Polysemy import Polysemy.Error import qualified Polysemy.TinyLog as P import System.Logger.Message (msg, val, (+++)) -import Wire.API.Conversation hiding (Member (..)) +import Wire.API.Conversation import qualified Wire.API.Conversation as Conversation import Wire.API.Federation.API.Galley diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 1a120160008..3c795bfcdef 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -195,12 +195,12 @@ filterMissing :: HasQuery r => Predicate r P.Error Public.OtrFilterMissing filterMissing = (>>= go) <$> (query "ignore_missing" ||| query "report_missing") where go (Left ign) = case fromByteString ign of - Just True -> return Public.OtrIgnoreAllMissing - Just False -> return Public.OtrReportAllMissing + Just True -> pure Public.OtrIgnoreAllMissing + Just False -> pure Public.OtrReportAllMissing Nothing -> Public.OtrIgnoreMissing <$> users "ignore_missing" ign go (Right rep) = case fromByteString rep of - Just True -> return Public.OtrReportAllMissing - Just False -> return Public.OtrIgnoreAllMissing + Just True -> pure Public.OtrReportAllMissing + Just False -> pure Public.OtrIgnoreAllMissing Nothing -> Public.OtrReportMissing <$> users "report_missing" rep users :: ByteString -> ByteString -> P.Result P.Error (Set UserId) users src bs = case fromByteString bs of diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index dbd6cf86a24..9ea2ca16b6e 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -381,7 +381,7 @@ getConversationsInternal luser mids mstart msize = do let localConvIds = ids cs <- E.getConversations localConvIds - >>= filterM (removeDeleted) + >>= filterM removeDeleted >>= filterM (pure . isMember (tUnqualified luser) . Data.convLocalMembers) pure $ Public.ConversationList cs more where diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 7fcb2e29e83..dfd9ed97f93 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -14,6 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# LANGUAGE LambdaCase #-} module Galley.API.Teams ( createBindingTeam, @@ -293,11 +294,11 @@ updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do journal _ _ = throwS @'InvalidTeamStatusUpdate validateTransition :: Member (ErrorS 'InvalidTeamStatusUpdate) r => (TeamStatus, TeamStatus) -> Sem r Bool validateTransition = \case - (PendingActive, Active) -> return True - (Active, Active) -> return False - (Active, Suspended) -> return True - (Suspended, Active) -> return True - (Suspended, Suspended) -> return False + (PendingActive, Active) -> pure True + (Active, Active) -> pure False + (Active, Suspended) -> pure True + (Suspended, Active) -> pure True + (Suspended, Suspended) -> pure False (_, _) -> throwS @'InvalidTeamStatusUpdate updateTeamH :: @@ -326,7 +327,7 @@ updateTeamH zusr zcon tid updateData = do memList <- getTeamMembersForFanout tid let e = newEvent tid now (EdTeamUpdate updateData) let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) - E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon + E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn ?~ zcon deleteTeam :: forall r. @@ -357,7 +358,7 @@ deleteTeam zusr zcon tid body = do where checkPermissions team = do void $ permissionCheck DeleteTeam =<< E.getTeamMember tid zusr - when ((tdTeam team) ^. teamBinding == Binding) $ do + when (tdTeam team ^. teamBinding == Binding) $ do ensureReAuthorised zusr (body ^. tdAuthPassword) (body ^. tdVerificationCode) (Just U.DeleteTeam) -- This can be called by stern @@ -438,8 +439,8 @@ uncheckedDeleteTeam lusr zcon tid = do -- To avoid DoS on gundeck, send team deletion events in chunks let chunkSize = fromMaybe defConcurrentDeletionEvents (o ^. setConcurrentDeletionEvents) let chunks = List.chunksOf chunkSize (toList r) - forM_ chunks $ \chunk -> case chunk of - [] -> return () + forM_ chunks $ \case + [] -> pure () -- push TeamDelete events. Note that despite having a complete list, we are guaranteed in the -- push module to never fan this out to more than the limit x : xs -> E.push1 (newPushLocal1 ListComplete (tUnqualified lusr) (TeamEvent e) (list1 x xs) & pushConn .~ zcon) @@ -652,7 +653,7 @@ uncheckedGetTeamMembers :: TeamId -> Range 1 HardTruncationLimit Int32 -> Sem r TeamMemberList -uncheckedGetTeamMembers tid maxResults = E.getTeamMembersWithLimit tid maxResults +uncheckedGetTeamMembers = E.getTeamMembersWithLimit addTeamMember :: Members @@ -812,7 +813,7 @@ updateTeamMember lzusr zcon tid newMember = do let ePriv = newEvent tid now privilegedUpdate -- push to all members (user is privileged) let pushPriv = newPushLocal (updatedMembers ^. teamMemberListType) zusr (TeamEvent ePriv) $ privilegedRecipients - for_ pushPriv $ \p -> E.push1 $ p & pushConn .~ Just zcon + for_ pushPriv $ \p -> E.push1 $ p & pushConn ?~ zcon deleteTeamMember :: Members @@ -1130,7 +1131,7 @@ ensureUnboundUsers uids = do -- can only be part of one team. teams <- Map.elems <$> E.getUsersTeams uids binds <- E.getTeamsBindings teams - when (any (== Binding) binds) $ + when (Binding `elem` binds) $ throwS @'UserBindingExists ensureNonBindingTeam :: @@ -1139,7 +1140,7 @@ ensureNonBindingTeam :: Sem r () ensureNonBindingTeam tid = do team <- noteS @'TeamNotFound =<< E.getTeam tid - when ((tdTeam team) ^. teamBinding == Binding) $ + when (tdTeam team ^. teamBinding == Binding) $ throwS @'NoAddToBinding -- ensure that the permissions are not "greater" than the user's copy permissions @@ -1161,7 +1162,7 @@ ensureNotTooLarge tid = do (TeamSize size) <- E.getSize tid unless (size < fromIntegral (o ^. optSettings . setMaxTeamSize)) $ throwS @'TooManyTeamMembers - return $ TeamSize size + pure $ TeamSize size -- | Ensure that a team doesn't exceed the member count limit for the LegalHold -- feature. A team with more members than the fanout limit is too large, because @@ -1239,7 +1240,7 @@ addTeamMemberInternal tid origin originConn (ntmNewTeamMember -> new) memList = E.push1 $ newPushLocal1 (memList ^. teamMemberListType) (new ^. userId) (TeamEvent e) (recipients origin new) & pushConn .~ originConn APITeamQueue.pushTeamEvent tid e - return sizeBeforeAdd + pure sizeBeforeAdd where recipients (Just o) n = list1 diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 2f8e6323371..060eeac7415 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -{-# LANGUAGE RecordWildCards #-} module Galley.API.Teams.Features ( getFeatureStatus, diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index e6d2c03d42e..c0f08564b53 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -413,8 +413,7 @@ updateConversationReceiptModeUnqualified :: ConvId -> ConversationReceiptModeUpdate -> Sem r (UpdateResult Event) -updateConversationReceiptModeUnqualified lusr zcon cnv update = - updateConversationReceiptMode lusr zcon (qUntagged (qualifyAs lusr cnv)) update +updateConversationReceiptModeUnqualified lusr zcon cnv = updateConversationReceiptMode lusr zcon (qUntagged (qualifyAs lusr cnv)) updateConversationMessageTimer :: Members @@ -460,8 +459,7 @@ updateConversationMessageTimerUnqualified :: ConvId -> ConversationMessageTimerUpdate -> Sem r (UpdateResult Event) -updateConversationMessageTimerUnqualified lusr zcon cnv update = - updateConversationMessageTimer lusr zcon (qUntagged (qualifyAs lusr cnv)) update +updateConversationMessageTimerUnqualified lusr zcon cnv = updateConversationMessageTimer lusr zcon (qUntagged (qualifyAs lusr cnv)) deleteLocalConversation :: Members @@ -1086,7 +1084,7 @@ removeMemberFromRemoteConv cnv lusr victim | qUntagged lusr == victim = do let lc = LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) let rpc = fedClient @'Galley @"leave-conversation" lc - (either handleError handleSuccess =<<) . fmap leaveResponse $ + (either handleError handleSuccess . leaveResponse =<<) $ E.runFederated cnv rpc | otherwise = throwS @('ActionDenied 'RemoveConversationMember) where @@ -1195,7 +1193,7 @@ postProteusBroadcast :: ConnId -> QualifiedNewOtrMessage -> Sem r (PostOtrResponse MessageSendingStatus) -postProteusBroadcast sender zcon msg = postBroadcast sender (Just zcon) msg +postProteusBroadcast sender zcon = postBroadcast sender (Just zcon) unqualifyEndpoint :: Functor f => @@ -1435,7 +1433,7 @@ addServiceH :: Sem r Response addServiceH req = do E.createService =<< fromJsonBody req - return empty + pure empty rmServiceH :: Members '[ServiceStore, WaiRoutes] r => @@ -1443,7 +1441,7 @@ rmServiceH :: Sem r Response rmServiceH req = do E.deleteService =<< fromJsonBody req - return empty + pure empty addBotH :: Members @@ -1526,7 +1524,7 @@ addBot lusr zcon b = do unless (any ((== b ^. addBotId) . botMemId) bots) $ do let botId = qualifyAs lusr (botUserId (b ^. addBotId)) ensureMemberLimit (toList $ Data.convLocalMembers c) [qUntagged botId] - return (bots, users) + pure (bots, users) rmBotH :: Members diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index f50bce8dca7..edfcde581e0 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -- This file is part of the Wire Server implementation. @@ -219,7 +218,7 @@ permissionCheckS :: permissionCheckS p = \case Just m -> do - if m `hasPermission` (fromSing p) + if m `hasPermission` fromSing p then pure m else throwS @(PermError p) -- FUTUREWORK: factor `noteS` out of this function. @@ -253,7 +252,7 @@ assertOnTeam :: Members '[ErrorS 'NotATeamMember, TeamStore] r => UserId -> Team assertOnTeam uid tid = getTeamMember tid uid >>= \case Nothing -> throwS @'NotATeamMember - Just _ -> return () + Just _ -> pure () -- | Try to accept a 1-1 conversation, promoting connect conversations as appropriate. acceptOne2One :: @@ -277,10 +276,10 @@ acceptOne2One lusr conv conn = do case Data.convType conv of One2OneConv -> if tUnqualified lusr `isMember` mems - then return conv + then pure conv else do mm <- createMember lcid lusr - return $ conv {Data.convLocalMembers = mems <> toList mm} + pure conv {Data.convLocalMembers = mems <> toList mm} ConnectConv -> case mems of [_, _] | tUnqualified lusr `isMember` mems -> promote [_, _] -> throwS @'ConvNotFound @@ -294,7 +293,7 @@ acceptOne2One lusr conv conn = do let mems' = mems <> toList mm for_ (newPushLocal ListComplete (tUnqualified lusr) (ConvEvent e) (recipient <$> mems')) $ \p -> push1 $ p & pushConn .~ conn & pushRoute .~ RouteDirect - return $ conv' {Data.convLocalMembers = mems'} + pure conv' {Data.convLocalMembers = mems'} _ -> throwS @'InvalidOperation where cid = Data.convId conv @@ -457,8 +456,7 @@ getSelfMemberFromLocals :: UserId -> t LocalMember -> Sem r LocalMember -getSelfMemberFromLocals usr lmems = - getMember @'ConvNotFound lmId usr lmems +getSelfMemberFromLocals = getMember @'ConvNotFound lmId -- | Throw 'ConvMemberNotFound' if the given user is not part of a -- conversation (either locally or remotely). @@ -558,7 +556,7 @@ verifyReusableCode convCode = do >>= noteS @'CodeNotFound unless (DataTypes.codeValue c == conversationCode convCode) $ throwS @'CodeNotFound - return c + pure c ensureConversationAccess :: Members @@ -794,7 +792,7 @@ allLegalholdConsentGiven uids = do -- conversation with user under legalhold. flip allM (chunksOf 32 uids) $ \uidsPage -> do teamsPage <- nub . Map.elems <$> getUsersTeams uidsPage - allM (isTeamLegalholdWhitelisted) teamsPage + allM isTeamLegalholdWhitelisted teamsPage -- | Add to every uid the legalhold status getLHStatusForUsers :: @@ -803,11 +801,13 @@ getLHStatusForUsers :: Sem r [(UserId, UserLegalHoldStatus)] getLHStatusForUsers uids = mconcat - <$> ( for (chunksOf 32 uids) $ \uidsChunk -> do - teamsOfUsers <- getUsersTeams uidsChunk - for uidsChunk $ \uid -> do - (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid - ) + <$> for + (chunksOf 32 uids) + ( \uidsChunk -> do + teamsOfUsers <- getUsersTeams uidsChunk + for uidsChunk $ \uid -> do + (uid,) <$> getLHStatus (Map.lookup uid teamsOfUsers) uid + ) getTeamMembersForFanout :: Member TeamStore r => TeamId -> Sem r TeamMemberList getTeamMembersForFanout tid = do diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 72a221a3e7c..868bd15e3d2 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -152,7 +152,7 @@ createEnv m o = do Env def m o l mgr (o ^. optFederator) (o ^. optBrig) cass <$> Q.new 16000 <*> initExtEnv - <*> maybe (return Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. optJournal) + <*> maybe (pure Nothing) (fmap Just . Aws.mkEnv l mgr) (o ^. optJournal) initCassandra :: Opts -> Logger -> IO ClientState initCassandra o l = do @@ -214,7 +214,7 @@ interpretErrorToException :: (err -> exc) -> Sem (Error err ': r) a -> Sem r a -interpretErrorToException f = (either (embed @IO . UnliftIO.throwIO . f) pure =<<) . runError +interpretErrorToException f = either (embed @IO . UnliftIO.throwIO . f) pure <=< runError interpretWaiErrorToException :: (APIError e, Member (Embed IO) r) => diff --git a/services/galley/src/Galley/Aws.hs b/services/galley/src/Galley/Aws.hs index d5d9b81e1e5..149ebf6ad6e 100644 --- a/services/galley/src/Galley/Aws.hs +++ b/services/galley/src/Galley/Aws.hs @@ -103,7 +103,7 @@ mkEnv lgr mgr opts = do let g = Logger.clone (Just "aws.galley") lgr e <- mkAwsEnv g q <- getQueueUrl e (opts ^. awsQueueName) - return (Env e g q) + pure (Env e g q) where sqs e = AWS.setEndpoint (e ^. awsSecure) (e ^. awsHost) (e ^. awsPort) SQS.defaultService mkAwsEnv g = do @@ -153,7 +153,7 @@ mkEnv lgr mgr opts = do AWS.send e (SQS.newGetQueueUrl q) either (throwM . GeneralError) - (return . QueueUrl . view SQS.getQueueUrlResponse_queueUrl) + (pure . QueueUrl . view SQS.getQueueUrlResponse_queueUrl) x execute :: MonadIO m => Env -> Amazon a -> m a @@ -165,7 +165,7 @@ enqueue e = do rnd <- liftIO nextRandom amaznkaEnv <- view awsEnv res <- retrying (limitRetries 5 <> exponentialBackoff 1000000) (const canRetry) $ const (sendCatch amaznkaEnv (req url rnd)) - either (throwM . GeneralError) (const (return ())) res + either (throwM . GeneralError) (const (pure ())) res where event = decodeLatin1 $ B64.encode $ encodeMessage e req url dedup = diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index fc61117427e..d806b2e4921 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -190,9 +190,10 @@ localConversations :: [ConvId] -> Sem r [Conversation] localConversations = - (collectAndLog =<<) - . embedClient - . UnliftIO.pooledMapConcurrentlyN 8 localConversation' + collectAndLog + <=< ( embedClient + . UnliftIO.pooledMapConcurrentlyN 8 localConversation' + ) where collectAndLog cs = case partitionEithers cs of (errs, convs) -> traverse_ (warn . Log.msg) errs $> convs diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index 2fabd1d1d6d..d121e496ae2 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -115,7 +115,7 @@ removeRemoteMembersFromLocalConv cnv victims = do members :: ConvId -> Client [LocalMember] members conv = - fmap (catMaybes . map toMember) . retry x1 $ + fmap (mapMaybe toMember) . retry x1 $ query Cql.selectMembers (params LocalQuorum (Identity conv)) toMemberStatus :: diff --git a/services/galley/src/Galley/Cassandra/Instances.hs b/services/galley/src/Galley/Cassandra/Instances.hs index bce3737e83a..67cc7bd42e1 100644 --- a/services/galley/src/Galley/Cassandra/Instances.hs +++ b/services/galley/src/Galley/Cassandra/Instances.hs @@ -52,10 +52,10 @@ instance Cql ConvType where toCql ConnectConv = CqlInt 3 fromCql (CqlInt i) = case i of - 0 -> return RegularConv - 1 -> return SelfConv - 2 -> return One2OneConv - 3 -> return ConnectConv + 0 -> pure RegularConv + 1 -> pure SelfConv + 2 -> pure One2OneConv + 3 -> pure ConnectConv n -> Left $ "unexpected conversation-type: " ++ show n fromCql _ = Left "conv-type: int expected" @@ -68,10 +68,10 @@ instance Cql Access where toCql CodeAccess = CqlInt 4 fromCql (CqlInt i) = case i of - 1 -> return PrivateAccess - 2 -> return InviteAccess - 3 -> return LinkAccess - 4 -> return CodeAccess + 1 -> pure PrivateAccess + 2 -> pure InviteAccess + 3 -> pure LinkAccess + 4 -> pure CodeAccess n -> Left $ "Unexpected Access value: " ++ show n fromCql _ = Left "Access value: int expected" @@ -84,10 +84,10 @@ instance Cql AccessRoleLegacy where toCql NonActivatedAccessRole = CqlInt 4 fromCql (CqlInt i) = case i of - 1 -> return PrivateAccessRole - 2 -> return TeamAccessRole - 3 -> return ActivatedAccessRole - 4 -> return NonActivatedAccessRole + 1 -> pure PrivateAccessRole + 2 -> pure TeamAccessRole + 3 -> pure ActivatedAccessRole + 4 -> pure NonActivatedAccessRole n -> Left $ "Unexpected AccessRole value: " ++ show n fromCql _ = Left "AccessRole value: int expected" @@ -101,10 +101,10 @@ instance Cql AccessRoleV2 where ServiceAccessRole -> CqlInt 4 fromCql (CqlInt i) = case i of - 1 -> return TeamMemberAccessRole - 2 -> return NonTeamMemberAccessRole - 3 -> return GuestAccessRole - 4 -> return ServiceAccessRole + 1 -> pure TeamMemberAccessRole + 2 -> pure NonTeamMemberAccessRole + 3 -> pure GuestAccessRole + 4 -> pure ServiceAccessRole n -> Left $ "Unexpected AccessRoleV2 value: " ++ show n fromCql _ = Left "AccessRoleV2 value: int expected" @@ -138,11 +138,11 @@ instance Cql TeamStatus where toCql PendingActive = CqlInt 4 fromCql (CqlInt i) = case i of - 0 -> return Active - 1 -> return PendingDelete - 2 -> return Deleted - 3 -> return Suspended - 4 -> return PendingActive + 0 -> pure Active + 1 -> pure PendingDelete + 2 -> pure Deleted + 3 -> pure Suspended + 4 -> pure PendingActive n -> Left $ "unexpected team-status: " ++ show n fromCql _ = Left "team-status: int expected" @@ -181,8 +181,8 @@ instance Cql ProtocolTag where toCql ProtocolMLSTag = CqlInt 1 fromCql (CqlInt i) = case i of - 0 -> return ProtocolProteusTag - 1 -> return ProtocolMLSTag + 0 -> pure ProtocolProteusTag + 1 -> pure ProtocolMLSTag n -> Left $ "unexpected protocol: " ++ show n fromCql _ = Left "protocol: int expected" diff --git a/services/galley/src/Galley/Cassandra/LegalHold.hs b/services/galley/src/Galley/Cassandra/LegalHold.hs index 76673ba8ab1..4c74494a5bc 100644 --- a/services/galley/src/Galley/Cassandra/LegalHold.hs +++ b/services/galley/src/Galley/Cassandra/LegalHold.hs @@ -145,22 +145,22 @@ validateServiceKey :: MonadIO m => ServiceKeyPEM -> m (Maybe (ServiceKey, Finger validateServiceKey pem = liftIO $ readPublicKey >>= \pk -> - case join (SSL.toPublicKey <$> pk) of - Nothing -> return Nothing + case SSL.toPublicKey =<< pk of + Nothing -> pure Nothing Just pk' -> do Just sha <- SSL.getDigestByName "SHA256" let size = SSL.rsaSize (pk' :: SSL.RSAPubKey) if size < minRsaKeySize - then return Nothing + then pure Nothing else do fpr <- Fingerprint <$> SSL.rsaFingerprint sha pk' let bits = fromIntegral size * 8 let key = ServiceKey RsaServiceKey bits pem - return $ Just (key, fpr) + pure (Just (key, fpr)) where readPublicKey = handleAny - (const $ return Nothing) - (SSL.readPublicKey (LC8.unpack (toByteString pem)) >>= return . Just) + (const $ pure Nothing) + (SSL.readPublicKey (LC8.unpack (toByteString pem)) <&> Just) minRsaKeySize :: Int minRsaKeySize = 256 -- Bytes (= 2048 bits) diff --git a/services/galley/src/Galley/Cassandra/Queries.hs b/services/galley/src/Galley/Cassandra/Queries.hs index e2df9eb6acc..81a1c4e85dc 100644 --- a/services/galley/src/Galley/Cassandra/Queries.hs +++ b/services/galley/src/Galley/Cassandra/Queries.hs @@ -391,7 +391,7 @@ insertLegalHoldSettings = where team_id = ? |] -selectLegalHoldSettings :: PrepQuery R (Identity TeamId) (HttpsUrl, (Fingerprint Rsa), ServiceToken, ServiceKey) +selectLegalHoldSettings :: PrepQuery R (Identity TeamId) (HttpsUrl, Fingerprint Rsa, ServiceToken, ServiceKey) selectLegalHoldSettings = [r| select base_url, fingerprint, auth_token, pubkey diff --git a/services/galley/src/Galley/Cassandra/SearchVisibility.hs b/services/galley/src/Galley/Cassandra/SearchVisibility.hs index 58277e9c5b5..9a11ffe436d 100644 --- a/services/galley/src/Galley/Cassandra/SearchVisibility.hs +++ b/services/galley/src/Galley/Cassandra/SearchVisibility.hs @@ -44,7 +44,7 @@ getSearchVisibility tid = retry x1 $ query1 selectSearchVisibility (params LocalQuorum (Identity tid)) where -- The value is either set or we return the default - toSearchVisibility :: (Maybe (Identity (Maybe TeamSearchVisibility))) -> TeamSearchVisibility + toSearchVisibility :: Maybe (Identity (Maybe TeamSearchVisibility)) -> TeamSearchVisibility toSearchVisibility (Just (Identity (Just status))) = status toSearchVisibility _ = SearchVisibilityStandard diff --git a/services/galley/src/Galley/Cassandra/Team.hs b/services/galley/src/Galley/Cassandra/Team.hs index 670c4b6a063..15c12c171ee 100644 --- a/services/galley/src/Galley/Cassandra/Team.hs +++ b/services/galley/src/Galley/Cassandra/Team.hs @@ -143,7 +143,7 @@ createTeam :: TeamBinding -> Client Team createTeam t uid (fromRange -> n) i k b = do - tid <- maybe (Id <$> liftIO nextRandom) return t + tid <- maybe (Id <$> liftIO nextRandom) pure t retry x5 $ write Cql.insertTeam (params LocalQuorum (tid, uid, n, i, fromRange <$> k, initialStatus b, b)) pure (newTeam tid uid n i b & teamIconKey .~ (fromRange <$> k)) where @@ -284,7 +284,7 @@ teamMembersCollectedWithPagination lh tid = do tMembers <- mapM (newTeamMember' lh tid) (result mems) if hasMore mems then collectTeamMembersPaginated (tMembers ++ acc) =<< nextPage mems - else return (tMembers ++ acc) + else pure (tMembers ++ acc) -- Lookup only specific team members: this is particularly useful for large teams when -- needed to look up only a small subset of members (typically 2, user to perform the action diff --git a/services/galley/src/Galley/Cassandra/TeamNotifications.hs b/services/galley/src/Galley/Cassandra/TeamNotifications.hs index cd20b807897..5084be13bfb 100644 --- a/services/galley/src/Galley/Cassandra/TeamNotifications.hs +++ b/services/galley/src/Galley/Cassandra/TeamNotifications.hs @@ -60,10 +60,10 @@ interpretTeamNotificationStoreToCassandra = interpret $ \case mkNotificationId :: IO NotificationId mkNotificationId = do ni <- fmap Id <$> retrying x10 fun (const (liftIO UUID.nextUUID)) - maybe (throwM err) return ni + maybe (throwM err) pure ni where x10 = limitRetries 10 <> exponentialBackoff 10 - fun = const (return . isNothing) + fun = const (pure . isNothing) err = mkError status500 "internal-error" "unable to generate notification ID" -- FUTUREWORK: the magic 32 should be made configurable, so it can be tuned @@ -102,7 +102,7 @@ fetch tid since (fromRange -> size) = do -- This can probably simplified a lot further, but we need to understand -- 'Seq' in order to do that. If you find a bug, this may be a good -- place to start looking. - return $! case Seq.viewl (trim (isize - 1) ns) of + pure $! case Seq.viewl (trim (isize - 1) ns) of EmptyL -> ResultPage Seq.empty False (x :< xs) -> ResultPage (x <| xs) more where @@ -118,7 +118,7 @@ fetch tid since (fromRange -> size) = do num' = num - Seq.length nseq acc' = acc >< nseq in if not more || num' == 0 - then return (acc', more || not (null (snd ns))) + then pure (acc', more || not (null (snd ns))) else liftClient (nextPage page) >>= collect acc' num' trim :: Int -> Seq a -> Seq a trim l ns diff --git a/services/galley/src/Galley/Data/Scope.hs b/services/galley/src/Galley/Data/Scope.hs index f7546e6b4bb..8d649e0a693 100644 --- a/services/galley/src/Galley/Data/Scope.hs +++ b/services/galley/src/Galley/Data/Scope.hs @@ -30,5 +30,5 @@ instance Cql Scope where toCql ReusableCode = CqlInt 1 - fromCql (CqlInt 1) = return ReusableCode + fromCql (CqlInt 1) = pure ReusableCode fromCql _ = Left "unknown Scope" diff --git a/services/galley/src/Galley/Data/Services.hs b/services/galley/src/Galley/Data/Services.hs index 099070685b0..9fc2167f7a8 100644 --- a/services/galley/src/Galley/Data/Services.hs +++ b/services/galley/src/Galley/Data/Services.hs @@ -43,7 +43,7 @@ instance Ord BotMember where compare = compare `on` botMemId newBotMember :: LocalMember -> Maybe BotMember -newBotMember m = const (BotMember m) <$> lmService m +newBotMember m = BotMember m <$ lmService m botMemId :: BotMember -> BotId botMemId = BotId . lmId . fromBotMember diff --git a/services/galley/src/Galley/Data/Types.hs b/services/galley/src/Galley/Data/Types.hs index 74b7067587f..e3eedc4edb0 100644 --- a/services/galley/src/Galley/Data/Types.hs +++ b/services/galley/src/Galley/Data/Types.hs @@ -74,7 +74,7 @@ generate :: MonadIO m => ConvId -> Scope -> Timeout -> m Code generate cnv s t = do key <- mkKey cnv val <- liftIO $ Value . unsafeRange . Ascii.encodeBase64Url <$> randBytes 15 - return + pure Code { codeKey = key, codeValue = val, @@ -86,4 +86,4 @@ generate cnv s t = do mkKey :: MonadIO m => ConvId -> m Key mkKey cnv = do sha256 <- liftIO $ fromJust <$> getDigestByName "SHA256" - return $ Key . unsafeRange . Ascii.encodeBase64Url . BS.take 15 $ digestBS sha256 (toByteString' cnv) + pure $ Key . unsafeRange . Ascii.encodeBase64Url . BS.take 15 $ digestBS sha256 (toByteString' cnv) diff --git a/services/galley/src/Galley/Effects/TeamStore.hs b/services/galley/src/Galley/Effects/TeamStore.hs index 215a67e6203..5836300ac6b 100644 --- a/services/galley/src/Galley/Effects/TeamStore.hs +++ b/services/galley/src/Galley/Effects/TeamStore.hs @@ -148,5 +148,5 @@ lookupBindingTeam zusr = do tid <- getOneUserTeam zusr >>= noteS @'TeamNotFound binding <- getTeamBinding tid >>= noteS @'TeamNotFound case binding of - Binding -> return tid + Binding -> pure tid NonBinding -> throwS @'NonBindingTeam diff --git a/services/galley/src/Galley/Effects/WaiRoutes/IO.hs b/services/galley/src/Galley/Effects/WaiRoutes/IO.hs index 9a5da38e869..358513d8da3 100644 --- a/services/galley/src/Galley/Effects/WaiRoutes/IO.hs +++ b/services/galley/src/Galley/Effects/WaiRoutes/IO.hs @@ -32,8 +32,8 @@ interpretWaiRoutes :: Sem (WaiRoutes ': r) a -> Sem r a interpretWaiRoutes = interpret $ \case - FromJsonBody r -> exceptT (throw . InvalidPayload) return (parseBody r) - FromOptionalJsonBody r -> exceptT (throw . InvalidPayload) return (parseOptionalBody r) + FromJsonBody r -> exceptT (throw . InvalidPayload) pure (parseBody r) + FromOptionalJsonBody r -> exceptT (throw . InvalidPayload) pure (parseOptionalBody r) FromProtoBody r -> do b <- readBody r - either (throw . InvalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) + either (throw . InvalidPayload . fromString) pure (runGetLazy Proto.decodeMessage b) diff --git a/services/galley/src/Galley/Env.hs b/services/galley/src/Galley/Env.hs index ef3d3a32b79..d085c0289e2 100644 --- a/services/galley/src/Galley/Env.hs +++ b/services/galley/src/Galley/Env.hs @@ -85,7 +85,7 @@ initExtEnv = do managerConnCount = 100 } Just sha <- getDigestByName "SHA256" - return $ ExtEnv (mgr, mkVerify sha) + pure $ ExtEnv (mgr, mkVerify sha) where mkVerify sha fprs = let pinset = map toByteString' fprs @@ -97,6 +97,6 @@ reqIdMsg = ("request" .=) . unRequestId currentFanoutLimit :: Opts -> Range 1 Teams.HardTruncationLimit Int32 currentFanoutLimit o = do - let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defFanoutLimit (o ^. optSettings ^. setMaxFanoutSize) - let maxTeamSize = fromIntegral (o ^. optSettings ^. setMaxTeamSize) + let optFanoutLimit = fromIntegral . fromRange $ fromMaybe defFanoutLimit (o ^. (optSettings . setMaxFanoutSize)) + let maxTeamSize = fromIntegral (o ^. (optSettings . setMaxTeamSize)) unsafeRange (min maxTeamSize optFanoutLimit) diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index a695155f302..c0c4e1806c4 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -72,10 +72,10 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) exec :: (BotMember, Event) -> App Bool exec (b, e) = lookupService (botMemService b) >>= \case - Nothing -> return False + Nothing -> pure False Just s -> do deliver1 s b e - return True + pure True eval :: [BotMember] -> (BotMember, Async Bool) -> App [BotMember] eval gone (b, a) = do let s = botMemService b @@ -87,14 +87,14 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) ~~ field "service" (toByteString (s ^. serviceRefId)) ~~ field "bot" (toByteString (botMemId b)) ~~ msg (val "External delivery success") - return gone + pure gone Right False -> do Log.debug $ field "provider" (toByteString (s ^. serviceRefProvider)) ~~ field "service" (toByteString (s ^. serviceRefId)) ~~ field "bot" (toByteString (botMemId b)) ~~ msg (val "External service gone") - return (b : gone) + pure (b : gone) Left ex | Just (Http.HttpExceptionRequest _ (Http.StatusCodeException rs _)) <- fromException ex, Http.responseStatus rs == status410 -> do @@ -103,7 +103,7 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) ~~ field "service" (toByteString (s ^. serviceRefId)) ~~ field "bot" (toByteString (botMemId b)) ~~ msg (val "External bot gone") - return (b : gone) + pure (b : gone) Left ex -> do Log.info $ field "provider" (toByteString (s ^. serviceRefProvider)) @@ -111,7 +111,7 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) ~~ field "bot" (toByteString (botMemId b)) ~~ field "error" (show ex) ~~ msg (val "External delivery failure") - return gone + pure gone -- Internal ------------------------------------------------------------------- @@ -134,7 +134,7 @@ deliver1 s bm e . timeout 5000 . secure . expect2xx - | otherwise = return () + | otherwise = pure () urlHost :: HttpsUrl -> Maybe ByteString urlHost (HttpsUrl u) = u ^. authorityL <&> view (authorityHostL . hostBSL) @@ -143,13 +143,13 @@ urlPort :: HttpsUrl -> Maybe Word16 urlPort (HttpsUrl u) = do a <- u ^. authorityL p <- a ^. authorityPortL - return (fromIntegral (p ^. portNumberL)) + pure (fromIntegral (p ^. portNumberL)) sendMessage :: [Fingerprint Rsa] -> (Request -> Request) -> App () sendMessage fprs reqBuilder = do (man, verifyFingerprints) <- view (extEnv . extGetManager) liftIO . withVerifiedSslConnection (verifyFingerprints fprs) man reqBuilder $ \req -> - Http.withResponse req man (const $ return ()) + Http.withResponse req man (const $ pure ()) x3 :: RetryPolicy x3 = limitRetries 3 <> constantDelay 1000000 diff --git a/services/galley/src/Galley/External/LegalHoldService.hs b/services/galley/src/Galley/External/LegalHoldService.hs index 5d7c570e2bf..979c34b5530 100644 --- a/services/galley/src/Galley/External/LegalHoldService.hs +++ b/services/galley/src/Galley/External/LegalHoldService.hs @@ -63,11 +63,11 @@ checkLegalHoldServiceStatus :: Sem r () checkLegalHoldServiceStatus fpr url = do resp <- makeVerifiedRequestFreshManager fpr url reqBuilder - if - | Bilge.statusCode resp < 400 -> pure () - | otherwise -> do - P.info . Log.msg $ showResponse resp - throwS @'LegalHoldServiceBadResponse + if Bilge.statusCode resp < 400 + then pure () + else do + P.info . Log.msg $ showResponse resp + throwS @'LegalHoldServiceBadResponse where reqBuilder :: Http.Request -> Http.Request reqBuilder = diff --git a/services/galley/src/Galley/Intra/Client.hs b/services/galley/src/Galley/Intra/Client.hs index 33c9596c97b..95563d9c071 100644 --- a/services/galley/src/Galley/Intra/Client.hs +++ b/services/galley/src/Galley/Intra/Client.hs @@ -70,7 +70,7 @@ lookupClients uids = do . json (UserSet $ Set.fromList uids) . expect2xx clients <- parseResponse (mkError status502 "server-error") r - return $ filterClients (not . Set.null) clients + pure $ filterClients (not . Set.null) clients -- | Calls 'Brig.API.internalListClientsFullH'. lookupClientsFull :: @@ -84,7 +84,7 @@ lookupClientsFull uids = do . json (UserSet $ Set.fromList uids) . expect2xx clients <- parseResponse (mkError status502 "server-error") r - return $ filterClientsFull (not . Set.null) clients + pure $ filterClientsFull (not . Set.null) clients -- | Calls 'Brig.API.legalHoldClientRequestedH'. notifyClientsAboutLegalHoldRequest :: diff --git a/services/galley/src/Galley/Intra/Federator.hs b/services/galley/src/Galley/Intra/Federator.hs index caa0d499e89..8f8f871e9ce 100644 --- a/services/galley/src/Galley/Intra/Federator.hs +++ b/services/galley/src/Galley/Intra/Federator.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/services/galley/src/Galley/Intra/Push/Internal.hs b/services/galley/src/Galley/Intra/Push/Internal.hs index 5d25aff8ff2..24273dd4c8f 100644 --- a/services/galley/src/Galley/Intra/Push/Internal.hs +++ b/services/galley/src/Galley/Intra/Push/Internal.hs @@ -131,7 +131,7 @@ pushLocal ps = do filter ( \p -> (pushRecipientListType p == Teams.ListComplete) - && (length (_pushRecipients p) <= (fromIntegral $ fromRange limit)) + && (length (_pushRecipients p) <= fromIntegral (fromRange limit)) ) recipient :: LocalMember -> Recipient @@ -155,14 +155,14 @@ newPush1 recipientListType from e rr = } newPushLocal1 :: Teams.ListType -> UserId -> PushEvent -> List1 Recipient -> Push -newPushLocal1 lt uid e rr = newPush1 lt (Just uid) e rr +newPushLocal1 lt uid = newPush1 lt (Just uid) newPush :: Teams.ListType -> Maybe UserId -> PushEvent -> [Recipient] -> Maybe Push newPush _ _ _ [] = Nothing newPush t u e (r : rr) = Just $ newPush1 t u e (list1 r rr) newPushLocal :: Teams.ListType -> UserId -> PushEvent -> [Recipient] -> Maybe Push -newPushLocal lt uid e rr = newPush lt (Just uid) e rr +newPushLocal lt uid = newPush lt (Just uid) newConversationEventPush :: Event -> Local [UserId] -> Maybe Push newConversationEventPush e users = @@ -172,7 +172,7 @@ newConversationEventPush e users = pushSlowly :: Foldable f => f Push -> App () pushSlowly ps = do mmillis <- view (options . optSettings . setDeleteConvThrottleMillis) - let delay = 1000 * (fromMaybe defDeleteConvThrottleMillis mmillis) + let delay = 1000 * fromMaybe defDeleteConvThrottleMillis mmillis forM_ ps $ \p -> do push [p] threadDelay delay diff --git a/services/galley/src/Galley/Intra/Util.hs b/services/galley/src/Galley/Intra/Util.hs index 06fadd4ff50..0cf3bf12717 100644 --- a/services/galley/src/Galley/Intra/Util.hs +++ b/services/galley/src/Galley/Intra/Util.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/services/galley/src/Galley/Options.hs b/services/galley/src/Galley/Options.hs index be010a3a9d8..72c5561916a 100644 --- a/services/galley/src/Galley/Options.hs +++ b/services/galley/src/Galley/Options.hs @@ -95,7 +95,7 @@ data Settings = Settings -- allowedDomains: -- - wire.com -- - example.com - _setFederationDomain :: !(Domain), + _setFederationDomain :: !Domain, -- | When true, galley will assume data in `billing_team_member` table is -- consistent and use it for billing. -- When false, billing information for large teams is not guaranteed to have all diff --git a/services/galley/src/Galley/Validation.hs b/services/galley/src/Galley/Validation.hs index 4e988a9f117..4ff62e03e23 100644 --- a/services/galley/src/Galley/Validation.hs +++ b/services/galley/src/Galley/Validation.hs @@ -35,14 +35,14 @@ import Polysemy import Polysemy.Error rangeChecked :: (Member (Error InvalidInput) r, Within a n m) => a -> Sem r (Range n m a) -rangeChecked = either throwErr return . checkedEither +rangeChecked = either throwErr pure . checkedEither {-# INLINE rangeChecked #-} rangeCheckedMaybe :: (Member (Error InvalidInput) r, Within a n m) => Maybe a -> Sem r (Maybe (Range n m a)) -rangeCheckedMaybe Nothing = return Nothing +rangeCheckedMaybe Nothing = pure Nothing rangeCheckedMaybe (Just a) = Just <$> rangeChecked a {-# INLINE rangeCheckedMaybe #-} @@ -63,7 +63,7 @@ checkedConvSize o x = do let minV :: Integer = 0 limit = o ^. optSettings . setMaxConvSize - 1 if length x <= fromIntegral limit - then return (ConvSizeChecked x) + then pure (ConvSizeChecked x) else throwErr (errorMsg minV limit "") throwErr :: Member (Error InvalidInput) r => String -> Sem r a diff --git a/services/spar/.hlint.yaml b/services/spar/.hlint.yaml new file mode 120000 index 00000000000..f6977905d3e --- /dev/null +++ b/services/spar/.hlint.yaml @@ -0,0 +1 @@ +../../.hlint.yaml \ No newline at end of file diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 66200ec4d12..d2666a2673d 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} +{-# HLINT ignore "Use $>" #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -171,7 +173,7 @@ apiSSO :: Opts -> ServerT APISSO (Sem r) apiSSO opts = - (SAML2.meta appName (SamlProtocolSettings.spIssuer Nothing) (SamlProtocolSettings.responseURI Nothing)) + SAML2.meta appName (SamlProtocolSettings.spIssuer Nothing) (SamlProtocolSettings.responseURI Nothing) :<|> (\tid -> SAML2.meta appName (SamlProtocolSettings.spIssuer (Just tid)) (SamlProtocolSettings.responseURI (Just tid))) :<|> authreqPrecheck :<|> authreq (maxttlAuthreqDiffTime opts) DoInitiateLogin @@ -235,7 +237,7 @@ authreqPrecheck :: authreqPrecheck msucc merr idpid = validateAuthreqParams msucc merr *> getIdPConfig idpid - *> return NoContent + *> pure NoContent authreq :: Members @@ -315,7 +317,7 @@ validateRedirectURL :: Member (Error SparError) r => URI.URI -> Sem r () validateRedirectURL uri = do unless ((SBS.take 4 . URI.schemeBS . URI.uriScheme $ uri) == "wire") $ do throwSparSem $ SparBadInitiateLoginQueryParams "invalid-schema" - unless ((SBS.length $ URI.serializeURIRef' uri) <= redirectURLMaxLength) $ do + unless (SBS.length (URI.serializeURIRef' uri) <= redirectURLMaxLength) $ do throwSparSem $ SparBadInitiateLoginQueryParams "url-too-long" authresp :: @@ -364,7 +366,7 @@ authresp mbtid ckyraw arbody = logErrors $ SAML2.authResp mbtid (SamlProtocolSet ckyraw ssoSettings :: Member DefaultSsoCode r => Sem r SsoSettings -ssoSettings = do +ssoSettings = SsoSettings <$> DefaultSsoCode.get ---------------------------------------------------------------------------- @@ -464,7 +466,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons BrigAccess.delete uid SAMLUserStore.delete uid uref unless (null some) doPurge - when (not idpIsEmpty) $ do + unless idpIsEmpty $ if purge then doPurge else throwSparSem SparIdPHasBoundUsers @@ -480,7 +482,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons do IdPConfigStore.deleteConfig idp IdPRawMetadataStore.delete idpid - return NoContent + pure NoContent where updateOldIssuers :: IdP -> Sem r () updateOldIssuers _ = pure () @@ -492,7 +494,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons -- leave old issuers dangling for now. updateReplacingIdP :: IdP -> Sem r () - updateReplacingIdP idp = forM_ (idp ^. SAML.idpExtraInfo . wiOldIssuers) $ \oldIssuer -> do + updateReplacingIdP idp = forM_ (idp ^. SAML.idpExtraInfo . wiOldIssuers) $ \oldIssuer -> getIdPIdByIssuer oldIssuer (idp ^. SAML.idpExtraInfo . wiTeam) >>= \case GetIdPFound iid -> IdPConfigStore.clearReplacedBy $ Replaced iid GetIdPNotFound -> pure () @@ -519,7 +521,7 @@ idpCreate :: Maybe SAML.IdPId -> Maybe WireIdPAPIVersion -> Sem r IdP -idpCreate zusr (IdPMetadataValue raw xml) midpid apiversion = idpCreateXML zusr raw xml midpid apiversion +idpCreate zusr (IdPMetadataValue raw xml) = idpCreateXML zusr raw xml -- | We generate a new UUID for each IdP used as IdPConfig's path, thereby ensuring uniqueness. idpCreateXML :: @@ -547,7 +549,7 @@ idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apive idp <- validateNewIdP apiversion idpmeta teamid mReplaces IdPRawMetadataStore.store (idp ^. SAML.idpId) raw storeIdPConfig idp - forM_ mReplaces $ \replaces -> do + forM_ mReplaces $ \replaces -> IdPConfigStore.setReplacedBy (Replaced replaces) (Replacing (idp ^. SAML.idpId)) pure idp @@ -567,7 +569,7 @@ assertNoScimOrNoIdP :: assertNoScimOrNoIdP teamid = do numTokens <- length <$> ScimTokenStore.lookupByTeam teamid numIdps <- length <$> IdPConfigStore.getConfigsByTeam teamid - when (numTokens > 0 && numIdps > 0) $ do + when (numTokens > 0 && numIdps > 0) $ throwSparSem $ SparProvisioningMoreThanOneIdP "Teams with SCIM tokens can only have at most one IdP" @@ -662,7 +664,7 @@ idpUpdate :: IdPMetadataInfo -> SAML.IdPId -> Sem r IdP -idpUpdate zusr (IdPMetadataValue raw xml) idpid = idpUpdateXML zusr raw xml idpid +idpUpdate zusr (IdPMetadataValue raw xml) = idpUpdateXML zusr raw xml idpUpdateXML :: Members @@ -719,7 +721,7 @@ validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateNewIdP" (Just Nothing -> throw errUnknownIdPId Just idp -> pure idp teamId <- authorizeIdP zusr previousIdP - unless (previousIdP ^. SAML.idpExtraInfo . wiTeam == teamId) $ do + unless (previousIdP ^. SAML.idpExtraInfo . wiTeam == teamId) $ throw errUnknownIdP _idpExtraInfo <- do let previousIssuer = previousIdP ^. SAML.idpMetadata . SAML.edIssuer @@ -735,7 +737,7 @@ validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateNewIdP" (Just res@(GetIdPNonUnique _) -> throwSparSem . SparIdPNotFound . ("validateIdPUpdate: " <>) . cs . show $ res -- impossible (because team id was used in lookup) GetIdPWrongTeam _ -> pure False if notInUseByOthers - then pure $ (previousIdP ^. SAML.idpExtraInfo) & wiOldIssuers %~ nub . (previousIssuer :) + then pure $ previousIdP ^. SAML.idpExtraInfo & wiOldIssuers %~ nub . (previousIssuer :) else throwSparSem SparIdPIssuerInUse let requri = _idpMetadata ^. SAML.edRequestURI enforceHttps requri @@ -767,7 +769,7 @@ authorizeIdP (Just zusr) idp = do pure teamid enforceHttps :: Member (Error SparError) r => URI.URI -> Sem r () -enforceHttps uri = do +enforceHttps uri = unless ((uri ^. URI.uriSchemeL . URI.schemeBSL) == "https") $ do throwSparSem . SparNewIdPWantHttps . cs . SAML.renderURI $ uri @@ -796,7 +798,7 @@ internalPutSsoSettings :: internalPutSsoSettings SsoSettings {defaultSsoCode = Nothing} = do DefaultSsoCode.delete pure NoContent -internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} = do +internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} = IdPConfigStore.getConfig code >>= \case Nothing -> -- this will return a 404, which is not quite right, diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 75dd6d7f84b..32916d0cac3 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -131,10 +131,10 @@ getIdPConfig :: r => IdPId -> Sem r IdP -getIdPConfig = (>>= maybe (throwSparSem (SparIdPNotFound mempty)) pure) . IdPConfigStore.getConfig +getIdPConfig = maybe (throwSparSem (SparIdPNotFound mempty)) pure <=< IdPConfigStore.getConfig storeIdPConfig :: Member IdPConfigStore r => IdP -> Sem r () -storeIdPConfig idp = IdPConfigStore.storeConfig idp +storeIdPConfig = IdPConfigStore.storeConfig getIdPConfigByIssuerOptionalSPId :: Members '[IdPConfigStore, Error SparError] r => Issuer -> Maybe TeamId -> Sem r IdP getIdPConfigByIssuerOptionalSPId issuer mbteam = do @@ -146,7 +146,7 @@ getIdPConfigByIssuerOptionalSPId issuer mbteam = do res@(GetIdPWrongTeam _) -> throwSparSem $ SparIdPNotFound (cs $ show res) insertUser :: Member SAMLUserStore r => SAML.UserRef -> UserId -> Sem r () -insertUser uref uid = SAMLUserStore.insert uref uid +insertUser = SAMLUserStore.insert -- | Look up user locally in table @spar.user@ or @spar.scim_user@ (depending on the -- argument), then in brig, then return the 'UserId'. If either lookup fails, or user is not @@ -198,7 +198,7 @@ instance Functor GetUserResult where -- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR getUserIdByScimExternalId :: Members '[BrigAccess, ScimExternalIdStore] r => TeamId -> Email -> Sem r (Maybe UserId) getUserIdByScimExternalId tid email = do - muid <- (ScimExternalIdStore.lookup tid email) + muid <- ScimExternalIdStore.lookup tid email case muid of Nothing -> pure Nothing Just uid -> do @@ -395,7 +395,7 @@ verdictHandler cky mbteam aresp verdict = do reqid <- either (throwSparSem . SparNoRequestRefInResponse . cs) pure $ SAML.rspInResponseTo aresp format :: Maybe VerdictFormat <- VerdictFormatStore.get reqid resp <- case format of - Just (VerdictFormatWeb) -> + Just VerdictFormatWeb -> verdictHandlerResult cky mbteam verdict >>= verdictHandlerWeb Just (VerdictFormatMobile granted denied) -> verdictHandlerResult cky mbteam verdict >>= verdictHandlerMobile granted denied @@ -509,7 +509,7 @@ verdictHandlerResultCore bindCky mbteam = \case pure $ VerifyHandlerDenied reasons SAML.AccessGranted userref -> do uid :: UserId <- do - viaBindCookie <- maybe (pure Nothing) (BindCookieStore.lookup) bindCky + viaBindCookie <- maybe (pure Nothing) BindCookieStore.lookup bindCky viaSparCassandra <- getUserIdByUref mbteam userref -- race conditions: if the user has been created on spar, but not on brig, 'getUser' -- returns 'Nothing'. this is ok assuming 'createUser', 'bindUser' (called below) are @@ -696,7 +696,7 @@ errorPage err mpInputs mcky = -- | Like 'getIdPIdByIssuer', but do not require a 'TeamId'. If none is provided, see if a -- single solution can be found without. getIdPIdByIssuerAllowOld :: - (HasCallStack) => + HasCallStack => Member IdPConfigStore r => SAML.Issuer -> Maybe TeamId -> diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index 37c47365246..7c9e3de3fe4 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -90,7 +90,7 @@ type CanonicalEffs = IdPConfigStore, IdPRawMetadataStore, SAMLUserStore, - Embed (Cas.Client), + Embed Cas.Client, BrigAccess, GalleyAccess, Error TTLError, diff --git a/services/spar/src/Spar/Data.hs b/services/spar/src/Spar/Data.hs index be1cd5c59de..e513ac897cb 100644 --- a/services/spar/src/Spar/Data.hs +++ b/services/spar/src/Spar/Data.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/services/spar/src/Spar/Data/Instances.hs b/services/spar/src/Spar/Data/Instances.hs index 78ff47130ec..da7c96d7b31 100644 --- a/services/spar/src/Spar/Data/Instances.hs +++ b/services/spar/src/Spar/Data/Instances.hs @@ -50,7 +50,7 @@ instance Cql SAML.XmlText where fromCql (CqlText t) = pure $ SAML.mkXmlText t fromCql _ = Left "XmlText: expected CqlText" -instance Cql (SignedCertificate) where +instance Cql SignedCertificate where ctype = Tagged BlobColumn toCql = CqlBlob . cs . renderKeyInfo @@ -88,8 +88,8 @@ instance Cql VerdictFormatCon where toCql VerdictFormatConMobile = CqlInt 1 fromCql (CqlInt i) = case i of - 0 -> return VerdictFormatConWeb - 1 -> return VerdictFormatConMobile + 0 -> pure VerdictFormatConWeb + 1 -> pure VerdictFormatConMobile n -> Left $ "unexpected VerdictFormatCon: " ++ show n fromCql _ = Left "member-status: int expected" diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index d4ce48c6ef8..a78c2c0fb2b 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -158,10 +158,10 @@ renderSparError (SAML.Forbidden msg) = Right $ Wai.mkError status403 "forbidden" renderSparError (SAML.BadSamlResponseBase64Error msg) = Right $ Wai.mkError status400 "bad-response-encoding" ("Bad response: base64 error: " <> cs msg) renderSparError (SAML.BadSamlResponseXmlError msg) = Right $ Wai.mkError status400 "bad-response-xml" ("Bad response: XML parse error: " <> cs msg) renderSparError (SAML.BadSamlResponseSamlError msg) = Right $ Wai.mkError status400 "bad-response-saml" ("Bad response: SAML parse error: " <> cs msg) -renderSparError SAML.BadSamlResponseFormFieldMissing = Right $ Wai.mkError status400 "bad-response-saml" ("Bad response: SAMLResponse form field missing from HTTP body") -renderSparError SAML.BadSamlResponseIssuerMissing = Right $ Wai.mkError status400 "bad-response-saml" ("Bad response: no Issuer in AuthnResponse") -renderSparError SAML.BadSamlResponseNoAssertions = Right $ Wai.mkError status400 "bad-response-saml" ("Bad response: no assertions in AuthnResponse") -renderSparError SAML.BadSamlResponseAssertionWithoutID = Right $ Wai.mkError status400 "bad-response-saml" ("Bad response: assertion without ID") +renderSparError SAML.BadSamlResponseFormFieldMissing = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: SAMLResponse form field missing from HTTP body" +renderSparError SAML.BadSamlResponseIssuerMissing = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: no Issuer in AuthnResponse" +renderSparError SAML.BadSamlResponseNoAssertions = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: no assertions in AuthnResponse" +renderSparError SAML.BadSamlResponseAssertionWithoutID = Right $ Wai.mkError status400 "bad-response-saml" "Bad response: assertion without ID" renderSparError (SAML.BadSamlResponseInvalidSignature msg) = Right $ Wai.mkError status400 "bad-response-signature" (cs msg) renderSparError (SAML.CustomError (SparIdPNotFound "")) = Right $ Wai.mkError status404 "not-found" "Could not find IdP." renderSparError (SAML.CustomError (SparIdPNotFound msg)) = Right $ Wai.mkError status404 "not-found" ("Could not find IdP: " <> msg) diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index 3e0a04cd898..8965710ec21 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -165,7 +163,7 @@ getBrigUserAccount havePending buid = do ] case statusCode resp of - 200 -> do + 200 -> parseResponse @[UserAccount] "brig" resp >>= \case [account] -> pure $ @@ -220,11 +218,9 @@ setBrigUserName buid (Name name) = do . paths ["/i/users", toByteString' buid, "name"] . json (NameUpdate name) let sCode = statusCode resp - if - | sCode < 300 -> - pure () - | otherwise -> - rethrow "brig" resp + if sCode < 300 + then pure () + else rethrow "brig" resp -- | Set user's handle. Fails with status <500 if brig fails with <500, and with 500 if brig fails -- with >= 500. @@ -240,9 +236,9 @@ setBrigUserHandle buid handle = do . paths ["/i/users", toByteString' buid, "handle"] . json (HandleUpdate (fromHandle handle)) case (statusCode resp, Wai.label <$> responseJsonMaybe @Wai.Error resp) of - (200, Nothing) -> do + (200, Nothing) -> pure () - _ -> do + _ -> rethrow "brig" resp -- | Set user's managedBy. Fails with status <500 if brig fails with <500, and with 500 if @@ -355,7 +351,7 @@ ssoLogin buid = do . path "/i/sso-login" . json (SsoLogin buid Nothing) . queryItem "persist" "true" - if (statusCode resp == 200) + if statusCode resp == 200 then respToCookie resp else rethrow "brig" resp diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index 1c5506baa58..4825dcb0b66 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} -- This file is part of the Wire Server implementation. @@ -114,7 +113,7 @@ mkUserName (Just n) = const $ mkName n mkUserName Nothing = runValidExternalIdEither (\uref -> mkName (CI.original . SAML.unsafeShowNameID $ uref ^. SAML.uidSubject)) - (\email -> mkName (fromEmail email)) + (mkName . fromEmail) renderValidExternalId :: ValidExternalId -> Maybe Text renderValidExternalId = runValidExternalIdEither urefToExternalId (Just . fromEmail) diff --git a/services/spar/src/Spar/Intra/Galley.hs b/services/spar/src/Spar/Intra/Galley.hs index 998bb84c9fe..e3c6399de8e 100644 --- a/services/spar/src/Spar/Intra/Galley.hs +++ b/services/spar/src/Spar/Intra/Galley.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -54,7 +52,7 @@ getTeamMembers tid = do call $ method GET . paths ["i", "teams", toByteString' tid, "members"] - if (statusCode resp == 200) + if statusCode resp == 200 then (^. teamMembers) <$> parseResponse @TeamMemberList "galley" resp else rethrow "galley" resp @@ -69,7 +67,7 @@ assertHasPermission tid perm uid = do resp <- call $ method GET - . (paths ["i", "teams", toByteString' tid, "members", toByteString' uid]) + . paths ["i", "teams", toByteString' tid, "members", toByteString' uid] case (statusCode resp, parseResponse @TeamMember "galley" resp) of (200, Right member) | hasPermission member perm -> pure () _ -> throwSpar (SparNoPermission (cs $ show perm)) @@ -93,8 +91,7 @@ isEmailValidationEnabledTeam :: (HasCallStack, MonadSparToGalley m) => TeamId -> isEmailValidationEnabledTeam tid = do resp <- call $ method GET . paths ["i", "teams", toByteString' tid, "features", "validateSAMLemails"] pure - ( (statusCode resp == 200) - && ( responseJsonMaybe @(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails) resp - == Just (TeamFeatureStatusNoConfig TeamFeatureEnabled) - ) + ( statusCode resp == 200 + && responseJsonMaybe @(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails) resp + == Just (TeamFeatureStatusNoConfig TeamFeatureEnabled) ) diff --git a/services/spar/src/Spar/Orphans.hs b/services/spar/src/Spar/Orphans.hs index ba96d1fe3dd..5c0c644b575 100644 --- a/services/spar/src/Spar/Orphans.hs +++ b/services/spar/src/Spar/Orphans.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index d72fd2e241d..1bf505a9a24 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -- This file is part of the Wire Server implementation. diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index bd62db7a8d7..0a75c49fb2e 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -130,7 +130,7 @@ createScimToken zusr Api.CreateScimToken {..} = do let descr = createScimTokenDescr teamid <- Intra.Brig.authorizeScimTokenManagement zusr BrigAccess.ensureReAuthorised zusr createScimTokenPassword createScimTokenCode (Just User.CreateScimToken) - tokenNumber <- fmap length $ ScimTokenStore.lookupByTeam teamid + tokenNumber <- length <$> ScimTokenStore.lookupByTeam teamid maxTokens <- inputs maxScimTokens unless (tokenNumber < maxTokens) $ throwSparSem E.SparProvisioningTokenLimitReached diff --git a/services/spar/src/Spar/Scim/Types.hs b/services/spar/src/Spar/Scim/Types.hs index 09deb0b723c..0df82a6ecd0 100644 --- a/services/spar/src/Spar/Scim/Types.hs +++ b/services/spar/src/Spar/Scim/Types.hs @@ -2,18 +2,9 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -- This file is part of the Wire Server implementation. -- @@ -96,4 +87,4 @@ normalizeLikeStored usr = tweakExtra = ScimUserExtra . RichInfo . normalizeRichInfoAssocList . unRichInfo . view sueRichInfo tweakActive :: Maybe Scim.ScimBool -> Maybe Scim.ScimBool - tweakActive = fmap Scim.ScimBool . maybe (Just True) Just . fmap Scim.unScimBool + tweakActive = Just . Scim.ScimBool . maybe True Scim.unScimBool diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 9451deb7ffc..c9e8acf9777 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -7,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} @@ -133,7 +132,7 @@ instance ScimTokenInfo -> Maybe Scim.Filter -> Scim.ScimHandler (Sem r) (Scim.ListResponse (Scim.StoredUser ST.SparTag)) - getUsers _ Nothing = do + getUsers _ Nothing = throwError $ Scim.badRequest Scim.TooMany (Just "Please specify a filter when getting users.") getUsers tokeninfo@ScimTokenInfo {stiTeam, stiIdP} (Just filter') = logScim @@ -209,7 +208,7 @@ validateScimUser errloc tokinfo user = do validateScimUser' errloc mIdpConfig richInfoLimit user tokenInfoToIdP :: Member IdPConfigStore r => ScimTokenInfo -> Scim.ScimHandler (Sem r) (Maybe IdP) -tokenInfoToIdP ScimTokenInfo {stiIdP} = do +tokenInfoToIdP ScimTokenInfo {stiIdP} = maybe (pure Nothing) (lift . IdPConfigStore.getConfig) stiIdP -- | Validate a handle (@userName@). @@ -307,7 +306,7 @@ mkValidExternalId :: Maybe IdP -> Maybe Text -> m ST.ValidExternalId -mkValidExternalId _ Nothing = do +mkValidExternalId _ Nothing = throwError $ Scim.badRequest Scim.InvalidValue @@ -332,7 +331,7 @@ mkValidExternalId (Just idp) (Just extid) = do unameId :: SAML.UnqualifiedNameID <- do let eEmail = SAML.mkUNameIDEmail txt unspec = SAML.mkUNameIDUnspecified txt - pure . either (const unspec) id $ eEmail + pure . fromRight unspec $ eEmail case SAML.mkNameID unameId Nothing Nothing Nothing of Right nameId -> pure nameId Left err -> @@ -451,7 +450,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid uid <- Id <$> Random.uuid BrigAccess.createSAML uref uid stiTeam name ManagedByScim ) - ( \email -> do + ( \email -> BrigAccess.createNoSAML email stiTeam name ) veid @@ -577,16 +576,16 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid newValidScimUser = do let old = oldValidScimUser ^. ST.vsuExternalId new = newValidScimUser ^. ST.vsuExternalId - when (old /= new) $ do + when (old /= new) $ updateVsuUref stiTeam uid old new - when (newValidScimUser ^. ST.vsuName /= oldValidScimUser ^. ST.vsuName) $ do + when (newValidScimUser ^. ST.vsuName /= oldValidScimUser ^. ST.vsuName) $ BrigAccess.setName uid (newValidScimUser ^. ST.vsuName) - when (oldValidScimUser ^. ST.vsuHandle /= newValidScimUser ^. ST.vsuHandle) $ do + when (oldValidScimUser ^. ST.vsuHandle /= newValidScimUser ^. ST.vsuHandle) $ BrigAccess.setHandle uid (newValidScimUser ^. ST.vsuHandle) - when (oldValidScimUser ^. ST.vsuRichInfo /= newValidScimUser ^. ST.vsuRichInfo) $ do + when (oldValidScimUser ^. ST.vsuRichInfo /= newValidScimUser ^. ST.vsuRichInfo) $ BrigAccess.setRichInfo uid (newValidScimUser ^. ST.vsuRichInfo) BrigAccess.getStatusMaybe uid >>= \case @@ -698,7 +697,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = $ do mbBrigUser <- lift (Brig.getBrigUser Brig.WithPendingInvitations uid) case mbBrigUser of - Nothing -> do + Nothing -> -- double-deletion gets you a 404. throwError $ Scim.notFound "user" (idToText uid) Just brigUser -> do @@ -724,7 +723,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = lift $ ScimUserTimesStore.delete uid lift $ BrigAccess.delete uid - return () + pure () ---------------------------------------------------------------------------- -- Utilities @@ -753,13 +752,15 @@ calculateVersion uid usr = Scim.Weak (Text.pack (show h)) -- -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. -assertExternalIdUnused :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> Scim.ScimHandler (Sem r) () -assertExternalIdUnused tid veid = do +assertExternalIdUnused :: + Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => + TeamId -> + ST.ValidExternalId -> + Scim.ScimHandler (Sem r) () +assertExternalIdUnused = assertExternalIdInAllowedValues [Nothing] "externalId is already taken" - tid - veid -- | -- Check that the UserRef is not taken any user other than the passed 'UserId' @@ -768,7 +769,7 @@ assertExternalIdUnused tid veid = do -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. assertExternalIdNotUsedElsewhere :: Members '[BrigAccess, ScimExternalIdStore, SAMLUserStore] r => TeamId -> ST.ValidExternalId -> UserId -> Scim.ScimHandler (Sem r) () -assertExternalIdNotUsedElsewhere tid veid wireUserId = do +assertExternalIdNotUsedElsewhere tid veid wireUserId = assertExternalIdInAllowedValues [Nothing, Just wireUserId] "externalId already in use by another Wire user" @@ -846,12 +847,12 @@ synthesizeStoredUser usr veid = let writeState :: Maybe (UTCTimeMillis, UTCTimeMillis) -> ManagedBy -> RI.RichInfo -> Scim.StoredUser ST.SparTag -> Sem r () writeState oldAccessTimes oldManagedBy oldRichInfo storedUser = do - when (isNothing oldAccessTimes) $ do + when (isNothing oldAccessTimes) $ ScimUserTimesStore.write storedUser - when (oldManagedBy /= ManagedByScim) $ do + when (oldManagedBy /= ManagedByScim) $ BrigAccess.setManagedBy uid ManagedByScim let newRichInfo = view ST.sueRichInfo . Scim.extra . Scim.value . Scim.thing $ storedUser - when (oldRichInfo /= newRichInfo) $ do + when (oldRichInfo /= newRichInfo) $ BrigAccess.setRichInfo uid newRichInfo (richInfo, accessTimes, baseuri) <- lift readState @@ -938,9 +939,9 @@ getUserById midp stiTeam uid = do assertExternalIdNotUsedElsewhere stiTeam veid uid createValidScimUserSpar stiTeam uid storedUser veid lift $ do - when (veidChanged (accountUser brigUser) veid) $ do + when (veidChanged (accountUser brigUser) veid) $ BrigAccess.setVeid uid veid - when (managedByChanged (accountUser brigUser)) $ do + when (managedByChanged (accountUser brigUser)) $ BrigAccess.setManagedBy uid ManagedByScim pure storedUser _ -> Applicative.empty @@ -1008,7 +1009,7 @@ scimFindUserByEmail mIdpConfig stiTeam email = do getUserById mIdpConfig stiTeam . userId . accountUser $ brigUser where withUref :: SAML.UserRef -> Sem r (Maybe UserId) - withUref uref = do + withUref uref = SAMLUserStore.get uref >>= \case Nothing -> maybe (pure Nothing) withEmailOnly $ Brig.urefToEmail uref Just uid -> pure (Just uid) diff --git a/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs b/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs index caae98767cc..fdd369cb860 100644 --- a/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs @@ -76,7 +76,7 @@ insertBindCookie cky uid ttlNDT = do lookupBindCookie :: (HasCallStack, MonadClient m) => BindCookie -> m (Maybe UserId) lookupBindCookie (cs . fromBindCookie -> ckyval :: ST) = runIdentity <$$> do - (retry x1 . query1 sel $ params LocalQuorum (Identity ckyval)) + retry x1 . query1 sel $ params LocalQuorum (Identity ckyval) where sel :: PrepQuery R (Identity ST) (Identity UserId) sel = "SELECT session_owner FROM bind_cookie WHERE cookie = ?" diff --git a/services/spar/src/Spar/Sem/IdPConfigStore/Mem.hs b/services/spar/src/Spar/Sem/IdPConfigStore/Mem.hs index 708c380ab43..a2f72884db5 100644 --- a/services/spar/src/Spar/Sem/IdPConfigStore/Mem.hs +++ b/services/spar/src/Spar/Sem/IdPConfigStore/Mem.hs @@ -65,10 +65,8 @@ storeConfig iw = M.insert (iw ^. SAML.idpId) iw . M.filter ( \iw' -> - or - [ iw' ^. SAML.idpMetadata . SAML.edIssuer /= iw ^. SAML.idpMetadata . SAML.edIssuer, - iw' ^. SAML.idpExtraInfo . IP.wiTeam /= iw ^. SAML.idpExtraInfo . IP.wiTeam - ] + (iw' ^. SAML.idpMetadata . SAML.edIssuer /= iw ^. SAML.idpMetadata . SAML.edIssuer) + || (iw' ^. SAML.idpExtraInfo . IP.wiTeam /= iw ^. SAML.idpExtraInfo . IP.wiTeam) ) getConfig :: SAML.IdPId -> TypedState -> Maybe IP.IdP diff --git a/services/spar/src/Spar/Sem/IdPConfigStore/Spec.hs b/services/spar/src/Spar/Sem/IdPConfigStore/Spec.hs index 4edc680f99b..c022971f0a7 100644 --- a/services/spar/src/Spar/Sem/IdPConfigStore/Spec.hs +++ b/services/spar/src/Spar/Sem/IdPConfigStore/Spec.hs @@ -48,16 +48,16 @@ propsForInterpreter :: (forall x. Show x => Maybe (f x -> String)) -> (forall x. Sem r x -> IO (f x)) -> Spec -propsForInterpreter interpreter extract labeler lower = do +propsForInterpreter interpreter extract labeler lower = describe interpreter $ do prop "deleteConfig/deleteConfig" $ prop_deleteDelete Nothing lower prop "deleteConfig/getConfig" $ prop_deleteGet labeler lower - prop "getConfig/storeConfig" $ prop_getStore (Just $ show . (() <$) . extract) lower - prop "getConfig/getConfig" $ prop_getGet (Just $ show . ((() <$) *** (() <$)) . extract) lower + prop "getConfig/storeConfig" $ prop_getStore (Just $ show . void . extract) lower + prop "getConfig/getConfig" $ prop_getGet (Just $ show . (void *** void) . extract) lower prop "setReplacedBy/clearReplacedBy" $ prop_setClear labeler lower - prop "setReplacedBy/getReplacedBy" $ prop_setGet (Just $ show . (fmap (() <$)) . extract) lower - prop "setReplacedBy/setReplacedBy" $ prop_setSet (Just $ show . (fmap (() <$)) . extract) lower - prop "storeConfig/getConfig" $ prop_storeGet (Just $ show . (() <$) . extract) lower + prop "setReplacedBy/getReplacedBy" $ prop_setGet (Just $ show . fmap void . extract) lower + prop "setReplacedBy/setReplacedBy" $ prop_setSet (Just $ show . fmap void . extract) lower + prop "storeConfig/getConfig" $ prop_storeGet (Just $ show . void . extract) lower xit "storeConfig/getIdByIssuerWithoutTeam" $ property $ prop_storeGetByIssuer (Just $ constructorLabel . extract) lower prop "storeConfig/storeConfig (different keys)" $ prop_storeStoreInterleave Nothing lower prop "storeConfig/storeConfig (same keys)" $ prop_storeStore Nothing lower diff --git a/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs index 64bac454109..c33baf07f2d 100644 --- a/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs +++ b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-orphans #-} -- This file is part of the Wire Server implementation. @@ -33,6 +34,6 @@ instance SAML.HasConfig ((->) SAML.Config) where getConfig = id sparRouteToServant :: SAML.Config -> Sem (SamlProtocolSettings ': r) a -> Sem r a -sparRouteToServant cfg = interpret $ \x -> case x of +sparRouteToServant cfg = interpret $ \case SpIssuer mitlt -> pure $ sparSPIssuer mitlt cfg ResponseURI mitlt -> pure $ sparResponseURI mitlt cfg diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs index 79157b5e268..d8d9adb7a3e 100644 --- a/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore/Spec.hs @@ -38,12 +38,12 @@ propsForInterpreter :: propsForInterpreter interpreter extract lower = do describe interpreter $ do prop "delete/delete" $ prop_deleteDelete Nothing lower - prop "delete/lookup" $ prop_deleteLookup (Just $ show . (() <$) . extract) lower + prop "delete/lookup" $ prop_deleteLookup (Just $ show . void . extract) lower prop "delete/insert" $ prop_deleteInsert Nothing lower prop "lookup/insert" $ prop_lookupInsert Nothing lower prop "insert/delete" $ prop_insertDelete Nothing lower - prop "insert/lookup" $ prop_insertLookup (Just $ show . (() <$) . extract) lower - prop "insert/insert" $ prop_insertInsert (Just $ show . (() <$) . extract) lower + prop "insert/lookup" $ prop_insertLookup (Just $ show . void . extract) lower + prop "insert/insert" $ prop_insertInsert (Just $ show . void . extract) lower -- | All the constraints we need to generalize properties in this module. -- A regular type synonym doesn't work due to dreaded impredicative diff --git a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs index e2b7f727920..54b94fe908d 100644 --- a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs @@ -74,15 +74,15 @@ insertScimToken token ScimTokenInfo {..} = retry x5 . batch $ do insByToken, insByTeam :: PrepQuery W ScimTokenRow () insByToken = [r| - INSERT INTO team_provisioning_by_token - (token_, team, id, created_at, idp, descr) - VALUES (?, ?, ?, ?, ?, ?) + INSERT INTO team_provisioning_by_token + (token_, team, id, created_at, idp, descr) + VALUES (?, ?, ?, ?, ?, ?) |] insByTeam = [r| - INSERT INTO team_provisioning_by_team - (token_, team, id, created_at, idp, descr) - VALUES (?, ?, ?, ?, ?, ?) + INSERT INTO team_provisioning_by_team + (token_, team, id, created_at, idp, descr) + VALUES (?, ?, ?, ?, ?, ?) |] scimTokenLookupKey :: ScimTokenRow -> ScimTokenLookupKey diff --git a/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs b/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs index 7793369ab1a..255d9a8e2ad 100644 --- a/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs +++ b/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs @@ -38,4 +38,4 @@ scimTokenStoreToMem = (runState mempty .) $ Lookup st -> gets $ M.lookup st LookupByTeam tid -> gets $ filter ((== tid) . stiTeam) . M.elems Delete tid stid -> modify $ M.filter $ \sti -> not $ stiTeam sti == tid && stiId sti == stid - DeleteByTeam tid -> modify $ M.filter (not . (== tid) . stiTeam) + DeleteByTeam tid -> modify $ M.filter ((/= tid) . stiTeam) diff --git a/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs b/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs index 9c1f559fcd7..84fde20e408 100644 --- a/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH diff --git a/tools/stern/.hlint.yaml b/tools/stern/.hlint.yaml new file mode 120000 index 00000000000..f6977905d3e --- /dev/null +++ b/tools/stern/.hlint.yaml @@ -0,0 +1 @@ +../../.hlint.yaml \ No newline at end of file diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 1252be7bade..0b2d23e3f92 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} @@ -77,7 +76,7 @@ start o = do s <- Server.newSettings (server e) runSettings s (pipeline e) where - server e = Server.defaultServer (unpack $ (stern o) ^. epHost) ((stern o) ^. epPort) (e ^. applog) (e ^. metrics) + server e = Server.defaultServer (unpack $ stern o ^. epHost) (stern o ^. epPort) (e ^. applog) (e ^. metrics) pipeline e = GZip.gzip GZip.def $ serve e serve e r k = runHandler e r (Server.route (Server.compile sitemap) r k) k @@ -90,8 +89,8 @@ routes :: Routes Doc.ApiBuilder Handler () routes = do -- Begin Internal - get "/i/status" (continue $ const $ return empty) true - head "/i/status" (continue $ const $ return empty) true + get "/i/status" (continue $ const $ pure empty) true + head "/i/status" (continue $ const $ pure empty) true -- End Internal @@ -387,7 +386,7 @@ routes = do description "Team ID" Doc.parameter Doc.Path "feature" Doc.typeTeamFeatureNameNoConfig $ description "Feature name" - Doc.parameter Doc.Query "status" Public.typeTeamFeatureStatusValue $ do + Doc.parameter Doc.Query "status" Public.typeTeamFeatureStatusValue $ Doc.description "team feature status (enabled or disabled)" Doc.response 200 "Team feature flag status" Doc.end @@ -395,7 +394,7 @@ routes = do -- These endpoints should be part of team settings. Until then, we access them from here -- for authorized personnel to enable/disable this on the team's behalf - get "/teams/:tid/search-visibility" (continue (liftM json . Intra.getSearchVisibility)) $ + get "/teams/:tid/search-visibility" (continue (fmap json . Intra.getSearchVisibility)) $ capture "tid" document "GET" "getSearchVisibility" $ do summary "Shows the current TeamSearchVisibility value for the given team" @@ -480,7 +479,7 @@ routes = do document "GET" "getConsentLog" $ do summary "Fetch the consent log given an email address of a non-user" notes "Relevant only internally at Wire" - Doc.parameter Doc.Query "email" Doc.string' $ do + Doc.parameter Doc.Query "email" Doc.string' $ Doc.description "An email address" Doc.response 200 "Consent Log" Doc.end Doc.response 403 "Access denied! There is a user with this email address" Doc.end @@ -490,7 +489,7 @@ routes = do document "GET" "getUserMetaInfo" $ do summary "Fetch a user's meta info given a user id: TEMPORARY!" notes "Relevant only internally at Wire" - Doc.parameter Doc.Query "id" Doc.bytes' $ do + Doc.parameter Doc.Query "id" Doc.bytes' $ Doc.description "A user's ID" Doc.response 200 "Meta Info" Doc.end @@ -513,22 +512,22 @@ type JSON = Media "application" "json" suspendUser :: UserId -> Handler Response suspendUser uid = do Intra.putUserStatus Suspended uid - return empty + pure empty unsuspendUser :: UserId -> Handler Response -unsuspendUser uid = Intra.putUserStatus Active uid >> return empty +unsuspendUser uid = Intra.putUserStatus Active uid >> pure empty usersByEmail :: Email -> Handler Response -usersByEmail = liftM json . Intra.getUserProfilesByIdentity . Left +usersByEmail = fmap json . Intra.getUserProfilesByIdentity . Left usersByPhone :: Phone -> Handler Response -usersByPhone = liftM json . Intra.getUserProfilesByIdentity . Right +usersByPhone = fmap json . Intra.getUserProfilesByIdentity . Right usersByIds :: List UserId -> Handler Response -usersByIds = liftM json . Intra.getUserProfiles . Left . fromList +usersByIds = fmap json . Intra.getUserProfiles . Left . fromList usersByHandles :: List Handle -> Handler Response -usersByHandles = liftM json . Intra.getUserProfiles . Right . fromList +usersByHandles = fmap json . Intra.getUserProfiles . Right . fromList ejpdInfoByHandles :: (List Handle ::: Bool) -> Handler Response ejpdInfoByHandles (handles ::: includeContacts) = json <$> Intra.getEjpdInfo (fromList handles) includeContacts @@ -536,29 +535,29 @@ ejpdInfoByHandles (handles ::: includeContacts) = json <$> Intra.getEjpdInfo (fr userConnections :: UserId -> Handler Response userConnections uid = do conns <- Intra.getUserConnections uid - return . json $ groupByStatus conns + pure . json $ groupByStatus conns usersConnections :: List UserId -> Handler Response -usersConnections = liftM json . Intra.getUsersConnections +usersConnections = fmap json . Intra.getUsersConnections searchOnBehalf :: UserId ::: T.Text ::: Range 1 100 Int32 -> Handler Response searchOnBehalf (uid ::: q ::: s) = - liftM json $ Intra.getContacts uid q (fromRange s) + json <$> Intra.getContacts uid q (fromRange s) revokeIdentity :: Either Email Phone -> Handler Response -revokeIdentity emailOrPhone = Intra.revokeIdentity emailOrPhone >> return empty +revokeIdentity emailOrPhone = Intra.revokeIdentity emailOrPhone >> pure empty changeEmail :: JSON ::: UserId ::: Bool ::: JsonRequest EmailUpdate -> Handler Response changeEmail (_ ::: uid ::: validate ::: req) = do upd <- parseBody req !>> mkError status400 "client-error" Intra.changeEmail uid upd validate - return empty + pure empty changePhone :: JSON ::: UserId ::: JsonRequest PhoneUpdate -> Handler Response changePhone (_ ::: uid ::: req) = do upd <- parseBody req !>> mkError status400 "client-error" Intra.changePhone uid upd - return empty + pure empty deleteUser :: UserId ::: Either Email Phone -> Handler Response deleteUser (uid ::: emailOrPhone) = do @@ -569,9 +568,9 @@ deleteUser (uid ::: emailOrPhone) = do then do info $ userMsg uid . msg (val "Deleting account") void $ Intra.deleteAccount uid - return empty + pure empty else throwE $ mkError status400 "match-error" "email or phone did not match UserId" - _ -> return $ setStatus status404 empty + _ -> pure $ setStatus status404 empty where checkUUID u = userId u == uid @@ -590,7 +589,7 @@ deleteTeam (givenTid ::: False ::: Just email) = do unless (length (tiMembers tInfo) == 1) $ throwE wrongMemberCount void $ Intra.deleteBindingTeam givenTid - return $ setStatus status202 empty + pure $ setStatus status202 empty where handleNoUser = ifNothing (mkError status404 "no-user" "No such user with that email") handleNoTeam = ifNothing (mkError status404 "no-binding-team" "No such binding team") @@ -599,7 +598,7 @@ deleteTeam (givenTid ::: False ::: Just email) = do deleteTeam (tid ::: True ::: _) = do void $ Intra.getTeamData tid -- throws 404 if team does not exist void $ Intra.deleteBindingTeamForce tid - return $ setStatus status202 empty + pure $ setStatus status202 empty isUserKeyBlacklisted :: Either Email Phone -> Handler Response isUserKeyBlacklisted emailOrPhone = do @@ -609,7 +608,7 @@ isUserKeyBlacklisted emailOrPhone = do else response status404 "The given user key is NOT blacklisted" where response st reason = - return + pure . setStatus st . json $ object ["status" .= (reason :: Text)] @@ -617,18 +616,18 @@ isUserKeyBlacklisted emailOrPhone = do addBlacklist :: Either Email Phone -> Handler Response addBlacklist emailOrPhone = do Intra.setBlacklistStatus True emailOrPhone - return empty + pure empty deleteFromBlacklist :: Either Email Phone -> Handler Response deleteFromBlacklist emailOrPhone = do Intra.setBlacklistStatus False emailOrPhone - return empty + pure empty getTeamInfo :: TeamId -> Handler Response -getTeamInfo = liftM json . Intra.getTeamInfo +getTeamInfo = fmap json . Intra.getTeamInfo getTeamAdminInfo :: TeamId -> Handler Response -getTeamAdminInfo = liftM (json . toAdminInfo) . Intra.getTeamInfo +getTeamAdminInfo = fmap (json . toAdminInfo) . Intra.getTeamInfo getTeamFeatureFlagH :: forall (a :: Public.TeamFeatureName). @@ -669,13 +668,13 @@ setTeamFeatureNoConfigFlagH (tid ::: featureName ::: statusValue) = setSearchVisibility :: JSON ::: TeamId ::: JsonRequest Team.TeamSearchVisibility -> Handler Response setSearchVisibility (_ ::: tid ::: req) = do status :: Team.TeamSearchVisibility <- parseBody req !>> mkError status400 "client-error" - liftM json $ Intra.setSearchVisibility tid status + json <$> Intra.setSearchVisibility tid status getTeamBillingInfo :: TeamId -> Handler Response getTeamBillingInfo tid = do ti <- Intra.getTeamBillingInfo tid case ti of - Just t -> return $ json t + Just t -> pure $ json t Nothing -> throwE (mkError status404 "no-team" "No team or no billing info for team") updateTeamBillingInfo :: JSON ::: TeamId ::: JsonRequest TeamBillingInfoUpdate -> Handler Response @@ -684,20 +683,20 @@ updateTeamBillingInfo (_ ::: tid ::: req) = do current <- Intra.getTeamBillingInfo tid >>= handleNoTeam let changes = parse update current Intra.setTeamBillingInfo tid changes - liftM json $ Intra.getTeamBillingInfo tid + json <$> Intra.getTeamBillingInfo tid where handleNoTeam = ifNothing (mkError status404 "no-team" "No team or no billing info for team") parse :: TeamBillingInfoUpdate -> TeamBillingInfo -> TeamBillingInfo parse TeamBillingInfoUpdate {..} tbi = tbi - { tbiFirstname = fromMaybe (tbiFirstname tbi) (fromRange <$> tbiuFirstname), - tbiLastname = fromMaybe (tbiLastname tbi) (fromRange <$> tbiuLastname), - tbiStreet = fromMaybe (tbiStreet tbi) (fromRange <$> tbiuStreet), - tbiZip = fromMaybe (tbiZip tbi) (fromRange <$> tbiuZip), - tbiCity = fromMaybe (tbiCity tbi) (fromRange <$> tbiuCity), - tbiCountry = fromMaybe (tbiCountry tbi) (fromRange <$> tbiuCountry), - tbiCompany = (fromRange <$> tbiuCompany) <|> tbiCompany tbi, - tbiState = (fromRange <$> tbiuState) <|> tbiState tbi + { tbiFirstname = maybe (tbiFirstname tbi) fromRange tbiuFirstname, + tbiLastname = maybe (tbiLastname tbi) fromRange tbiuLastname, + tbiStreet = maybe (tbiStreet tbi) fromRange tbiuStreet, + tbiZip = maybe (tbiZip tbi) fromRange tbiuZip, + tbiCity = maybe (tbiCity tbi) fromRange tbiuCity, + tbiCountry = maybe (tbiCountry tbi) fromRange tbiuCountry, + tbiCompany = fromRange <$> tbiuCompany <|> tbiCompany tbi, + tbiState = fromRange <$> tbiuState <|> tbiState tbi } setTeamBillingInfo :: JSON ::: TeamId ::: JsonRequest TeamBillingInfo -> Handler Response @@ -711,9 +710,9 @@ setTeamBillingInfo (_ ::: tid ::: req) = do getTeamInfoByMemberEmail :: Email -> Handler Response getTeamInfoByMemberEmail e = do - acc <- (listToMaybe <$> Intra.getUserProfilesByIdentity (Left e)) >>= handleUser + acc <- Intra.getUserProfilesByIdentity (Left e) >>= handleUser . listToMaybe tid <- (Intra.getUserBindingTeam . userId . accountUser $ acc) >>= handleTeam - liftM json $ Intra.getTeamInfo tid + json <$> Intra.getTeamInfo tid where handleUser = ifNothing (mkError status404 "no-user" "No such user with that email") handleTeam = ifNothing (mkError status404 "no-binding-team" "No such binding team") @@ -721,17 +720,17 @@ getTeamInfoByMemberEmail e = do getTeamInvoice :: TeamId ::: InvoiceId ::: JSON -> Handler Response getTeamInvoice (tid ::: iid ::: _) = do url <- Intra.getInvoiceUrl tid iid - return $ plain (fromStrict url) + pure $ plain (fromStrict url) getConsentLog :: Email -> Handler Response getConsentLog e = do - acc <- (listToMaybe <$> Intra.getUserProfilesByIdentity (Left e)) + acc <- listToMaybe <$> Intra.getUserProfilesByIdentity (Left e) when (isJust acc) $ throwE $ mkError status403 "user-exists" "Trying to access consent log of existing user!" consentLog <- Intra.getEmailConsentLog e marketo <- Intra.getMarketoResult e - return . json $ + pure . json $ object [ "consent_log" .= consentLog, "marketo" .= marketo @@ -740,7 +739,7 @@ getConsentLog e = do -- TODO: This will be removed as soon as this is ported to another tool getUserData :: UserId -> Handler Response getUserData uid = do - account <- (listToMaybe <$> Intra.getUserProfiles (Left [uid])) >>= noSuchUser + account <- Intra.getUserProfiles (Left [uid]) >>= noSuchUser . listToMaybe conns <- Intra.getUserConnections uid convs <- Intra.getUserConversations uid clts <- Intra.getUserClients uid @@ -751,8 +750,8 @@ getUserData uid = do properties <- Intra.getUserProperties uid -- Get all info from Marketo too let em = userEmail $ accountUser account - marketo <- maybe (return noEmail) Intra.getMarketoResult em - return . json $ + marketo <- maybe (pure noEmail) Intra.getMarketoResult em + pure . json $ object [ "account" .= account, "cookies" .= cookies, @@ -786,7 +785,7 @@ groupByStatus conns = byStatus s = length . filter ((==) s . ucStatus) ifNothing :: Error -> Maybe a -> Handler a -ifNothing e = maybe (throwE e) return +ifNothing e = maybe (throwE e) pure noSuchUser :: Maybe a -> Handler a noSuchUser = ifNothing (mkError status404 "no-user" "No such user") diff --git a/tools/stern/src/Stern/App.hs b/tools/stern/src/Stern/App.hs index 1907faf80fa..17bc07c7268 100644 --- a/tools/stern/src/Stern/App.hs +++ b/tools/stern/src/Stern/App.hs @@ -71,11 +71,11 @@ newEnv :: Opts -> IO Env newEnv o = do mt <- Metrics.metrics l <- Log.mkLogger (O.logLevel o) (O.logNetStrings o) (O.logFormat o) - Env (mkRequest $ O.brig o) (mkRequest $ O.galley o) (mkRequest $ O.gundeck o) (mkRequest $ O.ibis o) (mkRequest $ O.galeb o) l mt - <$> pure def - <*> Bilge.newManager (Bilge.defaultManagerSettings {Bilge.managerResponseTimeout = responseTimeoutMicro 10000000}) + Env (mkRequest $ O.brig o) (mkRequest $ O.galley o) (mkRequest $ O.gundeck o) (mkRequest $ O.ibis o) (mkRequest $ O.galeb o) l mt def + <$> newManager where mkRequest s = Bilge.host (encodeUtf8 (s ^. epHost)) . Bilge.port (s ^. epPort) $ Bilge.empty + newManager = Bilge.newManager (Bilge.defaultManagerSettings {Bilge.managerResponseTimeout = responseTimeoutMicro 10000000}) -- Monads newtype AppT m a = AppT (ReaderT Env m a) @@ -131,12 +131,12 @@ runHandler e r h k = do i <- reqId (lookupRequestId r) let e' = set requestId (Bilge.RequestId i) e a <- runAppT e' (runExceptT h) - either (onError (view applog e) r k) return a + either (onError (view applog e) r k) pure a where - reqId (Just i) = return i + reqId (Just i) = pure i reqId Nothing = do uuid <- UUID.nextRandom - return $ toByteString' $ "stern-" ++ toString uuid + pure $ toByteString' $ "stern-" ++ toString uuid onError :: Logger -> Request -> Continue IO -> Error -> IO ResponseReceived onError g r k e = do diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 3b3df24fcab..2c719c228fc 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -155,7 +155,7 @@ getUserConnections uid = do let batch = clConnections userConnectionList if (not . null) batch && clHasMore userConnectionList then fetchAll (batch ++ xs) (Just . qUnqualified . ucTo $ last batch) - else return (batch ++ xs) + else pure (batch ++ xs) fetchBatch :: Maybe UserId -> Handler UserConnectionList fetchBatch start = do b <- view brig @@ -196,7 +196,7 @@ getUserProfiles :: Either [UserId] [Handle] -> Handler [UserAccount] getUserProfiles uidsOrHandles = do info $ msg "Getting user accounts" b <- view brig - return . concat =<< mapM (doRequest b) (prepareQS uidsOrHandles) + concat <$> mapM (doRequest b) (prepareQS uidsOrHandles) where doRequest :: Request -> (Request -> Request) -> Handler [UserAccount] doRequest b qry = do @@ -211,7 +211,7 @@ getUserProfiles uidsOrHandles = do . expect2xx ) parseResponse (mkError status502 "bad-upstream") r - prepareQS :: Either [UserId] [Handle] -> [(Request -> Request)] + prepareQS :: Either [UserId] [Handle] -> [Request -> Request] prepareQS (Left uids) = fmap (queryItem "ids") (toQS uids) prepareQS (Right handles) = fmap (queryItem "handles") (toQS handles) toQS :: ToByteString a => [a] -> [ByteString] @@ -240,7 +240,7 @@ getEjpdInfo handles includeContacts = do info $ msg "Getting ejpd info on users by handle" b <- view brig let bdy :: Value - bdy = object ["ejpd_request" .= ((cs @_ @Text . toByteString') <$> handles)] + bdy = object ["ejpd_request" .= (cs @_ @Text . toByteString' <$> handles)] r <- catchRpcErrors $ rpc' @@ -301,7 +301,7 @@ deleteAccount uid = do setStatusBindingTeam :: TeamId -> Team.TeamStatus -> Handler () setStatusBindingTeam tid status = do - info $ msg ("Setting team status to " <> (cs $ encode status)) + info $ msg ("Setting team status to " <> cs (encode status)) g <- view galley void . catchRpcErrors $ rpc' @@ -380,7 +380,7 @@ getTeamInfo :: TeamId -> Handler TeamInfo getTeamInfo tid = do d <- getTeamData tid m <- getTeamMembers tid - return $ TeamInfo d (map TeamMemberInfo (m ^. teamMembers)) + pure $ TeamInfo d (map TeamMemberInfo (m ^. teamMembers)) getUserBindingTeam :: UserId -> Handler (Maybe TeamId) getUserBindingTeam u = do @@ -398,7 +398,7 @@ getUserBindingTeam u = do . expect2xx ) teams <- parseResponse (mkError status502 "bad-upstream") r - return $ + pure $ listToMaybe $ fmap (view teamId) $ filter ((== Binding) . view teamBinding) $ @@ -418,7 +418,7 @@ getInvoiceUrl tid iid = do . noRedirect . expectStatus (== 307) ) - return $ getHeader' "Location" r + pure $ getHeader' "Location" r getTeamBillingInfo :: TeamId -> Handler (Maybe TeamBillingInfo) getTeamBillingInfo tid = do @@ -434,7 +434,7 @@ getTeamBillingInfo tid = do ) case Bilge.statusCode r of 200 -> Just <$> parseResponse (mkError status502 "bad-upstream") r - 404 -> return Nothing + 404 -> pure Nothing _ -> throwE (mkError status502 "bad-upstream" "bad response") setTeamBillingInfo :: TeamId -> TeamBillingInfo -> Handler () @@ -466,8 +466,8 @@ isBlacklisted emailOrPhone = do . userKeyToParam emailOrPhone ) case Bilge.statusCode r of - 200 -> return True - 404 -> return False + 200 -> pure True + 404 -> pure False _ -> throwE (mkError status502 "bad-upstream" "bad response") setBlacklistStatus :: Bool -> Either Email Phone -> Handler () @@ -570,7 +570,7 @@ getSearchVisibility :: TeamId -> Handler TeamSearchVisibilityView getSearchVisibility tid = do info $ msg "Getting TeamSearchVisibilityView value" gly <- view galley - (>>= fromResponseBody) . catchRpcErrors $ + fromResponseBody <=< catchRpcErrors $ rpc' "galley" gly @@ -708,7 +708,7 @@ getMarketoResult email = do -- 404 is acceptable when marketo doesn't know about this user, return an empty result case statusCode r of 200 -> parseResponse (mkError status502 "bad-upstream") r - 404 -> return noEmail + 404 -> pure noEmail _ -> throwE (mkError status502 "bad-upstream" "") where noEmail = MarketoResult $ KeyMap.singleton "results" emptyArray @@ -752,9 +752,9 @@ getUserConversations uid = do fetchAll xs start = do userConversationList <- fetchBatch start let batch = convList userConversationList - if (not . null) batch && (convHasMore userConversationList) + if (not . null) batch && convHasMore userConversationList then fetchAll (batch ++ xs) (Just . qUnqualified . cnvQualifiedId $ last batch) - else return (batch ++ xs) + else pure (batch ++ xs) fetchBatch :: Maybe ConvId -> Handler (ConversationList Conversation) fetchBatch start = do b <- view galley @@ -808,7 +808,7 @@ getUserProperties uid = do keys <- parseResponse (mkError status502 "bad-upstream") r :: Handler [PropertyKey] UserProperties <$> fetchProperty b keys mempty where - fetchProperty _ [] acc = return acc + fetchProperty _ [] acc = pure acc fetchProperty b (x : xs) acc = do r <- catchRpcErrors $ @@ -832,9 +832,9 @@ getUserNotifications uid = do fetchAll xs start = do userNotificationList <- fetchBatch start let batch = view queuedNotifications userNotificationList - if (not . null) batch && (view queuedHasMore userNotificationList) - then fetchAll (batch ++ xs) (Just . (view queuedNotificationId) $ last batch) - else return (batch ++ xs) + if (not . null) batch && view queuedHasMore userNotificationList + then fetchAll (batch ++ xs) (Just . view queuedNotificationId $ last batch) + else pure (batch ++ xs) fetchBatch :: Maybe NotificationId -> Handler QueuedNotificationList fetchBatch start = do b <- view gundeck diff --git a/tools/stern/src/Stern/Options.hs b/tools/stern/src/Stern/Options.hs index 103d381a2cc..f47f2bf5180 100644 --- a/tools/stern/src/Stern/Options.hs +++ b/tools/stern/src/Stern/Options.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -- This file is part of the Wire Server implementation. -- diff --git a/tools/stern/src/Stern/Types.hs b/tools/stern/src/Stern/Types.hs index 063c4f63aab..9af0409b2bd 100644 --- a/tools/stern/src/Stern/Types.hs +++ b/tools/stern/src/Stern/Types.hs @@ -76,7 +76,7 @@ isOwner :: TeamMember -> Bool isOwner m = hasPermission m SetBilling isAdmin :: TeamMember -> Bool -isAdmin m = (hasPermission m AddTeamMember) && not (hasPermission m SetBilling) +isAdmin m = hasPermission m AddTeamMember && not (hasPermission m SetBilling) instance ToJSON TeamInfo where toJSON (TeamInfo d m) =