diff --git a/.ormolu b/.ormolu new file mode 100644 index 00000000000..a427ec702a8 --- /dev/null +++ b/.ormolu @@ -0,0 +1,5 @@ +infixr 10 .= +infix 4 === +infix 4 =/= +infixr 3 !!! +infixr 3 BotClient -> m SymmetricKeys randomSymmetricKeys clt = - SymmetricKeys <$> randomBytes (botClientBox clt) 32 + SymmetricKeys + <$> randomBytes (botClientBox clt) 32 <*> randomBytes (botClientBox clt) 32 encryptSymmetric :: MonadIO m => BotClient -> SymmetricKeys -> Plaintext -> m Ciphertext diff --git a/libs/api-bot/src/Network/Wire/Bot/Email.hs b/libs/api-bot/src/Network/Wire/Bot/Email.hs index 2d5dada326a..590667c9875 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Email.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Email.hs @@ -56,7 +56,8 @@ data MailboxSettings = MailboxSettings instance FromJSON MailboxSettings where parseJSON = withObject "mailbox-settings" $ \o -> - MailboxSettings <$> o .: "host" + MailboxSettings + <$> o .: "host" <*> o .: "user" <*> o .: "pass" <*> o .: "conn" diff --git a/libs/api-bot/src/Network/Wire/Bot/Monad.hs b/libs/api-bot/src/Network/Wire/Bot/Monad.hs index bab19b4368c..bef187e2db5 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Monad.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Monad.hs @@ -169,8 +169,8 @@ newBotNetEnv manager logger o = do serverSSL = setBotNetApiSSL o, serverManager = manager } - pure - $! BotNetEnv + pure $! + BotNetEnv { botNetGen = gen, botNetMailboxes = mbx, botNetSender = setBotNetSender o, @@ -195,16 +195,16 @@ initMetrics = do pure m where counters = - Metrics.assertionsTotal : - Metrics.assertionsFailed : - Metrics.exceptionsTotal : - Metrics.botsCreatedNew : - Metrics.botsCreatedCached : - Metrics.eventsTotalRcvd : - Metrics.eventsTotalAckd : - Metrics.eventsTotalIgnd : - Metrics.eventsTotalMssd : - concatMap etc [(minBound :: EventType) ..] + Metrics.assertionsTotal + : Metrics.assertionsFailed + : Metrics.exceptionsTotal + : Metrics.botsCreatedNew + : Metrics.botsCreatedCached + : Metrics.eventsTotalRcvd + : Metrics.eventsTotalAckd + : Metrics.eventsTotalIgnd + : Metrics.eventsTotalMssd + : concatMap etc [(minBound :: EventType) ..] etc t = [ Metrics.eventTypeRcvd t, Metrics.eventTypeAckd t, @@ -592,7 +592,9 @@ assertFailure :: (HasCallStack, MonadBotNet m) => Text -> m () assertFailure m = whenAsserts $ do incrAssertFailed log Error . msg $ - val "Assertion failed: " +++ m +++ val "\n" + val "Assertion failed: " + +++ m + +++ val "\n" +++ prettyCallStack callStack -- | Place an assertion on a 'Bot', expecting a matching 'Event' to arrive @@ -771,7 +773,8 @@ heartbeat bot e = forever $ do for_ out $ liftIO . atomically . flip tryPutTMVar Nothing botLog l bot Warn $ msg $ - "Assertion Timeout: " <> eventTypeText typ + "Assertion Timeout: " + <> eventTypeText typ <> "\nAssertion was created at: " <> pack (prettyCallStack stack) -- Re-establish the push connection, if it died diff --git a/libs/api-bot/src/Network/Wire/Bot/Report/Text.hs b/libs/api-bot/src/Network/Wire/Bot/Report/Text.hs index 17afb497862..ae75aeb39df 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Report/Text.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Report/Text.hs @@ -43,12 +43,15 @@ formatReport :: Lazy.Text formatReport pretty r = toLazyText $ - "\n" <> title <> "\n" + "\n" + <> title + <> "\n" <> foldMap section (reportSections r) where pp x = if pretty then x else mempty title = - pp underline <> pp bold + pp underline + <> pp bold <> fromText (reportTitle r) <> " Report\n\n" <> pp clear @@ -57,7 +60,10 @@ formatReport pretty r = <> pp clear <> "\n" section s = - pp bold <> fromText (sectionName s) <> "\n" <> pp clear + pp bold + <> fromText (sectionName s) + <> "\n" + <> pp clear <> foldMap metric (sectionMetrics s) <> "\n" metric (Counter l p) = single l . fromString . show $ reportCounter r p diff --git a/libs/api-client/.ormolu b/libs/api-client/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/api-client/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/api-client/src/Network/Wire/Client/API/Push.hs b/libs/api-client/src/Network/Wire/Client/API/Push.hs index cddd7be34c0..30f91155e37 100644 --- a/libs/api-client/src/Network/Wire/Client/API/Push.hs +++ b/libs/api-client/src/Network/Wire/Client/API/Push.hs @@ -287,7 +287,8 @@ instance FromJSON Notification where instance FromJSON a => FromJSON (ConvEvent a) where parseJSON = withObject "conversation-event" $ \o -> - ConvEvent <$> o .: "conversation" + ConvEvent + <$> o .: "conversation" <*> o .: "from" <*> o .: "time" <*> o .: "data" diff --git a/libs/api-client/src/Network/Wire/Client/HTTP.hs b/libs/api-client/src/Network/Wire/Client/HTTP.hs index 20a4b499bd7..148b444f156 100644 --- a/libs/api-client/src/Network/Wire/Client/HTTP.hs +++ b/libs/api-client/src/Network/Wire/Client/HTTP.hs @@ -52,7 +52,8 @@ data Error = Error instance FromJSON Error where parseJSON = withObject "error" $ \o -> - Error <$> o .: "code" + Error + <$> o .: "code" <*> o .: "label" <*> o .: "message" @@ -89,7 +90,8 @@ clientRequest rq expected f = do exec = do s <- getServer let rq' = - rq & setServer s + rq + & setServer s & header hUserAgent "api-client" Log.debug $ Log.msg (show rq') runInIO <- askRunInIO diff --git a/libs/bilge/.ormolu b/libs/bilge/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/bilge/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/bilge/src/Bilge/Assert.hs b/libs/bilge/src/Bilge/Assert.hs index 71159fcd04f..2a584e5b6d9 100644 --- a/libs/bilge/src/Bilge/Assert.hs +++ b/libs/bilge/src/Bilge/Assert.hs @@ -87,8 +87,8 @@ io brReadSome (Rq.responseBody res) 1024 - throwHttp $ Rq.StatusCodeException (void res) some + some <- Lazy.toStrict <$> brReadSome (Rq.responseBody res) 1024 + throwHttp $ Rq.StatusCodeException (void res) some checkStatus :: (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException) -> Request -> Request checkStatus f r = r {Rq.checkResponse = check} diff --git a/libs/brig-types/.ormolu b/libs/brig-types/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/brig-types/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/brig-types/src/Brig/Types/Common.hs b/libs/brig-types/src/Brig/Types/Common.hs index 2b95cb7639c..a55bf865736 100644 --- a/libs/brig-types/src/Brig/Types/Common.hs +++ b/libs/brig-types/src/Brig/Types/Common.hs @@ -88,7 +88,8 @@ instance FromJSON PhonePrefix where Just p -> pure p Nothing -> fail $ - "Invalid phone number prefix: [" ++ show s + "Invalid phone number prefix: [" + ++ show s ++ "]. Expected format similar to E.164 (with 1-15 digits after the +)." instance FromByteString PhonePrefix where diff --git a/libs/brig-types/src/Brig/Types/Team/LegalHold.hs b/libs/brig-types/src/Brig/Types/Team/LegalHold.hs index 8cde9eae14c..1105b5edd97 100644 --- a/libs/brig-types/src/Brig/Types/Team/LegalHold.hs +++ b/libs/brig-types/src/Brig/Types/Team/LegalHold.hs @@ -46,13 +46,13 @@ data LegalHoldService = LegalHoldService instance ToJSON LegalHoldService where toJSON s = - object $ - "team_id" .= legalHoldServiceTeam s - # "base_url" .= legalHoldServiceUrl s - # "fingerprint" .= legalHoldServiceFingerprint s - # "auth_token" .= legalHoldServiceToken s - # "public_key" .= legalHoldServiceKey s - # [] + object + $ "team_id" .= legalHoldServiceTeam s + # "base_url" .= legalHoldServiceUrl s + # "fingerprint" .= legalHoldServiceFingerprint s + # "auth_token" .= legalHoldServiceToken s + # "public_key" .= legalHoldServiceKey s + # [] instance FromJSON LegalHoldService where parseJSON = withObject "LegalHoldService" $ \o -> @@ -85,7 +85,7 @@ instance FromJSON LegalHoldClientRequest where instance ToJSON LegalHoldClientRequest where toJSON (LegalHoldClientRequest requester lastPrekey') = - object $ - "requester" .= requester - # "last_prekey" .= lastPrekey' - # [] + object + $ "requester" .= requester + # "last_prekey" .= lastPrekey' + # [] diff --git a/libs/brig-types/src/Brig/Types/User/Auth.hs b/libs/brig-types/src/Brig/Types/User/Auth.hs new file mode 100644 index 00000000000..2ca14dca398 --- /dev/null +++ b/libs/brig-types/src/Brig/Types/User/Auth.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Brig.Types.User.Auth + ( SsoLogin (..), + LegalHoldLogin (..), + ) +where + +import Data.Aeson +import Data.Id (UserId) +import Data.Misc (PlainTextPassword (..)) +import Imports +import Wire.API.User.Auth + +-- | A special kind of login that is only used for an internal endpoint. +data SsoLogin + = SsoLogin !UserId !(Maybe CookieLabel) + +-- | A special kind of login that is only used for an internal endpoint. +-- This kind of login returns restricted 'LegalHoldUserToken's instead of regular +-- tokens. +data LegalHoldLogin + = LegalHoldLogin !UserId !(Maybe PlainTextPassword) !(Maybe CookieLabel) + +instance FromJSON SsoLogin where + parseJSON = withObject "SsoLogin" $ \o -> + SsoLogin <$> o .: "user" <*> o .:? "label" + +instance ToJSON SsoLogin where + toJSON (SsoLogin uid label) = + object ["user" .= uid, "label" .= label] + +instance FromJSON LegalHoldLogin where + parseJSON = withObject "LegalHoldLogin" $ \o -> + LegalHoldLogin + <$> o + .: "user" + <*> o + .:? "password" + <*> o + .:? "label" + +instance ToJSON LegalHoldLogin where + toJSON (LegalHoldLogin uid password label) = + object + [ "user" .= uid, + "password" .= password, + "label" .= label + ] diff --git a/libs/cargohold-types/.ormolu b/libs/cargohold-types/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/cargohold-types/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/cassandra-util/.ormolu b/libs/cassandra-util/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/cassandra-util/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/cassandra-util/src/Cassandra/Schema.hs b/libs/cassandra-util/src/Cassandra/Schema.hs index 5205078b9ef..5e4c0e12ee5 100644 --- a/libs/cassandra-util/src/Cassandra/Schema.hs +++ b/libs/cassandra-util/src/Cassandra/Schema.hs @@ -137,7 +137,8 @@ createKeyspace (Keyspace k) rs = void $ schema (cql rs) (params All ()) where cql (SimpleStrategy (ReplicationFactor n)) = QueryString . toLazyText $ - fromText "create keyspace if not exists " <> fromText k + fromText "create keyspace if not exists " + <> fromText k <> fromText " with replication = { " <> fromText " 'class': 'SimpleStrategy' " <> fromText " , 'replication_factor': '" @@ -146,7 +147,8 @@ createKeyspace (Keyspace k) rs = void $ schema (cql rs) (params All ()) <> fromText "};" cql (NetworkTopologyStrategy (ReplicationMap dcs)) = QueryString . toLazyText $ - fromText "create keyspace if not exists " <> fromText k + fromText "create keyspace if not exists " + <> fromText k <> fromText " with replication = { " <> fromText " 'class': 'NetworkTopologyStrategy' " <> fromText " , " @@ -165,8 +167,8 @@ migrateSchema :: Log.Logger -> MigrationOpts -> [Migration] -> IO () migrateSchema l o ms = do hosts <- initialContactsPlain $ pack (migHost o) p <- - CQL.init $ - setLogger (CT.mkLogger l) + CQL.init + $ setLogger (CT.mkLogger l) . setContacts (NonEmpty.head hosts) (NonEmpty.tail hosts) . setPortNumber (fromIntegral $ migPort o) . setMaxConnections 1 @@ -183,7 +185,7 @@ migrateSchema l o ms = do . setSendTimeout 20 . setResponseTimeout 50 . setProtocolVersion V4 - $ defSettings + $ defSettings runClient p $ do let keyspace = Keyspace . migKeyspace $ o when (migReset o) $ do diff --git a/libs/cassandra-util/src/Cassandra/Util.hs b/libs/cassandra-util/src/Cassandra/Util.hs index 54ea705f25c..062d9913a99 100644 --- a/libs/cassandra-util/src/Cassandra/Util.hs +++ b/libs/cassandra-util/src/Cassandra/Util.hs @@ -38,9 +38,9 @@ writeTimeToUTC = posixSecondsToUTCTime . fromIntegral . (`div` 1000000) defInitCassandra :: Text -> Text -> Word16 -> Log.Logger -> IO ClientState defInitCassandra ks h p lg = - init $ - setLogger (CT.mkLogger lg) + init + $ setLogger (CT.mkLogger lg) . setPortNumber (fromIntegral p) . setContacts (unpack h) [] . setKeyspace (Keyspace ks) - $ defSettings + $ defSettings diff --git a/libs/deriving-swagger2/.ormolu b/libs/deriving-swagger2/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/deriving-swagger2/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/dns-util/.ormolu b/libs/dns-util/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/dns-util/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/extended/.ormolu b/libs/extended/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/extended/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/galley-types/.ormolu b/libs/galley-types/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/galley-types/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/galley-types/src/Galley/Types/Bot.hs b/libs/galley-types/src/Galley/Types/Bot.hs index 220f1b62df5..94837ee81e4 100644 --- a/libs/galley-types/src/Galley/Types/Bot.hs +++ b/libs/galley-types/src/Galley/Types/Bot.hs @@ -54,7 +54,8 @@ addBot = AddBot instance FromJSON AddBot where parseJSON = withObject "AddBot" $ \o -> - AddBot <$> o .: "service" + AddBot + <$> o .: "service" <*> o .: "conversation" <*> o .: "bot" <*> o .: "client" @@ -82,7 +83,8 @@ removeBot = RemoveBot instance FromJSON RemoveBot where parseJSON = withObject "RemoveBot" $ \o -> - RemoveBot <$> o .: "conversation" + RemoveBot + <$> o .: "conversation" <*> o .: "bot" instance ToJSON RemoveBot where diff --git a/libs/galley-types/src/Galley/Types/Bot/Service.hs b/libs/galley-types/src/Galley/Types/Bot/Service.hs index 2f557a1a25c..30d969dd739 100644 --- a/libs/galley-types/src/Galley/Types/Bot/Service.hs +++ b/libs/galley-types/src/Galley/Types/Bot/Service.hs @@ -53,7 +53,8 @@ newService ref url tok fps = Service ref url tok fps True instance FromJSON Service where parseJSON = withObject "Service" $ \o -> - Service <$> o .: "ref" + Service + <$> o .: "ref" <*> o .: "base_url" <*> o .: "auth_token" <*> o .: "fingerprints" diff --git a/libs/galley-types/src/Galley/Types/Conversations/One2One.hs b/libs/galley-types/src/Galley/Types/Conversations/One2One.hs index 00a61d2e666..bd2afdc7fd3 100644 --- a/libs/galley-types/src/Galley/Types/Conversations/One2One.hs +++ b/libs/galley-types/src/Galley/Types/Conversations/One2One.hs @@ -100,7 +100,8 @@ one2OneConvId a b = case compareDomains a b of ] x = hash c result = - U.toUUID . U.mk @U.V5 + U.toUUID + . U.mk @U.V5 . fromMaybe UUID.nil -- fromByteString only returns 'Nothing' when the input is not -- exactly 16 bytes long, here this should not be a case since diff --git a/libs/galley-types/src/Galley/Types/Teams/Intra.hs b/libs/galley-types/src/Galley/Types/Teams/Intra.hs index 31fee74e254..75369bc73a9 100644 --- a/libs/galley-types/src/Galley/Types/Teams/Intra.hs +++ b/libs/galley-types/src/Galley/Types/Teams/Intra.hs @@ -91,7 +91,8 @@ data TeamStatusUpdate = TeamStatusUpdate instance FromJSON TeamStatusUpdate where parseJSON = withObject "team-status-update" $ \o -> - TeamStatusUpdate <$> o .: "status" + TeamStatusUpdate + <$> o .: "status" <*> o .:? "currency" instance ToJSON TeamStatusUpdate where diff --git a/libs/gundeck-types/.ormolu b/libs/gundeck-types/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/gundeck-types/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs index c491d89963f..e71cfef2601 100644 --- a/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs +++ b/libs/gundeck-types/src/Gundeck/Types/Push/V2.hs @@ -141,7 +141,8 @@ recipient u r = Recipient u r RecipientClientsAll instance FromJSON Recipient where parseJSON = withObject "Recipient" $ \p -> - Recipient <$> p .: "user_id" + Recipient + <$> p .: "user_id" <*> p .: "route" <*> p .:? "clients" .!= RecipientClientsAll @@ -216,7 +217,8 @@ instance ToJSON ApsData where instance FromJSON ApsData where parseJSON = withObject "ApsData" $ \o -> - ApsData <$> o .: "loc_key" + ApsData + <$> o .: "loc_key" <*> o .:? "loc_args" .!= [] <*> o .:? "sound" <*> o .:? "preference" @@ -291,7 +293,8 @@ singletonPayload = List1.singleton . toJSONObject instance FromJSON Push where parseJSON = withObject "Push" $ \p -> - Push <$> p .: "recipients" + Push + <$> p .: "recipients" <*> p .:? "origin" <*> p .:? "connections" .!= Set.empty <*> p .:? "origin_connection" diff --git a/libs/hscim/.ormolu b/libs/hscim/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/hscim/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/hscim/src/Web/Scim/Class/Group.hs b/libs/hscim/src/Web/Scim/Class/Group.hs index 3386d19c2d5..6643d273830 100644 --- a/libs/hscim/src/Web/Scim/Class/Group.hs +++ b/libs/hscim/src/Web/Scim/Class/Group.hs @@ -87,25 +87,25 @@ data GroupSite tag route = GroupSite gsGetGroup :: route :- Capture "id" (GroupId tag) - :> Get '[SCIM] (StoredGroup tag), + :> Get '[SCIM] (StoredGroup tag), gsPostGroup :: route :- ReqBody '[SCIM] Group - :> PostCreated '[SCIM] (StoredGroup tag), + :> PostCreated '[SCIM] (StoredGroup tag), gsPutGroup :: route :- Capture "id" (GroupId tag) - :> ReqBody '[SCIM] Group - :> Put '[SCIM] (StoredGroup tag), + :> ReqBody '[SCIM] Group + :> Put '[SCIM] (StoredGroup tag), gsPatchGroup :: route :- Capture "id" (GroupId tag) - :> ReqBody '[SCIM] Aeson.Value - :> Patch '[SCIM] (StoredGroup tag), + :> ReqBody '[SCIM] Aeson.Value + :> Patch '[SCIM] (StoredGroup tag), gsDeleteGroup :: route :- Capture "id" (GroupId tag) - :> DeleteNoContent + :> DeleteNoContent } deriving (Generic) diff --git a/libs/hscim/src/Web/Scim/Class/User.hs b/libs/hscim/src/Web/Scim/Class/User.hs index 1d355dc9787..982ad3700e8 100644 --- a/libs/hscim/src/Web/Scim/Class/User.hs +++ b/libs/hscim/src/Web/Scim/Class/User.hs @@ -49,29 +49,29 @@ data UserSite tag route = UserSite { usGetUsers :: route :- QueryParam "filter" Filter - :> Get '[SCIM] (ListResponse (StoredUser tag)), + :> Get '[SCIM] (ListResponse (StoredUser tag)), usGetUser :: route :- Capture "id" (UserId tag) - :> Get '[SCIM] (StoredUser tag), + :> Get '[SCIM] (StoredUser tag), usPostUser :: route :- ReqBody '[SCIM] (User tag) - :> PostCreated '[SCIM] (StoredUser tag), + :> PostCreated '[SCIM] (StoredUser tag), usPutUser :: route :- Capture "id" (UserId tag) - :> ReqBody '[SCIM] (User tag) - :> Put '[SCIM] (StoredUser tag), + :> ReqBody '[SCIM] (User tag) + :> Put '[SCIM] (StoredUser tag), usPatchUser :: route :- Capture "id" (UserId tag) - :> ReqBody '[SCIM] (PatchOp tag) - :> Patch '[SCIM] (StoredUser tag), + :> ReqBody '[SCIM] (PatchOp tag) + :> Patch '[SCIM] (StoredUser tag), usDeleteUser :: route :- Capture "id" (UserId tag) - :> DeleteNoContent + :> DeleteNoContent } deriving (Generic) diff --git a/libs/hscim/src/Web/Scim/ContentType.hs b/libs/hscim/src/Web/Scim/ContentType.hs index 4b6a2e803f1..81aa5dd10e9 100644 --- a/libs/hscim/src/Web/Scim/ContentType.hs +++ b/libs/hscim/src/Web/Scim/ContentType.hs @@ -40,11 +40,11 @@ data SCIM instance Accept SCIM where contentTypes _ = - "application" // "scim+json" /: ("charset", "utf-8") - :| "application" // "scim+json" : - "application" // "json" /: ("charset", "utf-8") : - "application" // "json" : - [] + ("application" // "scim+json" /: ("charset", "utf-8")) + :| [ "application" // "scim+json", + "application" // "json" /: ("charset", "utf-8"), + "application" // "json" + ] instance ToJSON a => MimeRender SCIM a where mimeRender _ = mimeRender (Proxy @JSON) diff --git a/libs/hscim/src/Web/Scim/Schema/User.hs b/libs/hscim/src/Web/Scim/Schema/User.hs index 2da8ae9b31e..c453309b838 100644 --- a/libs/hscim/src/Web/Scim/Schema/User.hs +++ b/libs/hscim/src/Web/Scim/Schema/User.hs @@ -348,7 +348,7 @@ instance (UserTypes tag, FromJSON (User tag), Patchable (UserExtra tag)) => Patc | isUserSchema schema = applyUserOperation user op | isSupportedCustomSchema schema = (\x -> user {extra = x}) <$> applyOperation (extra user) op | otherwise = - throwError $ badRequest InvalidPath $ Just $ "we only support these schemas: " <> Text.intercalate ", " (map getSchemaUri (supportedSchemas @tag)) + throwError $ badRequest InvalidPath $ Just $ "we only support these schemas: " <> Text.intercalate ", " (map getSchemaUri (supportedSchemas @tag)) where isSupportedCustomSchema = maybe False (`elem` supportedSchemas @tag) applyOperation user op = applyUserOperation user op diff --git a/libs/hscim/src/Web/Scim/Server.hs b/libs/hscim/src/Web/Scim/Server.hs index 2d51c437159..2559a942d9d 100644 --- a/libs/hscim/src/Web/Scim/Server.hs +++ b/libs/hscim/src/Web/Scim/Server.hs @@ -70,13 +70,13 @@ data Site tag route = Site users :: route :- Header "Authorization" (AuthData tag) - :> "Users" - :> UserAPI tag, + :> "Users" + :> UserAPI tag, groups :: route :- Header "Authorization" (AuthData tag) - :> "Groups" - :> GroupAPI tag + :> "Groups" + :> GroupAPI tag } deriving (Generic) diff --git a/libs/hscim/src/Web/Scim/Server/Mock.hs b/libs/hscim/src/Web/Scim/Server/Mock.hs index adeccdb05df..11ffb37f60b 100644 --- a/libs/hscim/src/Web/Scim/Server/Mock.hs +++ b/libs/hscim/src/Web/Scim/Server/Mock.hs @@ -242,13 +242,13 @@ nt storage = filterUser :: Filter -> User extra -> Either Text Bool filterUser (FilterAttrCompare (AttrPath schema' attrib subAttr) op val) user | isUserSchema schema' = - case (subAttr, val) of - (Nothing, ValString str) - | attrib == "userName" -> - Right (compareStr op (CI.foldCase (userName user)) (CI.foldCase str)) - (Nothing, _) - | attrib == "userName" -> - Left "usernames can only be compared with strings" - (_, _) -> - Left "Only search on usernames is currently supported" + case (subAttr, val) of + (Nothing, ValString str) + | attrib == "userName" -> + Right (compareStr op (CI.foldCase (userName user)) (CI.foldCase str)) + (Nothing, _) + | attrib == "userName" -> + Left "usernames can only be compared with strings" + (_, _) -> + Left "Only search on usernames is currently supported" | otherwise = Left "Invalid schema. Only user schema is supported" diff --git a/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs index 867ce928379..70c5fd314c9 100644 --- a/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs +++ b/libs/hscim/test/Test/Schema/MetaSchemaSpec.hs @@ -95,5 +95,6 @@ genAuthenticationSchemeEncoding = do genSupported :: forall a. Gen a -> Gen (Supported a) genSupported gen = do - Supported <$> (ScimBool <$> Gen.bool) + Supported + <$> (ScimBool <$> Gen.bool) <*> gen diff --git a/libs/hscim/test/Test/Schema/PatchOpSpec.hs b/libs/hscim/test/Test/Schema/PatchOpSpec.hs index 6ddb155e07f..dc5323cfa9c 100644 --- a/libs/hscim/test/Test/Schema/PatchOpSpec.hs +++ b/libs/hscim/test/Test/Schema/PatchOpSpec.hs @@ -115,7 +115,7 @@ spec = do "operations": [] }|] `shouldSatisfy` (not . isSuccess) - --TODO(arianvp): We don't support arbitrary path names (yet) + -- TODO(arianvp): We don't support arbitrary path names (yet) it "roundtrips Path" $ require $ prop_roundtrip @PatchTestTag it "roundtrips PatchOp" $ require $ prop_roundtrip_PatchOp @PatchTestTag it "case-insensitive" $ require $ mk_prop_caseInsensitive (genSimplePatchOp @PatchTestTag) diff --git a/libs/hscim/test/Test/Schema/UserSpec.hs b/libs/hscim/test/Test/Schema/UserSpec.hs index 83b67eb2864..6ebcf1c4ae5 100644 --- a/libs/hscim/test/Test/Schema/UserSpec.hs +++ b/libs/hscim/test/Test/Schema/UserSpec.hs @@ -161,7 +161,8 @@ genStoredUser = do genMeta :: Gen Meta genMeta = - Meta <$> Gen.enumBounded + Meta + <$> Gen.enumBounded <*> Gen.element [read "2021-08-23 13:13:31.450140036 UTC", read "2019-01-01 09:55:59 UTC"] <*> Gen.element [read "2021-08-23 13:13:31.450140036 UTC", read "2022-01-01 09:55:59 UTC"] <*> (Gen.element [Weak, Strong] <*> Gen.text (Range.constant 0 20) Gen.unicode) diff --git a/libs/imports/.ormolu b/libs/imports/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/imports/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/jwt-tools/.ormolu b/libs/jwt-tools/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/jwt-tools/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/metrics-core/.ormolu b/libs/metrics-core/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/metrics-core/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/metrics-wai/.ormolu b/libs/metrics-wai/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/metrics-wai/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/polysemy-wire-zoo/.ormolu b/libs/polysemy-wire-zoo/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/polysemy-wire-zoo/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/ropes/.ormolu b/libs/ropes/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/ropes/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/ropes/src/Ropes/Nexmo.hs b/libs/ropes/src/Ropes/Nexmo.hs index ba770c4db4d..6ff2034564d 100644 --- a/libs/ropes/src/Ropes/Nexmo.hs +++ b/libs/ropes/src/Ropes/Nexmo.hs @@ -78,7 +78,8 @@ data Credentials = Credentials instance FromJSON Credentials where parseJSON = withObject "credentials" $ \o -> - Credentials <$> o .: "key" + Credentials + <$> o .: "key" <*> o .: "secret" -- * SMS related @@ -135,7 +136,8 @@ instance Exception MessageErrorResponse instance FromJSON MessageErrorResponse where parseJSON = withObject "message-error-response" $ \o -> - MessageErrorResponse <$> o .: "status" + MessageErrorResponse + <$> o .: "status" <*> o .:? "error-text" newtype ParseError = ParseError String @@ -225,7 +227,8 @@ instance Exception CallErrorResponse instance FromJSON CallErrorResponse where parseJSON = withObject "call-error-response" $ \o -> - CallErrorResponse <$> o .: "status" + CallErrorResponse + <$> o .: "status" <*> o .:? "error-text" -- * Internal call parsers diff --git a/libs/ropes/src/Ropes/Twilio.hs b/libs/ropes/src/Ropes/Twilio.hs index 9776ffffdee..659e4dd0df4 100644 --- a/libs/ropes/src/Ropes/Twilio.hs +++ b/libs/ropes/src/Ropes/Twilio.hs @@ -69,7 +69,8 @@ data Credentials = Credentials instance FromJSON Credentials where parseJSON = withObject "credentials" $ \o -> - Credentials <$> (SID . encodeUtf8 <$> o .: "sid") + Credentials + <$> (SID . encodeUtf8 <$> o .: "sid") <*> (AccessToken . encodeUtf8 <$> o .: "token") data Message = Message @@ -91,7 +92,8 @@ instance Exception ErrorResponse instance FromJSON ErrorResponse where parseJSON = withObject "error-response" $ \o -> - ErrorResponse <$> o .: "status" + ErrorResponse + <$> o .: "status" <*> o .: "message" <*> o .:? "code" <*> o .:? "more_info" @@ -132,12 +134,14 @@ data PhoneType instance FromJSON LookupResult where parseJSON = withObject "LookupResult" $ \o -> - LookupResult <$> o .: "phone_number" + LookupResult + <$> o .: "phone_number" <*> o .:? "carrier" instance FromJSON CarrierInfo where parseJSON = withObject "CarrierInfo" $ \o -> - CarrierInfo <$> o .:? "name" + CarrierInfo + <$> o .:? "name" <*> o .:? "type" instance FromJSON PhoneType where diff --git a/libs/schema-profunctor/.ormolu b/libs/schema-profunctor/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/schema-profunctor/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/schema-profunctor/test/unit/Test/Data/Schema.hs b/libs/schema-profunctor/test/unit/Test/Data/Schema.hs index 0a4c79d1929..3f6d2e5c311 100644 --- a/libs/schema-profunctor/test/unit/Test/Data/Schema.hs +++ b/libs/schema-profunctor/test/unit/Test/Data/Schema.hs @@ -298,7 +298,8 @@ testRefField = testCase "Reference in a field" $ do let (defs, _) = S.runDeclare (S.declareSchemaRef (Proxy @Named)) mempty assertBool "Referenced schema should be declared" $ - not . nullOf (ix "Name") $ defs + not . nullOf (ix "Name") $ + defs testRmClientWrong :: TestTree testRmClientWrong = @@ -511,10 +512,11 @@ instance ToSchema Tag where instance ToSchema TaggedObject where schema = object "TaggedObject" $ - uncurry TO <$> (toTag &&& toObj) - .= bind - (fst .= field "tag" schema) - (snd .= fieldOver _1 "obj" (objectOver _1 "UntaggedObject" untaggedSchema)) + uncurry TO + <$> (toTag &&& toObj) + .= bind + (fst .= field "tag" schema) + (snd .= fieldOver _1 "obj" (objectOver _1 "UntaggedObject" untaggedSchema)) where untaggedSchema = dispatch $ \case Tag1 -> tag _Obj1 (field "tag1_data" schema) @@ -601,10 +603,11 @@ tagSchema = detailSchema :: ValueSchema NamedSwaggerDoc Detail detailSchema = object "Detail" $ - fromTagged <$> toTagged - .= bind - (fst .= field "tag" tagSchema) - (snd .= fieldOver _1 "value" untaggedSchema) + fromTagged + <$> toTagged + .= bind + (fst .= field "tag" tagSchema) + (snd .= fieldOver _1 "value" untaggedSchema) where toTagged :: Detail -> (DetailTag, Detail) toTagged d@(Name _) = (NameTag, d) diff --git a/libs/sodium-crypto-sign/.ormolu b/libs/sodium-crypto-sign/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/sodium-crypto-sign/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/ssl-util/.ormolu b/libs/ssl-util/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/ssl-util/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/tasty-cannon/.ormolu b/libs/tasty-cannon/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/tasty-cannon/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/types-common-aws/.ormolu b/libs/types-common-aws/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/types-common-aws/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/types-common-journal/.ormolu b/libs/types-common-journal/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/types-common-journal/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/types-common/.ormolu b/libs/types-common/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/types-common/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index 0807be0e76e..c049381e78d 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -273,7 +273,7 @@ instance ToSchema HttpsUrl where schema = (decodeUtf8 . toByteString') .= parsedText "HttpsUrl" (runParser parser . encodeUtf8) - & doc' . S.schema . S.example ?~ toJSON ("https://example.com" :: Text) + & doc' . S.schema . S.example ?~ toJSON ("https://example.com" :: Text) instance Cql HttpsUrl where ctype = Tagged BlobColumn @@ -318,7 +318,8 @@ deriving via instance ToSchema (Fingerprint Rsa) where schema = (decodeUtf8 . B64.encode . fingerprintBytes) - .= parsedText "Fingerprint" (runParser p . encodeUtf8) & doc' . S.schema . S.example ?~ toJSON ("ioy3GeIjgQRsobf2EKGO3O8mq/FofFxHRqy0T4ERIZ8=" :: Text) + .= parsedText "Fingerprint" (runParser p . encodeUtf8) + & doc' . S.schema . S.example ?~ toJSON ("ioy3GeIjgQRsobf2EKGO3O8mq/FofFxHRqy0T4ERIZ8=" :: Text) where p :: Chars.Parser (Fingerprint Rsa) p = do diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index 0eb22eb4d5e..6e85b55c07a 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -121,9 +121,9 @@ qualifyAs = ($>) foldQualified :: Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b foldQualified loc f g q | tDomain loc == qDomain q = - f (qTagUnsafe q) + f (qTagUnsafe q) | otherwise = - g (qTagUnsafe q) + g (qTagUnsafe q) -- Partition a collection of qualified values into locals and remotes. -- diff --git a/libs/types-common/src/Util/Options.hs b/libs/types-common/src/Util/Options.hs index b5f7f8f048c..06d65cfb1fb 100644 --- a/libs/types-common/src/Util/Options.hs +++ b/libs/types-common/src/Util/Options.hs @@ -138,7 +138,8 @@ getOptions desc pars defaultPath = do -- Config doesn't exist but at least we have a CLI options parser (False, Just p) -> do hPutStrLn stderr $ - "Config file at " ++ path + "Config file at " + ++ path ++ " does not exist, falling back to command-line arguments. \n" execParser (info (helper <*> p) mkDesc) -- No config, no parser :( @@ -159,7 +160,9 @@ parseConfigPath defaultPath desc = do pathParser :: Parser String pathParser = strOption $ - long "config-file" <> short 'c' <> help "Config file to load" + long "config-file" + <> short 'c' + <> help "Config file to load" <> showDefault <> value defaultPath diff --git a/libs/wai-utilities/.ormolu b/libs/wai-utilities/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/wai-utilities/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs index aff82534191..01b7a4cee8f 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Error.hs @@ -86,7 +86,8 @@ instance ToJSON Error where instance FromJSON Error where parseJSON = withObject "Error" $ \o -> - Error <$> (toEnum <$> o .: "code") + Error + <$> (toEnum <$> o .: "code") <*> o .: "label" <*> o .: "message" <*> o .:? "data" diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index ea4708a3253..83aeac19a6a 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -103,14 +103,14 @@ newSettings (Server h p l m t) = do -- (Atomically) initialise the standard metrics, to avoid races. void $ gaugeGet (path "net.connections") m void $ counterGet (path "net.errors") m - pure $ - setHost (fromString h) + pure + $ setHost (fromString h) . setPort (fromIntegral p) . setBeforeMainLoop logStart . setOnOpen (const $ connStart >> pure True) . setOnClose (const connEnd) . setTimeout (fromMaybe 300 t) - $ defaultSettings + $ defaultSettings where connStart = gaugeIncr (path "net.connections") m connEnd = gaugeDecr (path "net.connections") m @@ -312,8 +312,8 @@ rethrow5xx logger app req k = app req k' -- an unnecessary wrapper. wrapError :: Status -> LByteString -> Wai.Error wrapError st body = - decode body - ?: Wai.mkError st "server-error" (cs body) + decode body ?: + Wai.mkError st "server-error" (cs body) -- | This flushes the response! If you want to keep using the response, you need to construct -- a new one with a fresh body stream. diff --git a/libs/wire-api-federation/.ormolu b/libs/wire-api-federation/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/wire-api-federation/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index a2f3f1896fa..906017a6fec 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -265,25 +265,25 @@ mkFailureResponse status domain path body -- client, since it is always due to a server issue, so we map it to a 500 -- error. | HTTP.statusCode status == 403 = - Wai.mkError - HTTP.status500 - "federation-local-error" - ( "Local federator failure: " - <> LText.decodeUtf8With Text.lenientDecode body - ) + Wai.mkError + HTTP.status500 + "federation-local-error" + ( "Local federator failure: " + <> LText.decodeUtf8With Text.lenientDecode body + ) -- Any other error is interpreted as a correctly formatted wai error, and -- returned to the client. | otherwise = - (fromMaybe defaultError (Aeson.decode body)) - { Wai.errorData = - Just - Wai.FederationErrorData - { Wai.federrDomain = domain, - Wai.federrPath = - "/federation" - <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path) - } - } + (fromMaybe defaultError (Aeson.decode body)) + { Wai.errorData = + Just + Wai.FederationErrorData + { Wai.federrDomain = domain, + Wai.federrPath = + "/federation" + <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path) + } + } where defaultError = Wai.mkError diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs b/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs index 2dec5a76a39..cada1b48728 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Endpoint.hs @@ -38,6 +38,8 @@ type FedEndpoint name input output = FedEndpointWithMods '[] name input output type StreamingFedEndpoint name input output = Named name - ( name :> OriginDomainHeader :> ReqBody '[JSON] input + ( name + :> OriginDomainHeader + :> ReqBody '[JSON] input :> StreamPost NoFraming OctetStream output ) diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs index f9353cc061a..b56149ae488 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs @@ -270,7 +270,8 @@ federationServantErrorToWai (UnsupportedContentType mediaType res) = Wai.mkError unexpectedFederationResponseStatus "federation-unsupported-content-type" - ( "Content-type: " <> federationErrorContentType res + ( "Content-type: " + <> federationErrorContentType res <> ", Media-Type: " <> LT.pack (show mediaType) ) diff --git a/libs/wire-api/.ormolu b/libs/wire-api/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/wire-api/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/wire-api/src/Wire/API/Asset.hs b/libs/wire-api/src/Wire/API/Asset.hs index 2020b1d5576..d90ace2b2f2 100644 --- a/libs/wire-api/src/Wire/API/Asset.hs +++ b/libs/wire-api/src/Wire/API/Asset.hs @@ -178,7 +178,7 @@ instance ToSchema AssetKey where schema = assetKeyToText .= parsedText "AssetKey" (runParser parser . T.encodeUtf8) - & doc' . S.schema . S.example ?~ toJSON ("3-1-47de4580-ae51-4650-acbb-d10c028cb0ac" :: Text) + & doc' . S.schema . S.example ?~ toJSON ("3-1-47de4580-ae51-4650-acbb-d10c028cb0ac" :: Text) instance S.ToParamSchema AssetKey where toParamSchema _ = S.toParamSchema (Proxy @Text) @@ -200,9 +200,10 @@ newtype AssetToken = AssetToken {assetTokenAscii :: AsciiBase64Url} instance ToSchema AssetToken where schema = - AssetToken <$> assetTokenAscii - .= schema - & doc' . S.schema . S.example ?~ toJSON ("aGVsbG8" :: Text) + AssetToken + <$> assetTokenAscii + .= schema + & doc' . S.schema . S.example ?~ toJSON ("aGVsbG8" :: Text) instance S.ToParamSchema AssetToken where toParamSchema _ = S.toParamSchema (Proxy @Text) diff --git a/libs/wire-api/src/Wire/API/Conversation.hs b/libs/wire-api/src/Wire/API/Conversation.hs index affad99eb3f..8bcafda6edb 100644 --- a/libs/wire-api/src/Wire/API/Conversation.hs +++ b/libs/wire-api/src/Wire/API/Conversation.hs @@ -174,7 +174,8 @@ accessRolesSchemaOpt = toOutput .= accessRolesSchemaTuple `withParser` validate accessRolesSchemaTuple :: ObjectSchema SwaggerDoc (Maybe AccessRoleLegacy, Maybe (Set AccessRoleV2)) accessRolesSchemaTuple = - (,) <$> fst .= optFieldWithDocModifier "access_role" (description ?~ "Deprecated, please use access_role_v2") (maybeWithDefault A.Null schema) + (,) + <$> fst .= optFieldWithDocModifier "access_role" (description ?~ "Deprecated, please use access_role_v2") (maybeWithDefault A.Null schema) <*> snd .= optFieldWithDocModifier "access_role_v2" (description ?~ desc) (maybeWithDefault A.Null $ set schema) where desc = "This field is optional. If it is not present, the default will be `[team_member, non_team_member, service]`. Please note that an empty list is not allowed when creating a new conversation." diff --git a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs index 408f10ecb6a..30ca0b6591d 100644 --- a/libs/wire-api/src/Wire/API/Conversation/Protocol.hs +++ b/libs/wire-api/src/Wire/API/Conversation/Protocol.hs @@ -96,10 +96,11 @@ protocolTagSchema = fmap (fromMaybe ProtocolProteusTag) (optField "protocol" sch protocolSchema :: ObjectSchema SwaggerDoc Protocol protocolSchema = - snd <$> (protocolTag &&& id) - .= bind - (fst .= protocolTagSchema) - (snd .= dispatch protocolDataSchema) + snd + <$> (protocolTag &&& id) + .= bind + (fst .= protocolTagSchema) + (snd .= dispatch protocolDataSchema) instance ToSchema Protocol where schema = object "Protocol" protocolSchema @@ -116,17 +117,17 @@ mlsDataSchema :: ObjectSchema SwaggerDoc ConversationMLSData mlsDataSchema = ConversationMLSData <$> cnvmlsGroupId - .= fieldWithDocModifier - "group_id" - (description ?~ "An MLS group identifier (at most 256 bytes long)") - schema + .= fieldWithDocModifier + "group_id" + (description ?~ "An MLS group identifier (at most 256 bytes long)") + schema <*> cnvmlsEpoch - .= fieldWithDocModifier - "epoch" - (description ?~ "The epoch number of the corresponding MLS group") - schema + .= fieldWithDocModifier + "epoch" + (description ?~ "The epoch number of the corresponding MLS group") + schema <*> cnvmlsCipherSuite - .= fieldWithDocModifier - "cipher_suite" - (description ?~ "The cipher suite of the corresponding MLS group") - schema + .= fieldWithDocModifier + "cipher_suite" + (description ?~ "The cipher suite of the corresponding MLS group") + schema diff --git a/libs/wire-api/src/Wire/API/Internal/Notification.hs b/libs/wire-api/src/Wire/API/Internal/Notification.hs index 7d28908e10e..5bdfaa6e822 100644 --- a/libs/wire-api/src/Wire/API/Internal/Notification.hs +++ b/libs/wire-api/src/Wire/API/Internal/Notification.hs @@ -60,7 +60,8 @@ data Notification = Notification instance FromJSON Notification where parseJSON = withObject "notification" $ \o -> - Notification <$> o .: "id" + Notification + <$> o .: "id" <*> o .:? "transient" .!= False <*> o .: "payload" @@ -88,7 +89,8 @@ target u = NotificationTarget u [] instance FromJSON NotificationTarget where parseJSON = withObject "NotificationTarget" $ \o -> - NotificationTarget <$> o .: "user" + NotificationTarget + <$> o .: "user" <*> o .: "clients" instance ToJSON NotificationTarget where diff --git a/libs/wire-api/src/Wire/API/MLS/Credential.hs b/libs/wire-api/src/Wire/API/MLS/Credential.hs index 4b7d62f99ee..e695eba1d98 100644 --- a/libs/wire-api/src/Wire/API/MLS/Credential.hs +++ b/libs/wire-api/src/Wire/API/MLS/Credential.hs @@ -191,7 +191,8 @@ signaturePurposeFromName :: Text -> Either String SignaturePurpose signaturePurposeFromName name = note ("Unsupported signature purpose " <> T.unpack name) . getAlt - $ flip foldMap [minBound .. maxBound] $ \s -> + $ flip foldMap [minBound .. maxBound] + $ \s -> guard (signaturePurposeName s == name) $> s instance FromJSON SignaturePurpose where diff --git a/libs/wire-api/src/Wire/API/MLS/Group.hs b/libs/wire-api/src/Wire/API/MLS/Group.hs index 54a5fff5138..647e5330168 100644 --- a/libs/wire-api/src/Wire/API/MLS/Group.hs +++ b/libs/wire-api/src/Wire/API/MLS/Group.hs @@ -48,7 +48,7 @@ instance ToSchema GroupId where schema = GroupId <$> unGroupId - .= named "GroupId" (Base64ByteString .= fmap fromBase64ByteString (unnamed schema)) + .= named "GroupId" (Base64ByteString .= fmap fromBase64ByteString (unnamed schema)) -- | Return the group ID associated to a conversation ID. Note that is not -- assumed to be stable over time or even consistent among different backends. diff --git a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs index 1a878a40b39..4d213c71b06 100644 --- a/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs +++ b/libs/wire-api/src/Wire/API/MLS/KeyPackage.hs @@ -78,8 +78,9 @@ newtype KeyPackageData = KeyPackageData {kpData :: ByteString} instance ToSchema KeyPackageData where schema = (S.schema %~ addKeyPackageSwagger) - ( KeyPackageData <$> kpData - .= named "KeyPackage" base64Schema + ( KeyPackageData + <$> kpData + .= named "KeyPackage" base64Schema ) instance Cql KeyPackageData where diff --git a/libs/wire-api/src/Wire/API/MLS/Keys.hs b/libs/wire-api/src/Wire/API/MLS/Keys.hs index 0aa187bb8cb..96841a46868 100644 --- a/libs/wire-api/src/Wire/API/MLS/Keys.hs +++ b/libs/wire-api/src/Wire/API/MLS/Keys.hs @@ -54,8 +54,9 @@ newtype MLSPublicKeys = MLSPublicKeys instance ToSchema MLSPublicKeys where schema = named "MLSKeys" $ - MLSPublicKeys <$> unMLSPublicKeys - .= map_ (map_ base64Schema) + MLSPublicKeys + <$> unMLSPublicKeys + .= map_ (map_ base64Schema) mlsKeysToPublic1 :: MLSKeys -> Map SignatureSchemeTag ByteString mlsKeysToPublic1 (MLSKeys mEd25519key) = diff --git a/libs/wire-api/src/Wire/API/MLS/Proposal.hs b/libs/wire-api/src/Wire/API/MLS/Proposal.hs index 4264a319183..b67ec6223fa 100644 --- a/libs/wire-api/src/Wire/API/MLS/Proposal.hs +++ b/libs/wire-api/src/Wire/API/MLS/Proposal.hs @@ -142,9 +142,9 @@ instance ParseMLS ReInit where parseMLS = ReInit <$> parseMLS - <*> parseMLS - <*> parseMLS - <*> parseMLSVector @Word32 parseMLS + <*> parseMLS + <*> parseMLS + <*> parseMLSVector @Word32 parseMLS data MessageRange = MessageRange { mrSender :: KeyPackageRef, diff --git a/libs/wire-api/src/Wire/API/Message.hs b/libs/wire-api/src/Wire/API/Message.hs index f5676a013f2..e0dc107f817 100644 --- a/libs/wire-api/src/Wire/API/Message.hs +++ b/libs/wire-api/src/Wire/API/Message.hs @@ -295,7 +295,8 @@ mkQualifiedOtrPayload sender entries dat strat = } where mkRecipients = - QualifiedOtrRecipients . QualifiedUserClientMap + QualifiedOtrRecipients + . QualifiedUserClientMap . foldr ( \(Qualified u d, c, t) -> Map.insertWith @@ -376,7 +377,8 @@ modelOtrRecipients = Doc.defineModel "OtrRecipients" $ do protoToOtrRecipients :: [Proto.UserEntry] -> OtrRecipients protoToOtrRecipients = - OtrRecipients . UserClientMap + OtrRecipients + . UserClientMap . foldl' userEntries mempty where userEntries :: Map UserId (Map ClientId Text) -> Proto.UserEntry -> Map UserId (Map ClientId Text) @@ -542,7 +544,10 @@ data ClientMismatch = ClientMismatch instance Arbitrary ClientMismatch where arbitrary = ClientMismatch - <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary modelClientMismatch :: Doc.Model modelClientMismatch = Doc.defineModel "ClientMismatch" $ do diff --git a/libs/wire-api/src/Wire/API/Notification.hs b/libs/wire-api/src/Wire/API/Notification.hs index eef2c3f34c2..954cc65d786 100644 --- a/libs/wire-api/src/Wire/API/Notification.hs +++ b/libs/wire-api/src/Wire/API/Notification.hs @@ -92,9 +92,9 @@ instance ToSchema QueuedNotification where object "QueuedNotification" $ QueuedNotification <$> _queuedNotificationId - .= field "id" schema + .= field "id" schema <*> _queuedNotificationPayload - .= field "payload" (nonEmptyArray jsonObject) + .= field "payload" (nonEmptyArray jsonObject) makeLenses ''QueuedNotification @@ -131,11 +131,11 @@ instance ToSchema QueuedNotificationList where object "QueuedNotificationList" $ QueuedNotificationList <$> _queuedNotifications - .= field "notifications" (array schema) + .= field "notifications" (array schema) <*> _queuedHasMore - .= fmap (fromMaybe False) (optField "has_more" schema) + .= fmap (fromMaybe False) (optField "has_more" schema) <*> _queuedTime - .= maybe_ (optField "time" utcTimeSchema) + .= maybe_ (optField "time" utcTimeSchema) makeLenses ''QueuedNotificationList diff --git a/libs/wire-api/src/Wire/API/Push/V2/Token.hs b/libs/wire-api/src/Wire/API/Push/V2/Token.hs index d55d9055521..d5a9174f227 100644 --- a/libs/wire-api/src/Wire/API/Push/V2/Token.hs +++ b/libs/wire-api/src/Wire/API/Push/V2/Token.hs @@ -74,7 +74,7 @@ instance ToSchema PushTokenList where objectWithDocModifier "PushTokenList" (description ?~ "List of Native Push Tokens") $ PushTokenList <$> pushTokens - .= fieldWithDocModifier "tokens" (description ?~ "Push tokens") (array schema) + .= fieldWithDocModifier "tokens" (description ?~ "Push tokens") (array schema) data PushToken = PushToken { _tokenTransport :: Transport, @@ -94,13 +94,13 @@ instance ToSchema PushToken where objectWithDocModifier "PushToken" desc $ PushToken <$> _tokenTransport - .= fieldWithDocModifier "transport" transDesc schema + .= fieldWithDocModifier "transport" transDesc schema <*> _tokenApp - .= fieldWithDocModifier "app" appDesc schema + .= fieldWithDocModifier "app" appDesc schema <*> _token - .= fieldWithDocModifier "token" tokenDesc schema + .= fieldWithDocModifier "token" tokenDesc schema <*> _tokenClient - .= fieldWithDocModifier "client" clientIdDesc schema + .= fieldWithDocModifier "client" clientIdDesc schema where desc = description ?~ "Native Push Token" transDesc = description ?~ "Transport" diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 5f0c5fe255a..3192f9ca004 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -156,7 +156,8 @@ type AccountAPI = ) :<|> Named "createUserNoVerifySpar" - ( "users" :> "spar" + ( "users" + :> "spar" :> ReqBody '[Servant.JSON] NewUserSpar :> MultiVerb 'POST '[Servant.JSON] CreateUserSparInternalResponses (Either CreateUserSparError SelfProfile) ) @@ -175,8 +176,8 @@ instance ToSchema NewKeyPackageRef where object "NewKeyPackageRef" $ NewKeyPackageRef <$> nkprUserId .= field "user_id" schema - <*> nkprClientId .= field "client_id" schema - <*> nkprConversation .= field "conversation" schema + <*> nkprClientId .= field "client_id" schema + <*> nkprConversation .= field "conversation" schema data NewKeyPackage = NewKeyPackage { nkpConversation :: Qualified ConvId, @@ -190,7 +191,7 @@ instance ToSchema NewKeyPackage where object "NewKeyPackage" $ NewKeyPackage <$> nkpConversation .= field "conversation" schema - <*> nkpKeyPackage .= field "key_package" schema + <*> nkpKeyPackage .= field "key_package" schema data NewKeyPackageResult = NewKeyPackageResult { nkpresClientIdentity :: ClientIdentity, @@ -204,11 +205,12 @@ instance ToSchema NewKeyPackageResult where object "NewKeyPackageResult" $ NewKeyPackageResult <$> nkpresClientIdentity .= field "client_identity" schema - <*> nkpresKeyPackageRef .= field "key_package_ref" schema + <*> nkpresKeyPackageRef .= field "key_package_ref" schema type MLSAPI = "mls" - :> ( ( "key-packages" :> Capture "ref" KeyPackageRef + :> ( ( "key-packages" + :> Capture "ref" KeyPackageRef :> ( Named "get-client-by-key-package-ref" ( Summary "Resolve an MLS key package ref to a qualified client ID" @@ -376,7 +378,8 @@ type AuthAPI = ) :<|> Named "login-code" - ( "users" :> "login-code" + ( "users" + :> "login-code" :> QueryParam' [Required, Strict] "phone" Phone :> MultiVerb1 'GET '[JSON] (Respond 200 "Login code" PendingLoginCode) ) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs b/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs index a09f8bfb107..530449cbfd8 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/LegalHold.hs @@ -22,8 +22,14 @@ import Servant.API hiding (Header, WithStatus) import Wire.API.Team.Feature type InternalLegalHoldAPI = - "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" + "i" + :> "teams" + :> Capture "tid" TeamId + :> "legalhold" :> Get '[JSON] (WithStatus LegalholdConfig) - :<|> "i" :> "teams" :> Capture "tid" TeamId :> "legalhold" + :<|> "i" + :> "teams" + :> Capture "tid" TeamId + :> "legalhold" :> ReqBody '[JSON] (WithStatusNoLock LegalholdConfig) :> Put '[] NoContent diff --git a/libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs b/libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs index ef2ec8bbe7d..a6fef5f7f4d 100644 --- a/libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs +++ b/libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs @@ -71,7 +71,8 @@ instance accCheck = when (isNothing cmediatype) $ delayedFail err406 contentHeader = (hContentType, HTTP.renderHeader . maybeToList $ cmediatype) in runAction - ( action `addMethodCheck` methodCheck method request + ( action + `addMethodCheck` methodCheck method request `addAcceptCheck` accCheck ) env diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index 20d7505f8f7..d05be1286ad 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -483,8 +483,9 @@ combineSwaggerSchema s1 s2 -- if they are both errors, merge label enums | notNullOf (S.properties . ix "code") s1 && notNullOf (S.properties . ix "code") s2 = - s1 & S.properties . ix "label" . S._Inline . S.enum_ . _Just - <>~ (s2 ^. S.properties . ix "label" . S._Inline . S.enum_ . _Just) + s1 + & S.properties . ix "label" . S._Inline . S.enum_ . _Just + <>~ (s2 ^. S.properties . ix "label" . S._Inline . S.enum_ . _Just) | otherwise = s1 -- | This type can be used in Servant to produce an endpoint which can return @@ -819,7 +820,8 @@ instance route _ _ action = leafRouter $ \env req k -> do let acc = getAcceptHeader req action' = - action `addMethodCheck` methodCheck method req + action + `addMethodCheck` methodCheck method req `addAcceptCheck` acceptCheck' (Proxy @cs) acc runAction action' env req k $ \output -> do let mresp = responseListRender @cs @as acc (toUnion @as output) diff --git a/libs/wire-api/src/Wire/API/Routes/Public.hs b/libs/wire-api/src/Wire/API/Routes/Public.hs index fd3d7748252..e3768695adf 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public.hs @@ -222,13 +222,13 @@ instance checkType token req = case (token, lookup "Z-Type" (Wai.requestHeaders req)) of (Just t, value) | value /= Just t -> - delayedFail - ServerError - { errHTTPCode = 403, - errReasonPhrase = "Access denied", - errBody = "", - errHeaders = [] - } + delayedFail + ServerError + { errHTTPCode = 403, + errReasonPhrase = "Access denied", + errBody = "", + errHeaders = [] + } _ -> pure () hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 6c429a73825..3a0d8698544 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -1158,7 +1158,8 @@ type AuthAPI = ) :<|> Named "send-login-code" - ( "login" :> "send" + ( "login" + :> "send" :> Summary "Send a login code to a verified phone number" :> Description "This operation generates and sends a login code via sms for phone login.\ @@ -1196,7 +1197,8 @@ type AuthAPI = ) :<|> Named "logout" - ( "access" :> "logout" + ( "access" + :> "logout" :> Summary "Log out in order to remove a cookie from the server" :> Description "Calling this endpoint will effectively revoke the given cookie\ @@ -1209,7 +1211,9 @@ type AuthAPI = ) :<|> Named "change-self-email" - ( "access" :> "self" :> "email" + ( "access" + :> "self" + :> "email" :> Summary "Change your email address" :> Cookies '["zuid" ::: SomeUserToken] :> Bearer SomeAccessToken @@ -1240,7 +1244,8 @@ type AuthAPI = ) :<|> Named "remove-cookies" - ( "cookies" :> "remove" + ( "cookies" + :> "remove" :> Summary "Revoke stored cookies" :> ZLocalUser :> CanThrow 'BadCredentials diff --git a/libs/wire-api/src/Wire/API/SwaggerHelper.hs b/libs/wire-api/src/Wire/API/SwaggerHelper.hs index 7d433825217..055d98d1069 100644 --- a/libs/wire-api/src/Wire/API/SwaggerHelper.hs +++ b/libs/wire-api/src/Wire/API/SwaggerHelper.hs @@ -31,7 +31,9 @@ cleanupSwagger = -- sanitise general responses . (S.responses . traverse . S.schema . _Just . S._Inline %~ sanitise) -- sanitise all responses of all paths - . ( S.allOperations . S.responses . S.responses + . ( S.allOperations + . S.responses + . S.responses . traverse . S._Inline . S.schema diff --git a/libs/wire-api/src/Wire/API/Team.hs b/libs/wire-api/src/Wire/API/Team.hs index bcebae30ac7..de679ad4705 100644 --- a/libs/wire-api/src/Wire/API/Team.hs +++ b/libs/wire-api/src/Wire/API/Team.hs @@ -181,7 +181,8 @@ modelTeamList = Doc.defineModel "TeamList" $ do instance ToSchema TeamList where schema = object "TeamList" $ - TeamList <$> _teamListTeams .= field "teams" (array schema) + TeamList + <$> _teamListTeams .= field "teams" (array schema) <*> _teamListHasMore .= field "has_more" schema -------------------------------------------------------------------------------- diff --git a/libs/wire-api/src/Wire/API/Team/LegalHold.hs b/libs/wire-api/src/Wire/API/Team/LegalHold.hs index 59f5b40cdf8..d4f93a235aa 100644 --- a/libs/wire-api/src/Wire/API/Team/LegalHold.hs +++ b/libs/wire-api/src/Wire/API/Team/LegalHold.hs @@ -90,8 +90,9 @@ instance ToSchema LHServiceStatus where instance ToSchema ViewLegalHoldService where schema = - object "ViewLegalHoldService" $ - toOutput .= recordSchema `withParser` validateViewLegalHoldService + object "ViewLegalHoldService" + $ toOutput .= recordSchema + `withParser` validateViewLegalHoldService where toOutput :: ViewLegalHoldService -> (LHServiceStatus, Maybe ViewLegalHoldServiceInfo) toOutput = \case diff --git a/libs/wire-api/src/Wire/API/Team/Member.hs b/libs/wire-api/src/Wire/API/Team/Member.hs index 5a0f59e4c94..ce8fa5e51f3 100644 --- a/libs/wire-api/src/Wire/API/Team/Member.hs +++ b/libs/wire-api/src/Wire/API/Team/Member.hs @@ -307,7 +307,8 @@ newTeamMemberSchema = invitedSchema :: ObjectSchemaP SwaggerDoc (Maybe (UserId, UTCTimeMillis)) (Maybe UserId, Maybe UTCTimeMillis) invitedSchema = - (,) <$> fmap fst .= optFieldWithDocModifier "created_by" (description ?~ "ID of the inviting user. Requires created_at.") (maybeWithDefault Null schema) + (,) + <$> fmap fst .= optFieldWithDocModifier "created_by" (description ?~ "ID of the inviting user. Requires created_at.") (maybeWithDefault Null schema) <*> fmap snd .= optFieldWithDocModifier "created_at" (description ?~ "Timestamp of invitation creation. Requires created_by.") (maybeWithDefault Null schema) invitedSchema' :: ObjectSchema SwaggerDoc (Maybe (UserId, UTCTimeMillis)) @@ -320,7 +321,8 @@ invitedSchema' = withParser invitedSchema $ \(invby, invat) -> instance ToSchema NewTeamMember where schema = objectWithDocModifier "NewTeamMember" (description ?~ "Required data when creating new team members") $ - fieldWithDocModifier "member" (description ?~ "the team member to add (the legalhold_status field must be null or missing!)") $ unnamed (object "Unnamed" newTeamMemberSchema) + fieldWithDocModifier "member" (description ?~ "the team member to add (the legalhold_status field must be null or missing!)") $ + unnamed (object "Unnamed" newTeamMemberSchema) -------------------------------------------------------------------------------- -- TeamMemberDeleteData diff --git a/libs/wire-api/src/Wire/API/Team/Permission.hs b/libs/wire-api/src/Wire/API/Team/Permission.hs index e6fe0aafb4e..4b5c7802351 100644 --- a/libs/wire-api/src/Wire/API/Team/Permission.hs +++ b/libs/wire-api/src/Wire/API/Team/Permission.hs @@ -73,7 +73,8 @@ data Permissions = Permissions permissionsSchema :: ValueSchemaP NamedSwaggerDoc Permissions (Set Perm, Set Perm) permissionsSchema = object "Permissions" $ - (,) <$> (permsToInt . _self) .= field "self" (intToPerms <$> schema) + (,) + <$> (permsToInt . _self) .= field "self" (intToPerms <$> schema) <*> (permsToInt . _copy) .= field "copy" (intToPerms <$> schema) instance ToSchema Permissions where diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index ac94b013412..c9eeca6cd07 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -501,13 +501,13 @@ instance ToSchema NewUserPublic where validateNewUserPublic :: NewUser -> Either String NewUserPublic validateNewUserPublic nu | isJust (newUserSSOId nu) = - Left "SSO-managed users are not allowed here." + Left "SSO-managed users are not allowed here." | isJust (newUserUUID nu) = - Left "it is not allowed to provide a UUID for the users here." + Left "it is not allowed to provide a UUID for the users here." | newUserManagedBy nu `notElem` [Nothing, Just ManagedByWire] = - Left "only managed-by-Wire users can be created here." + Left "only managed-by-Wire users can be created here." | otherwise = - Right (NewUserPublic nu) + Right (NewUserPublic nu) -- | A user is Ephemeral if she has neither email, phone, nor sso credentials and is not -- created via scim. Ephemeral users can be deleted after expires_in or sessionTokenTimeout diff --git a/libs/wire-api/src/Wire/API/User/Auth.hs b/libs/wire-api/src/Wire/API/User/Auth.hs index 99f339d2e27..cd217241e62 100644 --- a/libs/wire-api/src/Wire/API/User/Auth.hs +++ b/libs/wire-api/src/Wire/API/User/Auth.hs @@ -203,10 +203,10 @@ instance ToSchema LoginCodeTimeout where (description ?~ "A response for a successfully sent login code") $ LoginCodeTimeout <$> fromLoginCodeTimeout - .= fieldWithDocModifier - "expires_in" - (description ?~ "Number of seconds before the login code expires") - (unnamed schema) + .= fieldWithDocModifier + "expires_in" + (description ?~ "Number of seconds before the login code expires") + (unnamed schema) -------------------------------------------------------------------------------- -- Cookie @@ -432,8 +432,9 @@ instance ToSchema AccessToken where .= fieldWithDocModifier "access_token" (description ?~ "The opaque access token string") - ( LBS.fromStrict . T.encodeUtf8 <$> (T.decodeUtf8 . LBS.toStrict) - .= schema + ( LBS.fromStrict . T.encodeUtf8 + <$> (T.decodeUtf8 . LBS.toStrict) + .= schema ) <*> tokenType .= field "token_type" schema <*> expiresIn diff --git a/libs/wire-api/src/Wire/API/User/Auth2.hs b/libs/wire-api/src/Wire/API/User/Auth2.hs new file mode 100644 index 00000000000..93010b87a7b --- /dev/null +++ b/libs/wire-api/src/Wire/API/User/Auth2.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE StrictData #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +-- FUTUREWORK: replace `Wire.API.User.Auth` with this module once everything in `Auth` is migrated to schema-profunctor +module Wire.API.User.Auth2 where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson.Types as A +import Data.Handle (Handle) +import Data.Schema +import qualified Data.Swagger as S +import Data.Tuple.Extra (fst3, snd3, thd3) +import Imports +import Wire.API.User.Identity (Email, Phone) +import Wire.Arbitrary (Arbitrary, GenericUniform (..)) + +-------------------------------------------------------------------------------- +-- LoginId + +data LoginId + = LoginByEmail Email + | LoginByPhone Phone + | LoginByHandle Handle + deriving stock (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform LoginId) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema LoginId) + +-- NB. this should fail if (e.g.) the email is present but unparseable even if the JSON contains a valid phone number or handle. +-- See tests in `Test.Wire.API.User.Auth`. +instance ToSchema LoginId where + schema = + object "LoginId" + $ fromLoginId .= tupleSchema + `withParser` validate + where + fromLoginId :: LoginId -> (Maybe Email, Maybe Phone, Maybe Handle) + fromLoginId = \case + LoginByEmail e -> (Just e, Nothing, Nothing) + LoginByPhone p -> (Nothing, Just p, Nothing) + LoginByHandle h -> (Nothing, Nothing, Just h) + tupleSchema :: ObjectSchema SwaggerDoc (Maybe Email, Maybe Phone, Maybe Handle) + tupleSchema = + (,,) + <$> fst3 .= maybe_ (optField "email" schema) + <*> snd3 .= maybe_ (optField "phone" schema) + <*> thd3 .= maybe_ (optField "handle" schema) + validate :: (Maybe Email, Maybe Phone, Maybe Handle) -> A.Parser LoginId + validate (mEmail, mPhone, mHandle) = + maybe (fail "'email', 'phone' or 'handle' required") pure $ + (LoginByEmail <$> mEmail) <|> (LoginByPhone <$> mPhone) <|> (LoginByHandle <$> mHandle) diff --git a/libs/wire-api/src/Wire/API/User/Client.hs b/libs/wire-api/src/Wire/API/User/Client.hs index 7efbe1b78f7..e8b8f0574c9 100644 --- a/libs/wire-api/src/Wire/API/User/Client.hs +++ b/libs/wire-api/src/Wire/API/User/Client.hs @@ -833,13 +833,13 @@ instance ToSchema RmClient where object "DeleteClient" $ RmClient <$> rmPassword - .= optFieldWithDocModifier - "password" - ( description - ?~ "The password of the authenticated user for verification. \ - \The password is not required for deleting temporary clients." - ) - (maybeWithDefault A.Null schema) + .= optFieldWithDocModifier + "password" + ( description + ?~ "The password of the authenticated user for verification. \ + \The password is not required for deleting temporary clients." + ) + (maybeWithDefault A.Null schema) modelDeleteClient :: Doc.Model modelDeleteClient = Doc.defineModel "DeleteClient" $ do diff --git a/libs/wire-api/src/Wire/API/User/Profile.hs b/libs/wire-api/src/Wire/API/User/Profile.hs index f634fe7f080..758444a8915 100644 --- a/libs/wire-api/src/Wire/API/User/Profile.hs +++ b/libs/wire-api/src/Wire/API/User/Profile.hs @@ -192,7 +192,8 @@ parseLocale = hush . parseOnly localeParser where localeParser :: Parser Locale localeParser = - Locale <$> (languageParser "Language code") + Locale + <$> (languageParser "Language code") <*> (optional (char '-' *> countryParser) "Country code") -------------------------------------------------------------------------------- diff --git a/libs/wire-api/src/Wire/API/User/RichInfo.hs b/libs/wire-api/src/Wire/API/User/RichInfo.hs index d0a7be408dc..fe133caf099 100644 --- a/libs/wire-api/src/Wire/API/User/RichInfo.hs +++ b/libs/wire-api/src/Wire/API/User/RichInfo.hs @@ -249,14 +249,14 @@ instance Semigroup RichInfoAssocList where instance ToSchema RichInfoAssocList where schema = - object "RichInfoAssocList" $ - withParser + object "RichInfoAssocList" + $ withParser ( (,) <$> const (0 :: Int) .= field "version" schema <*> unRichInfoAssocList .= field "fields" (array schema) ) - $ \(version, fields) -> - mkRichInfoAssocList <$> validateRichInfoAssocList version fields + $ \(version, fields) -> + mkRichInfoAssocList <$> validateRichInfoAssocList version fields richInfoAssocListFromObject :: A.Object -> Aeson.Parser [RichField] richInfoAssocListFromObject richinfoObj = do diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index 45fd51a09b6..1576c0b3117 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -276,34 +276,34 @@ instance QC.Arbitrary (Scim.User SparTag) where instance Scim.Patchable ScimUserExtra where applyOperation (ScimUserExtra (RI.RichInfo rinfRaw)) (Operation o (Just (NormalPath (AttrPath (Just (CustomSchema sch)) (AttrName (CI.mk -> ciAttrName)) Nothing))) val) | sch == RI.richInfoMapURN = - let rinf = RI.richInfoMap $ RI.fromRichInfoAssocList rinfRaw - unrinf = ScimUserExtra . RI.RichInfo . RI.toRichInfoAssocList . RI.mkRichInfoMapAndList . fmap (uncurry RI.RichField) . Map.assocs - in unrinf <$> case o of - Scim.Remove -> - pure $ Map.delete ciAttrName rinf - _AddOrReplace -> - case val of - (Just (A.String textVal)) -> - pure $ Map.insert ciAttrName textVal rinf - _ -> throwError $ Scim.badRequest Scim.InvalidValue $ Just "rich info values can only be text" + let rinf = RI.richInfoMap $ RI.fromRichInfoAssocList rinfRaw + unrinf = ScimUserExtra . RI.RichInfo . RI.toRichInfoAssocList . RI.mkRichInfoMapAndList . fmap (uncurry RI.RichField) . Map.assocs + in unrinf <$> case o of + Scim.Remove -> + pure $ Map.delete ciAttrName rinf + _AddOrReplace -> + case val of + (Just (A.String textVal)) -> + pure $ Map.insert ciAttrName textVal rinf + _ -> throwError $ Scim.badRequest Scim.InvalidValue $ Just "rich info values can only be text" | sch == RI.richInfoAssocListURN = - let rinf = RI.richInfoAssocList $ RI.fromRichInfoAssocList rinfRaw - unrinf = ScimUserExtra . RI.RichInfo . RI.toRichInfoAssocList . RI.mkRichInfoMapAndList - matchesAttrName (RI.RichField k _) = k == ciAttrName - in unrinf <$> case o of - Scim.Remove -> - pure $ filter (not . matchesAttrName) rinf - _AddOrReplace -> - case val of - (Just (A.String textVal)) -> - let newField = RI.RichField ciAttrName textVal - replaceIfMatchesAttrName f = if matchesAttrName f then newField else f - newRichInfo = - if not $ any matchesAttrName rinf - then rinf ++ [newField] - else map replaceIfMatchesAttrName rinf - in pure newRichInfo - _ -> throwError $ Scim.badRequest Scim.InvalidValue $ Just "rich info values can only be text" + let rinf = RI.richInfoAssocList $ RI.fromRichInfoAssocList rinfRaw + unrinf = ScimUserExtra . RI.RichInfo . RI.toRichInfoAssocList . RI.mkRichInfoMapAndList + matchesAttrName (RI.RichField k _) = k == ciAttrName + in unrinf <$> case o of + Scim.Remove -> + pure $ filter (not . matchesAttrName) rinf + _AddOrReplace -> + case val of + (Just (A.String textVal)) -> + let newField = RI.RichField ciAttrName textVal + replaceIfMatchesAttrName f = if matchesAttrName f then newField else f + newRichInfo = + if not $ any matchesAttrName rinf + then rinf ++ [newField] + else map replaceIfMatchesAttrName rinf + in pure newRichInfo + _ -> throwError $ Scim.badRequest Scim.InvalidValue $ Just "rich info values can only be text" | otherwise = throwError $ Scim.badRequest Scim.InvalidValue $ Just "unknown schema, cannot patch" applyOperation _ _ = throwError $ Scim.badRequest Scim.InvalidValue $ Just "invalid patch op for rich info" diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Asset_asset.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Asset_asset.hs index b78329a9dab..1b3143a1e64 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Asset_asset.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/Asset_asset.hs @@ -143,9 +143,9 @@ testObject_Asset_asset_19 :: Asset testObject_Asset_asset_19 = mkAsset (Qualified (AssetKeyV3 (Id (fromJust (UUID.fromString "00000021-0000-0062-0000-002a0000006b"))) AssetVolatile) (Domain "example.com")) & assetExpires - .~ fmap read Nothing + .~ fmap read Nothing & assetToken - ?~ AssetToken {assetTokenAscii = fromRight undefined (validate "4wm3D03aqvZ_0oKFtwXCYnSTC7m_z1E=")} + ?~ AssetToken {assetTokenAscii = fromRight undefined (validate "4wm3D03aqvZ_0oKFtwXCYnSTC7m_z1E=")} testObject_Asset_asset_20 :: Asset testObject_Asset_asset_20 = diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs index 1970e7ab7b9..1a1414c6204 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCConfiguration_user.hs @@ -69,13 +69,17 @@ testObject_RTCConfiguration_user_1 = turnURI SchemeTurns (TurnHostName "123") (read "0") Nothing ] ) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "y" & tuVersion .~ 0 & tuKeyindex .~ 2 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "y" + & tuVersion .~ 0 + & tuKeyindex .~ 2 & tuT .~ '\990111' ) (fromRight undefined (validate "KA==")) :| [ rtcIceServer (turnURI SchemeTurns (TurnHostIp (IpAddr (read "11.115.71.116"))) (read "0") (Just TransportTCP) :| []) - ( turnUsername (secondsToNominalDiffTime 4.000000000000) "g9l" & tuVersion .~ 1 & tuKeyindex .~ 1 + ( turnUsername (secondsToNominalDiffTime 4.000000000000) "g9l" + & tuVersion .~ 1 + & tuKeyindex .~ 1 & tuT .~ 'F' ) (fromRight undefined (validate "vg==")), @@ -85,7 +89,9 @@ testObject_RTCConfiguration_user_1 = turnURI SchemeTurns (TurnHostIp (IpAddr (read "146.223.237.161"))) (read "0") (Just TransportTCP) ] ) - ( turnUsername (secondsToNominalDiffTime 4.000000000000) "vkw" & tuVersion .~ 2 & tuKeyindex .~ 2 + ( turnUsername (secondsToNominalDiffTime 4.000000000000) "vkw" + & tuVersion .~ 2 + & tuKeyindex .~ 2 & tuT .~ 'O' ) (fromRight undefined (validate "1Q==")), @@ -95,7 +101,9 @@ testObject_RTCConfiguration_user_1 = turnURI SchemeTurns (TurnHostIp (IpAddr (read "30.151.133.158"))) (read "1") (Just TransportTCP) ] ) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "qv" & tuVersion .~ 0 & tuKeyindex .~ 2 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "qv" + & tuVersion .~ 0 + & tuKeyindex .~ 2 & tuT .~ 'F' ) (fromRight undefined (validate "/w==")), @@ -103,7 +111,9 @@ testObject_RTCConfiguration_user_1 = ( turnURI SchemeTurns (TurnHostName "xn--mgbh0fb.xn--kgbechtv") (read "0") (Just TransportTCP) :| [turnURI SchemeTurn (TurnHostIp (IpAddr (read "212.204.103.144"))) (read "1") (Just TransportTCP)] ) - ( turnUsername (secondsToNominalDiffTime 4.000000000000) "b" & tuVersion .~ 3 & tuKeyindex .~ 1 + ( turnUsername (secondsToNominalDiffTime 4.000000000000) "b" + & tuVersion .~ 3 + & tuKeyindex .~ 1 & tuT .~ '\40387' ) (fromRight undefined (validate "TQ==")), @@ -111,7 +121,9 @@ testObject_RTCConfiguration_user_1 = ( turnURI SchemeTurn (TurnHostIp (IpAddr (read "36.138.227.130"))) (read "0") Nothing :| [turnURI SchemeTurns (TurnHostName "a-c") (read "0") (Just TransportTCP)] ) - ( turnUsername (secondsToNominalDiffTime 3.000000000000) "1j" & tuVersion .~ 3 & tuKeyindex .~ 1 + ( turnUsername (secondsToNominalDiffTime 3.000000000000) "1j" + & tuVersion .~ 3 + & tuKeyindex .~ 1 & tuT .~ '6' ) (fromRight undefined (validate "1CM=")), @@ -119,7 +131,9 @@ testObject_RTCConfiguration_user_1 = ( turnURI SchemeTurn (TurnHostIp (IpAddr (read "39.3.236.143"))) (read "0") (Just TransportUDP) :| [turnURI SchemeTurns (TurnHostName "xn--mgbh0fb.xn--kgbechtv") (read "1") (Just TransportTCP)] ) - ( turnUsername (secondsToNominalDiffTime 0.000000000000) "v" & tuVersion .~ 2 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 0.000000000000) "v" + & tuVersion .~ 2 + & tuKeyindex .~ 0 & tuT .~ 'D' ) (fromRight undefined (validate "xVY=")), @@ -129,7 +143,9 @@ testObject_RTCConfiguration_user_1 = turnURI SchemeTurns (TurnHostName "xn--mgbh0fb.xn--kgbechtv") (read "0") (Just TransportUDP) ] ) - ( turnUsername (secondsToNominalDiffTime 3.000000000000) "i3" & tuVersion .~ 3 & tuKeyindex .~ 1 + ( turnUsername (secondsToNominalDiffTime 3.000000000000) "i3" + & tuVersion .~ 3 + & tuKeyindex .~ 1 & tuT .~ '\DLE' ) (fromRight undefined (validate "9g==")) @@ -149,19 +165,25 @@ testObject_RTCConfiguration_user_2 = turnURI SchemeTurns (TurnHostName "xn--mgbh0fb.xn--kgbechtv") (read "0") (Just TransportUDP) ] ) - ( turnUsername (secondsToNominalDiffTime 3.000000000000) "i3u" & tuVersion .~ 0 & tuKeyindex .~ 1 + ( turnUsername (secondsToNominalDiffTime 3.000000000000) "i3u" + & tuVersion .~ 0 + & tuKeyindex .~ 1 & tuT .~ 'I' ) (fromRight undefined (validate "2w==")) :| [ rtcIceServer (turnURI SchemeTurn (TurnHostName "a-c") (read "1") Nothing :| []) - ( turnUsername (secondsToNominalDiffTime 1.000000000000) "x" & tuVersion .~ 3 & tuKeyindex .~ 1 + ( turnUsername (secondsToNominalDiffTime 1.000000000000) "x" + & tuVersion .~ 3 + & tuKeyindex .~ 1 & tuT .~ 'z' ) (fromRight undefined (validate "VA==")), rtcIceServer (turnURI SchemeTurn (TurnHostName "xn--mgbh0fb.xn--kgbechtv") (read "1") Nothing :| []) - ( turnUsername (secondsToNominalDiffTime 1.000000000000) "2" & tuVersion .~ 1 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 1.000000000000) "2" + & tuVersion .~ 1 + & tuKeyindex .~ 0 & tuT .~ '(' ) (fromRight undefined (validate "4A==")), @@ -171,7 +193,9 @@ testObject_RTCConfiguration_user_2 = turnURI SchemeTurns (TurnHostIp (IpAddr (read "172.9.22.21"))) (read "0") (Just TransportUDP) ] ) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "vp" & tuVersion .~ 3 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "vp" + & tuVersion .~ 3 + & tuKeyindex .~ 0 & tuT .~ '\DC2' ) (fromRight undefined (validate "")), @@ -179,19 +203,25 @@ testObject_RTCConfiguration_user_2 = ( turnURI SchemeTurns (TurnHostIp (IpAddr (read "37.46.50.11"))) (read "0") (Just TransportTCP) :| [turnURI SchemeTurns (TurnHostName "xn--mgbh0fb.xn--kgbechtv") (read "0") (Just TransportTCP)] ) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "4h4" & tuVersion .~ 1 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "4h4" + & tuVersion .~ 1 + & tuKeyindex .~ 0 & tuT .~ '\1100995' ) (fromRight undefined (validate "Mw==")), rtcIceServer (turnURI SchemeTurn (TurnHostName "123") (read "1") (Just TransportTCP) :| []) - ( turnUsername (secondsToNominalDiffTime 4.000000000000) "c9l" & tuVersion .~ 3 & tuKeyindex .~ 2 + ( turnUsername (secondsToNominalDiffTime 4.000000000000) "c9l" + & tuVersion .~ 3 + & tuKeyindex .~ 2 & tuT .~ 'w' ) (fromRight undefined (validate "")), rtcIceServer (turnURI SchemeTurn (TurnHostIp (IpAddr (read "137.180.116.174"))) (read "0") (Just TransportUDP) :| []) - ( turnUsername (secondsToNominalDiffTime 3.000000000000) "h8e" & tuVersion .~ 1 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 3.000000000000) "h8e" + & tuVersion .~ 1 + & tuKeyindex .~ 0 & tuT .~ '\1070826' ) (fromRight undefined (validate "")), @@ -202,13 +232,17 @@ testObject_RTCConfiguration_user_2 = turnURI SchemeTurn (TurnHostIp (IpAddr (read "102.41.143.12"))) (read "0") Nothing ] ) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "cr" & tuVersion .~ 1 & tuKeyindex .~ 1 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "cr" + & tuVersion .~ 1 + & tuKeyindex .~ 1 & tuT .~ '\v' ) (fromRight undefined (validate "")), rtcIceServer (turnURI SchemeTurn (TurnHostName "xn--mgbh0fb.xn--kgbechtv") (read "1") (Just TransportUDP) :| []) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "ol0" & tuVersion .~ 3 & tuKeyindex .~ 2 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "ol0" + & tuVersion .~ 3 + & tuKeyindex .~ 2 & tuT .~ '.' ) (fromRight undefined (validate "")), @@ -216,7 +250,9 @@ testObject_RTCConfiguration_user_2 = ( turnURI SchemeTurns (TurnHostName "a-c") (read "0") (Just TransportUDP) :| [turnURI SchemeTurns (TurnHostName "123") (read "0") (Just TransportTCP)] ) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "a" & tuVersion .~ 3 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "a" + & tuVersion .~ 3 + & tuKeyindex .~ 0 & tuT .~ '"' ) (fromRight undefined (validate "")) @@ -306,13 +342,17 @@ testObject_RTCConfiguration_user_3 = turnURI SchemeTurn (TurnHostName "xn--mgbh0fb.xn--kgbechtv") (read "0") (Just TransportTCP) ] ) - ( turnUsername (secondsToNominalDiffTime 0.000000000000) "m2s" & tuVersion .~ 2 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 0.000000000000) "m2s" + & tuVersion .~ 2 + & tuKeyindex .~ 0 & tuT .~ '\f' ) (fromRight undefined (validate "")) :| [ rtcIceServer (turnURI SchemeTurn (TurnHostIp (IpAddr (read "113.127.226.211"))) (read "1") Nothing :| []) - ( turnUsername (secondsToNominalDiffTime 1.000000000000) "2b" & tuVersion .~ 0 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 1.000000000000) "2b" + & tuVersion .~ 0 + & tuKeyindex .~ 0 & tuT .~ '\37292' ) (fromRight undefined (validate "")), @@ -320,7 +360,9 @@ testObject_RTCConfiguration_user_3 = ( turnURI SchemeTurn (TurnHostName "xn--mgbh0fb.xn--kgbechtv") (read "0") (Just TransportUDP) :| [turnURI SchemeTurn (TurnHostIp (IpAddr (read "222.209.199.151"))) (read "0") (Just TransportUDP)] ) - ( turnUsername (secondsToNominalDiffTime 0.000000000000) "w" & tuVersion .~ 1 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 0.000000000000) "w" + & tuVersion .~ 1 + & tuKeyindex .~ 0 & tuT .~ '-' ) (fromRight undefined (validate "Sjk=")), @@ -328,7 +370,9 @@ testObject_RTCConfiguration_user_3 = ( turnURI SchemeTurn (TurnHostIp (IpAddr (read "33.214.122.255"))) (read "0") (Just TransportUDP) :| [turnURI SchemeTurns (TurnHostName "007.com") (read "1") (Just TransportTCP)] ) - ( turnUsername (secondsToNominalDiffTime 4.000000000000) "py" & tuVersion .~ 1 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 4.000000000000) "py" + & tuVersion .~ 1 + & tuKeyindex .~ 0 & tuT .~ '#' ) (fromRight undefined (validate "awA=")), @@ -336,7 +380,9 @@ testObject_RTCConfiguration_user_3 = ( turnURI SchemeTurns (TurnHostIp (IpAddr (read "72.84.227.18"))) (read "0") (Just TransportUDP) :| [turnURI SchemeTurn (TurnHostName "007.com") (read "0") (Just TransportTCP)] ) - ( turnUsername (secondsToNominalDiffTime 1.000000000000) "l1f" & tuVersion .~ 2 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 1.000000000000) "l1f" + & tuVersion .~ 2 + & tuKeyindex .~ 0 & tuT .~ '$' ) (fromRight undefined (validate "jw==")), @@ -347,7 +393,9 @@ testObject_RTCConfiguration_user_3 = turnURI SchemeTurn (TurnHostName "007.com") (read "0") (Just TransportTCP) ] ) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "kke" & tuVersion .~ 2 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "kke" + & tuVersion .~ 2 + & tuKeyindex .~ 0 & tuT .~ '{' ) (fromRight undefined (validate "hQ==")), @@ -357,7 +405,9 @@ testObject_RTCConfiguration_user_3 = turnURI SchemeTurn (TurnHostName "xn--mgbh0fb.xn--kgbechtv") (read "0") Nothing ] ) - ( turnUsername (secondsToNominalDiffTime 0.000000000000) "8" & tuVersion .~ 2 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 0.000000000000) "8" + & tuVersion .~ 2 + & tuKeyindex .~ 0 & tuT .~ 'Z' ) (fromRight undefined (validate "mHw=")), @@ -365,7 +415,9 @@ testObject_RTCConfiguration_user_3 = ( turnURI SchemeTurn (TurnHostIp (IpAddr (read "148.8.193.103"))) (read "1") Nothing :| [turnURI SchemeTurns (TurnHostName "host.name") (read "0") (Just TransportUDP)] ) - ( turnUsername (secondsToNominalDiffTime 1.000000000000) "shf" & tuVersion .~ 2 & tuKeyindex .~ 1 + ( turnUsername (secondsToNominalDiffTime 1.000000000000) "shf" + & tuVersion .~ 2 + & tuKeyindex .~ 1 & tuT .~ '^' ) (fromRight undefined (validate "")), @@ -373,13 +425,17 @@ testObject_RTCConfiguration_user_3 = ( turnURI SchemeTurns (TurnHostName "host.name") (read "1") (Just TransportTCP) :| [turnURI SchemeTurn (TurnHostIp (IpAddr (read "159.246.220.178"))) (read "1") (Just TransportTCP)] ) - ( turnUsername (secondsToNominalDiffTime 4.000000000000) "x5" & tuVersion .~ 3 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 4.000000000000) "x5" + & tuVersion .~ 3 + & tuKeyindex .~ 0 & tuT .~ 'd' ) (fromRight undefined (validate "FU0=")), rtcIceServer (turnURI SchemeTurns (TurnHostName "007.com") (read "0") (Just TransportTCP) :| []) - ( turnUsername (secondsToNominalDiffTime 4.000000000000) "v" & tuVersion .~ 2 & tuKeyindex .~ 2 + ( turnUsername (secondsToNominalDiffTime 4.000000000000) "v" + & tuVersion .~ 2 + & tuKeyindex .~ 2 & tuT .~ 'q' ) (fromRight undefined (validate "1Q==")), @@ -390,7 +446,9 @@ testObject_RTCConfiguration_user_3 = turnURI SchemeTurns (TurnHostName "123") (read "0") Nothing ] ) - ( turnUsername (secondsToNominalDiffTime 1.000000000000) "8" & tuVersion .~ 3 & tuKeyindex .~ 1 + ( turnUsername (secondsToNominalDiffTime 1.000000000000) "8" + & tuVersion .~ 3 + & tuKeyindex .~ 1 & tuT .~ '\b' ) (fromRight undefined (validate "")) @@ -430,7 +488,9 @@ testObject_RTCConfiguration_user_4 = turnURI SchemeTurn (TurnHostName "host.name") (read "1") (Just TransportTCP) ] ) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "tj" & tuVersion .~ 0 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "tj" + & tuVersion .~ 0 + & tuKeyindex .~ 0 & tuT .~ '\1011805' ) (fromRight undefined (validate "")) @@ -623,7 +683,9 @@ testObject_RTCConfiguration_user_5 = turnURI SchemeTurn (TurnHostName "host.name") (read "1") (Just TransportTCP) ] ) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "tj" & tuVersion .~ 0 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "tj" + & tuVersion .~ 0 + & tuKeyindex .~ 0 & tuT .~ '\1011805' ) (fromRight undefined (validate "")) @@ -663,7 +725,9 @@ testObject_RTCConfiguration_user_6 = turnURI SchemeTurn (TurnHostName "host.name") (read "1") (Just TransportTCP) ] ) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "tj" & tuVersion .~ 0 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "tj" + & tuVersion .~ 0 + & tuKeyindex .~ 0 & tuT .~ '\1011805' ) (fromRight undefined (validate "")) @@ -683,7 +747,9 @@ testObject_RTCConfiguration_user_7 = turnURI SchemeTurn (TurnHostName "host.name") (read "1") (Just TransportTCP) ] ) - ( turnUsername (secondsToNominalDiffTime 2.000000000000) "tj" & tuVersion .~ 0 & tuKeyindex .~ 0 + ( turnUsername (secondsToNominalDiffTime 2.000000000000) "tj" + & tuVersion .~ 0 + & tuKeyindex .~ 0 & tuT .~ '\1011805' ) (fromRight undefined (validate "")) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCIceServer_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCIceServer_user.hs index 758c6a88be3..175d2e46ae0 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCIceServer_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/RTCIceServer_user.hs @@ -51,7 +51,9 @@ testObject_RTCIceServer_user_1 = turnURI SchemeTurns (TurnHostIp (IpAddr (read "125.103.68.5"))) (read "1") (Just TransportTCP) ] ) - ( turnUsername (secondsToNominalDiffTime 38.000000000000) "6vgzfba" & tuVersion .~ 4 & tuKeyindex .~ 24 + ( turnUsername (secondsToNominalDiffTime 38.000000000000) "6vgzfba" + & tuVersion .~ 4 + & tuKeyindex .~ 24 & tuT .~ '\DC1' ) (fromRight undefined (validate "ZtBPgUaUYg==")) @@ -62,7 +64,9 @@ testObject_RTCIceServer_user_2 = ( turnURI SchemeTurn (TurnHostIp (IpAddr (read "108.37.81.160"))) (read "0") (Just TransportTCP) :| [] ) - ( turnUsername (secondsToNominalDiffTime 3.000000000000) "a8kdffu4" & tuVersion .~ 5 & tuKeyindex .~ 24 + ( turnUsername (secondsToNominalDiffTime 3.000000000000) "a8kdffu4" + & tuVersion .~ 5 + & tuKeyindex .~ 24 & tuT .~ '\SOH' ) (fromRight undefined (validate "d1VUzpxZ3TeM")) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TurnUsername_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TurnUsername_user.hs index 8caedd40d2d..e76875324ca 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TurnUsername_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/TurnUsername_user.hs @@ -24,118 +24,140 @@ import Wire.API.Call.Config (TurnUsername, tuKeyindex, tuT, tuVersion, turnUsern testObject_TurnUsername_user_1 :: TurnUsername testObject_TurnUsername_user_1 = - turnUsername (secondsToNominalDiffTime 15527713.000000000000) "ptwsd7g5za2solzq6qhub3" & tuVersion .~ 18 + turnUsername (secondsToNominalDiffTime 15527713.000000000000) "ptwsd7g5za2solzq6qhub3" + & tuVersion .~ 18 & tuKeyindex .~ 4829 & tuT .~ ';' testObject_TurnUsername_user_2 :: TurnUsername testObject_TurnUsername_user_2 = - turnUsername (secondsToNominalDiffTime 13392461.000000000000) "ehn30n10n6op" & tuVersion .~ 9 + turnUsername (secondsToNominalDiffTime 13392461.000000000000) "ehn30n10n6op" + & tuVersion .~ 9 & tuKeyindex .~ 13335 & tuT .~ 'r' testObject_TurnUsername_user_3 :: TurnUsername testObject_TurnUsername_user_3 = - turnUsername (secondsToNominalDiffTime 11177852.000000000000) "txrqjvuzw5uokh21hitqy070mjmj" & tuVersion .~ 20 + turnUsername (secondsToNominalDiffTime 11177852.000000000000) "txrqjvuzw5uokh21hitqy070mjmj" + & tuVersion .~ 20 & tuKeyindex .~ 10953 & tuT .~ '9' testObject_TurnUsername_user_4 :: TurnUsername testObject_TurnUsername_user_4 = - turnUsername (secondsToNominalDiffTime 14690986.000000000000) "st5xpvjb3" & tuVersion .~ 1 + turnUsername (secondsToNominalDiffTime 14690986.000000000000) "st5xpvjb3" + & tuVersion .~ 1 & tuKeyindex .~ 2644 & tuT .~ '+' testObject_TurnUsername_user_5 :: TurnUsername testObject_TurnUsername_user_5 = - turnUsername (secondsToNominalDiffTime 4615190.000000000000) "u86l0yvllw39" & tuVersion .~ 8 + turnUsername (secondsToNominalDiffTime 4615190.000000000000) "u86l0yvllw39" + & tuVersion .~ 8 & tuKeyindex .~ 9984 & tuT .~ 'S' testObject_TurnUsername_user_6 :: TurnUsername testObject_TurnUsername_user_6 = - turnUsername (secondsToNominalDiffTime 13876542.000000000000) "eg21qov6rkavdo4etld2agglp6q" & tuVersion .~ 9 + turnUsername (secondsToNominalDiffTime 13876542.000000000000) "eg21qov6rkavdo4etld2agglp6q" + & tuVersion .~ 9 & tuKeyindex .~ 544 & tuT .~ '\DC3' testObject_TurnUsername_user_7 :: TurnUsername testObject_TurnUsername_user_7 = - turnUsername (secondsToNominalDiffTime 604256.000000000000) "v3ectdcmttrhx8qi2jtqhmy" & tuVersion .~ 28 + turnUsername (secondsToNominalDiffTime 604256.000000000000) "v3ectdcmttrhx8qi2jtqhmy" + & tuVersion .~ 28 & tuKeyindex .~ 10304 & tuT .~ '\1056774' testObject_TurnUsername_user_8 :: TurnUsername testObject_TurnUsername_user_8 = - turnUsername (secondsToNominalDiffTime 11461340.000000000000) "55dox167gmdusgejbcu3p0kk" & tuVersion .~ 30 + turnUsername (secondsToNominalDiffTime 11461340.000000000000) "55dox167gmdusgejbcu3p0kk" + & tuVersion .~ 30 & tuKeyindex .~ 32328 & tuT .~ '=' testObject_TurnUsername_user_9 :: TurnUsername testObject_TurnUsername_user_9 = - turnUsername (secondsToNominalDiffTime 9116692.000000000000) "9xedqmed5p" & tuVersion .~ 12 + turnUsername (secondsToNominalDiffTime 9116692.000000000000) "9xedqmed5p" + & tuVersion .~ 12 & tuKeyindex .~ 3780 & tuT .~ '\'' testObject_TurnUsername_user_10 :: TurnUsername testObject_TurnUsername_user_10 = - turnUsername (secondsToNominalDiffTime 2632630.000000000000) "yagwhzw2d8tddoj4" & tuVersion .~ 30 + turnUsername (secondsToNominalDiffTime 2632630.000000000000) "yagwhzw2d8tddoj4" + & tuVersion .~ 30 & tuKeyindex .~ 19902 & tuT .~ '\v' testObject_TurnUsername_user_11 :: TurnUsername testObject_TurnUsername_user_11 = - turnUsername (secondsToNominalDiffTime 3719294.000000000000) "xevuwd5vsfydbvo5" & tuVersion .~ 15 + turnUsername (secondsToNominalDiffTime 3719294.000000000000) "xevuwd5vsfydbvo5" + & tuVersion .~ 15 & tuKeyindex .~ 20428 & tuT .~ '\28541' testObject_TurnUsername_user_12 :: TurnUsername testObject_TurnUsername_user_12 = - turnUsername (secondsToNominalDiffTime 11821785.000000000000) "1t2k2a3ua0pwp196rs" & tuVersion .~ 29 + turnUsername (secondsToNominalDiffTime 11821785.000000000000) "1t2k2a3ua0pwp196rs" + & tuVersion .~ 29 & tuKeyindex .~ 14407 & tuT .~ '@' testObject_TurnUsername_user_13 :: TurnUsername testObject_TurnUsername_user_13 = - turnUsername (secondsToNominalDiffTime 5664368.000000000000) "w" & tuVersion .~ 28 & tuKeyindex .~ 1216 + turnUsername (secondsToNominalDiffTime 5664368.000000000000) "w" + & tuVersion .~ 28 + & tuKeyindex .~ 1216 & tuT .~ '\1076387' testObject_TurnUsername_user_14 :: TurnUsername testObject_TurnUsername_user_14 = - turnUsername (secondsToNominalDiffTime 3247777.000000000000) "83sca0pn0dxoizci0g" & tuVersion .~ 3 + turnUsername (secondsToNominalDiffTime 3247777.000000000000) "83sca0pn0dxoizci0g" + & tuVersion .~ 3 & tuKeyindex .~ 21012 & tuT .~ '`' testObject_TurnUsername_user_15 :: TurnUsername testObject_TurnUsername_user_15 = - turnUsername (secondsToNominalDiffTime 11893034.000000000000) "09x4jnuekod" & tuVersion .~ 18 + turnUsername (secondsToNominalDiffTime 11893034.000000000000) "09x4jnuekod" + & tuVersion .~ 18 & tuKeyindex .~ 28830 & tuT .~ 'J' testObject_TurnUsername_user_16 :: TurnUsername testObject_TurnUsername_user_16 = - turnUsername (secondsToNominalDiffTime 8117361.000000000000) "ao8bs8og70" & tuVersion .~ 19 + turnUsername (secondsToNominalDiffTime 8117361.000000000000) "ao8bs8og70" + & tuVersion .~ 19 & tuKeyindex .~ 2488 & tuT .~ ',' testObject_TurnUsername_user_17 :: TurnUsername testObject_TurnUsername_user_17 = - turnUsername (secondsToNominalDiffTime 716501.000000000000) "nct4" & tuVersion .~ 1 & tuKeyindex .~ 5062 + turnUsername (secondsToNominalDiffTime 716501.000000000000) "nct4" + & tuVersion .~ 1 + & tuKeyindex .~ 5062 & tuT .~ '\10507' testObject_TurnUsername_user_18 :: TurnUsername testObject_TurnUsername_user_18 = - turnUsername (secondsToNominalDiffTime 5517978.000000000000) "mxlyrynabc3fkdt9ze9" & tuVersion .~ 11 + turnUsername (secondsToNominalDiffTime 5517978.000000000000) "mxlyrynabc3fkdt9ze9" + & tuVersion .~ 11 & tuKeyindex .~ 20637 & tuT .~ '\FS' testObject_TurnUsername_user_19 :: TurnUsername testObject_TurnUsername_user_19 = - turnUsername (secondsToNominalDiffTime 12116794.000000000000) "pfa5lx43lko41m" & tuVersion .~ 8 + turnUsername (secondsToNominalDiffTime 12116794.000000000000) "pfa5lx43lko41m" + & tuVersion .~ 8 & tuKeyindex .~ 19266 & tuT .~ ':' testObject_TurnUsername_user_20 :: TurnUsername testObject_TurnUsername_user_20 = - turnUsername (secondsToNominalDiffTime 3040922.000000000000) "csp6eh0ti" & tuVersion .~ 15 + turnUsername (secondsToNominalDiffTime 3040922.000000000000) "csp6eh0ti" + & tuVersion .~ 15 & tuKeyindex .~ 30634 & tuT .~ '\SI' diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs index 143b58f5200..fbeb5bb498f 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Runner.hs @@ -128,7 +128,8 @@ testFromJSONFailureWithMsg msg path = do Nothing -> pure () Just m -> assertBool - ( failurePrefix <> " had a wrong failure: " + ( failurePrefix + <> " had a wrong failure: " <> show m <> " is not contained in " <> show err diff --git a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs index 62d403c65a7..8d623a2bb3e 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/MLS.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/MLS.hs @@ -165,10 +165,10 @@ testVerifyMLSPlainTextWithKey = do _ -> error "Expected ProposalMessage" let pubkey = bcSignatureKey . kpCredential . rmValue $ kp - liftIO $ - assertBool + liftIO + $ assertBool "message signature verification failed" - $ verifyMessageSignature MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 msg pubkey + $ verifyMessageSignature MLS_128_DHKEMX25519_AES128GCM_SHA256_Ed25519 msg pubkey testRemoveProposalMessageSignature :: IO () testRemoveProposalMessageSignature = withSystemTempDirectory "mls" $ \tmp -> do diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index fd0536c9b03..0cef6f4c10b 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -119,6 +119,7 @@ library Wire.API.User.Auth.LegalHold Wire.API.User.Auth.ReAuth Wire.API.User.Auth.Sso + Wire.API.User.Auth2 Wire.API.User.Client Wire.API.User.Client.DPoPAccessToken Wire.API.User.Client.Prekey diff --git a/libs/wire-message-proto-lens/.ormolu b/libs/wire-message-proto-lens/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/wire-message-proto-lens/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/zauth/.ormolu b/libs/zauth/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/libs/zauth/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/libs/zauth/src/Data/ZAuth/Token.hs b/libs/zauth/src/Data/ZAuth/Token.hs index 50966b53100..375ab26099d 100644 --- a/libs/zauth/src/Data/ZAuth/Token.hs +++ b/libs/zauth/src/Data/ZAuth/Token.hs @@ -263,7 +263,8 @@ readToken :: Type -> (Properties -> Maybe a) -> LByteString -> Maybe (Token a) readToken t f b = case split '.' b of (s : rest) -> let p = map pairwise rest - in Token <$> hush (Signature <$> decode (toStrict s)) + in Token + <$> hush (Signature <$> decode (toStrict s)) <*> readHeader t p <*> f p _ -> Nothing @@ -332,7 +333,8 @@ writeData h a = writeHeader h <> dot <> builder a writeHeader :: Header -> Builder writeHeader t = - field "v" (t ^. version) <> dot + field "v" (t ^. version) + <> dot <> field "k" (t ^. key) <> dot <> field "d" (t ^. time) @@ -343,17 +345,20 @@ writeHeader t = instance ToByteString Access where builder t = - field "u" (toLazyASCIIBytes $ t ^. userId) <> dot + field "u" (toLazyASCIIBytes $ t ^. userId) + <> dot <> field "c" (t ^. connection) instance ToByteString User where builder t = - field "u" (toLazyASCIIBytes $ t ^. user) <> dot + field "u" (toLazyASCIIBytes $ t ^. user) + <> dot <> field "r" (Hex (t ^. rand)) instance ToByteString Bot where builder t = - field "p" (toLazyASCIIBytes $ t ^. prov) <> dot + field "p" (toLazyASCIIBytes $ t ^. prov) + <> dot <> field "b" (toLazyASCIIBytes $ t ^. bot) <> dot <> field "c" (toLazyASCIIBytes $ t ^. conv) @@ -363,12 +368,14 @@ instance ToByteString Provider where instance ToByteString LegalHoldAccess where builder t = - field "u" (toLazyASCIIBytes $ t ^. legalHoldAccess . userId) <> dot + field "u" (toLazyASCIIBytes $ t ^. legalHoldAccess . userId) + <> dot <> field "c" (t ^. legalHoldAccess . connection) instance ToByteString LegalHoldUser where builder t = - field "u" (toLazyASCIIBytes $ t ^. legalHoldUser . user) <> dot + field "u" (toLazyASCIIBytes $ t ^. legalHoldUser . user) + <> dot <> field "r" (Hex (t ^. legalHoldUser . rand)) instance ToByteString Type where diff --git a/nix/overlay.nix b/nix/overlay.nix index 41df0f7a5e4..917301f96d3 100644 --- a/nix/overlay.nix +++ b/nix/overlay.nix @@ -139,4 +139,8 @@ self: super: { inherit (super) stdenv fetchurl; }; + + # This is to match the ormolu version that ships with HLS. + # This doesn't compile with ghc8107 howerver, so we use ghc92 + ormolu = super.haskell.lib.justStaticExecutables (super.haskell.lib.doJailbreak super.haskell.packages.ghc92.ormolu_0_5_0_1); } diff --git a/services/brig/.ormolu b/services/brig/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/services/brig/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index faed54da93f..f90addbec29 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -418,7 +418,8 @@ customerExtensionBlockedDomain :: Domain -> Wai.Error customerExtensionBlockedDomain domain = Wai.mkError (mkStatus 451 "Unavailable For Legal Reasons") "domain-blocked-for-registration" msg where msg = - "[Customer extension] the email domain " <> cs (show domain) + "[Customer extension] the email domain " + <> cs (show domain) <> " that you are attempting to register a user with has been \ \blocked for creating wire users. Please contact your IT department." diff --git a/services/brig/src/Brig/API/Federation.hs b/services/brig/src/Brig/API/Federation.hs index 80100b8d8b3..305e32f4cd9 100644 --- a/services/brig/src/Brig/API/Federation.hs +++ b/services/brig/src/Brig/API/Federation.hs @@ -196,11 +196,11 @@ searchUsers domain (SearchRequest searchTerm) = do exactHandleSearch :: Int -> ExceptT Error (AppT r) [Contact] exactHandleSearch n | n > 0 = do - let maybeHandle = parseHandle searchTerm - maybeOwnerId <- maybe (pure Nothing) (wrapHttpClientE . API.lookupHandle) maybeHandle - case maybeOwnerId of - Nothing -> pure [] - Just foundUser -> lift $ contactFromProfile <$$> API.lookupLocalProfiles Nothing [foundUser] + let maybeHandle = parseHandle searchTerm + maybeOwnerId <- maybe (pure Nothing) (wrapHttpClientE . API.lookupHandle) maybeHandle + case maybeOwnerId of + Nothing -> pure [] + Just foundUser -> lift $ contactFromProfile <$$> API.lookupLocalProfiles Nothing [foundUser] | otherwise = pure [] getUserClients :: Domain -> GetUserClients -> (Handler r) (UserMap (Set PubClient)) diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index 9f8a41149d4..5d29b9a2797 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -146,10 +146,10 @@ onError g r k e = do -- So, this can probably be deleted and is not part of the new servant -- handler. Server.flushRequestBody r - k $ - setStatus (WaiError.code we) + k + $ setStatus (WaiError.code we) . appEndo (foldMap (Endo . uncurry addHeader) hs) - $ json e + $ json e where (we, hs) = case e of StdError x -> (x, []) diff --git a/services/brig/src/Brig/API/MLS/KeyPackages.hs b/services/brig/src/Brig/API/MLS/KeyPackages.hs index 9748e920f29..74d2f39faf9 100644 --- a/services/brig/src/Brig/API/MLS/KeyPackages.hs +++ b/services/brig/src/Brig/API/MLS/KeyPackages.hs @@ -100,13 +100,13 @@ claimRemoteKeyPackages lusr target = do bundle <- withExceptT clientError . (handleFailure =<<) - $ withExceptT ClientFederationError $ - runBrigFederatorClient (tDomain target) $ - fedClient @'Brig @"claim-key-packages" $ - ClaimKeyPackageRequest - { ckprClaimant = tUnqualified lusr, - ckprTarget = tUnqualified target - } + $ withExceptT ClientFederationError + $ runBrigFederatorClient (tDomain target) + $ fedClient @'Brig @"claim-key-packages" + $ ClaimKeyPackageRequest + { ckprClaimant = tUnqualified lusr, + ckprTarget = tUnqualified target + } -- validate and set up mappings for all claimed key packages for_ (kpbEntries bundle) $ \e -> do diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index aecd64f2f53..cb3bb4d3e90 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -472,8 +472,9 @@ addClient usr con ip new = do -- Users can't add legal hold clients when (Public.newClientType new == Public.LegalHoldClientType) $ throwE (clientError ClientLegalHoldCannotBeAdded) - clientResponse <$> API.addClient usr (Just con) (ipAddr <$> ip) new - !>> clientError + clientResponse + <$> API.addClient usr (Just con) (ipAddr <$> ip) new + !>> clientError where clientResponse :: Public.Client -> NewClientResponse clientResponse client = Servant.addHeader (Public.clientId client) client @@ -631,9 +632,9 @@ createUser (Public.NewUserPublic new) = lift . runExceptT $ do | Just teamUser <- mTeamUser, Public.NewTeamCreator creator <- teamUser, let Public.BindingNewTeamUser (Public.BindingNewTeam team) _ = creator = - sendTeamActivationMail e u p l (fromRange $ team ^. Public.newTeamName) + sendTeamActivationMail e u p l (fromRange $ team ^. Public.newTeamName) | otherwise = - sendActivationMail e u p l Nothing + sendActivationMail e u p l Nothing sendWelcomeEmail :: Public.Email -> CreateUserTeam -> Public.NewTeamUser -> Maybe Public.Locale -> (AppT r) () -- NOTE: Welcome e-mails for the team creator are not dealt by brig anymore @@ -861,7 +862,8 @@ customerExtensionCheckBlockedDomains email = do pure () -- if it doesn't fit the syntax of blocked domains, it is not blocked Right domain -> when (domain `elem` blockedDomains) $ - throwM $ customerExtensionBlockedDomain domain + throwM $ + customerExtensionBlockedDomain domain createConnectionUnqualified :: Members @@ -1029,13 +1031,13 @@ activateKey :: (Handler r) ActivationRespWithStatus activateKey (Public.Activate tgt code dryrun) | dryrun = do - wrapClientE (API.preverify tgt code) !>> actError - pure ActivationRespDryRun + wrapClientE (API.preverify tgt code) !>> actError + pure ActivationRespDryRun | otherwise = do - result <- API.activate tgt code Nothing !>> actError - pure $ case result of - ActivationSuccess ident x -> respond ident x - ActivationPass -> ActivationRespPass + result <- API.activate tgt code Nothing !>> actError + pure $ case result of + ActivationSuccess ident x -> respond ident x + ActivationPass -> ActivationRespPass where respond (Just ident) x = ActivationResp $ Public.ActivationResponse ident x respond Nothing _ = ActivationRespSuccessNoIdent diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 07c3d600e26..b0a991140c8 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -429,8 +429,8 @@ createUser new = do case (inv, Team.inInviteeEmail <$> inv) of (Just invite, Just em) | e == userEmailKey em -> do - _ <- ensureMemberCanJoin (Team.iiTeam ii) - pure $ Just (invite, ii, Team.iiTeam ii) + _ <- ensureMemberCanJoin (Team.iiTeam ii) + pure $ Just (invite, ii, Team.iiTeam ii) _ -> throwE RegisterErrorInvalidInvitationCode Nothing -> throwE RegisterErrorInvalidInvitationCode @@ -654,18 +654,18 @@ checkHandle uhandle = do owner <- lift . wrapClient $ lookupHandle xhandle if | isJust owner -> - -- Handle is taken (=> getHandleInfo will return 200) - pure CheckHandleFound + -- Handle is taken (=> getHandleInfo will return 200) + pure CheckHandleFound | isBlacklistedHandle xhandle -> - -- Handle is free but cannot be taken - -- - -- FUTUREWORK: i wonder if this is correct? isn't this the error for malformed - -- handles? shouldn't we throw not-found here? or should there be a fourth case - -- 'CheckHandleBlacklisted'? - pure CheckHandleInvalid + -- Handle is free but cannot be taken + -- + -- FUTUREWORK: i wonder if this is correct? isn't this the error for malformed + -- handles? shouldn't we throw not-found here? or should there be a fourth case + -- 'CheckHandleBlacklisted'? + pure CheckHandleInvalid | otherwise -> - -- Handle is free and can be taken - pure CheckHandleNotFound + -- Handle is free and can be taken + pure CheckHandleNotFound -------------------------------------------------------------------------------- -- Check Handles @@ -1054,7 +1054,7 @@ sendActivationCode emailOrPhone loc call = case emailOrPhone of case mbTeam of Just team | team ^. teamCreator == uid -> - sendTeamActivationMail em name p loc' (team ^. teamName) + sendTeamActivationMail em name p loc' (team ^. teamName) _otherwise -> sendActivationMail em name p loc' ident diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 322fbf391bf..b94ae259d49 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -103,7 +103,8 @@ traverseConcurrentlyWithErrors :: t a -> ExceptT e m (t b) traverseConcurrentlyWithErrors f = - ExceptT . try + ExceptT + . try . ( traverse (either throwIO pure) <=< pooledMapConcurrentlyN 8 (runExceptT . f) ) @@ -116,7 +117,8 @@ traverseConcurrentlyWithErrorsSem :: t a -> ExceptT e (Sem r) [b] traverseConcurrentlyWithErrorsSem f = - ExceptT . E.runError + ExceptT + . E.runError . ( traverse (either E.throw pure) <=< C.unsafePooledMapConcurrentlyN 8 (raise . runExceptT . f) ) diff --git a/services/brig/src/Brig/AWS.hs b/services/brig/src/Brig/AWS.hs index 33e55bb6d45..1f9a88dbe16 100644 --- a/services/brig/src/Brig/AWS.hs +++ b/services/brig/src/Brig/AWS.hs @@ -225,9 +225,12 @@ sendMail m = do -- documented in the cases of SES, we can only handle the errors -- after the fact. AWS.ServiceError se - | se ^. AWS.serviceStatus == status400 - && "Invalid domain name" `Text.isPrefixOf` AWS.toText (se ^. AWS.serviceCode) -> - throwM SESInvalidDomain + | se + ^. AWS.serviceStatus + == status400 + && "Invalid domain name" + `Text.isPrefixOf` AWS.toText (se ^. AWS.serviceCode) -> + throwM SESInvalidDomain _ -> throwM (GeneralError x) -------------------------------------------------------------------------------- diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index b384000078c..fb600c55cbb 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -235,8 +235,8 @@ newEnv o = do Just True -> Just <$> newMVar () _ -> pure Nothing kpLock <- newMVar () - pure - $! Env + pure $! + Env { _cargohold = mkEndpoint $ Opt.cargohold o, _galley = mkEndpoint $ Opt.galley o, _gundeck = mkEndpoint $ Opt.gundeck o, @@ -391,8 +391,8 @@ initCassandra o g = do (Cas.initialContactsDisco "cassandra_brig" . unpack) (Opt.discoUrl o) p <- - Cas.init $ - Cas.setLogger (Cas.mkLogger (Log.clone (Just "cassandra.brig") g)) + Cas.init + $ Cas.setLogger (Cas.mkLogger (Log.clone (Just "cassandra.brig") g)) . Cas.setContacts (NE.head c) (NE.tail c) . Cas.setPortNumber (fromIntegral (Opt.cassandra o ^. casEndpoint . epPort)) . Cas.setKeyspace (Keyspace (Opt.cassandra o ^. casKeyspace)) @@ -402,7 +402,7 @@ initCassandra o g = do . Cas.setResponseTimeout 10 . Cas.setProtocolVersion Cas.V4 . Cas.setPolicy (Cas.dcFilterPolicyIfConfigured g (Opt.cassandra o ^. casFilterNodesByDatacentre)) - $ Cas.defSettings + $ Cas.defSettings runClient p $ versionCheck schemaVersion pure p @@ -496,7 +496,8 @@ instance MonadLogger (AppT r) where AppT $ lift $ embedFinal @IO $ - Log.log g l $ field "request" (unRequestId r) ~~ m + Log.log g l $ + field "request" (unRequestId r) ~~ m instance MonadLogger (ExceptT err (AppT r)) where log l m = lift (LC.log l m) diff --git a/services/brig/src/Brig/Code.hs b/services/brig/src/Brig/Code.hs index 5d4c11a0b40..695ba1952cd 100644 --- a/services/brig/src/Brig/Code.hs +++ b/services/brig/src/Brig/Code.hs @@ -334,8 +334,8 @@ verify k s v = lookup k s >>= maybe (pure Nothing) continue continue c | codeValue c == v = pure (Just c) | codeRetries c > 0 = do - insertInternal (c {codeRetries = codeRetries c - 1}) - pure Nothing + insertInternal (c {codeRetries = codeRetries c - 1}) + pure Nothing | otherwise = pure Nothing -- | Delete a code associated with the given key and scope. diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 3de71d39827..0bbb97b5871 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -122,15 +122,15 @@ activateKey k c u = verifyCode k c >>= pickUser >>= activate -- activating existing key and exactly same profile -- (can happen when a user clicks on activation links more than once) | oldKey == Just key && profileNeedsUpdate = do - lift $ foldKey (updateEmailAndDeleteEmailUnvalidated uid) (updatePhone uid) key - pure . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key + lift $ foldKey (updateEmailAndDeleteEmailUnvalidated uid) (updatePhone uid) key + pure . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key -- if the key is the same, we only want to update our profile | otherwise = do - lift (runM (codeStoreToCassandra @m @'[Embed m] (E.mkPasswordResetKey uid >>= E.codeDelete))) - claim key uid - lift $ foldKey (updateEmailAndDeleteEmailUnvalidated uid) (updatePhone uid) key - for_ oldKey $ lift . deleteKey - pure . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key + lift (runM (codeStoreToCassandra @m @'[Embed m] (E.mkPasswordResetKey uid >>= E.codeDelete))) + claim key uid + lift $ foldKey (updateEmailAndDeleteEmailUnvalidated uid) (updatePhone uid) key + for_ oldKey $ lift . deleteKey + pure . Just $ foldKey (EmailActivated uid) (PhoneActivated uid) key where updateEmailAndDeleteEmailUnvalidated :: UserId -> Email -> m () updateEmailAndDeleteEmailUnvalidated u' email = diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 480f8bebf7d..6887c86216e 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -172,8 +172,8 @@ addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients loc cps = do prm = (u, newId, now, newClientType c, newClientLabel c, newClientClass c, newClientCookie c, lat, lon, mdl, C.Set . Set.toList <$> cps) retry x5 $ write insertClient (params LocalQuorum prm) addMLSPublicKeys u newId (Map.assocs (newClientMLSPublicKeys c)) - pure - $! Client + pure $! + Client { clientId = newId, clientType = newClientType c, clientTime = now, @@ -359,7 +359,7 @@ addMLSPublicKey u c ss pk = do case rows of [row] | C.fromRow 0 row /= Right (Just True) -> - throwE MLSPublicKeyDuplicate + throwE MLSPublicKeyDuplicate _ -> pure () ------------------------------------------------------------------------------- @@ -515,17 +515,20 @@ withOptLock u c ma = go (10 :: Int) _ -> Nothing get :: Text -> AWS.GetItem get t = - AWS.newGetItem t & AWS.getItem_key .~ key u c + AWS.newGetItem t + & AWS.getItem_key .~ key u c & AWS.getItem_consistentRead ?~ True put :: Maybe Word32 -> Text -> AWS.PutItem put v t = - AWS.newPutItem t & AWS.putItem_item .~ item v + AWS.newPutItem t + & AWS.putItem_item .~ item v & AWS.putItem_expected ?~ check v check :: Maybe Word32 -> HashMap Text AWS.ExpectedAttributeValue check Nothing = HashMap.singleton ddbVersion $ AWS.newExpectedAttributeValue & AWS.expectedAttributeValue_comparisonOperator ?~ AWS.ComparisonOperator_NULL check (Just v) = HashMap.singleton ddbVersion $ - AWS.newExpectedAttributeValue & AWS.expectedAttributeValue_comparisonOperator ?~ AWS.ComparisonOperator_EQ + AWS.newExpectedAttributeValue + & AWS.expectedAttributeValue_comparisonOperator ?~ AWS.ComparisonOperator_EQ & AWS.expectedAttributeValue_attributeValueList ?~ [toAttributeValue v] item :: Maybe Word32 -> HashMap Text AWS.AttributeValue item v = diff --git a/services/brig/src/Brig/IO/Intra.hs b/services/brig/src/Brig/IO/Intra.hs index 4c0bedd91a4..a6c893db527 100644 --- a/services/brig/src/Brig/IO/Intra.hs +++ b/services/brig/src/Brig/IO/Intra.hs @@ -509,7 +509,7 @@ notifyContacts events orig route conn = do screenMemberList :: Maybe Team.TeamMemberList -> m [UserId] screenMemberList (Just mems) | mems ^. Team.teamMemberListType == Team.ListComplete = - pure $ fmap (view Team.userId) (mems ^. Team.teamMembers) + pure $ fmap (view Team.userId) (mems ^. Team.teamMembers) screenMemberList _ = pure [] -- Event Serialisation: diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index e7629392ea2..d64bfac01ce 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -103,13 +103,13 @@ runCommand l = \case initES esURI mgr = ES.mkBHEnv (toESServer esURI) mgr initDb cas = - C.init $ - C.setLogger (C.mkLogger l) + C.init + $ C.setLogger (C.mkLogger l) . C.setContacts (view cHost cas) [] . C.setPortNumber (fromIntegral (view cPort cas)) . C.setKeyspace (view cKeyspace cas) . C.setProtocolVersion C.V4 - $ C.defSettings + $ C.defSettings waitForTaskToComplete :: forall a m. (ES.MonadBH m, MonadThrow m, FromJSON a) => Int -> ES.TaskNodeId -> m () waitForTaskToComplete timeoutSeconds taskNodeId = do diff --git a/services/brig/src/Brig/Index/Migrations.hs b/services/brig/src/Brig/Index/Migrations.hs index d0879d3a0d3..e022aac8ede 100644 --- a/services/brig/src/Brig/Index/Migrations.hs +++ b/services/brig/src/Brig/Index/Migrations.hs @@ -53,7 +53,8 @@ migrate l es cas galleyEndpoint = do logAndThrowAgain :: forall a. SomeException -> IO a logAndThrowAgain e = do runWithLogger l $ - Log.err $ Log.msg (Log.val "Migration failed with exception") . Log.field "exception" (show e) + Log.err $ + Log.msg (Log.val "Migration failed with exception") . Log.field "exception" (show e) throwM e -- | Increase this number any time you want to force reindexing. @@ -86,13 +87,13 @@ mkEnv l es cas galleyEndpoint = do <*> pure galleyEndpoint where initCassandra = - C.init $ - C.setLogger (C.mkLogger l) + C.init + $ C.setLogger (C.mkLogger l) . C.setContacts (view Opts.cHost cas) [] . C.setPortNumber (fromIntegral (view Opts.cPort cas)) . C.setKeyspace (view Opts.cKeyspace cas) . C.setProtocolVersion C.V4 - $ C.defSettings + $ C.defSettings initLogger = pure l createMigrationsIndexIfNotPresent :: (MonadThrow m, ES.MonadBH m, Log.MonadLogger m) => m () diff --git a/services/brig/src/Brig/Phone.hs b/services/brig/src/Brig/Phone.hs index eea25e0f5ff..55dabbd3a17 100644 --- a/services/brig/src/Brig/Phone.hs +++ b/services/brig/src/Brig/Phone.hs @@ -206,17 +206,17 @@ validatePhone :: (MonadClient m, MonadReader Env m) => Phone -> m (Maybe Phone) validatePhone (Phone p) | isTestPhone p = pure (Just (Phone p)) | otherwise = do - c <- view twilioCreds - m <- view httpManager - r <- - liftIO . try @_ @Twilio.ErrorResponse $ - recovering x3 httpHandlers $ - const $ - Twilio.lookupPhone c m p LookupNoDetail Nothing - case r of - Right x -> pure (Just (Phone (Twilio.lookupE164 x))) - Left e | Twilio.errStatus e == 404 -> pure Nothing - Left e -> throwM e + c <- view twilioCreds + m <- view httpManager + r <- + liftIO . try @_ @Twilio.ErrorResponse $ + recovering x3 httpHandlers $ + const $ + Twilio.lookupPhone c m p LookupNoDetail Nothing + case r of + Right x -> pure (Just (Phone (Twilio.lookupE164 x))) + Left e | Twilio.errStatus e == 404 -> pure Nothing + Left e -> throwM e isTestPhone :: Text -> Bool isTestPhone = Text.isPrefixOf "+0" diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 90d4ed862ef..26cbdc0bae1 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -138,12 +138,12 @@ routesPublic = do get "/provider/activate" (continue activateAccountKeyH) $ accept "application" "json" .&> query "key" - .&. query "code" + .&. query "code" get "/provider/approve" (continue approveAccountKeyH) $ accept "application" "json" .&> query "key" - .&. query "code" + .&. query "code" post "/provider/login" (continue loginH) $ jsonRequest @Public.ProviderLogin @@ -161,23 +161,23 @@ routesPublic = do delete "/provider" (continue deleteAccountH) $ zauth ZAuthProvider .&> zauthProviderId - .&. jsonRequest @Public.DeleteProvider + .&. jsonRequest @Public.DeleteProvider put "/provider" (continue updateAccountProfileH) $ accept "application" "json" .&> zauth ZAuthProvider .&> zauthProviderId - .&. jsonRequest @Public.UpdateProvider + .&. jsonRequest @Public.UpdateProvider put "/provider/email" (continue updateAccountEmailH) $ zauth ZAuthProvider .&> zauthProviderId - .&. jsonRequest @Public.EmailUpdate + .&. jsonRequest @Public.EmailUpdate put "/provider/password" (continue updateAccountPasswordH) $ zauth ZAuthProvider .&> zauthProviderId - .&. jsonRequest @Public.PasswordChange + .&. jsonRequest @Public.PasswordChange get "/provider" (continue getAccountH) $ accept "application" "json" @@ -188,7 +188,7 @@ routesPublic = do accept "application" "json" .&> zauth ZAuthProvider .&> zauthProviderId - .&. jsonRequest @Public.NewService + .&. jsonRequest @Public.NewService get "/provider/services" (continue listServicesH) $ accept "application" "json" @@ -199,19 +199,19 @@ routesPublic = do accept "application" "json" .&> zauth ZAuthProvider .&> zauthProviderId - .&. capture "sid" + .&. capture "sid" put "/provider/services/:sid" (continue updateServiceH) $ zauth ZAuthProvider .&> zauthProviderId - .&. capture "sid" - .&. jsonRequest @Public.UpdateService + .&. capture "sid" + .&. jsonRequest @Public.UpdateService put "/provider/services/:sid/connection" (continue updateServiceConnH) $ zauth ZAuthProvider .&> zauthProviderId - .&. capture "sid" - .&. jsonRequest @Public.UpdateServiceConn + .&. capture "sid" + .&. jsonRequest @Public.UpdateServiceConn -- TODO -- post "/provider/services/:sid/token" (continue genServiceTokenH) $ @@ -221,8 +221,8 @@ routesPublic = do delete "/provider/services/:sid" (continue deleteServiceH) $ zauth ZAuthProvider .&> zauthProviderId - .&. capture "sid" - .&. jsonRequest @Public.DeleteService + .&. capture "sid" + .&. jsonRequest @Public.DeleteService -- User API ---------------------------------------------------------------- @@ -240,14 +240,14 @@ routesPublic = do accept "application" "json" .&> zauth ZAuthAccess .&> capture "pid" - .&. capture "sid" + .&. capture "sid" get "/services" (continue searchServiceProfilesH) $ accept "application" "json" .&> zauth ZAuthAccess .&> opt (query "tags") - .&. opt (query "start") - .&. def (unsafeRange 20) (query "size") + .&. opt (query "start") + .&. def (unsafeRange 20) (query "size") get "/services/tags" (continue getServiceTagListH) $ accept "application" "json" @@ -256,33 +256,33 @@ routesPublic = do get "/teams/:tid/services/whitelisted" (continue searchTeamServiceProfilesH) $ accept "application" "json" .&> zauthUserId - .&. capture "tid" - .&. opt (query "prefix") - .&. def True (query "filter_disabled") - .&. def (unsafeRange 20) (query "size") + .&. capture "tid" + .&. opt (query "prefix") + .&. def True (query "filter_disabled") + .&. def (unsafeRange 20) (query "size") post "/teams/:tid/services/whitelist" (continue updateServiceWhitelistH) $ accept "application" "json" .&> zauth ZAuthAccess .&> zauthUserId - .&. zauthConnId - .&. capture "tid" - .&. jsonRequest @Public.UpdateServiceWhitelist + .&. zauthConnId + .&. capture "tid" + .&. jsonRequest @Public.UpdateServiceWhitelist post "/conversations/:cnv/bots" (continue addBotH) $ accept "application" "json" .&> zauth ZAuthAccess .&> zauthUserId - .&. zauthConnId - .&. capture "cnv" - .&. jsonRequest @Public.AddBot + .&. zauthConnId + .&. capture "cnv" + .&. jsonRequest @Public.AddBot delete "/conversations/:cnv/bots/:bot" (continue removeBotH) $ zauth ZAuthAccess .&> zauthUserId - .&. zauthConnId - .&. capture "cnv" - .&. capture "bot" + .&. zauthConnId + .&. capture "cnv" + .&. capture "bot" -- Bot API ----------------------------------------------------------------- @@ -294,7 +294,7 @@ routesPublic = do delete "/bot/self" (continue botDeleteSelfH) $ zauth ZAuthBot .&> zauthBotId - .&. zauthConvId + .&. zauthConvId get "/bot/client/prekeys" (continue botListPrekeysH) $ accept "application" "json" @@ -304,7 +304,7 @@ routesPublic = do post "/bot/client/prekeys" (continue botUpdatePrekeysH) $ zauth ZAuthBot .&> zauthBotId - .&. jsonRequest @Public.UpdateBotPrekeys + .&. jsonRequest @Public.UpdateBotPrekeys get "/bot/client" (continue botGetClientH) $ contentType "application" "json" @@ -872,17 +872,17 @@ updateServiceWhitelist uid con tid upd = do (True, False) -> do -- When the service is de-whitelisted, remove its bots from team -- conversations - lift $ - fmap + lift + $ fmap wrapHttpClient runConduit - $ User.lookupServiceUsersForTeam pid sid tid - .| C.mapM_ - ( pooledMapConcurrentlyN_ - 16 - ( uncurry (deleteBot uid (Just con)) - ) - ) + $ User.lookupServiceUsersForTeam pid sid tid + .| C.mapM_ + ( pooledMapConcurrentlyN_ + 16 + ( uncurry (deleteBot uid (Just con)) + ) + ) wrapClientE $ DB.deleteServiceWhitelist (Just tid) pid sid pure UpdateServiceWhitelistRespChanged diff --git a/services/brig/src/Brig/Provider/DB.hs b/services/brig/src/Brig/Provider/DB.hs index f7222269184..0c08f483c0e 100644 --- a/services/brig/src/Brig/Provider/DB.hs +++ b/services/brig/src/Brig/Provider/DB.hs @@ -520,17 +520,17 @@ updateServiceTags :: updateServiceTags pid sid (oldName, oldTags) (newName, newTags) | eqTags && eqNames = pure () | eqNames = do - let name = oldNameLower - let added = diffTags newTags oldTags - let removed = diffTags oldTags newTags - let retained = unfoldTags (diffTags oldTags removed) - for_ (nonEmptyTags removed) $ \r -> - deleteTags name (r `unfoldTagsInto` retained) - for_ (nonEmptyTags added) $ \a -> - insertTags name (a `unfoldTagsInto` retained) + let name = oldNameLower + let added = diffTags newTags oldTags + let removed = diffTags oldTags newTags + let retained = unfoldTags (diffTags oldTags removed) + for_ (nonEmptyTags removed) $ \r -> + deleteTags name (r `unfoldTagsInto` retained) + for_ (nonEmptyTags added) $ \a -> + insertTags name (a `unfoldTagsInto` retained) | otherwise = do - deleteTags oldNameLower (unfoldTags oldTags) - insertTags newNameLower (unfoldTags newTags) + deleteTags oldNameLower (unfoldTags oldTags) + insertTags newNameLower (unfoldTags newTags) where oldNameLower = Name (Text.toLower (fromName oldName)) newNameLower = Name (Text.toLower (fromName newName)) @@ -797,8 +797,8 @@ paginateServiceWhitelist tid mbPrefix filterDisabled size = liftClient $ do . maybeFilterDisabled . catMaybes <$> mapConcurrently (uncurry lookupServiceProfile) p - pure - $! ServiceProfilePage + pure $! + ServiceProfilePage (length r > fromIntegral size) (trim size r) where @@ -812,8 +812,8 @@ paginateServiceWhitelist tid mbPrefix filterDisabled size = liftClient $ do | otherwise = id maybeFilterPrefix | Just prefix <- mbPrefix = - let prefix' = Text.toLower (fromRange prefix) - in filter ((prefix' `Text.isPrefixOf`) . Text.toLower . fromName . serviceProfileName) + let prefix' = Text.toLower (fromRange prefix) + in filter ((prefix' `Text.isPrefixOf`) . Text.toLower . fromName . serviceProfileName) | otherwise = id getServiceWhitelistStatus :: diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs index e52a5113728..4af2ad91ec1 100644 --- a/services/brig/src/Brig/Team/DB.hs +++ b/services/brig/src/Brig/Team/DB.hs @@ -225,8 +225,8 @@ lookupInvitationInfo :: MonadClient m => InvitationCode -> m (Maybe InvitationIn lookupInvitationInfo ic@(InvitationCode c) | c == mempty = pure Nothing | otherwise = - fmap (toInvitationInfo ic) - <$> retry x1 (query1 cqlInvitationInfo (params LocalQuorum (Identity ic))) + fmap (toInvitationInfo ic) + <$> retry x1 (query1 cqlInvitationInfo (params LocalQuorum (Identity ic))) where toInvitationInfo i (t, r) = InvitationInfo i t r cqlInvitationInfo :: PrepQuery R (Identity InvitationCode) (TeamId, InvitationId) diff --git a/services/brig/src/Brig/Template.hs b/services/brig/src/Brig/Template.hs index 25aeb74d19e..ec607886a64 100644 --- a/services/brig/src/Brig/Template.hs +++ b/services/brig/src/Brig/Template.hs @@ -177,7 +177,8 @@ readWithDefault readFn baseDir defLoc typ prefix name = do where fileToLoad = prefix <> "/" <> name fallback = - baseDir <> "/" + baseDir + <> "/" <> unpack (locToText defLoc) <> "/" <> typ diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index f4f546d1818..3ec6397f00e 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -163,7 +163,8 @@ login (SmsLogin (SmsLoginData phone code label)) typ = do wrapHttpClientE $ checkRetryLimit uid ok <- wrapHttpClientE $ Data.verifyLoginCode uid code unless ok $ - wrapHttpClientE $ loginFailed uid + wrapHttpClientE $ + loginFailed uid wrapHttpClientE $ newAccess @ZAuth.User @ZAuth.Access uid typ label verifyCode :: diff --git a/services/brig/src/Brig/User/Auth/Cookie/Limit.hs b/services/brig/src/Brig/User/Auth/Cookie/Limit.hs index fec43c726ed..26f5dc04fe1 100644 --- a/services/brig/src/Brig/User/Auth/Cookie/Limit.hs +++ b/services/brig/src/Brig/User/Auth/Cookie/Limit.hs @@ -44,17 +44,17 @@ limitCookies :: CookieLimit -> UTCTime -> [Cookie a] -> [Cookie a] limitCookies lim now cs | freeSlots > 0 = [] | otherwise = - let carry = max 1 (abs freeSlots) - in take carry (sortBy preference cs) + let carry = max 1 (abs freeSlots) + in take carry (sortBy preference cs) where freeSlots = cookieLimitTotal lim - length cs preference a b | cookieExpires a < now = LT | cookieExpires b < now = GT | otherwise = case (cookieSucc a, cookieSucc b) of - (Just _, Nothing) -> LT - (Nothing, Just _) -> GT - (_, _) -> comparing cookieCreated a b + (Just _, Nothing) -> LT + (Nothing, Just _) -> GT + (_, _) -> comparing cookieCreated a b -------------------------------------------------------------------------------- -- Temporal Throttling diff --git a/services/brig/src/Brig/User/Search/Index/Types.hs b/services/brig/src/Brig/User/Search/Index/Types.hs index aca57aca26c..92c5392d22c 100644 --- a/services/brig/src/Brig/User/Search/Index/Types.hs +++ b/services/brig/src/Brig/User/Search/Index/Types.hs @@ -131,7 +131,8 @@ instance ToJSON UserDoc where instance FromJSON UserDoc where parseJSON = withObject "UserDoc" $ \o -> - UserDoc <$> o .: "id" + UserDoc + <$> o .: "id" <*> o .:? "team" <*> o .:? "name" <*> o .:? "normalized" diff --git a/services/brig/src/Brig/Whitelist.hs b/services/brig/src/Brig/Whitelist.hs index e3cbc659a09..9f9bac98da7 100644 --- a/services/brig/src/Brig/Whitelist.hs +++ b/services/brig/src/Brig/Whitelist.hs @@ -71,7 +71,8 @@ verify (Whitelist url user pass) key = urlEmail = queryItem "email" . encodeUtf8 . fromEmail urlPhone = queryItem "mobile" . encodeUtf8 . fromPhone req u p = - port 443 . secure + port 443 + . secure . either urlEmail urlPhone key . applyBasicAuth u p x3 = limitRetries 3 <> exponentialBackoff 100000 diff --git a/services/brig/test/integration/API/Federation.hs b/services/brig/test/integration/API/Federation.hs index d05eb060d8b..3e54a402139 100644 --- a/services/brig/test/integration/API/Federation.hs +++ b/services/brig/test/integration/API/Federation.hs @@ -188,11 +188,12 @@ testSearchRestrictions opts brig = do refreshIndex brig let opts' = - opts & Opt.optionSettings . Opt.federationDomainConfigs - ?~ [ Opt.FederationDomainConfig domainNoSearch NoSearch, - Opt.FederationDomainConfig domainExactHandle ExactHandleSearch, - Opt.FederationDomainConfig domainFullSearch FullSearch - ] + opts + & Opt.optionSettings . Opt.federationDomainConfigs + ?~ [ Opt.FederationDomainConfig domainNoSearch NoSearch, + Opt.FederationDomainConfig domainExactHandle ExactHandleSearch, + Opt.FederationDomainConfig domainFullSearch FullSearch + ] let expectSearch domain squery expectedUsers expectedSearchPolicy = do searchResponse <- @@ -222,11 +223,12 @@ testGetUserByHandleRestrictions opts brig = do refreshIndex brig let opts' = - opts & Opt.optionSettings . Opt.federationDomainConfigs - ?~ [ Opt.FederationDomainConfig domainNoSearch NoSearch, - Opt.FederationDomainConfig domainExactHandle ExactHandleSearch, - Opt.FederationDomainConfig domainFullSearch FullSearch - ] + opts + & Opt.optionSettings . Opt.federationDomainConfigs + ?~ [ Opt.FederationDomainConfig domainNoSearch NoSearch, + Opt.FederationDomainConfig domainExactHandle ExactHandleSearch, + Opt.FederationDomainConfig domainFullSearch FullSearch + ] let expectSearch domain expectedUser = do maybeUserProfile <- @@ -434,7 +436,7 @@ testClaimKeyPackages brig fedBrigClient = do cid <- responseJsonError =<< get (brig . paths ["i", "mls", "key-packages", toHeader (kpbeRef e)]) - Brig -> UserId -> AccountStatus -> m ResponseLBS setAccountStatus brig u s = put - ( brig . paths ["i", "users", toByteString' u, "status"] + ( brig + . paths ["i", "users", toByteString' u, "status"] . contentJson . json (AccountStatusUpdate s) ) @@ -338,7 +339,8 @@ testAddKeyPackageRef brig = do qusr <- liftIO $ generate arbitrary c <- liftIO $ generate arbitrary put - ( brig . paths ["i", "mls", "key-packages", toByteString' $ toUrlPiece ref] + ( brig + . paths ["i", "mls", "key-packages", toByteString' $ toUrlPiece ref] . json NewKeyPackageRef { nkprUserId = qusr, @@ -350,7 +352,7 @@ testAddKeyPackageRef brig = do ci <- responseJsonError =<< get (brig . paths ["i", "mls", "key-packages", toByteString' $ toUrlPiece ref]) - (Request -> Request) -> UserId -> m ResponseLBS diff --git a/services/brig/test/integration/API/MLS.hs b/services/brig/test/integration/API/MLS.hs index 527fa1dccb7..93c118cf177 100644 --- a/services/brig/test/integration/API/MLS.hs +++ b/services/brig/test/integration/API/MLS.hs @@ -220,7 +220,7 @@ checkMapping brig u bundle = cid <- responseJsonError =<< get (brig . paths ["i", "mls", "key-packages", toHeader (kpbeRef e)]) - Brig -> Qualified UserId -> ClientId -> Ht getKeyPackageCount brig u c = responseJsonError =<< get - ( brig . paths ["mls", "key-packages", "self", toByteString' c, "count"] + ( brig + . paths ["mls", "key-packages", "self", toByteString' c, "count"] . zUser (qUnqualified u) ) - ByteString -> IO a decodeMLSError s = case decodeMLS' s of diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 5fbaed14e6b..1449ce29c53 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -435,7 +435,7 @@ testListServices config db brig = do . header "Z-User" (toByteString' uid) ) !!! const 400 - === statusCode + === statusCode -- An empty prefix is not sufficient listServiceProfilesByPrefix brig uid (Name "") 10 !!! const 400 === statusCode -- nb. We use a random name prefix so tests can run concurrently @@ -1638,8 +1638,8 @@ waitFor t f ma = do | f a -> pure a | t <= 0 -> liftIO $ throwM TimedOut | otherwise -> do - liftIO $ threadDelay (1 # Second) - waitFor (t - 1 # Second) f ma + liftIO $ threadDelay (1 # Second) + waitFor (t - 1 # Second) f ma -- | Run a test case with an external service application. withTestService :: @@ -1659,7 +1659,8 @@ registerService config db brig = do new <- defNewService config let Just url = fromByteString $ - encodeUtf8 (botHost config) <> ":" + encodeUtf8 (botHost config) + <> ":" <> C8.pack (show (botPort config)) svc <- addGetService brig (providerId prv) (new {newServiceUrl = url}) let pid = providerId prv diff --git a/services/brig/test/integration/API/RichInfo/Util.hs b/services/brig/test/integration/API/RichInfo/Util.hs index a1d44a904a2..8607b5fe07b 100644 --- a/services/brig/test/integration/API/RichInfo/Util.hs +++ b/services/brig/test/integration/API/RichInfo/Util.hs @@ -44,8 +44,8 @@ getRichInfo brig self uid = do | statusCode r == 200 -> Right <$> responseJsonError r | statusCode r `elem` [403, 404] -> pure . Left . statusCode $ r | otherwise -> - error $ - "expected status code 200, 403, or 404, got: " <> show (statusCode r) + error $ + "expected status code 200, 403, or 404, got: " <> show (statusCode r) -- | This contacts an internal end-point. Note the asymmetry between this and the external -- GET end-point in the body: here we need to wrap the 'RichInfo' in a 'RichInfoUpdate'. diff --git a/services/brig/test/integration/API/Search/Util.hs b/services/brig/test/integration/API/Search/Util.hs index 3fc752b5fa4..a8b09b01916 100644 --- a/services/brig/test/integration/API/Search/Util.hs +++ b/services/brig/test/integration/API/Search/Util.hs @@ -128,5 +128,5 @@ executeTeamUserSearch brig teamid self mbSearchText mRoleFilter mSortBy mSortOrd . maybe id (queryItem "sortorder" . cs . toByteString) mSortOrder ) randomBytes 24 post - ( brig . path "/register" . contentJson + ( brig + . path "/register" + . contentJson . body ( RequestBodyLBS . encode $ object @@ -481,7 +491,7 @@ testTeamNoPassword brig = do ) ) !!! const 400 - === statusCode + === statusCode testInvitationCodeExists :: Brig -> Http () testInvitationCodeExists brig = do @@ -547,7 +557,9 @@ testInvitationMutuallyExclusive brig = do HttpT IO (Response (Maybe LByteString)) req e c t i = post - ( brig . path "/register" . contentJson + ( brig + . path "/register" + . contentJson . body ( RequestBodyLBS . encode $ object @@ -572,7 +584,8 @@ testInvitationTooManyMembers brig galley (TeamSizeLimit limit) = do inv <- responseJsonError =<< postInvitation brig tid creator (invite email) Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) post - ( brig . path "/register" + ( brig + . path "/register" . contentJson . body (accept email inviteeCode) ) @@ -670,7 +683,8 @@ testSuspendTeam brig = do Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) rsp2 <- post - ( brig . path "/register" + ( brig + . path "/register" . contentJson . body (accept inviteeEmail inviteeCode) ) diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 020447a2d8c..6fa61788ab3 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -90,12 +90,14 @@ createPopulatedBindingTeamWithNames brig names = do inviteeEmail <- randomEmail let invite = stdInvitationRequest inviteeEmail inv <- - responseJsonError =<< postInvitation brig tid (userId inviter) invite - getSelfProfile brig (userId invitee) @@ -205,7 +209,7 @@ updatePermissions from tid (to, perm) galley = . Bilge.json changeMember ) !!! const 200 - === statusCode + === statusCode where changeMember = Member.mkNewTeamMember to perm Nothing @@ -224,7 +228,7 @@ createTeamConv g tid u us mtimer = do . lbytes (encode conv) ) Galley -> TeamId -> UserId -> Http () deleteTeam g tid u = do @@ -250,7 +254,7 @@ deleteTeam g tid u = do . json (newTeamDeleteData $ Just Util.defPassword) ) !!! const 202 - === statusCode + === statusCode getTeams :: (MonadIO m, MonadCatch m, MonadHttp m, HasCallStack) => @@ -314,7 +318,9 @@ extAccept email name phone phoneCode code = register :: Email -> BindingNewTeam -> Brig -> Http (Response (Maybe LByteString)) register e t brig = post - ( brig . path "/register" . contentJson + ( brig + . path "/register" + . contentJson . body ( RequestBodyLBS . encode $ object @@ -329,7 +335,9 @@ register e t brig = register' :: Email -> BindingNewTeam -> ActivationCode -> Brig -> Http (Response (Maybe LByteString)) register' e t c brig = post - ( brig . path "/register" . contentJson + ( brig + . path "/register" + . contentJson . body ( RequestBodyLBS . encode $ object diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 9fbc2b7571d..11638887a91 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -1615,28 +1615,29 @@ testTooManyMembersForLegalhold opts brig = do inviteeEmail <- randomEmail let invite = stdInvitationRequest inviteeEmail inv <- - responseJsonError =<< postInvitation brig tid owner invite - listCookies b (userId u) liftIO $ ["nexus2", "nexus3"] @=? sort _cookies let rem2 = encode $ remJson defPassword Nothing Nothing @@ -1074,7 +1075,7 @@ testRemoveCookiesByLabel b = do . zUser (userId u) ) !!! const 200 - === statusCode + === statusCode listCookies b (userId u) >>= liftIO . ([] @=?) . mapMaybe cookieLabel testRemoveCookiesByLabelAndId :: Brig -> Http () @@ -1097,7 +1098,7 @@ testRemoveCookiesByLabelAndId b = do . zUser (userId u) ) !!! const 200 - === statusCode + === statusCode -- Check the remaining cookie let lbl = cookieLabel c4 listCookies b (userId u) >>= liftIO . ([lbl] @=?) . map cookieLabel @@ -1212,7 +1213,8 @@ listCookiesWithLabel :: HasCallStack => Brig -> UserId -> [CookieLabel] -> Http listCookiesWithLabel b u l = do rs <- get - ( b . path "/cookies" + ( b + . path "/cookies" . queryItem "labels" labels . header "Z-User" (toByteString' u) ) diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 9a96ec7d34c..d3171c6ee46 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -706,7 +706,7 @@ testRemoveClient hasPwd brig cannon = do when hasPwd $ do login brig (defEmailLogin email) PersistentCookie !!! const 200 - === statusCode + === statusCode numCookies <- countCookies brig uid defCookieLabel liftIO $ Just 1 @=? numCookies c <- responseJsonError =<< addClient brig uid (client PermanentClientType (someLastPrekeys !! 10)) @@ -717,7 +717,7 @@ testRemoveClient hasPwd brig cannon = do WS.bracketR cannon uid $ \ws -> do deleteClient brig uid (clientId c) (if hasPwd then Just defPasswordText else Nothing) !!! const 200 - === statusCode + === statusCode void . liftIO . WS.assertMatch (5 # Second) ws $ \n -> do let j = Object $ List1.head (ntfPayload n) let etype = j ^? key "type" . _String @@ -754,14 +754,14 @@ testRemoveClientShortPwd brig = do -- Permanent client with attached cookie login brig (defEmailLogin email) PersistentCookie !!! const 200 - === statusCode + === statusCode numCookies <- countCookies brig uid defCookieLabel liftIO $ Just 1 @=? numCookies c <- responseJsonError =<< addClient brig uid (client PermanentClientType (someLastPrekeys !! 10)) resp <- deleteClient brig uid (clientId c) (Just "a") ( get (apiVersion "v1" . brig . paths ["users", toByteString' uid, "prekeys", toByteString' (clientId c)] . zUser uid) Prekey -> Http () @@ -960,7 +960,7 @@ testUpdateClient opts brig = do } ) !!! const 200 - === statusCode + === statusCode checkClientLabel put ( brig @@ -969,7 +969,7 @@ testUpdateClient opts brig = do . json defUpdateClient {updateClientCapabilities = caps} ) !!! const 200 - === statusCode + === statusCode checkClientLabel checkClientPrekeys prekey checkClientPrekeys (unpackLastPrekey lastprekey) @@ -1140,7 +1140,7 @@ testCan'tDeleteLegalHoldClient brig = do resp <- addClientInternal brig uid (defNewClient LegalHoldClientType [pk] lk) responseJsonError resp deleteClient brig uid lhClientId Nothing !!! const 400 === statusCode diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index 208782f0fdd..d7f0bcd432e 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -971,8 +971,9 @@ testInternalGetConnStatusesAll brig opts fedBrigClient = do receiveConnectionAction brig fedBrigClient uid remoteDomain2User1 RemoteConnect (Just RemoteConnect) Accepted allStatuses :: [ConnectionStatusV2] <- - responseJsonError =<< getConnStatusInternal brig (ConnectionsStatusRequestV2 uids Nothing Nothing) - (preview (key "cookies" . _Array) =<< responseJsonMaybe @Value r) assertConnections :: (MonadCatch m, MonadIO m, MonadHttp m, HasCallStack) => Brig -> UserId -> [ConnectionStatus] -> m () @@ -464,7 +464,7 @@ uploadAsset c usr sts dat = do . lbytes (toLazyByteString mpb) ) diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index e9f9305d56c..c9c6c4f01f7 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -348,7 +348,8 @@ registerInvitation :: Brig -> Email -> Name -> InvitationCode -> Bool -> Http () registerInvitation brig email name inviteeCode shouldSucceed = do void $ post - ( brig . path "/register" + ( brig + . path "/register" . contentJson . json (acceptWithName name email inviteeCode) ) diff --git a/services/brig/test/integration/API/Version.hs b/services/brig/test/integration/API/Version.hs index 455925be8c0..4995d8754ef 100644 --- a/services/brig/test/integration/API/Version.hs +++ b/services/brig/test/integration/API/Version.hs @@ -42,16 +42,18 @@ tests p opts brig = testVersion :: Brig -> Http () testVersion brig = do vinfo <- - responseJsonError =<< get (brig . path "/api-version") - Http () testVersionV1 brig = do vinfo <- - responseJsonError =<< get (apiVersion "v1" . brig . path "api-version") - Http () testUnsupportedVersion brig = do e <- - responseJsonError =<< get (apiVersion "v500" . brig . path "api-version") - Brig -> Http () testFederationDomain opts brig = do let domain = setFederationDomain (optSettings opts) vinfo <- - responseJsonError =<< get (brig . path "/api-version") - getConversationQualified galley1 (userId alice) convId liftIO $ map omQualifiedId (cmOthers (cnvMembers aliceConvBeforeDelete)) @?= [bobId] @@ -368,7 +369,7 @@ leaveRemoteConversation brig1 galley1 brig2 galley2 = do convId <- fmap cnvQualifiedId . responseJsonError =<< createConversation galley1 (userId alice) [bobId] - getConversationQualified galley1 (userId alice) convId liftIO $ map omQualifiedId (cmOthers (cnvMembers aliceConvBeforeDelete)) @?= [bobId] @@ -409,7 +410,7 @@ testRemoteUsersInNewConv brig1 galley1 brig2 galley2 = do convId <- fmap cnvQualifiedId . responseJsonError =<< createConversation galley1 (userId alice) [userQualifiedId bob] - pure (unGroupId (cnvmlsGroupId p)) ProtocolProteus -> liftIO $ assertFailure "Expected MLS conversation" diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index b206405bfff..7fab864c0a8 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -155,30 +155,30 @@ runTests iConf brigOpts otherArgs = do let mlsApi = MLS.tests mg b brigOpts - withArgs otherArgs . defaultMain $ - testGroup + withArgs otherArgs . defaultMain + $ testGroup "Brig API Integration" - $ [ testCase "sitemap" $ - assertEqual - "inconcistent sitemap" - mempty - (pathsConsistencyCheck . treeToPaths . compile $ Brig.API.sitemap @BrigCanonicalEffects @InternalPaging), - userApi, - providerApi, - searchApis, - teamApis, - turnApi, - metricsApi, - settingsApi, - createIndex, - userPendingActivation, - browseTeam, - federationEndpoints, - internalApi, - versionApi, - mlsApi - ] - <> [federationEnd2End | includeFederationTests] + $ [ testCase "sitemap" $ + assertEqual + "inconcistent sitemap" + mempty + (pathsConsistencyCheck . treeToPaths . compile $ Brig.API.sitemap @BrigCanonicalEffects @InternalPaging), + userApi, + providerApi, + searchApis, + teamApis, + turnApi, + metricsApi, + settingsApi, + createIndex, + userPendingActivation, + browseTeam, + federationEndpoints, + internalApi, + versionApi, + mlsApi + ] + <> [federationEnd2End | includeFederationTests] where mkRequest (Endpoint h p) = host (encodeUtf8 h) . port p diff --git a/services/brig/test/integration/Util.hs b/services/brig/test/integration/Util.hs index fb994505286..4d85118766e 100644 --- a/services/brig/test/integration/Util.hs +++ b/services/brig/test/integration/Util.hs @@ -808,7 +808,8 @@ getStatus :: HasCallStack => Brig -> UserId -> (MonadIO m, MonadHttp m) => m Acc getStatus brig u = (^?! key "status" . (_JSON @Value @AccountStatus)) . (responseJsonUnsafe @Value) <$> get - ( brig . paths ["i", "users", toByteString' u, "status"] + ( brig + . paths ["i", "users", toByteString' u, "status"] . expect2xx ) @@ -822,12 +823,13 @@ setStatus :: Brig -> UserId -> AccountStatus -> Http () setStatus brig u s = let js = RequestBodyLBS . encode $ AccountStatusUpdate s in put - ( brig . paths ["i", "users", toByteString' u, "status"] + ( brig + . paths ["i", "users", toByteString' u, "status"] . contentJson . body js ) !!! const 200 - === statusCode + === statusCode -------------------------------------------------------------------------------- -- Utilities @@ -1232,7 +1234,8 @@ instance Servant.RunClient WaiTestFedClient where Nothing -> HTTP.statusIsSuccessful status Just ex -> status `elem` ex unless statusIsSuccess $ - unWaiTestFedClient $ throwClientError (FailureResponse (bimap (const ()) (\x -> (Servant.BaseUrl Servant.Http "" 80 "", cs (toLazyByteString x))) servantRequest) servantResponse) + unWaiTestFedClient $ + throwClientError (FailureResponse (bimap (const ()) (\x -> (Servant.BaseUrl Servant.Http "" 80 "", cs (toLazyByteString x))) servantRequest) servantResponse) pure servantResponse throwClientError = liftIO . throw @@ -1252,7 +1255,8 @@ fromServantRequest domain r = -- Content-Type and Accept are specified by requestBody and requestAccept headers = filter (\(h, _) -> h /= "Accept" && h /= "Content-Type") $ - toList $ Servant.requestHeaders r + toList $ + Servant.requestHeaders r acceptHdr | null hs = Nothing | otherwise = Just ("Accept", renderHeader hs) diff --git a/services/brig/test/unit/Test/Brig/Calling.hs b/services/brig/test/unit/Test/Brig/Calling.hs index f7ca40a4f67..d93feb71ab3 100644 --- a/services/brig/test/unit/Test/Brig/Calling.hs +++ b/services/brig/test/unit/Test/Brig/Calling.hs @@ -141,7 +141,8 @@ testSFTDiscoveryLoopWhenSuccessful = do tick <- newEmptyMVar delayCallsTVar <- newTVarIO [] discoveryLoop <- - Async.async . runM + Async.async + . runM . ignoreLogs . runDelayWithTick tick delayCallsTVar . runFakeDNSLookup fakeDNSEnv diff --git a/services/cannon/.ormolu b/services/cannon/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/services/cannon/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/services/cannon/src/Cannon/App.hs b/services/cannon/src/Cannon/App.hs index 21d1973aa87..23988f8c9f3 100644 --- a/services/cannon/src/Cannon/App.hs +++ b/services/cannon/src/Cannon/App.hs @@ -108,14 +108,14 @@ writeLoop ws clock (TTL ttl) st = loop s <- readIORef st if | s ^. counter == 0 -> do - set counter st succ - threadDelay $ s ^. pingFreq - keepAlive + set counter st succ + threadDelay $ s ^. pingFreq + keepAlive | s ^. counter < 3 -> do - set counter st succ - send (connection ws) ping - threadDelay $ (10 # Second) `min` (s ^. pingFreq) - keepAlive + set counter st succ + send (connection ws) ping + threadDelay $ (10 # Second) `min` (s ^. pingFreq) + keepAlive | otherwise -> pure () keepAlive = do time <- getTime clock diff --git a/services/cannon/test/Test/Cannon/Dict.hs b/services/cannon/test/Test/Cannon/Dict.hs index 0b4b4e8c465..0b06d9ab7a1 100644 --- a/services/cannon/test/Test/Cannon/Dict.hs +++ b/services/cannon/test/Test/Cannon/Dict.hs @@ -108,8 +108,8 @@ assertEq :: (Show a, Eq a, Monad m) => String -> a -> a -> PropertyM m () assertEq m a b | a == b = pure () | otherwise = - fail $ - "assertEq: " ++ m ++ ": " ++ show a ++ " =/= " ++ show b + fail $ + "assertEq: " ++ m ++ ": " ++ show a ++ " =/= " ++ show b samples :: Int -> Gen a -> IO [a] samples n (MkGen f) = do diff --git a/services/cargohold/.ormolu b/services/cargohold/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/services/cargohold/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/services/cargohold/src/CargoHold/API/V3.hs b/services/cargohold/src/CargoHold/API/V3.hs index 5cd52a6683d..dc6b38e5bd3 100644 --- a/services/cargohold/src/CargoHold/API/V3.hs +++ b/services/cargohold/src/CargoHold/API/V3.hs @@ -82,9 +82,10 @@ upload own bdy = do expires <- case V3.assetRetentionSeconds ret of Just n -> Just . addUTCTime n <$> liftIO getCurrentTime Nothing -> pure Nothing - pure $! V3.mkAsset key - & set V3.assetExpires expires - & set V3.assetToken tok + pure $! + V3.mkAsset key + & set V3.assetExpires expires + & set V3.assetToken tok renewToken :: V3.Principal -> V3.AssetKey -> Handler V3.AssetToken renewToken own key = do @@ -142,7 +143,8 @@ sinkParser p = fmapL mkError <$> Conduit.sinkParserEither p where mkError = clientError . LT.pack . mkMsg mkMsg e = - "Expected: " ++ intercalate ", " (Conduit.errorContexts e) + "Expected: " + ++ intercalate ", " (Conduit.errorContexts e) ++ ", " ++ Conduit.errorMessage e ++ " at " @@ -216,15 +218,15 @@ headers allowed = do pure [] Just name | name `notElem` allowed -> - -- might also be a duplicate - fail $ "Unexpected header: " ++ show (CI.original name) + -- might also be a duplicate + fail $ "Unexpected header: " ++ show (CI.original name) | otherwise -> do - _ <- char ':' - skipSpace - value <- takeTill isEOL "header value" - eol - -- we don't want to parse it again (this also ensures quick termination) - ((name, value) :) <$> headers (List.delete name allowed) + _ <- char ':' + skipSpace + value <- takeTill isEOL "header value" + eol + -- we don't want to parse it again (this also ensures quick termination) + ((name, value) :) <$> headers (List.delete name allowed) eol :: Parser () eol = endOfLine "\r\n" diff --git a/services/cargohold/src/CargoHold/App.hs b/services/cargohold/src/CargoHold/App.hs index c5854621991..83226c45cf4 100644 --- a/services/cargohold/src/CargoHold/App.hs +++ b/services/cargohold/src/CargoHold/App.hs @@ -119,9 +119,9 @@ initHttpManager s3Compat = where dropContentLengthHeaderIfChunked req | ("content-encoding", "aws-chunked") `elem` requestHeaders req = - modifyRequestHeaders (filter ((/= "content-length") . fst)) req + modifyRequestHeaders (filter ((/= "content-length") . fst)) req | otherwise = - req + req modifyRequestHeaders f req = req {requestHeaders = f (requestHeaders req)} diff --git a/services/cargohold/src/CargoHold/CloudFront.hs b/services/cargohold/src/CargoHold/CloudFront.hs index be93827aa27..9b379e9bcc2 100644 --- a/services/cargohold/src/CargoHold/CloudFront.hs +++ b/services/cargohold/src/CargoHold/CloudFront.hs @@ -74,8 +74,8 @@ signedURL :: (MonadIO m, ToByteString p) => CloudFront -> p -> m URI signedURL (CloudFront base kid ttl clock sign) path = liftIO $ do time <- (+ ttl) . round <$> clock sig <- sign (toStrict (toLazyByteString (policy url time))) - pure - $! url + pure $! + url { uriQuery = Query [ ("Expires", toByteString' time), @@ -86,7 +86,8 @@ signedURL (CloudFront base kid ttl clock sign) path = liftIO $ do where url = base {uriPath = "/" <> toByteString' path} policy r t = - "{\"Statement\":[{\"Resource\":\"" <> serializeURIRef r + "{\"Statement\":[{\"Resource\":\"" + <> serializeURIRef r <> "\",\ \\"Condition\":{\ \\"DateLessThan\":{\ diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs index 39b35dac67e..88f733e763e 100644 --- a/services/cargohold/test/integration/API.hs +++ b/services/cargohold/test/integration/API.hs @@ -318,13 +318,13 @@ testRemoteDownloadNoAsset = do qkey = Qualified key (Domain "faraway.example.com") respond req | frRPC req == "get-asset" = - pure ("application" // "json", Aeson.encode (GetAssetResponse False)) + pure ("application" // "json", Aeson.encode (GetAssetResponse False)) | otherwise = - throw - . MockErrorResponse HTTP.status404 - . LText.decodeUtf8With Text.lenientDecode - . Aeson.encode - $ assetNotFound + throw + . MockErrorResponse HTTP.status404 + . LText.decodeUtf8With Text.lenientDecode + . Aeson.encode + $ assetNotFound (_, reqs) <- withMockFederator respond $ do downloadAsset uid qkey () !!! do const 404 === statusCode @@ -348,12 +348,13 @@ testRemoteDownloadFederationFailure = do qkey = Qualified key (Domain "faraway.example.com") respond req | frRPC req == "get-asset" = - pure ("application" // "json", Aeson.encode (GetAssetResponse True)) + pure ("application" // "json", Aeson.encode (GetAssetResponse True)) | otherwise = throw (MockErrorResponse HTTP.status500 "mock error") (resp, _) <- withMockFederator respond $ do - responseJsonError =<< downloadAsset uid qkey () Qualified AssetKey -> TestM (Response (Maybe Lazy.ByteS deleteAsset u k = do c <- viewCargohold delete $ - c . zUser u + c + . zUser u . paths [ "assets", toByteString' (qDomain k), @@ -144,7 +145,8 @@ downloadAssetWith :: downloadAssetWith r uid loc tok = do c <- viewUnversionedCargohold get $ - c . r + c + . r . zUser uid . locationPath loc . tokenParam tok @@ -162,14 +164,16 @@ postToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) postToken uid key = do c <- viewCargohold post $ - c . zUser uid + c + . zUser uid . paths ["assets", toByteString' key, "token"] deleteToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) deleteToken uid key = do c <- viewCargohold delete $ - c . zUser uid + c + . zUser uid . paths ["assets", toByteString' key, "token"] viewFederationDomain :: TestM Domain diff --git a/services/cargohold/test/integration/Main.hs b/services/cargohold/test/integration/Main.hs index ec5be0ba913..71d1fb6cc93 100644 --- a/services/cargohold/test/integration/Main.hs +++ b/services/cargohold/test/integration/Main.hs @@ -72,5 +72,5 @@ main = do includingOptions [ Option (Proxy :: Proxy ServiceConfigFile), Option (Proxy :: Proxy IntegrationConfigFile) - ] : - defaultIngredients + ] + : defaultIngredients diff --git a/services/cargohold/test/integration/TestSetup.hs b/services/cargohold/test/integration/TestSetup.hs index af4eb7d6677..7b494caa43a 100644 --- a/services/cargohold/test/integration/TestSetup.hs +++ b/services/cargohold/test/integration/TestSetup.hs @@ -174,8 +174,8 @@ runFederationClient action = do let req' = defaultMakeClientRequest burl req in req' { requestHeaders = - (originDomainHeaderName, toByteString' domain) : - requestHeaders req' + (originDomainHeaderName, toByteString' domain) + : requestHeaders req' } } diff --git a/services/federator/.ormolu b/services/federator/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/services/federator/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/services/federator/src/Federator/Monitor/Internal.hs b/services/federator/src/Federator/Monitor/Internal.hs index a7fa5c05afa..4fd0faef579 100644 --- a/services/federator/src/Federator/Monitor/Internal.hs +++ b/services/federator/src/Federator/Monitor/Internal.hs @@ -126,14 +126,14 @@ delMonitor :: (Members '[TinyLog, Embed IO] r) => Monitor -> Sem r () -delMonitor monitor = Polysemy.resourceToIO $ - Polysemy.bracket +delMonitor monitor = Polysemy.resourceToIO + $ Polysemy.bracket (takeMVar (monLock monitor)) (putMVar (monLock monitor)) . const - $ do - watches <- readIORef (monWatches monitor) - traverse_ stop watches + $ do + watches <- readIORef (monWatches monitor) + traverse_ stop watches where stop (wd, _) = do -- ignore exceptions when removing watches diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 7597595bc9d..1ea810df185 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -76,10 +76,14 @@ instance AsWai RemoteError where federationRemoteResponseError status waiErrorDescription (RemoteError tgt e) = - "Error while connecting to " <> displayTarget tgt <> ": " + "Error while connecting to " + <> displayTarget tgt + <> ": " <> Text.pack (displayException e) waiErrorDescription (RemoteErrorResponse tgt status body) = - "Federator at " <> displayTarget tgt <> " failed with status code " + "Federator at " + <> displayTarget tgt + <> " failed with status code " <> Text.pack (show (HTTP.statusCode status)) <> ": " <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict body) diff --git a/services/federator/src/Federator/Validation.hs b/services/federator/src/Federator/Validation.hs index e9269ce3473..fc43fa1c946 100644 --- a/services/federator/src/Federator/Validation.hs +++ b/services/federator/src/Federator/Validation.hs @@ -159,7 +159,8 @@ validateDomain (Just encodedCertificate) unparsedDomain = do hostnames <- srvTargetDomain <$$> discoverAllFederatorsWithError targetDomain let validationErrors = (\h -> validateDomainName (B8.unpack h) certificate) <$> hostnames unless (any null validationErrors) $ - throw $ AuthenticationFailure validationErrors + throw $ + AuthenticationFailure validationErrors pure targetDomain diff --git a/services/federator/test/integration/Test/Federator/InwardSpec.hs b/services/federator/test/integration/Test/Federator/InwardSpec.hs index ed960962660..2d6c692bfcb 100644 --- a/services/federator/test/integration/Test/Federator/InwardSpec.hs +++ b/services/federator/test/integration/Test/Federator/InwardSpec.hs @@ -73,8 +73,9 @@ spec env = let expectedProfile = (publicProfile user UserLegalHoldNoConsent) {profileHandle = Just (Handle hdl)} bdy <- - responseJsonError =<< inwardCall "/federation/brig/get-user-by-handle" (encode hdl) - = s = - pure $ toLazyByteString (acc <> byteString (BS.take s chunk)) + pure $ toLazyByteString (acc <> byteString (BS.take s chunk)) | otherwise = do - takeStepT (acc <> byteString chunk) (s - BS.length chunk) next + takeStepT (acc <> byteString chunk) (s - BS.length chunk) next takeStepT acc s (Effect m) = m >>= takeStepT acc s takeSourceT :: Int -> SourceT IO ByteString -> IO LByteString diff --git a/services/federator/test/unit/Test/Federator/Validation.hs b/services/federator/test/unit/Test/Federator/Validation.hs index a01c399149e..95c842f6764 100644 --- a/services/federator/test/unit/Test/Federator/Validation.hs +++ b/services/federator/test/unit/Test/Federator/Validation.hs @@ -155,7 +155,8 @@ validateDomainCertMissing :: TestTree validateDomainCertMissing = testCase "should fail if no client certificate is provided" $ do res <- - runM . runError + runM + . runError . assertNoError @DiscoveryFailure . mockDiscoveryTrivial . runInputConst noClientCertSettings @@ -168,7 +169,8 @@ validateDomainCertInvalid :: TestTree validateDomainCertInvalid = testCase "should fail if the client certificate is invalid" $ do res <- - runM . runError + runM + . runError . assertNoError @DiscoveryFailure . mockDiscoveryTrivial . runInputConst noClientCertSettings @@ -186,7 +188,8 @@ validateDomainCertWrongDomain = testCase "should fail if the client certificate has a wrong domain" $ do exampleCert <- BS.readFile "test/resources/unit/localhost.example.com.pem" res <- - runM . runError + runM + . runError . assertNoError @DiscoveryFailure . mockDiscoveryTrivial . runInputConst noClientCertSettings @@ -250,7 +253,8 @@ validateDomainDiscoveryFailed = testCase "should fail if discovery fails" $ do exampleCert <- BS.readFile "test/resources/unit/example.com.pem" res <- - runM . runError + runM + . runError . assertNoError @ValidationError . mockDiscoveryFailure . runInputConst noClientCertSettings diff --git a/services/galley/.ormolu b/services/galley/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/services/galley/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/services/galley/migrate-data/src/Galley/DataMigration.hs b/services/galley/migrate-data/src/Galley/DataMigration.hs index 14f1655eea3..1c3033e7f5d 100644 --- a/services/galley/migrate-data/src/Galley/DataMigration.hs +++ b/services/galley/migrate-data/src/Galley/DataMigration.hs @@ -70,13 +70,13 @@ mkEnv l cas = <*> initLogger where initCassandra = - C.init $ - C.setLogger (C.mkLogger l) + C.init + $ C.setLogger (C.mkLogger l) . C.setContacts (cHost cas) [] . C.setPortNumber (fromIntegral (cPort cas)) . C.setKeyspace (cKeyspace cas) . C.setProtocolVersion C.V4 - $ C.defSettings + $ C.defSettings initLogger = pure l -- | Runs only the migrations which need to run diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 3238c43446c..f13e89c12fe 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -474,20 +474,20 @@ createConnectConversation lusr conn j = do 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 - 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 -> - E.push1 $ - p - & pushRoute .~ RouteDirect - & pushConn .~ conn - pure $ Data.convSetName n' conv + let lcnv = qualifyAs lusr (Data.convId conv) + n' <- case n of + Just x -> do + E.setConversationName (Data.convId conv) x + 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 -> + E.push1 $ + p + & pushRoute .~ RouteDirect + & pushConn .~ conn + pure $ Data.convSetName n' conv | otherwise = pure conv -------------------------------------------------------------------------------- diff --git a/services/galley/src/Galley/API/Federation.hs b/services/galley/src/Galley/API/Federation.hs index 0a109d3917a..00f6fb2a33e 100644 --- a/services/galley/src/Galley/API/Federation.hs +++ b/services/galley/src/Galley/API/Federation.hs @@ -723,14 +723,14 @@ mlsSendWelcome _origDomain (fromBase64ByteString . F.unMLSWelcomeRequest -> rawW welcome <- either (throw . InternalErrorWithDescription . LT.fromStrict) pure $ decodeMLS' rawWelcome -- Extract only recipients local to this backend rcpts <- - fmap catMaybes $ - traverse + fmap catMaybes + $ traverse ( fmap (fmap cidQualifiedClient . hush) . runError @(Tagged 'MLSKeyPackageRefNotFound ()) . derefKeyPackage . gsNewMember ) - $ welSecrets welcome + $ welSecrets welcome let lrcpts = qualifyAs loc $ fst $ partitionQualified loc rcpts sendLocalWelcomes Nothing now rawWelcome lrcpts pure EmptyResponse diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index e7d9876ba43..f57d698186f 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -302,7 +302,8 @@ type ITeamsAPIBase = Named "get-team-internal" (CanThrow 'TeamNotFound :> Get '[Servant.JSON] TeamData) :<|> Named "create-binding-team" - ( ZUser :> ReqBody '[Servant.JSON] BindingNewTeam + ( ZUser + :> ReqBody '[Servant.JSON] BindingNewTeam :> MultiVerb1 'PUT '[Servant.JSON] @@ -324,7 +325,9 @@ type ITeamsAPIBase = :<|> Named "get-team-name" ("name" :> CanThrow 'TeamNotFound :> Get '[Servant.JSON] TeamName) :<|> Named "update-team-status" - ( "status" :> CanThrow 'TeamNotFound :> CanThrow 'InvalidTeamStatusUpdate + ( "status" + :> CanThrow 'TeamNotFound + :> CanThrow 'InvalidTeamStatusUpdate :> ReqBody '[Servant.JSON] TeamStatusUpdate :> MultiVerb1 'PUT '[Servant.JSON] (RespondEmpty 200 "OK") ) @@ -343,7 +346,8 @@ type ITeamsAPIBase = ) :<|> Named "unchecked-get-team-member" - ( Capture "uid" UserId :> CanThrow 'TeamMemberNotFound + ( Capture "uid" UserId + :> CanThrow 'TeamMemberNotFound :> Get '[Servant.JSON] TeamMember ) :<|> Named @@ -355,7 +359,8 @@ type ITeamsAPIBase = ) :<|> Named "user-is-team-owner" - ( "is-team-owner" :> Capture "uid" UserId + ( "is-team-owner" + :> Capture "uid" UserId :> CanThrow 'AccessDenied :> CanThrow 'TeamMemberNotFound :> CanThrow 'NotATeamMember @@ -691,21 +696,21 @@ rmUser lusr conn = do ConnectConv -> deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) $> Nothing RegularConv | tUnqualified lusr `isMember` Data.convLocalMembers c -> do - runError (removeUser (qualifyAs lusr c) (qUntagged lusr)) >>= \case - Left e -> P.err $ Log.msg ("failed to send remove proposal: " <> internalErrorDescription e) - Right _ -> pure () - deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) - let e = - Event - (qUntagged (qualifyAs lusr (Data.convId c))) - (qUntagged lusr) - now - (EdMembersLeave (QualifiedUserIdList [qUser])) - for_ (bucketRemote (fmap rmId (Data.convRemoteMembers c))) $ notifyRemoteMembers now qUser (Data.convId c) - pure $ - Intra.newPushLocal ListComplete (tUnqualified lusr) (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) - <&> set Intra.pushConn conn - . set Intra.pushRoute Intra.RouteDirect + runError (removeUser (qualifyAs lusr c) (qUntagged lusr)) >>= \case + Left e -> P.err $ Log.msg ("failed to send remove proposal: " <> internalErrorDescription e) + Right _ -> pure () + deleteMembers (Data.convId c) (UserList [tUnqualified lusr] []) + let e = + Event + (qUntagged (qualifyAs lusr (Data.convId c))) + (qUntagged lusr) + now + (EdMembersLeave (QualifiedUserIdList [qUser])) + for_ (bucketRemote (fmap rmId (Data.convRemoteMembers c))) $ notifyRemoteMembers now qUser (Data.convId c) + pure $ + Intra.newPushLocal ListComplete (tUnqualified lusr) (Intra.ConvEvent e) (Intra.recipient <$> Data.convLocalMembers c) + <&> set Intra.pushConn conn + . set Intra.pushRoute Intra.RouteDirect | otherwise -> pure Nothing for_ diff --git a/services/galley/src/Galley/API/MLS/GroupInfo.hs b/services/galley/src/Galley/API/MLS/GroupInfo.hs index 40637193b6d..3fe6894264f 100644 --- a/services/galley/src/Galley/API/MLS/GroupInfo.hs +++ b/services/galley/src/Galley/API/MLS/GroupInfo.hs @@ -93,6 +93,7 @@ getGroupInfoFromRemoteConv lusr rcnv = do case response of GetGroupInfoResponseError e -> rethrowErrors @MLSGroupInfoStaticErrors e GetGroupInfoResponseState s -> - pure . OpaquePublicGroupState + pure + . OpaquePublicGroupState . fromBase64ByteString $ s diff --git a/services/galley/src/Galley/API/MLS/Message.hs b/services/galley/src/Galley/API/MLS/Message.hs index bda3e0344ac..cbc101b8f10 100644 --- a/services/galley/src/Galley/API/MLS/Message.hs +++ b/services/galley/src/Galley/API/MLS/Message.hs @@ -642,17 +642,17 @@ processCommitWithAction qusr senderClient con lconv cm epoch groupId action send case (sender, self, cmAssocs cm) of (MemberSender currentRef, Left lm, [(qu, (creatorClient, _))]) | qu == qUntagged (qualifyAs lconv (lmId lm)) -> do - -- use update path as sender reference and if not existing fall back to sender - senderRef <- - maybe - (pure currentRef) - ( note (mlsProtocolError "Could not compute key package ref") - . kpRef' - . upLeaf - ) - $ cPath commit - -- register the creator client - updateKeyPackageMapping lconv qusr creatorClient Nothing senderRef + -- use update path as sender reference and if not existing fall back to sender + senderRef <- + maybe + (pure currentRef) + ( note (mlsProtocolError "Could not compute key package ref") + . kpRef' + . upLeaf + ) + $ cPath commit + -- register the creator client + updateKeyPackageMapping lconv qusr creatorClient Nothing senderRef -- remote clients cannot send the first commit (_, Right _, _) -> throwS @'MLSStaleMessage -- uninitialised conversations should contain exactly one client diff --git a/services/galley/src/Galley/API/Message.hs b/services/galley/src/Galley/API/Message.hs index c0ff968a6d4..199129610a7 100644 --- a/services/galley/src/Galley/API/Message.hs +++ b/services/galley/src/Galley/API/Message.hs @@ -318,8 +318,8 @@ postBroadcast lusr con msg = runError $ do mapError @LegalholdConflicts @(MessageNotSent MessageSendingStatus) (const MessageNotSentLegalhold) - $ runLocalInput lusr $ - guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients + $ runLocalInput lusr + $ guardQualifiedLegalholdPolicyConflicts lhProtectee missingClients throw $ MessageNotSentClientMissing otrResult failedToSend <- @@ -534,16 +534,18 @@ sendLocalMessages :: Sem r (Set (UserId, ClientId)) sendLocalMessages loc now sender senderClient mconn qcnv botMap metadata localMessages = do let events = - localMessages & reindexed (first (qualifyAs loc)) itraversed - %@~ newMessageEvent - qcnv - sender - senderClient - (mmData metadata) - now + localMessages + & reindexed (first (qualifyAs loc)) itraversed + %@~ newMessageEvent + qcnv + sender + senderClient + (mmData metadata) + now pushes = - events & itraversed - %@~ newMessagePush loc botMap mconn metadata + events + & itraversed + %@~ newMessagePush loc botMap mconn metadata runMessagePush @t loc qcnv (pushes ^. traversed) pure mempty diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 0ad7300d9a0..d4e84f32fe0 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -158,8 +158,8 @@ sitemap = do get "/bot/conversation" (continueE (getBotConversationH @Cassandra)) $ zauth ZAuthBot .&> zauthBotId - .&. zauthConvId - .&. accept "application" "json" + .&. zauthConvId + .&. accept "application" "json" getBotConversationH :: forall db r. diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index a84e13cab01..852ae13115d 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -128,9 +128,9 @@ getBotConversation zbot lcnv = do mkMember :: Domain -> LocalMember -> Maybe OtherMember mkMember domain m | lmId m == botUserId zbot = - Nothing -- no need to list the bot itself + Nothing -- no need to list the bot itself | otherwise = - Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) + Just (OtherMember (Qualified (lmId m) domain) (lmService m) (lmConvRoleName m)) getUnqualifiedConversation :: Members diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index b085feabb30..0ee2281513a 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -1129,10 +1129,10 @@ removeMemberFromRemoteConv :: Sem r (Maybe Event) 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 . leaveResponse =<<) $ - E.runFederated cnv rpc + let lc = LeaveConversationRequest (tUnqualified cnv) (qUnqualified victim) + let rpc = fedClient @'Galley @"leave-conversation" lc + (either handleError handleSuccess . leaveResponse =<<) $ + E.runFederated cnv rpc | otherwise = throwS @('ActionDenied 'RemoveConversationMember) where handleError :: @@ -1177,16 +1177,16 @@ removeMemberFromLocalConv :: Sem r (Maybe Event) removeMemberFromLocalConv lcnv lusr con victim | qUntagged lusr == victim = - fmap (fmap lcuEvent . hush) - . runError @NoChanges - . updateLocalConversation @'ConversationLeaveTag lcnv (qUntagged lusr) con - $ () + fmap (fmap lcuEvent . hush) + . runError @NoChanges + . updateLocalConversation @'ConversationLeaveTag lcnv (qUntagged lusr) con + $ () | otherwise = - fmap (fmap lcuEvent . hush) - . runError @NoChanges - . updateLocalConversation @'ConversationRemoveMembersTag lcnv (qUntagged lusr) con - . pure - $ victim + fmap (fmap lcuEvent . hush) + . runError @NoChanges + . updateLocalConversation @'ConversationRemoveMembersTag lcnv (qUntagged lusr) con + . pure + $ victim -- OTR diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 189966f3b5e..24891e22c65 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -90,7 +90,8 @@ ensureAccessRole :: ensureAccessRole roles users = do when (Set.null roles) $ throwS @'ConvAccessDenied unless (NonTeamMemberAccessRole `Set.member` roles) $ - when (any (isNothing . snd) users) $ throwS @'NotATeamMember + when (any (isNothing . snd) users) $ + throwS @'NotATeamMember unless (Set.fromList [GuestAccessRole, ServiceAccessRole] `Set.isSubsetOf` roles) $ do activated <- lookupActivatedUsers (fst <$> users) let guestsExist = length activated /= length users @@ -291,7 +292,8 @@ acceptOne2One lusr conv conn = do [_, _] -> throwS @'ConvNotFound _ -> do when (length mems > 2) $ - throw . BadConvState $ cid + throw . BadConvState $ + cid now <- input mm <- createMember lcid lusr let e = memberJoinEvent lusr (qUntagged lcid) now mm [] @@ -534,10 +536,10 @@ getConversationAndMemberWithError usr lcnv = do canDeleteMember :: TeamMember -> TeamMember -> Bool canDeleteMember deleter deletee | getRole deletee == RoleOwner = - getRole deleter == RoleOwner -- owners can only be deleted by another owner - && (deleter ^. userId /= deletee ^. userId) -- owner cannot delete itself + getRole deleter == RoleOwner -- owners can only be deleted by another owner + && (deleter ^. userId /= deletee ^. userId) -- owner cannot delete itself | otherwise = - True + True where -- (team members having no role is an internal error, but we don't want to deal with that -- here, so we pick a reasonable default.) diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 6cca62b1f45..092fdf9e4c8 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -138,7 +138,8 @@ validateOptions l o = do l ( msg . val - $ "You're journaling events for teams larger than " <> toByteString' optFanoutLimit + $ "You're journaling events for teams larger than " + <> toByteString' optFanoutLimit <> " may have some admin user ids missing. \ \ This is fine for testing purposes but NOT for production use!!" ) diff --git a/services/galley/src/Galley/Aws.hs b/services/galley/src/Galley/Aws.hs index 149ebf6ad6e..1ef921a7052 100644 --- a/services/galley/src/Galley/Aws.hs +++ b/services/galley/src/Galley/Aws.hs @@ -169,7 +169,8 @@ enqueue e = do where event = decodeLatin1 $ B64.encode $ encodeMessage e req url dedup = - SQS.newSendMessage url event & SQS.sendMessage_messageGroupId ?~ "team.events" + SQS.newSendMessage url event + & SQS.sendMessage_messageGroupId ?~ "team.events" & SQS.sendMessage_messageDeduplicationId ?~ toText dedup -------------------------------------------------------------------------------- diff --git a/services/galley/src/Galley/Cassandra/Conversation.hs b/services/galley/src/Galley/Cassandra/Conversation.hs index a245c29269a..81f25951d4b 100644 --- a/services/galley/src/Galley/Cassandra/Conversation.hs +++ b/services/galley/src/Galley/Cassandra/Conversation.hs @@ -210,8 +210,8 @@ localConversation cid = UnliftIO.runConcurrently $ toConv cid <$> UnliftIO.Concurrently (members cid) - <*> UnliftIO.Concurrently (lookupRemoteMembers cid) - <*> UnliftIO.Concurrently (retry x1 $ query1 Cql.selectConv (params LocalQuorum (Identity cid))) + <*> UnliftIO.Concurrently (lookupRemoteMembers cid) + <*> UnliftIO.Concurrently (retry x1 $ query1 Cql.selectConv (params LocalQuorum (Identity cid))) localConversations :: Members '[Embed IO, Input ClientState, TinyLog] r => diff --git a/services/galley/src/Galley/Cassandra/Conversation/Members.hs b/services/galley/src/Galley/Cassandra/Conversation/Members.hs index 4d2c03fc9de..a4d4622e8c7 100644 --- a/services/galley/src/Galley/Cassandra/Conversation/Members.hs +++ b/services/galley/src/Galley/Cassandra/Conversation/Members.hs @@ -288,13 +288,13 @@ updateOtherMemberLocalConv lcid quid omu = do let addQuery r | tDomain lcid == qDomain quid = - addPrepQuery - Cql.updateMemberConvRoleName - (r, tUnqualified lcid, qUnqualified quid) + addPrepQuery + Cql.updateMemberConvRoleName + (r, tUnqualified lcid, qUnqualified quid) | otherwise = - addPrepQuery - Cql.updateRemoteMemberConvRoleName - (r, tUnqualified lcid, qDomain quid, qUnqualified quid) + addPrepQuery + Cql.updateRemoteMemberConvRoleName + (r, tUnqualified lcid, qDomain quid, qUnqualified quid) retry x5 . batch $ do setType BatchUnLogged setConsistency LocalQuorum diff --git a/services/galley/src/Galley/Cassandra/TeamNotifications.hs b/services/galley/src/Galley/Cassandra/TeamNotifications.hs index 5084be13bfb..22416dbfcc2 100644 --- a/services/galley/src/Galley/Cassandra/TeamNotifications.hs +++ b/services/galley/src/Galley/Cassandra/TeamNotifications.hs @@ -124,8 +124,8 @@ fetch tid since (fromRange -> size) = do trim l ns | Seq.length ns <= l = ns | otherwise = case Seq.viewr ns of - EmptyR -> ns - xs :> _ -> xs + EmptyR -> ns + xs :> _ -> xs cqlStart :: PrepQuery R (Identity TeamId) (TimeUuid, Blob) cqlStart = "SELECT id, payload \ diff --git a/services/galley/src/Galley/External.hs b/services/galley/src/Galley/External.hs index 8d8b84f696a..1f41ca3b527 100644 --- a/services/galley/src/Galley/External.hs +++ b/services/galley/src/Galley/External.hs @@ -99,12 +99,12 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) Left ex | Just (Http.HttpExceptionRequest _ (Http.StatusCodeException rs _)) <- fromException ex, Http.responseStatus rs == status410 -> do - Log.debug $ - field "provider" (toByteString (s ^. serviceRefProvider)) - ~~ field "service" (toByteString (s ^. serviceRefId)) - ~~ field "bot" (toByteString (botMemId b)) - ~~ msg (val "External bot gone") - pure (b : gone) + Log.debug $ + field "provider" (toByteString (s ^. serviceRefProvider)) + ~~ field "service" (toByteString (s ^. serviceRefId)) + ~~ field "bot" (toByteString (botMemId b)) + ~~ msg (val "External bot gone") + pure (b : gone) Left ex -> do Log.info $ field "provider" (toByteString (s ^. serviceRefProvider)) @@ -119,22 +119,22 @@ deliver pp = mapM (async . exec) pp >>= foldM eval [] . zip (map fst pp) deliver1 :: Service -> BotMember -> Event -> App () deliver1 s bm e | s ^. serviceEnabled = do - let t = toByteString' (s ^. serviceToken) - let u = s ^. serviceUrl - let b = botMemId bm - let HttpsUrl url = u - recovering x3 httpHandlers $ - const $ - sendMessage (s ^. serviceFingerprints) $ - method POST - . maybe id host (urlHost u) - . maybe (port 443) port (urlPort u) - . paths [url ^. pathL, "bots", toByteString' b, "messages"] - . header "Authorization" ("Bearer " <> t) - . json e - . timeout 5000 - . secure - . expect2xx + let t = toByteString' (s ^. serviceToken) + let u = s ^. serviceUrl + let b = botMemId bm + let HttpsUrl url = u + recovering x3 httpHandlers $ + const $ + sendMessage (s ^. serviceFingerprints) $ + method POST + . maybe id host (urlHost u) + . maybe (port 443) port (urlPort u) + . paths [url ^. pathL, "bots", toByteString' b, "messages"] + . header "Authorization" ("Bearer " <> t) + . json e + . timeout 5000 + . secure + . expect2xx | otherwise = pure () urlHost :: HttpsUrl -> Maybe ByteString diff --git a/services/galley/src/Galley/Types/Clients.hs b/services/galley/src/Galley/Types/Clients.hs index 6771b261a26..d58c67ecbe0 100644 --- a/services/galley/src/Galley/Types/Clients.hs +++ b/services/galley/src/Galley/Types/Clients.hs @@ -91,7 +91,8 @@ singleton u c = filter :: (UserId -> Bool) -> Clients -> Clients filter p = - Clients . UserClients + Clients + . UserClients . Map.filterWithKey (\u _ -> p u) . (userClients . clients) @@ -101,7 +102,8 @@ contains u c = insert :: UserId -> ClientId -> Clients -> Clients insert u c = - Clients . UserClients + Clients + . UserClients . Map.insertWith Set.union u (Set.singleton c) . (userClients . clients) diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index f8d9b3092f9..3f30b17bed3 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -686,10 +686,10 @@ postMessageQualifiedLocalOwningBackendSuccess = do pure $ if | d == bDomain -> - UserMap . Map.fromList $ - [ (qUnqualified bob, Set.singleton (mkPubClient bobClient)), - (qUnqualified bart, Set.fromList (map mkPubClient [bartClient1, bartClient2])) - ] + UserMap . Map.fromList $ + [ (qUnqualified bob, Set.singleton (mkPubClient bobClient)), + (qUnqualified bart, Set.fromList (map mkPubClient [bartClient1, bartClient2])) + ] | d == cDomain -> UserMap (Map.singleton (qUnqualified carl) (Set.singleton (PubClient carlClient Nothing))) | otherwise -> mempty @@ -886,7 +886,8 @@ postMessageQualifiedLocalOwningBackendRedundantAndDeletedClients = do in pure $ UserMap . Map.fromList . mapMaybe lookupClients $ F.gucUsers getUserClients galleyApi _ = mkHandler @(FedApi 'Galley) $ - Named @"on-message-sent" $ \_ _ -> pure () + Named @"on-message-sent" $ + \_ _ -> pure () (resp2, _requests) <- postProteusMessageQualifiedWithMockFederator aliceUnqualified aliceClient convId message "data" Message.MismatchReportAll brigApi galleyApi pure resp2 !!! do @@ -1520,7 +1521,7 @@ testAccessUpdateGuestRemoved = do { newConvQualifiedUsers = [bob, charlie, dee], newConvTeam = Just (ConvTeamInfo tid) } - do @@ -1702,8 +1703,9 @@ getConvsOk2 = do carl <- randomUser connectUsers alice (singleton carl) cnv2 <- - responseJsonError =<< postConv alice [bob, carl] (Just "gossip2") [] Nothing Nothing - FederatedRequest -> Value respond bob req | frComponent req == Brig = - toJSON [mkProfile bob (Name "bob")] + toJSON [mkProfile bob (Name "bob")] | frRPC req == "on-new-remote-conversation" = - toJSON EmptyResponse + toJSON EmptyResponse | otherwise = toJSON () testDeleteTeamConversationWithRemoteMembers :: TestM () @@ -2870,10 +2872,10 @@ deleteRemoteMemberConvLocalQualifiedOk = do case (frTargetDomain fedReq, frRPC fedReq) of (d, mp) | d == remoteDomain1 && mp == getUsersRPC -> - success [mkProfile qChad (Name "Chad"), mkProfile qDee (Name "Dee")] + success [mkProfile qChad (Name "Chad"), mkProfile qDee (Name "Dee")] (d, mp) | d == remoteDomain2 && mp == getUsersRPC -> - success [mkProfile qEve (Name "Eve")] + success [mkProfile qEve (Name "Eve")] _ -> success () (convId, _) <- @@ -2921,7 +2923,7 @@ leaveRemoteConvQualifiedOk = do let mockedFederatedGalleyResponse :: FederatedRequest -> Maybe Value mockedFederatedGalleyResponse req | frComponent req == Galley = - Just . toJSON . F.LeaveConversationResponse . Right $ () + Just . toJSON . F.LeaveConversationResponse . Right $ () | otherwise = Nothing mockResponses = joinMockedFederatedResponses @@ -2952,14 +2954,15 @@ leaveNonExistentRemoteConv = do let mockResponses :: FederatedRequest -> Maybe Value mockResponses req | frComponent req == Galley = - Just . toJSON . F.LeaveConversationResponse $ - Left F.RemoveFromConversationErrorNotFound + Just . toJSON . F.LeaveConversationResponse $ + Left F.RemoveFromConversationErrorNotFound | otherwise = Nothing (resp, fedRequests) <- withTempMockFederator mockResponses $ - responseJsonError =<< deleteMemberQualified (qUnqualified alice) alice conv - Maybe Value mockResponses req | frComponent req == Galley = - Just . toJSON . F.LeaveConversationResponse $ - Left F.RemoveFromConversationErrorRemovalNotAllowed + Just . toJSON . F.LeaveConversationResponse $ + Left F.RemoveFromConversationErrorRemovalNotAllowed | otherwise = Nothing (resp, fedRequests) <- withTempMockFederator mockResponses $ - responseJsonError =<< deleteMemberQualified (qUnqualified alice) alice conv - do let e = List1.head (WS.unpackPayload n) ntfTransient n @?= False @@ -3721,12 +3725,12 @@ removeUser = do let handler :: FederatedRequest -> IO LByteString handler freq | frTargetDomain freq == dDomain = - throw $ DiscoveryFailureSrvNotAvailable "dDomain" + throw $ DiscoveryFailureSrvNotAvailable "dDomain" | frTargetDomain freq `elem` [bDomain, cDomain] = - case frRPC freq of - "leave-conversation" -> pure (encode (F.LeaveConversationResponse (Right ()))) - "on-conversation-updated" -> pure (encode ()) - _ -> throw $ MockErrorResponse HTTP.status404 "invalid rpc" + case frRPC freq of + "leave-conversation" -> pure (encode (F.LeaveConversationResponse (Right ()))) + "on-conversation-updated" -> pure (encode ()) + _ -> throw $ MockErrorResponse HTTP.status404 "invalid rpc" | otherwise = throw $ MockErrorResponse HTTP.status500 "unmocked domain" (_, fedRequests) <- withTempMockFederator' handler $ diff --git a/services/galley/test/integration/API/Federation.hs b/services/galley/test/integration/API/Federation.hs index c0b2381fdb0..89ef4c2ebd7 100644 --- a/services/galley/test/integration/API/Federation.hs +++ b/services/galley/test/integration/API/Federation.hs @@ -641,10 +641,10 @@ leaveConversationSuccess = do case (frTargetDomain fedReq, frRPC fedReq) of (d, mp) | d == remoteDomain1 && mp == getUsersRPC -> - success [mkProfile qChad (Name "Chad"), mkProfile qDee (Name "Dee")] + success [mkProfile qChad (Name "Chad"), mkProfile qDee (Name "Dee")] (d, mp) | d == remoteDomain2 && mp == getUsersRPC -> - success [mkProfile qEve (Name "Eve")] + success [mkProfile qEve (Name "Eve")] _ -> success () (convId, _) <- @@ -701,7 +701,7 @@ leaveConversationNonExistent = do . header "Wire-Origin-Domain" (toByteString' remoteDomain) . json leaveRequest ) - do @@ -994,7 +994,7 @@ onUserDeleted = do . header "Wire-Origin-Domain" (toByteString' (tDomain bob)) . json udcn ) - pure w err <- - responseJsonError =<< postWelcome (ciUser alice1) welcome - ClientIdentity -> KeyPackageRef -> MLSTest FilePath keyPackageFile qcid ref = State.gets $ \mls -> - mlsBaseDir mls cid2Str qcid + mlsBaseDir mls + cid2Str qcid T.unpack (T.decodeUtf8 (hex (unKeyPackageRef ref))) claimLocalKeyPackages :: HasCallStack => ClientIdentity -> Local UserId -> MLSTest KeyPackageBundle @@ -449,7 +452,7 @@ claimLocalKeyPackages qcid lusr = do . paths ["mls", "key-packages", "claim", toByteString' (tDomain lusr), toByteString' (tUnqualified lusr)] . zUser (ciUser qcid) ) - Qualified UserId -> MLSTest [ClientIdentity] @@ -762,7 +765,7 @@ sendAndConsumeMessage mp = do events <- fmap mmssEvents . responseJsonError =<< postMessage (ciUser (mpSender mp)) (mpMessage mp) - do @@ -818,7 +821,7 @@ sendAndConsumeCommitBundle mp = do fmap mmssEvents . responseJsonError =<< postCommitBundle (ciUser (mpSender mp)) bundle - do delete @@ -1198,7 +1198,7 @@ testDeleteBindingTeam ownerHasPassword = do ) ) !!! const 202 - === statusCode + === statusCode checkUserDeleteEvent owner wsOwner checkUserDeleteEvent (mem1 ^. userId) wsMember1 checkUserDeleteEvent (mem2 ^. userId) wsMember2 @@ -1283,7 +1283,7 @@ testUpdateTeamIconValidation = do . json payload ) !!! const expectedStatusCode - === statusCode + === statusCode let payloadWithInvalidIcon = object ["name" .= String "name", "icon" .= String "invalid"] update payloadWithInvalidIcon 400 let payloadWithValidIcon = @@ -1312,7 +1312,7 @@ testUpdateTeam = do . body (RequestBodyLBS payload) ) !!! const code - === statusCode + === statusCode let bad = object ["name" .= T.replicate 100 "too large"] doPut (encode bad) 400 @@ -1414,7 +1414,7 @@ testTeamAddRemoveMemberAboveThresholdNoEvents = do . json u ) !!! const 200 - === statusCode + === statusCode if expect then mapM_ (checkUserUpdateEvent target) wsListeners else WS.assertNoEvent (1 # Second) wsListeners @@ -1432,7 +1432,7 @@ testTeamAddRemoveMemberAboveThresholdNoEvents = do . json u ) !!! const 200 - === statusCode + === statusCode -- Due to the fact that the team is too large, we expect no events! if expect then checkTeamUpdateEvent tid u wsOrigin @@ -1460,7 +1460,7 @@ testTeamAddRemoveMemberAboveThresholdNoEvents = do . json (newTeamMemberDeleteData (Just $ Util.defPassword)) ) !!! const 202 - === statusCode + === statusCode if expect then checkTeamMemberLeave tid victim wsOwner else WS.assertNoEvent (1 # Second) [wsOwner] diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index cf56f46ddd0..4246598847f 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -277,7 +277,8 @@ testSSO setSSOFeature = do putSSOInternal :: HasCallStack => TeamId -> Public.FeatureStatus -> TestM () putSSOInternal tid = - void . putTeamFeatureFlagInternal @Public.SSOConfig expect2xx tid + void + . putTeamFeatureFlagInternal @Public.SSOConfig expect2xx tid . (\st -> Public.WithStatusNoLock st Public.SSOConfig Public.FeatureTTLUnlimited) patchSSOInternal :: HasCallStack => TeamId -> Public.FeatureStatus -> TestM () @@ -325,7 +326,8 @@ testLegalHold setLegalHoldInternal = do putLegalHoldInternal :: HasCallStack => (Request -> Request) -> TeamId -> Public.FeatureStatus -> TestM () putLegalHoldInternal expectation tid = - void . putTeamFeatureFlagInternal @Public.LegalholdConfig expectation tid + void + . putTeamFeatureFlagInternal @Public.LegalholdConfig expectation tid . (\st -> Public.WithStatusNoLock st Public.LegalholdConfig Public.FeatureTTLUnlimited) patchLegalHoldInternal :: HasCallStack => (Request -> Request) -> TeamId -> Public.FeatureStatus -> TestM () @@ -1011,7 +1013,8 @@ testFeatureConfigConsistency = do allTeamFeaturesRes <- getAllTeamFeatures member tid >>= parseObjectKeys unless (allTeamFeaturesRes `Set.isSubsetOf` allFeaturesRes) $ - liftIO $ expectationFailure (show allTeamFeaturesRes <> " is not a subset of " <> show allFeaturesRes) + liftIO $ + expectationFailure (show allTeamFeaturesRes <> " is not a subset of " <> show allFeaturesRes) where parseObjectKeys :: ResponseLBS -> TestM (Set.Set Text) parseObjectKeys res = do diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index d0130995c44..b2feb3227b6 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -1778,7 +1778,8 @@ assertNotification :: (HasCallStack, FromJSON a, MonadIO m) => WS.WebSocket -> ( assertNotification ws predicate = void . liftIO . WS.assertMatch (5 WS.# WS.Second) ws $ \notif -> do unless ((NonEmpty.length . List1.toNonEmpty $ ntfPayload $ notif) == 1) $ - error $ "not suppored by test helper: event with more than one object in the payload: " <> cs (Aeson.encode notif) + error $ + "not suppored by test helper: event with more than one object in the payload: " <> cs (Aeson.encode notif) let j = Aeson.Object $ List1.head (ntfPayload notif) case Aeson.fromJSON j of Aeson.Success x -> predicate x diff --git a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs index 677895ad58d..1b57b2cfa84 100644 --- a/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs +++ b/services/galley/test/integration/API/Teams/LegalHold/DisabledByDefault.hs @@ -1293,7 +1293,8 @@ assertNotification :: (HasCallStack, FromJSON a, MonadIO m) => WS.WebSocket -> ( assertNotification ws predicate = void . liftIO . WS.assertMatch (5 WS.# WS.Second) ws $ \notif -> do unless ((NonEmpty.length . List1.toNonEmpty $ ntfPayload $ notif) == 1) $ - error $ "not suppored by test helper: event with more than one object in the payload: " <> cs (Aeson.encode notif) + error $ + "not suppored by test helper: event with more than one object in the payload: " <> cs (Aeson.encode notif) let j = Aeson.Object $ List1.head (ntfPayload notif) case Aeson.fromJSON j of Aeson.Success x -> predicate x diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index ae8e4484ca7..029b5816b8e 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -255,11 +255,12 @@ changeTeamStatus :: HasCallStack => TeamId -> TeamStatus -> TestM () changeTeamStatus tid s = do g <- viewGalley put - ( g . paths ["i", "teams", toByteString' tid, "status"] + ( g + . paths ["i", "teams", toByteString' tid, "status"] . json (TeamStatusUpdate s Nothing) ) !!! const 200 - === statusCode + === statusCode createBindingTeamInternal :: HasCallStack => Text -> UserId -> TestM TeamId createBindingTeamInternal name owner = do @@ -329,7 +330,7 @@ getTeamMembersInternalTruncated tid n = do . queryItem "maxResults" (C.pack $ show n) ) UserId -> TeamId -> [UserId] -> TestM TeamMemberList @@ -343,7 +344,7 @@ bulkGetTeamMembers usr tid uids = do . json (UserIdList uids) ) UserId -> TeamId -> [UserId] -> Int -> TestM ResponseLBS @@ -419,7 +420,8 @@ addUserToTeamWithRole' role inviter tid = do inviteeCode <- getInvitationCode tid (inInvitation inv) r <- post - ( brig . path "/register" + ( brig + . path "/register" . contentJson . body (acceptInviteBody inviteeEmail inviteeCode) ) @@ -444,7 +446,7 @@ makeOwner owner mem tid = do . json changeMember ) !!! const 200 - === statusCode + === statusCode acceptInviteBody :: Email -> InvitationCode -> RequestBody acceptInviteBody email code = @@ -892,7 +894,8 @@ postBroadcast lu c b = do in contentProtobuf . bytes m let name = case bAPI b of BroadcastQualified -> "proteus"; _ -> "otr" post $ - g . bReq b + g + . bReq b . paths ["broadcast", name, "messages"] . zUser u . zConn "conn" @@ -1354,11 +1357,11 @@ getTeamQueue zusr msince msize onlyLast = parseEventList :: QueuedNotificationList -> [(NotificationId, UserId)] parseEventList qnl | isJust msize && qnl ^. queuedHasMore /= snd (fromJust msize) = - error $ "expected has_more: " <> show (snd $ fromJust msize) <> "; but found: " <> show (qnl ^. queuedHasMore) + error $ "expected has_more: " <> show (snd $ fromJust msize) <> "; but found: " <> show (qnl ^. queuedHasMore) | isJust (qnl ^. queuedTime) = - error $ "expected time: Nothing; but found: " <> show (qnl ^. queuedTime) + error $ "expected time: Nothing; but found: " <> show (qnl ^. queuedTime) | otherwise = - fmap (_2 %~ parseEvt) . mconcat . fmap parseEvts . view queuedNotifications $ qnl + fmap (_2 %~ parseEvt) . mconcat . fmap parseEvts . view queuedNotifications $ qnl parseEvts :: QueuedNotification -> [(NotificationId, Object)] parseEvts qn = (qn ^. queuedNotificationId,) <$> toList (qn ^. queuedNotificationPayload) @@ -1375,7 +1378,8 @@ getTeamQueue' :: HasCallStack => UserId -> Maybe NotificationId -> Maybe Int -> getTeamQueue' zusr msince msize onlyLast = do g <- viewGalley get - ( g . path "/teams/notifications" + ( g + . path "/teams/notifications" . zUser zusr . zConn "conn" . zType "access" @@ -1412,7 +1416,8 @@ getFeatureStatusMulti :: forall cfg. (IsFeatureConfig cfg, KnownSymbol (FeatureS getFeatureStatusMulti req = do g <- viewGalley post - ( g . paths ["i", "features-multi-teams", featureNameBS @cfg] + ( g + . paths ["i", "features-multi-teams", featureNameBS @cfg] . json req ) @@ -1875,7 +1880,7 @@ connectWithRemoteUser self other = do . json req ) !!! const 200 - === statusCode + === statusCode -- | A copy of 'postConnection' from Brig integration tests. postConnection :: UserId -> UserId -> TestM ResponseLBS @@ -1946,7 +1951,8 @@ assertConnections u cstat = do let cstat' :: [ConnectionStatus] cstat' = fmap status . clConnections . fromMaybe (error "bad response") . responseJsonMaybe $ resp unless (all (`elem` cstat') cstat) $ - error $ "connection check failed: " <> show cstat <> " is not a subset of " <> show cstat' + error $ + "connection check failed: " <> show cstat <> " is not a subset of " <> show cstat' where status c = ConnectionStatus (ucFrom c) (qUnqualified $ ucTo c) (ucStatus c) listConnections brig usr = get $ brig . paths ["v1", "connections"] . zUser usr @@ -2693,7 +2699,7 @@ checkTimeout = 3 # Second mockedFederatedBrigResponse :: [(Qualified UserId, Text)] -> FederatedRequest -> Maybe Value mockedFederatedBrigResponse users req | frComponent req == Brig = - Just . toJSON $ [mkProfile mem (Name name) | (mem, name) <- users] + Just . toJSON $ [mkProfile mem (Name name) | (mem, name) <- users] | otherwise = Nothing -- | Combine two mocked services such that for a given request a JSON response @@ -2758,7 +2764,7 @@ createOne2OneConvWithRemote localUser remoteUser = do ooConvId <- fmap uuorConvId . responseJsonError =<< iUpsertOne2OneConversation (mkRequest LocalActor Nothing) - let expectedRecipients = Map.keysSet msg expectedRecipientMap = recipientSetToMap expectedRecipients - in not (Map.member sender msg) - ==> checkMessageClients sender expectedRecipientMap msg strat - === (True, msg, QualifiedMismatch mempty mempty mempty) + in not (Map.member sender msg) ==> + checkMessageClients sender expectedRecipientMap msg strat + === (True, msg, QualifiedMismatch mempty mempty mempty) checkMessageClientRedundantSender :: TestTree checkMessageClientRedundantSender = testProperty "sender should be part of redundant" $ diff --git a/services/galley/test/unit/Test/Galley/Mapping.hs b/services/galley/test/unit/Test/Galley/Mapping.hs index 7ad96398c13..c9537d7b93c 100644 --- a/services/galley/test/unit/Test/Galley/Mapping.hs +++ b/services/galley/test/unit/Test/Galley/Mapping.hs @@ -65,21 +65,21 @@ tests = == Just (sort (convUids (tDomain luid) c)), testProperty "conversation view for an invalid user is empty" $ \(RandomConversation c) luid -> - notElem (tUnqualified luid) (map lmId (Data.convLocalMembers c)) - ==> isNothing (conversationViewMaybe luid c), + notElem (tUnqualified luid) (map lmId (Data.convLocalMembers c)) ==> + isNothing (conversationViewMaybe luid c), testProperty "remote conversation view for a valid user is non-empty" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (qUntagged ruid) /= dom - ==> isJust (conversationToRemote dom ruid c), + qDomain (qUntagged ruid) /= dom ==> + isJust (conversationToRemote dom ruid c), testProperty "self user role in remote conversation view is correct" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (qUntagged ruid) /= dom - ==> fmap (rcmSelfRole . rcnvMembers) (conversationToRemote dom ruid c) + qDomain (qUntagged ruid) /= dom ==> + fmap (rcmSelfRole . rcnvMembers) (conversationToRemote dom ruid c) == Just roleNameWireMember, testProperty "remote conversation view metadata is correct" $ \(ConvWithRemoteUser c ruid) dom -> - qDomain (qUntagged ruid) /= dom - ==> fmap rcnvMetadata (conversationToRemote dom ruid c) + qDomain (qUntagged ruid) /= dom ==> + fmap rcnvMetadata (conversationToRemote dom ruid c) == Just (Data.convMetadata c), testProperty "remote conversation view does not contain self" $ \(ConvWithRemoteUser c ruid) dom -> case conversationToRemote dom ruid c of @@ -92,8 +92,8 @@ tests = cnvUids :: Conversation -> [Qualified UserId] cnvUids c = let mems = cnvMembers c - in memId (cmSelf mems) : - map omQualifiedId (cmOthers mems) + in memId (cmSelf mems) + : map omQualifiedId (cmOthers mems) convUids :: Domain -> Data.Conversation -> [Qualified UserId] convUids dom c = @@ -123,7 +123,8 @@ genConversation = genConversationMetadata :: Gen ConversationMetadata genConversationMetadata = - ConversationMetadata RegularConv <$> arbitrary + ConversationMetadata RegularConv + <$> arbitrary <*> pure [] <*> pure (Set.fromList [TeamMemberAccessRole, NonTeamMemberAccessRole]) <*> arbitrary diff --git a/services/gundeck/.ormolu b/services/gundeck/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/services/gundeck/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/services/gundeck/src/Gundeck/Aws.hs b/services/gundeck/src/Gundeck/Aws.hs index 989a09964ea..5d642e68cdd 100644 --- a/services/gundeck/src/Gundeck/Aws.hs +++ b/services/gundeck/src/Gundeck/Aws.hs @@ -236,9 +236,10 @@ updateEndpoint us tk arn = do case res of Right _ -> pure () Left x@(AWS.ServiceError e) - | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode + | is "SNS" 400 x + && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isMetadataLengthError (e ^. serviceMessage) -> - throwM $ InvalidCustomData arn + throwM $ InvalidCustomData arn Left x -> throwM $ if is "SNS" 404 x @@ -301,18 +302,20 @@ createEndpoint u tr arnEnv app token = do Left x@(AWS.ServiceError e) | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode, Just ep <- parseExistsError (e ^. serviceMessage) -> - pure (Left (EndpointInUse ep)) - | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode + pure (Left (EndpointInUse ep)) + | is "SNS" 400 x + && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isLengthError (e ^. serviceMessage) -> - pure (Left (TokenTooLong $ tokenLength token)) - | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode + pure (Left (TokenTooLong $ tokenLength token)) + | is "SNS" 400 x + && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isTokenError (e ^. serviceMessage) -> - pure (Left (InvalidToken token)) + pure (Left (InvalidToken token)) | is "SNS" 404 x -> - pure (Left (AppNotFound app)) + pure (Left (AppNotFound app)) | is "SNS" 403 x -> do - warn $ "arn" .= toText arn ~~ msg (val "Not authorized.") - pure (Left (AppNotFound app)) + warn $ "arn" .= toText arn ~~ msg (val "Not authorized.") + pure (Left (AppNotFound app)) Left x -> throwM (GeneralError x) where readArn r = either (throwM . InvalidArn r) pure (fromText r) @@ -401,16 +404,19 @@ publish arn txt attrs = do Right _ -> pure (Right ()) Left x@(AWS.ServiceError e) | is "SNS" 400 x && AWS.newErrorCode "EndpointDisabled" == e ^. serviceCode -> - pure (Left (EndpointDisabled arn)) - | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode + pure (Left (EndpointDisabled arn)) + | is "SNS" 400 x + && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isProtocolSizeError (e ^. serviceMessage) -> - pure (Left (PayloadTooLarge arn)) - | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode + pure (Left (PayloadTooLarge arn)) + | is "SNS" 400 x + && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isSnsSizeError (e ^. serviceMessage) -> - pure (Left (PayloadTooLarge arn)) - | is "SNS" 400 x && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode + pure (Left (PayloadTooLarge arn)) + | is "SNS" 400 x + && AWS.newErrorCode "InvalidParameter" == e ^. serviceCode && isArnError (e ^. serviceMessage) -> - pure (Left (InvalidEndpoint arn)) + pure (Left (InvalidEndpoint arn)) Left x -> throwM (GeneralError x) where -- Thank you Amazon for not having granular error codes! diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index e841205deab..c7aa7f318b4 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -90,8 +90,8 @@ createEnv m o = do pure $ Just rAdd p <- - C.init $ - C.setLogger (C.mkLogger (Logger.clone (Just "cassandra.gundeck") l)) + C.init + $ C.setLogger (C.mkLogger (Logger.clone (Just "cassandra.gundeck") l)) . C.setContacts (NE.head c) (NE.tail c) . C.setPortNumber (fromIntegral $ o ^. optCassandra . casEndpoint . epPort) . C.setKeyspace (Keyspace (o ^. optCassandra . casKeyspace)) @@ -102,7 +102,7 @@ createEnv m o = do . C.setResponseTimeout 10 . C.setProtocolVersion C.V4 . C.setPolicy (C.dcFilterPolicyIfConfigured l (o ^. optCassandra . casFilterNodesByDatacentre)) - $ C.defSettings + $ C.defSettings a <- Aws.mkEnv l o n io <- mkAutoUpdate diff --git a/services/gundeck/src/Gundeck/Instances.hs b/services/gundeck/src/Gundeck/Instances.hs index f06fb8e2a76..d1ccbf08e95 100644 --- a/services/gundeck/src/Gundeck/Instances.hs +++ b/services/gundeck/src/Gundeck/Instances.hs @@ -85,6 +85,7 @@ instance FromText (Id a) where fromText = Parser.parseOnly $ Parser.take 36 >>= \txt -> - txt & Text.encodeUtf8 + txt + & Text.encodeUtf8 & Uuid.fromASCIIBytes & maybe (fail "Invalid UUID") (pure . Id) diff --git a/services/gundeck/src/Gundeck/Notification/Data.hs b/services/gundeck/src/Gundeck/Notification/Data.hs index 85d3428f8ce..53c5b305470 100644 --- a/services/gundeck/src/Gundeck/Notification/Data.hs +++ b/services/gundeck/src/Gundeck/Notification/Data.hs @@ -74,7 +74,8 @@ add n tgts (Blob . JSON.encode -> p) (notificationTTLSeconds -> t) = fetchId :: MonadClient m => UserId -> NotificationId -> Maybe ClientId -> m (Maybe QueuedNotification) fetchId u n c = listToMaybe . foldr' (toNotif c) [] - <$> query cqlById (params LocalQuorum (u, n)) & retry x1 + <$> query cqlById (params LocalQuorum (u, n)) + & retry x1 where cqlById :: PrepQuery R (UserId, NotificationId) (TimeUuid, Blob, Maybe (C.Set ClientId)) cqlById = @@ -133,7 +134,7 @@ fetch u c since (fromRange -> size) = do x :< xs -> case since of Just s | s == x ^. queuedNotificationId -> - ResultPage xs more False + ResultPage xs more False _ -> ResultPage (x <| xs) more (isJust since) where collect acc num page = @@ -148,8 +149,8 @@ fetch u c since (fromRange -> size) = do trim l ns | Seq.length ns <= l = ns | otherwise = case Seq.viewr ns of - EmptyR -> ns - xs :> _ -> xs + EmptyR -> ns + xs :> _ -> xs cqlStart :: PrepQuery R (Identity UserId) (TimeUuid, Blob, Maybe (C.Set ClientId)) cqlStart = "SELECT id, payload, clients \ diff --git a/services/gundeck/src/Gundeck/Presence/Data.hs b/services/gundeck/src/Gundeck/Presence/Data.hs index e5e4a571d2b..2bd9aa20782 100644 --- a/services/gundeck/src/Gundeck/Presence/Data.hs +++ b/services/gundeck/src/Gundeck/Presence/Data.hs @@ -120,7 +120,8 @@ instance ToJSON PresenceData where instance FromJSON PresenceData where parseJSON = withObject "PresenceData" $ \o -> - PresenceData <$> o .: "r" + PresenceData + <$> o .: "r" <*> o .:? "c" <*> o .:? "t" .!= 0 diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index c8a2d1e596a..f863ff57a03 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -347,10 +347,10 @@ nativeTargets psh rcps' alreadySent = addresses :: Recipient -> m [Address] addresses u = do addrs <- mntgtLookupAddresses (u ^. recipientId) - pure $ - preference + pure + $ preference . filter (eligible u) - $ addrs + $ addrs eligible :: Recipient -> Address -> Bool eligible u a -- Never include the origin client. @@ -409,7 +409,7 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) "user" .= UUID.toASCIIBytes (toUUID uid) ~~ "token" - .= Text.take 16 (tokenText (newtok ^. token)) + .= Text.take 16 (tokenText (newtok ^. token)) ~~ msg (val "Registering push token") continue newtok cur >>= either @@ -428,9 +428,9 @@ addToken uid cid newtok = mpaRunWithBudget 1 (Left Public.AddTokenErrorNoBudget) | a ^. addrTransport == t ^. tokenTransport && a ^. addrApp == t ^. tokenApp && a ^. addrClient == t ^. tokenClient = - if a ^. addrToken == t ^. token - then (Just a, old) - else (x, a : old) + if a ^. addrToken == t ^. token + then (Just a, old) + else (x, a : old) | otherwise = (x, old) continue :: @@ -535,9 +535,9 @@ updateEndpoint uid t arn e = do "user" .= UUID.toASCIIBytes (toUUID a) ~~ "token" - .= Text.take 16 (tokenText tk) + .= Text.take 16 (tokenText tk) ~~ "arn" - .= toText r + .= toText r ~~ msg (val m) deleteToken :: UserId -> Token -> Gundeck (Maybe ()) diff --git a/services/gundeck/src/Gundeck/Redis.hs b/services/gundeck/src/Gundeck/Redis.hs index d8dfa59d369..8994fb5e927 100644 --- a/services/gundeck/src/Gundeck/Redis.hs +++ b/services/gundeck/src/Gundeck/Redis.hs @@ -94,7 +94,8 @@ connectRobust l retryStrategy connectLowLevel = do reconnectOnce <- once . retry $ reconnectRedis robustConnection -- avoid concurrent attempts to reconnect let newReConnection = ReConnection {_rrConnection = conn, _rrReconnect = reconnectOnce} unlessM (tryPutMVar robustConnection newReConnection) $ - void $ swapMVar robustConnection newReConnection + void $ + swapMVar robustConnection newReConnection logEx :: Show e => ((Msg -> Msg) -> IO ()) -> e -> ByteString -> IO () logEx lLevel e description = lLevel $ Log.msg (Log.val description) . Log.field "error" (show e) diff --git a/services/gundeck/test/integration/API.hs b/services/gundeck/test/integration/API.hs index c9d1c27cc18..1e14a743544 100644 --- a/services/gundeck/test/integration/API.hs +++ b/services/gundeck/test/integration/API.hs @@ -184,7 +184,7 @@ replacePresence = do elem localhost8080 . map resource . decodePresence setPresence gu pres2 !!! const 201 - === statusCode + === statusCode getPresence gu (showUser uid) !!! do const 2 === length . decodePresence assertTrue "New Cannon" $ @@ -759,7 +759,7 @@ testUnregisterClient = do cid <- randomClientId unregisterClient g uid cid !!! const 200 - === statusCode + === statusCode ----------------------------------------------------------------------------- -- Native push token registration @@ -946,7 +946,7 @@ testRedisMigration = do g <- view tsGundeck setPresence g presence !!! const 201 - === statusCode + === statusCode retrievedPresence <- map resource . decodePresence <$> (getPresence g (toByteString' uid) NotificationTarget emptyMeansFullHack tgt = - tgt & targetClients %~ \case - [] -> clientIdsOfUser env (tgt ^. targetUser) - same@(_ : _) -> same + tgt + & targetClients %~ \case + [] -> clientIdsOfUser env (tgt ^. targetUser) + same@(_ : _) -> same forM_ clients $ \(userid, clientid) -> do msWSQueue %= deliver (userid, clientid) (ntfPayload notif) pure $ uncurry fakePresence <$> clients diff --git a/services/gundeck/test/unit/Native.hs b/services/gundeck/test/unit/Native.hs index 0d99b696005..e8715a44ba4 100644 --- a/services/gundeck/test/unit/Native.hs +++ b/services/gundeck/test/unit/Native.hs @@ -102,7 +102,8 @@ data GcmData = GcmData instance FromJSON GcmData where parseJSON = withObject "GcmData" $ \o -> - GcmData <$> o .: "priority" + GcmData + <$> o .: "priority" <*> o .: "data" data ApnsData = ApnsData @@ -113,7 +114,8 @@ data ApnsData = ApnsData instance FromJSON ApnsData where parseJSON = withObject "ApnsData" $ \o -> - ApnsData <$> o .: "aps" + ApnsData + <$> o .: "aps" <*> o .: "data" newtype Bundle = NoticeBundle NotificationId diff --git a/services/nginz/third_party/nginx-module-vts b/services/nginz/third_party/nginx-module-vts index 0009b3bc668..b606b13006f 160000 --- a/services/nginz/third_party/nginx-module-vts +++ b/services/nginz/third_party/nginx-module-vts @@ -1 +1 @@ -Subproject commit 0009b3bc668a7d73751c4cd8f8c0a161cba96832 +Subproject commit b606b13006ffc3c694e8e6326a85f629c1288568 diff --git a/services/proxy/.ormolu b/services/proxy/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/services/proxy/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/services/spar/.ormolu b/services/spar/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/services/spar/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index 58dc6bd8e7e..eae776c0313 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -324,11 +324,11 @@ checkHandleAvailable hnd = do let sCode = statusCode resp if | sCode == 200 -> -- handle exists - pure False + pure False | sCode == 404 -> -- handle not found - pure True + pure True | otherwise -> - rethrow "brig" resp + rethrow "brig" resp -- | Call brig to delete a user. -- If the user wasn't deleted completely before, another deletion attempt will be made. diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 90624de1779..5026f98af4d 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -146,11 +146,11 @@ instance case filter' of Scim.FilterAttrCompare (Scim.AttrPath schema attrName _subAttr) Scim.OpEq (Scim.ValString val) | Scim.isUserSchema schema -> do - x <- runMaybeT $ case attrName of - "username" -> scimFindUserByHandle mIdpConfig stiTeam val - "externalid" -> scimFindUserByEmail mIdpConfig stiTeam val - _ -> throwError (Scim.badRequest Scim.InvalidFilter (Just "Unsupported attribute")) - pure $ Scim.fromList (toList x) + x <- runMaybeT $ case attrName of + "username" -> scimFindUserByHandle mIdpConfig stiTeam val + "externalid" -> scimFindUserByEmail mIdpConfig stiTeam val + _ -> throwError (Scim.badRequest Scim.InvalidFilter (Just "Unsupported attribute")) + pure $ Scim.fromList (toList x) | otherwise -> throwError $ Scim.badRequest Scim.InvalidFilter (Just "Unsupported schema") _ -> throwError $ Scim.badRequest Scim.InvalidFilter (Just "Operation not supported") diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 3cae9779640..9e463aafbb9 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -1446,7 +1446,8 @@ specSparUserMigration = do let insert :: PrepQuery W (SAML.Issuer, SAML.NameID, UserId) () insert = "INSERT INTO user (issuer, sso_id, uid) VALUES (?, ?, ?)" runClient client $ - retry x5 $ write insert (params LocalQuorum (issuer, subject, memberUid)) + retry x5 $ + write insert (params LocalQuorum (issuer, subject, memberUid)) mbUserId <- do authnreq <- negotiateAuthnRequest idp diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 07ebef5de30..84bd1dcde5f 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -2215,5 +2215,5 @@ executeTeamUserSearch brig teamid self mbSearchText = . maybe id (queryItem "q" . encodeUtf8) mbSearchText ) >= fmap Search.searchResults . responseJsonError diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index fec79f6e1c5..50505ae9979 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -343,7 +343,8 @@ getUserBrig :: HasCallStack => UserId -> TestSpar (Maybe User) getUserBrig uid = do env <- ask let req = - (env ^. teBrig) . path "/self" + (env ^. teBrig) + . path "/self" . header "Z-User" (toByteString' uid) resp <- call $ get req case statusCode resp of @@ -414,12 +415,13 @@ inviteAndRegisterUser brig u tid inviteeEmail = do Just inviteeCode <- getInvitationCode tid (TeamInvitation.inInvitation inv) rspInvitee <- post - ( brig . path "/register" + ( brig + . path "/register" . contentJson . body (accept' inviteeEmail inviteeCode) ) getSelfProfile brig (userId invitee) diff --git a/services/spar/test-integration/Util/Invitation.hs b/services/spar/test-integration/Util/Invitation.hs index 038e4880418..7bf394177f2 100644 --- a/services/spar/test-integration/Util/Invitation.hs +++ b/services/spar/test-integration/Util/Invitation.hs @@ -46,7 +46,9 @@ getInvitation :: HasCallStack => BrigReq -> Email -> Http Invitation getInvitation brig email = responseJsonUnsafe <$> Bilge.get - ( brig . path "/i/teams/invitations/by-email" . contentJson + ( brig + . path "/i/teams/invitations/by-email" + . contentJson . queryItem "email" (toByteString' email) . expect2xx ) @@ -75,7 +77,8 @@ registerInvitation email name inviteeCode shouldSucceed = do call $ void $ post - ( brig . path "/register" + ( brig + . path "/register" . contentJson . json (acceptWithName name email inviteeCode) ) diff --git a/tools/api-simulations/.ormolu b/tools/api-simulations/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/tools/api-simulations/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs b/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs index 4f0ff9ed6c9..4a4f69c3960 100644 --- a/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs +++ b/tools/api-simulations/smoketest/src/Network/Wire/Simulations/SmokeTest.hs @@ -130,9 +130,9 @@ mainBotNet n = do let carlWithTablet = (carl, carlTablet) let people :: [(Bot, ConvId, BotClient)] -- everyone except for Ally people = - (bill, a2b, billPC) : - (carl, a2c, carlTablet) : - zip3 goons a2goons goonClients + (bill, a2b, billPC) + : (carl, a2c, carlTablet) + : zip3 goons a2goons goonClients info $ msg (val "OTR 1-1 greetings") -- Ally greets everyone in 1-1 runBotSession ally $ diff --git a/tools/db/assets/.ormolu b/tools/db/assets/.ormolu new file mode 120000 index 00000000000..ffc2ca9745e --- /dev/null +++ b/tools/db/assets/.ormolu @@ -0,0 +1 @@ +../../../.ormolu \ No newline at end of file diff --git a/tools/db/auto-whitelist/.ormolu b/tools/db/auto-whitelist/.ormolu new file mode 120000 index 00000000000..ffc2ca9745e --- /dev/null +++ b/tools/db/auto-whitelist/.ormolu @@ -0,0 +1 @@ +../../../.ormolu \ No newline at end of file diff --git a/tools/db/billing-team-member-backfill/.ormolu b/tools/db/billing-team-member-backfill/.ormolu new file mode 120000 index 00000000000..ffc2ca9745e --- /dev/null +++ b/tools/db/billing-team-member-backfill/.ormolu @@ -0,0 +1 @@ +../../../.ormolu \ No newline at end of file diff --git a/tools/db/find-undead/.ormolu b/tools/db/find-undead/.ormolu new file mode 120000 index 00000000000..ffc2ca9745e --- /dev/null +++ b/tools/db/find-undead/.ormolu @@ -0,0 +1 @@ +../../../.ormolu \ No newline at end of file diff --git a/tools/db/migrate-sso-feature-flag/.ormolu b/tools/db/migrate-sso-feature-flag/.ormolu new file mode 120000 index 00000000000..ffc2ca9745e --- /dev/null +++ b/tools/db/migrate-sso-feature-flag/.ormolu @@ -0,0 +1 @@ +../../../.ormolu \ No newline at end of file diff --git a/tools/db/move-team/.ormolu b/tools/db/move-team/.ormolu new file mode 120000 index 00000000000..ffc2ca9745e --- /dev/null +++ b/tools/db/move-team/.ormolu @@ -0,0 +1 @@ +../../../.ormolu \ No newline at end of file diff --git a/tools/db/repair-handles/.ormolu b/tools/db/repair-handles/.ormolu new file mode 120000 index 00000000000..ffc2ca9745e --- /dev/null +++ b/tools/db/repair-handles/.ormolu @@ -0,0 +1 @@ +../../../.ormolu \ No newline at end of file diff --git a/tools/db/repair-handles/src/Work.hs b/tools/db/repair-handles/src/Work.hs index cf5c1dced69..f1f303c7c1b 100644 --- a/tools/db/repair-handles/src/Work.hs +++ b/tools/db/repair-handles/src/Work.hs @@ -155,7 +155,8 @@ executeAction env = \case setUserHandle :: Env -> UserId -> Handle -> IO () setUserHandle Env {..} uid handle = runClient envBrig $ - Cas.write updateHandle $ params LocalQuorum (handle, uid) + Cas.write updateHandle $ + params LocalQuorum (handle, uid) where updateHandle :: PrepQuery W (Handle, UserId) () updateHandle = "UPDATE user SET handle = ? WHERE id = ?" @@ -163,7 +164,8 @@ executeAction env = \case removeHandle :: Env -> Handle -> IO () removeHandle Env {..} handle = runClient envBrig $ - Cas.write deleteHandle $ params LocalQuorum (pure handle) + Cas.write deleteHandle $ + params LocalQuorum (pure handle) where deleteHandle :: PrepQuery W (Identity Handle) () deleteHandle = "DELETE FROM user_handle WHERE handle = ?" diff --git a/tools/db/service-backfill/.ormolu b/tools/db/service-backfill/.ormolu new file mode 120000 index 00000000000..ffc2ca9745e --- /dev/null +++ b/tools/db/service-backfill/.ormolu @@ -0,0 +1 @@ +../../../.ormolu \ No newline at end of file diff --git a/tools/rex/.ormolu b/tools/rex/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/tools/rex/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file diff --git a/tools/stern/.ormolu b/tools/stern/.ormolu new file mode 120000 index 00000000000..157b212d7cd --- /dev/null +++ b/tools/stern/.ormolu @@ -0,0 +1 @@ +../../.ormolu \ No newline at end of file