diff --git a/.gitignore b/.gitignore index 50a4d5aff20..0b41c5aba60 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,5 @@ target -Cargo.lock +./libs/libzauth/libzauth/Cargo.lock *.aux* *.chi *.chs.h @@ -24,6 +24,7 @@ ID Setup.hs cabal.sandbox.config dist +dist-newstyle gen-hs log tags @@ -74,3 +75,13 @@ deploy/dockerephemeral/build/smtp/ # Ignore cabal files; use package.yaml instead *.cabal + +# Avoid storing generated keys +/deploy/services-demo/resources/turn/secret.txt + +# Avoid storing generated keys (privkeys.txt and pubkeys.txt are generated by demo.sh) +/deploy/services-demo/resources/zauth/privkeys.txt +/deploy/services-demo/resources/zauth/pubkeys.txt + +/libs/libzauth/bzauth-c/deb/usr + diff --git a/CHANGELOG.md b/CHANGELOG.md index 8822cc59ab4..803b4bcbdba 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,40 @@ +# 2020-03-10 + +## New features + +- Remove autoconnect functionality; deprecate end-point. (#1005) +- Email visible to all users in same team (#999) + +## Bug fixes + +- fix nginx permissions in docker image (#985) + +## Significant internal changes + +- Update nginx to latest stable (#725) + +## Internal Changes + +- ormolu.sh: make queries for options more robust (#1009) +- Run hscim azure tests (#941) +- move FUTUREWORK(federation) comment to right place +- stack snapshot 3.0. (#1004, works around 8697b57609b523905641f943d68bbbe18de110e8) +- Fix .gitignore shenanigans in Nix (#1002) +- Update types of some galley endpoints to be federation-aware (#1001) +- Cleanup (#1000) +- Compile nginx with libzauth using nix (#988) +- Move and create federation-related types (#997) +- Tweak ormolu script. (#998) +- Give handlers in gundeck, cannon stronger types (#990) +- Rename cassandra-schema.txt to cassandra-schema.cql (#992) +- Ignore dist-newstyle (#991) +- Refactor: separate HTTP handlers from app logic (galley) (#989) +- Mock federator (#986) +- Eliminate more CPP (#987) +- Cleanup compiler warnings (#984) +- Make ormolu available in builder (#983) + + # 2020-02-27 ## Hotfix diff --git a/Makefile b/Makefile index 3f5c550a052..3b2cafcf0e0 100644 --- a/Makefile +++ b/Makefile @@ -165,8 +165,8 @@ run-docker-builder: CASSANDRA_CONTAINER := $(shell docker ps | grep '/cassandra:' | perl -ne '/^(\S+)\s/ && print $$1') .PHONY: git-add-cassandra-schema git-add-cassandra-schema: db-reset - ( echo '# automatically generated with `make git-add-cassandra-schema`' ; docker exec -i $(CASSANDRA_CONTAINER) /usr/bin/cqlsh -e "DESCRIBE schema;" ) > ./docs/reference/cassandra-schema.txt - git add ./docs/reference/cassandra-schema.txt + ( echo '-- automatically generated with `make git-add-cassandra-schema`' ; docker exec -i $(CASSANDRA_CONTAINER) /usr/bin/cqlsh -e "DESCRIBE schema;" ) > ./docs/reference/cassandra-schema.cql + git add ./docs/reference/cassandra-schema.cql .PHONY: db-reset db-reset: diff --git a/build/alpine/Dockerfile.builder b/build/alpine/Dockerfile.builder index 9688b208d77..482e7aa42af 100644 --- a/build/alpine/Dockerfile.builder +++ b/build/alpine/Dockerfile.builder @@ -22,6 +22,7 @@ RUN set -x && \ stack build --haddock --dependencies-only haskell-src-exts && \ stack build --haddock --no-haddock-hyperlink-source haskell-src-exts && \ stack build --pedantic --haddock --test --no-run-tests --bench --no-run-benchmarks --dependencies-only && \ + stack install ormolu && \ cd / && \ # we run the build only to cache the built source in /root/.stack, we can remove the source code itself rm -rf /wire-server diff --git a/deploy/services-demo/conf/nginz/nginx-docker.conf b/deploy/services-demo/conf/nginz/nginx-docker.conf index a2a89eb7066..4592ce80ec5 100644 --- a/deploy/services-demo/conf/nginz/nginx-docker.conf +++ b/deploy/services-demo/conf/nginz/nginx-docker.conf @@ -106,8 +106,8 @@ http { listen 8080; listen 8081; - zauth_keystore resources/zauth/pubkeys.txt; - zauth_acl conf/nginz/zauth_acl.txt; + zauth_keystore /configs/resources/zauth/pubkeys.txt; + zauth_acl /configs/conf/nginz/zauth_acl.txt; location /status { zauth off; diff --git a/deploy/services-demo/resources/turn/.gitignore b/deploy/services-demo/resources/turn/.gitignore deleted file mode 100644 index 29609492879..00000000000 --- a/deploy/services-demo/resources/turn/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -# Avoid storing generated keys -secret.txt diff --git a/deploy/services-demo/resources/zauth/.gitignore b/deploy/services-demo/resources/zauth/.gitignore deleted file mode 100644 index 3b167b1e3bc..00000000000 --- a/deploy/services-demo/resources/zauth/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -# Avoid storing generated keys (privkeys.txt and pubkeys.txt are generated by demo.sh) -privkeys.txt -pubkeys.txt diff --git a/docs/reference/cassandra-schema.txt b/docs/reference/cassandra-schema.cql similarity index 98% rename from docs/reference/cassandra-schema.txt rename to docs/reference/cassandra-schema.cql index 32361450314..6134072c21b 100644 --- a/docs/reference/cassandra-schema.txt +++ b/docs/reference/cassandra-schema.cql @@ -1,4 +1,4 @@ -# automatically generated with `make git-add-cassandra-schema` +-- automatically generated with `make git-add-cassandra-schema` CREATE KEYSPACE galley_test WITH replication = {'class': 'SimpleStrategy', 'replication_factor': '1'} AND durable_writes = true; @@ -1380,6 +1380,26 @@ CREATE TABLE spar_test.idp ( AND read_repair_chance = 0.0 AND speculative_retry = '99PERCENTILE'; +CREATE TABLE spar_test.default_idp ( + partition_key_always_default text, + idp uuid, + PRIMARY KEY (partition_key_always_default, idp) +) WITH CLUSTERING ORDER BY (idp ASC) + AND bloom_filter_fp_chance = 0.1 + AND caching = {'keys': 'ALL', 'rows_per_partition': 'NONE'} + AND comment = '' + AND compaction = {'class': 'org.apache.cassandra.db.compaction.LeveledCompactionStrategy'} + AND compression = {'chunk_length_in_kb': '64', 'class': 'org.apache.cassandra.io.compress.LZ4Compressor'} + AND crc_check_chance = 1.0 + AND dclocal_read_repair_chance = 0.1 + AND default_time_to_live = 0 + AND gc_grace_seconds = 864000 + AND max_index_interval = 2048 + AND memtable_flush_period_in_ms = 0 + AND min_index_interval = 128 + AND read_repair_chance = 0.0 + AND speculative_retry = '99PERCENTILE'; + CREATE TABLE spar_test.team_provisioning_by_team ( team uuid, id uuid, diff --git a/docs/reference/user/connection.md b/docs/reference/user/connection.md index 2f85f4492cb..97b934c4ca0 100644 --- a/docs/reference/user/connection.md +++ b/docs/reference/user/connection.md @@ -12,8 +12,6 @@ Members of the same team are always considered connected, see [Connections betwe Internally, connection status is a _directed_ edge from one user to another that is attributed with a relation state and some meta information. If a user has a connection to another user, it can be in one of the six [connection states](#RefConnectionStates). -TODO describe autoconnection and onboarding. - ## Connection states {#RefConnectionStates} ### Sent {#RefConnectionSent} diff --git a/libs/api-bot/src/Network/Wire/Bot/Crypto.hs b/libs/api-bot/src/Network/Wire/Bot/Crypto.hs index c5b60994237..d659003e2a0 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Crypto.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Crypto.hs @@ -104,7 +104,8 @@ encrypt cl cnv val = fmap (OtrRecipients . UserClientMap) ciphertext <- do bs <- CBox.encrypt s val >>= unwrap >>= CBox.copyBytes return $! decodeUtf8 $! B64.encode bs - return $ Map.insertWith Map.union u (Map.singleton c ciphertext) rcps + let userId = makeIdOpaque u + return $ Map.insertWith Map.union userId (Map.singleton c ciphertext) rcps -- | Decrypt an OTR message received from a given user and client. decrypt :: BotClient -> UserId -> ClientId -> ByteString -> BotSession ByteString diff --git a/libs/api-client/src/Network/Wire/Client/API/Conversation.hs b/libs/api-client/src/Network/Wire/Client/API/Conversation.hs index 9ed0693ed05..057bfa98d3c 100644 --- a/libs/api-client/src/Network/Wire/Client/API/Conversation.hs +++ b/libs/api-client/src/Network/Wire/Client/API/Conversation.hs @@ -47,7 +47,7 @@ postOtrMessage cnv msg = sessionRequest req rsc readBody -- will be thrown. It's not possible that some users will be added and -- others will not. addMembers :: (MonadSession m, MonadThrow m) => ConvId -> List1 UserId -> m (Maybe (ConvEvent SimpleMembers)) -addMembers cnv mems = do +addMembers cnv (fmap makeIdOpaque -> mems) = do rs <- sessionRequest req rsc consumeBody case statusCode rs of 200 -> Just <$> responseJsonThrow (ParseError . pack) rs @@ -114,7 +114,7 @@ createConv :: -- | Conversation name Maybe Text -> m Conversation -createConv users name = sessionRequest req rsc readBody +createConv (fmap makeIdOpaque -> users) name = sessionRequest req rsc readBody where req = method POST diff --git a/libs/brig-types/package.yaml b/libs/brig-types/package.yaml index 0757c5b7f6e..fd9a17b6191 100644 --- a/libs/brig-types/package.yaml +++ b/libs/brig-types/package.yaml @@ -23,9 +23,12 @@ library: - base64-bytestring >=1.0 - bytestring >=0.9 - bytestring-conversion >=0.2 + - case-insensitive + - cassandra-util - containers >=0.5 - currency-codes >=2.0 - errors >=1.4 + - extra - galley-types >=0.45.7 - hashable - iproute >=1.5 @@ -34,6 +37,9 @@ library: - lens-aeson - network-uri >=2.6 - pem >=0.2 + - QuickCheck >=2.9 + - quickcheck-instances >=0.3.16 + - random - safe >=0.3 - scientific >=0.3.4 - singletons >=2.0 @@ -42,21 +48,8 @@ library: - time >=1.1 - types-common >=0.16 - unordered-containers >=0.2 + - uri-bytestring - uuid >=1.3 - - case-insensitive - when: - - condition: flag(cql) - cpp-options: -DWITH_CQL - dependencies: - - cassandra-util - - condition: flag(arbitrary) - cpp-options: -DWITH_ARBITRARY - dependencies: - - extra - - QuickCheck >=2.9 - - quickcheck-instances >=0.3.16 - - random - - uri-bytestring tests: brig-types-tests: main: Main.hs @@ -91,12 +84,3 @@ tests: - uuid - uri-bytestring - vector -flags: - cql: - description: Enable cql instances - manual: true - default: false - arbitrary: - description: Enable quickcheck arbitrary instances - manual: true - default: true diff --git a/libs/brig-types/src/Brig/Types.hs b/libs/brig-types/src/Brig/Types.hs index ec2baa44238..f02e5d5213e 100644 --- a/libs/brig-types/src/Brig/Types.hs +++ b/libs/brig-types/src/Brig/Types.hs @@ -1,7 +1,6 @@ module Brig.Types (module M) where import Brig.Types.Activation as M -import Brig.Types.AddressBook as M import Brig.Types.Client as M import Brig.Types.Connection as M import Brig.Types.Properties as M diff --git a/libs/brig-types/src/Brig/Types/AddressBook.hs b/libs/brig-types/src/Brig/Types/AddressBook.hs deleted file mode 100644 index 035fe1e3a5a..00000000000 --- a/libs/brig-types/src/Brig/Types/AddressBook.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Brig.Types.AddressBook - ( module Brig.Types.AddressBook, - ) -where - -import Data.Aeson -import qualified Data.ByteString.Base64 as B64 -import Data.Id -import Data.Json.Util -import qualified Data.Text.Encoding as T -import Imports - -newtype CardId = CardId Text - deriving (Eq, Show, Ord, FromJSON, ToJSON) - --- The base64-encoded SHA-256 of an email address or a phone number -newtype Entry = Entry {abEntrySha256 :: ByteString} - deriving (Eq, Show, Ord) - -instance FromJSON Entry where - parseJSON = - withText "Entry" $ - either (fail "Invalid Entry") (pure . Entry) . (B64.decode . T.encodeUtf8) - --- Used only in tests but defined here to avoid orphan -instance ToJSON Entry where - toJSON = String . T.decodeUtf8 . B64.encode . abEntrySha256 - -data Card - = Card - { cCardId :: !(Maybe CardId), -- Random card identifier, defined by clients - cEntries :: ![Entry] - } - deriving (Eq, Show) - -instance FromJSON Card where - parseJSON = withObject "matching-card" $ \o -> - Card <$> o .:? "card_id" - <*> o .: "contact" - -instance ToJSON Card where - toJSON c = - object - [ "card_id" .= cCardId c, - "contact" .= cEntries c - ] - -newtype AddressBook - = AddressBook - { abCards :: [Card] - } - deriving (Eq, Show) - -instance FromJSON AddressBook where - parseJSON = withObject "address-book" $ \o -> - AddressBook <$> o .: "cards" - -instance ToJSON AddressBook where - toJSON ab = - object - [ "cards" .= abCards ab - ] - --- V3 result - -data Match - = Match - { mUser :: !UserId, - mCardId :: !(Maybe CardId), -- Card id that was matched (Deprecated!) - mCards :: ![CardId] -- List of card ids matched - } - deriving (Eq, Ord, Show) - -instance FromJSON Match where - parseJSON = withObject "match" $ \o -> - Match <$> o .: "id" - <*> o .:? "card_id" - <*> o .:? "cards" .!= [] - -instance ToJSON Match where - toJSON m = - object $ - "id" .= mUser m - # "card_id" .= mCardId m - # "cards" .= mCards m - # [] - -data MatchingResult - = MatchingResult - { mrMatches :: ![Match], - mrAuto :: ![UserId] - } - deriving (Eq, Ord, Show) - -instance FromJSON MatchingResult where - parseJSON = withObject "matches" $ \o -> - MatchingResult <$> o .: "results" - <*> o .: "auto-connects" - -instance ToJSON MatchingResult where - toJSON r = - object - [ "results" .= mrMatches r, - "auto-connects" .= mrAuto r - ] diff --git a/libs/brig-types/src/Brig/Types/Common.hs b/libs/brig-types/src/Brig/Types/Common.hs index 0d728f66f84..d2a03f9275a 100644 --- a/libs/brig-types/src/Brig/Types/Common.hs +++ b/libs/brig-types/src/Brig/Types/Common.hs @@ -14,7 +14,6 @@ import Data.Aeson hiding (()) import qualified Data.Aeson.Types as Json import Data.Attoparsec.Text import Data.ByteString.Conversion -import Data.Hashable (Hashable) import Data.ISO3166_CountryCodes import Data.Json.Util ((#)) import Data.LanguageCodes @@ -23,48 +22,10 @@ import qualified Data.Text as Text import Data.Time.Clock import Imports --------------------------------------------------------------------------------- --- Handle - -newtype Handle - = Handle - {fromHandle :: Text} - deriving (Eq, Show, ToJSON, ToByteString, Hashable, Generic) - -instance FromByteString Handle where - parser = parser >>= maybe (fail "Invalid handle") return . parseHandle - -instance FromJSON Handle where - parseJSON = - withText "Handle" $ - maybe (fail "Invalid handle") pure . parseHandle - -parseHandle :: Text -> Maybe Handle -parseHandle t - | isValidHandle t = Just (Handle t) - | otherwise = Nothing - -isValidHandle :: Text -> Bool -isValidHandle t = - either (const False) (const True) $ - parseOnly handle t - where - handle = - count 2 (satisfy chars) - *> count 254 (optional (satisfy chars)) - *> endOfInput - -- NOTE: Ensure that characters such as `@` and `+` should _NOT_ - -- be used so that "phone numbers", "emails", and "handles" remain - -- disjoint sets. - -- The rationale behind max size here relates to the max length of - -- an email address as defined here: - -- http://www.rfc-editor.org/errata_search.php?rfc=3696&eid=1690 - -- with the intent that in the enterprise world handle =~ email address - chars = inClass "a-z0-9_.-" - -------------------------------------------------------------------------------- -- Name +-- | Usually called display name. newtype Name = Name {fromName :: Text} @@ -87,6 +48,7 @@ defaultAccentId = ColourId 0 ----------------------------------------------------------------------------- -- Email +-- FUTUREWORK: replace this type with 'EmailAddress' data Email = Email { emailLocal :: !Text, diff --git a/libs/brig-types/src/Brig/Types/Instances.hs b/libs/brig-types/src/Brig/Types/Instances.hs index 8b5a9d34d05..fe261900104 100644 --- a/libs/brig-types/src/Brig/Types/Instances.hs +++ b/libs/brig-types/src/Brig/Types/Instances.hs @@ -1,81 +1,90 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Brig.Types.Instances () where -#ifdef WITH_CQL -import Imports -import Brig.Types.Team.LegalHold +module Brig.Types.Instances + ( + ) +where + import Brig.Types.Client.Prekey import Brig.Types.Provider import Brig.Types.Provider.Tag -import Data.ByteString.Conversion +import Brig.Types.Team.LegalHold import Cassandra.CQL +import Data.ByteString.Conversion +import Imports instance Cql LegalHoldStatus where - ctype = Tagged IntColumn + ctype = Tagged IntColumn - fromCql (CqlInt n) = case n of - 0 -> pure $ LegalHoldDisabled - 1 -> pure $ LegalHoldEnabled - _ -> fail "fromCql: Invalid LegalHoldStatus" - fromCql _ = fail "fromCql: LegalHoldStatus: CqlInt expected" + fromCql (CqlInt n) = case n of + 0 -> pure $ LegalHoldDisabled + 1 -> pure $ LegalHoldEnabled + _ -> fail "fromCql: Invalid LegalHoldStatus" + fromCql _ = fail "fromCql: LegalHoldStatus: CqlInt expected" - toCql LegalHoldDisabled = CqlInt 0 - toCql LegalHoldEnabled = CqlInt 1 + toCql LegalHoldDisabled = CqlInt 0 + toCql LegalHoldEnabled = CqlInt 1 instance Cql PrekeyId where - ctype = Tagged IntColumn - toCql = CqlInt . fromIntegral . keyId - fromCql (CqlInt i) = return $ PrekeyId (fromIntegral i) - fromCql _ = fail "PrekeyId: Int expected" + ctype = Tagged IntColumn + toCql = CqlInt . fromIntegral . keyId + fromCql (CqlInt i) = return $ PrekeyId (fromIntegral i) + fromCql _ = fail "PrekeyId: Int expected" instance Cql ServiceTag where - ctype = Tagged BigIntColumn + ctype = Tagged BigIntColumn - fromCql (CqlBigInt i) = case intToTag i of - Just t -> return t - Nothing -> fail $ "unexpected service tag: " ++ show i - fromCql _ = fail "service tag: int expected" + fromCql (CqlBigInt i) = case intToTag i of + Just t -> return t + Nothing -> fail $ "unexpected service tag: " ++ show i + fromCql _ = fail "service tag: int expected" - toCql = CqlBigInt . tagToInt + toCql = CqlBigInt . tagToInt instance Cql ServiceKeyPEM where - ctype = Tagged BlobColumn + ctype = Tagged BlobColumn - fromCql (CqlBlob b) = maybe (fail "service key pem: malformed key") - pure - (fromByteString' b) - fromCql _ = fail "service key pem: blob expected" + fromCql (CqlBlob b) = + maybe + (fail "service key pem: malformed key") + pure + (fromByteString' b) + fromCql _ = fail "service key pem: blob expected" - toCql = CqlBlob . toByteString + toCql = CqlBlob . toByteString instance Cql ServiceKey where - ctype = Tagged (UdtColumn "pubkey" - [ ("typ", IntColumn) - , ("size", IntColumn) - , ("pem", BlobColumn) - ]) - - fromCql (CqlUdt fs) = do - t <- required "typ" - s <- required "size" - p <- required "pem" - case (t :: Int32) of - 0 -> return $! ServiceKey RsaServiceKey s p - _ -> fail $ "Unexpected service key type: " ++ show t - where - required :: Cql r => Text -> Either String r - required f = maybe (fail ("ServiceKey: Missing required field '" ++ show f ++ "'")) - fromCql - (lookup f fs) - fromCql _ = fail "service key: udt expected" + ctype = + Tagged + ( UdtColumn + "pubkey" + [ ("typ", IntColumn), + ("size", IntColumn), + ("pem", BlobColumn) + ] + ) - toCql (ServiceKey RsaServiceKey siz pem) = CqlUdt - [ ("typ", CqlInt 0) - , ("size", toCql siz) - , ("pem", toCql pem) - ] + fromCql (CqlUdt fs) = do + t <- required "typ" + s <- required "size" + p <- required "pem" + case (t :: Int32) of + 0 -> return $! ServiceKey RsaServiceKey s p + _ -> fail $ "Unexpected service key type: " ++ show t + where + required :: Cql r => Text -> Either String r + required f = + maybe + (fail ("ServiceKey: Missing required field '" ++ show f ++ "'")) + fromCql + (lookup f fs) + fromCql _ = fail "service key: udt expected" -#endif + toCql (ServiceKey RsaServiceKey siz pem) = + CqlUdt + [ ("typ", CqlInt 0), + ("size", toCql siz), + ("pem", toCql pem) + ] diff --git a/libs/brig-types/src/Brig/Types/Provider/External.hs b/libs/brig-types/src/Brig/Types/Provider/External.hs index 4b8f408bd56..b49288f43cc 100644 --- a/libs/brig-types/src/Brig/Types/Provider/External.hs +++ b/libs/brig-types/src/Brig/Types/Provider/External.hs @@ -16,6 +16,7 @@ where import Brig.Types.Client.Prekey import Brig.Types.Common import Data.Aeson +import Data.Handle (Handle) import Data.Id import Data.Json.Util ((#)) import Galley.Types.Bot diff --git a/libs/brig-types/src/Brig/Types/Provider/Tag.hs b/libs/brig-types/src/Brig/Types/Provider/Tag.hs index 4d45b149159..9e33dd25f6d 100644 --- a/libs/brig-types/src/Brig/Types/Provider/Tag.hs +++ b/libs/brig-types/src/Brig/Types/Provider/Tag.hs @@ -1,149 +1,148 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Brig.Types.Provider.Tag where -import Imports -import Data.Aeson -import Data.ByteString.Conversion -#ifdef WITH_CQL import Cassandra.CQL (Cql) -#endif -import Data.Range +import Data.Aeson import Data.Bits +import Data.ByteString.Conversion import Data.List (foldl') - -import qualified Data.Set as Set +import Data.Range +import qualified Data.Set as Set import qualified Data.Text.Encoding as Text +import Imports -------------------------------------------------------------------------------- -- ServiceTag -- | A fixed enumeration of tags for services. data ServiceTag - = AudioTag - | BooksTag - | BusinessTag - | DesignTag - | EducationTag - | EntertainmentTag - | FinanceTag - | FitnessTag - | FoodDrinkTag - | GamesTag - | GraphicsTag - | HealthTag - | IntegrationTag - | LifestyleTag - | MediaTag - | MedicalTag - | MoviesTag - | MusicTag - | NewsTag - | PhotographyTag - | PollTag - | ProductivityTag - | QuizTag - | RatingTag - | ShoppingTag - | SocialTag - | SportsTag - | TravelTag - | TutorialTag - | VideoTag - | WeatherTag - deriving (Eq, Show, Ord, Enum, Bounded) + = AudioTag + | BooksTag + | BusinessTag + | DesignTag + | EducationTag + | EntertainmentTag + | FinanceTag + | FitnessTag + | FoodDrinkTag + | GamesTag + | GraphicsTag + | HealthTag + | IntegrationTag + | LifestyleTag + | MediaTag + | MedicalTag + | MoviesTag + | MusicTag + | NewsTag + | PhotographyTag + | PollTag + | ProductivityTag + | QuizTag + | RatingTag + | ShoppingTag + | SocialTag + | SportsTag + | TravelTag + | TutorialTag + | VideoTag + | WeatherTag + deriving (Eq, Show, Ord, Enum, Bounded) instance FromByteString ServiceTag where - parser = parser >>= \t -> case (t :: ByteString) of - "audio" -> pure AudioTag - "books" -> pure BooksTag - "business" -> pure BusinessTag - "design" -> pure DesignTag - "education" -> pure EducationTag - "entertainment" -> pure EntertainmentTag - "finance" -> pure FinanceTag - "fitness" -> pure FitnessTag - "food-drink" -> pure FoodDrinkTag - "games" -> pure GamesTag - "graphics" -> pure GraphicsTag - "health" -> pure HealthTag - "integration" -> pure IntegrationTag - "lifestyle" -> pure LifestyleTag - "media" -> pure MediaTag - "medical" -> pure MedicalTag - "movies" -> pure MoviesTag - "music" -> pure MusicTag - "news" -> pure NewsTag - "photography" -> pure PhotographyTag - "poll" -> pure PollTag - "productivity" -> pure ProductivityTag - "quiz" -> pure QuizTag - "rating" -> pure RatingTag - "shopping" -> pure ShoppingTag - "social" -> pure SocialTag - "sports" -> pure SportsTag - "travel" -> pure TravelTag - "tutorial" -> pure TutorialTag - "video" -> pure VideoTag - "weather" -> pure WeatherTag - _ -> fail $ "Invalid tag: " ++ show t + parser = parser >>= \t -> case (t :: ByteString) of + "audio" -> pure AudioTag + "books" -> pure BooksTag + "business" -> pure BusinessTag + "design" -> pure DesignTag + "education" -> pure EducationTag + "entertainment" -> pure EntertainmentTag + "finance" -> pure FinanceTag + "fitness" -> pure FitnessTag + "food-drink" -> pure FoodDrinkTag + "games" -> pure GamesTag + "graphics" -> pure GraphicsTag + "health" -> pure HealthTag + "integration" -> pure IntegrationTag + "lifestyle" -> pure LifestyleTag + "media" -> pure MediaTag + "medical" -> pure MedicalTag + "movies" -> pure MoviesTag + "music" -> pure MusicTag + "news" -> pure NewsTag + "photography" -> pure PhotographyTag + "poll" -> pure PollTag + "productivity" -> pure ProductivityTag + "quiz" -> pure QuizTag + "rating" -> pure RatingTag + "shopping" -> pure ShoppingTag + "social" -> pure SocialTag + "sports" -> pure SportsTag + "travel" -> pure TravelTag + "tutorial" -> pure TutorialTag + "video" -> pure VideoTag + "weather" -> pure WeatherTag + _ -> fail $ "Invalid tag: " ++ show t instance ToByteString ServiceTag where - builder AudioTag = "audio" - builder BooksTag = "books" - builder BusinessTag = "business" - builder DesignTag = "design" - builder EducationTag = "education" - builder EntertainmentTag = "entertainment" - builder FinanceTag = "finance" - builder FitnessTag = "fitness" - builder FoodDrinkTag = "food-drink" - builder GamesTag = "games" - builder GraphicsTag = "graphics" - builder HealthTag = "health" - builder IntegrationTag = "integration" - builder LifestyleTag = "lifestyle" - builder MediaTag = "media" - builder MedicalTag = "medical" - builder MoviesTag = "movies" - builder MusicTag = "music" - builder NewsTag = "news" - builder PhotographyTag = "photography" - builder PollTag = "poll" - builder ProductivityTag = "productivity" - builder QuizTag = "quiz" - builder RatingTag = "rating" - builder ShoppingTag = "shopping" - builder SocialTag = "social" - builder SportsTag = "sports" - builder TravelTag = "travel" - builder TutorialTag = "tutorial" - builder VideoTag = "video" - builder WeatherTag = "weather" + builder AudioTag = "audio" + builder BooksTag = "books" + builder BusinessTag = "business" + builder DesignTag = "design" + builder EducationTag = "education" + builder EntertainmentTag = "entertainment" + builder FinanceTag = "finance" + builder FitnessTag = "fitness" + builder FoodDrinkTag = "food-drink" + builder GamesTag = "games" + builder GraphicsTag = "graphics" + builder HealthTag = "health" + builder IntegrationTag = "integration" + builder LifestyleTag = "lifestyle" + builder MediaTag = "media" + builder MedicalTag = "medical" + builder MoviesTag = "movies" + builder MusicTag = "music" + builder NewsTag = "news" + builder PhotographyTag = "photography" + builder PollTag = "poll" + builder ProductivityTag = "productivity" + builder QuizTag = "quiz" + builder RatingTag = "rating" + builder ShoppingTag = "shopping" + builder SocialTag = "social" + builder SportsTag = "sports" + builder TravelTag = "travel" + builder TutorialTag = "tutorial" + builder VideoTag = "video" + builder WeatherTag = "weather" instance FromJSON ServiceTag where - parseJSON = withText "ServiceTag" $ - either fail pure . runParser parser . Text.encodeUtf8 + parseJSON = + withText "ServiceTag" $ + either fail pure . runParser parser . Text.encodeUtf8 instance ToJSON ServiceTag where - toJSON = String . Text.decodeUtf8 . toByteString' + toJSON = String . Text.decodeUtf8 . toByteString' -------------------------------------------------------------------------------- -- ServiceTag Matchers -- | Logical disjunction of 'MatchAllTags' to match. -newtype MatchAny = MatchAny - { matchAnySet :: Set MatchAll } - deriving (Eq, Show, Ord) +newtype MatchAny + = MatchAny + {matchAnySet :: Set MatchAll} + deriving (Eq, Show, Ord) -- | Logical conjunction of 'ServiceTag's to match. -newtype MatchAll = MatchAll - { matchAllSet :: Set ServiceTag } - deriving (Eq, Show, Ord) +newtype MatchAll + = MatchAll + {matchAllSet :: Set ServiceTag} + deriving (Eq, Show, Ord) (.||.) :: MatchAny -> MatchAny -> MatchAny (.||.) (MatchAny a) (MatchAny b) = MatchAny (Set.union a b) @@ -160,13 +159,8 @@ match1 = matchAll . match match :: ServiceTag -> MatchAll match = MatchAll . Set.singleton - newtype Bucket = Bucket Int32 -#ifdef WITH_CQL - deriving newtype (Cql, Show) -#else - deriving newtype (Show) -#endif + deriving newtype (Cql, Show) -- | Bucketing allows us to distribute individual tag bitmasks -- across multiple wide rows, if it should become necessary. @@ -182,59 +176,60 @@ foldTags = foldl' (.|.) 0 . map tagToInt . Set.toList . fromRange unfoldTags :: Range 0 3 (Set ServiceTag) -> [Int64] unfoldTags s = case map tagToInt (Set.toList (fromRange s)) of - [] -> [] - [t] -> [t] - ts@[t,u] -> (t .|. u) : ts - ts@[t,u,v] -> (t .|. u) : (t .|. v) : (u .|. v) : (t .|. u .|. v) : ts - _ -> error "Brig.Provider.DB.Tag: unfoldTags: Too many tags." + [] -> [] + [t] -> [t] + ts@[t, u] -> (t .|. u) : ts + ts@[t, u, v] -> (t .|. u) : (t .|. v) : (u .|. v) : (t .|. u .|. v) : ts + _ -> error "Brig.Provider.DB.Tag: unfoldTags: Too many tags." unfoldTagsInto :: Range 1 3 (Set ServiceTag) -> [Int64] -> [Int64] unfoldTagsInto xs ys = - let xs' = unfoldTags (rcast xs) - in xs' ++ concatMap (\x -> map (.|. x) ys) xs' + let xs' = unfoldTags (rcast xs) + in xs' ++ concatMap (\x -> map (.|. x) ys) xs' -diffTags :: Range 0 3 (Set ServiceTag) - -> Range 0 3 (Set ServiceTag) - -> Range 0 3 (Set ServiceTag) +diffTags :: + Range 0 3 (Set ServiceTag) -> + Range 0 3 (Set ServiceTag) -> + Range 0 3 (Set ServiceTag) diffTags a b = unsafeRange $ Set.difference (fromRange a) (fromRange b) nonEmptyTags :: Range m 3 (Set ServiceTag) -> Maybe (Range 1 3 (Set ServiceTag)) nonEmptyTags r - | Set.null (fromRange r) = Nothing - | otherwise = Just (unsafeRange (fromRange r)) + | Set.null (fromRange r) = Nothing + | otherwise = Just (unsafeRange (fromRange r)) tagToInt :: ServiceTag -> Int64 -tagToInt AudioTag = 0b1 -tagToInt BooksTag = 0b10 -tagToInt BusinessTag = 0b100 -tagToInt DesignTag = 0b1000 -tagToInt EducationTag = 0b10000 +tagToInt AudioTag = 0b1 +tagToInt BooksTag = 0b10 +tagToInt BusinessTag = 0b100 +tagToInt DesignTag = 0b1000 +tagToInt EducationTag = 0b10000 tagToInt EntertainmentTag = 0b100000 -tagToInt FinanceTag = 0b1000000 -tagToInt FitnessTag = 0b10000000 -tagToInt FoodDrinkTag = 0b100000000 -tagToInt GamesTag = 0b1000000000 -tagToInt GraphicsTag = 0b10000000000 -tagToInt HealthTag = 0b100000000000 -tagToInt IntegrationTag = 0b1000000000000 -tagToInt LifestyleTag = 0b10000000000000 -tagToInt MediaTag = 0b100000000000000 -tagToInt MedicalTag = 0b1000000000000000 -tagToInt MoviesTag = 0b10000000000000000 -tagToInt MusicTag = 0b100000000000000000 -tagToInt NewsTag = 0b1000000000000000000 -tagToInt PhotographyTag = 0b10000000000000000000 -tagToInt PollTag = 0b100000000000000000000 -tagToInt ProductivityTag = 0b1000000000000000000000 -tagToInt QuizTag = 0b10000000000000000000000 -tagToInt RatingTag = 0b100000000000000000000000 -tagToInt ShoppingTag = 0b1000000000000000000000000 -tagToInt SocialTag = 0b10000000000000000000000000 -tagToInt SportsTag = 0b100000000000000000000000000 -tagToInt TravelTag = 0b1000000000000000000000000000 -tagToInt TutorialTag = 0b10000000000000000000000000000 -tagToInt VideoTag = 0b100000000000000000000000000000 -tagToInt WeatherTag = 0b1000000000000000000000000000000 +tagToInt FinanceTag = 0b1000000 +tagToInt FitnessTag = 0b10000000 +tagToInt FoodDrinkTag = 0b100000000 +tagToInt GamesTag = 0b1000000000 +tagToInt GraphicsTag = 0b10000000000 +tagToInt HealthTag = 0b100000000000 +tagToInt IntegrationTag = 0b1000000000000 +tagToInt LifestyleTag = 0b10000000000000 +tagToInt MediaTag = 0b100000000000000 +tagToInt MedicalTag = 0b1000000000000000 +tagToInt MoviesTag = 0b10000000000000000 +tagToInt MusicTag = 0b100000000000000000 +tagToInt NewsTag = 0b1000000000000000000 +tagToInt PhotographyTag = 0b10000000000000000000 +tagToInt PollTag = 0b100000000000000000000 +tagToInt ProductivityTag = 0b1000000000000000000000 +tagToInt QuizTag = 0b10000000000000000000000 +tagToInt RatingTag = 0b100000000000000000000000 +tagToInt ShoppingTag = 0b1000000000000000000000000 +tagToInt SocialTag = 0b10000000000000000000000000 +tagToInt SportsTag = 0b100000000000000000000000000 +tagToInt TravelTag = 0b1000000000000000000000000000 +tagToInt TutorialTag = 0b10000000000000000000000000000 +tagToInt VideoTag = 0b100000000000000000000000000000 +tagToInt WeatherTag = 0b1000000000000000000000000000000 intToTag :: Int64 -> Maybe ServiceTag intToTag 0b1 = pure AudioTag diff --git a/libs/brig-types/src/Brig/Types/Swagger.hs b/libs/brig-types/src/Brig/Types/Swagger.hs index edae400b70f..116ed323396 100644 --- a/libs/brig-types/src/Brig/Types/Swagger.hs +++ b/libs/brig-types/src/Brig/Types/Swagger.hs @@ -70,7 +70,6 @@ brigModels = addressBook, card, match, - onboardingMatches, -- Search searchResult, searchContact, @@ -834,16 +833,6 @@ match = defineModel "Match" $ do property "cards" (array string') $ description "List of card ids for this match." -onboardingMatches :: Model -onboardingMatches = defineModel "onboardingMatches" $ do - description "Result of the address book matching" - property "results" (array (ref match)) $ - description "List of matches." - property "auto-connects" (array (ref match)) $ - description - "List of user IDs matched. It's a bit redudant given 'results' \ - \but it is here for reasons of backwards compatibility." - -------------------------------------------------------------------------------- -- Search diff --git a/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs b/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs index a39b7132eb3..748286b7ed0 100644 --- a/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs +++ b/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs @@ -1,29 +1,24 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Brig.Types.Test.Arbitrary where -#ifdef WITH_ARBITRARY - -import Imports import Brig.Types.Activation import Brig.Types.Client.Prekey import Brig.Types.Code import Brig.Types.Intra -import Brig.Types.Provider (UpdateServiceWhitelist(..), ServiceKeyType(..),ServiceKey(..), ServiceKeyPEM(..)) +import Brig.Types.Provider (ServiceKey (..), ServiceKeyPEM (..), ServiceKeyType (..), UpdateServiceWhitelist (..)) import Brig.Types.TURN import Brig.Types.TURN.Internal import Brig.Types.Team.Invitation @@ -31,6 +26,7 @@ import Brig.Types.Team.LegalHold import Brig.Types.User import Brig.Types.User.Auth import Control.Lens hiding (elements) +import qualified Data.ByteString.Char8 as BS import Data.Currency import Data.IP import Data.Json.Util (UTCTimeMillis (..), toUTCTimeMillis) @@ -40,6 +36,8 @@ import Data.Misc import Data.PEM (pemParseBS) import Data.Proxy import Data.Range +import qualified Data.Set as Set +import qualified Data.Text as ST import Data.Text.Ascii import Data.Text.Encoding (encodeUtf8) import Data.UUID (nil) @@ -48,102 +46,95 @@ import Galley.Types import Galley.Types.Bot.Service.Internal import Galley.Types.Teams import Galley.Types.Teams.Internal +import Imports +import qualified System.Random import Test.QuickCheck import Test.QuickCheck.Instances () import Text.Hostname import URI.ByteString.QQ (uri) -import qualified Data.Set as Set -import qualified Data.ByteString.Char8 as BS -import qualified Data.Text as ST -import qualified System.Random - - -newtype Octet = Octet { octet :: Word16 } - deriving (Eq, Show) +newtype Octet = Octet {octet :: Word16} + deriving (Eq, Show) instance Arbitrary Octet where - arbitrary = Octet <$> arbitrary `suchThat` (<256) + arbitrary = Octet <$> arbitrary `suchThat` (< 256) instance Arbitrary Scheme where - arbitrary = genEnumBounded + arbitrary = genEnumBounded -- TODO: Add an arbitrary instance for IPv6 instance Arbitrary IpAddr where - arbitrary = ipV4Arbitrary - where - ipV4Arbitrary :: Gen IpAddr - ipV4Arbitrary = do - a <- ipV4Part - b <- ipV4Part - c <- ipV4Part - d <- ipV4Part - let adr = show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d - IpAddr . IPv4 <$> return (read adr) - - ipV4Part = octet <$> arbitrary + arbitrary = ipV4Arbitrary + where + ipV4Arbitrary :: Gen IpAddr + ipV4Arbitrary = do + a <- ipV4Part + b <- ipV4Part + c <- ipV4Part + d <- ipV4Part + let adr = show a ++ "." ++ show b ++ "." ++ show c ++ "." ++ show d + IpAddr . IPv4 <$> return (read adr) + ipV4Part = octet <$> arbitrary instance Arbitrary TurnHost where - arbitrary = oneof - [ TurnHostIp <$> arbitrary - , TurnHostName <$> arbitrary `suchThat` (validHostname . encodeUtf8) - ] + arbitrary = + oneof + [ TurnHostIp <$> arbitrary, + TurnHostName <$> arbitrary `suchThat` (validHostname . encodeUtf8) + ] instance Arbitrary Port where - arbitrary = Port <$> arbitrary + arbitrary = Port <$> arbitrary instance Arbitrary Transport where - arbitrary = genEnumBounded + arbitrary = genEnumBounded instance Arbitrary TurnURI where - arbitrary = turnURI <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - - -instance Arbitrary Handle where - arbitrary = Handle . ST.pack <$> do - let many n = replicateM n (elements $ ['a'..'z'] <> ['0'..'9'] <> ['_'] <> ['-'] <> ['.']) - ((<>) <$> many 2 <*> (many =<< choose (0, 254))) + arbitrary = + turnURI <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary instance Arbitrary Name where - arbitrary = Name . ST.pack <$> - ((`replicateM` arbitrary) =<< choose (1, 128)) + arbitrary = + Name . ST.pack + <$> ((`replicateM` arbitrary) =<< choose (1, 128)) instance Arbitrary ColourId where arbitrary = ColourId <$> arbitrary instance Arbitrary Email where arbitrary = do - localPart <- ST.filter (/= '@') <$> arbitrary - domain <- ST.filter (/= '@') <$> arbitrary - pure $ Email localPart domain + localPart <- ST.filter (/= '@') <$> arbitrary + domain <- ST.filter (/= '@') <$> arbitrary + pure $ Email localPart domain instance Arbitrary Phone where arbitrary = Phone . ST.pack <$> do - let mkdigits n = replicateM n (elements ['0'..'9']) - mini <- mkdigits 8 - maxi <- mkdigits =<< choose (0, 7) - pure $ '+' : mini <> maxi + let mkdigits n = replicateM n (elements ['0' .. '9']) + mini <- mkdigits 8 + maxi <- mkdigits =<< choose (0, 7) + pure $ '+' : mini <> maxi instance Arbitrary PhonePrefix where arbitrary = PhonePrefix . ST.pack <$> do - let mkdigits n = replicateM n (elements ['0'..'9']) - mini <- mkdigits 1 - maxi <- mkdigits =<< choose (0, 14) - pure $ '+' : mini <> maxi + let mkdigits n = replicateM n (elements ['0' .. '9']) + mini <- mkdigits 1 + maxi <- mkdigits =<< choose (0, 14) + pure $ '+' : mini <> maxi instance Arbitrary ExcludedPrefix where - arbitrary = ExcludedPrefix <$> arbitrary <*> arbitrary + arbitrary = ExcludedPrefix <$> arbitrary <*> arbitrary instance Arbitrary UserIdentity where - arbitrary = oneof - [ FullIdentity <$> arbitrary <*> arbitrary - , EmailIdentity <$> arbitrary - , PhoneIdentity <$> arbitrary - , SSOIdentity <$> arbitrary <*> arbitrary <*> arbitrary - ] + arbitrary = + oneof + [ FullIdentity <$> arbitrary <*> arbitrary, + EmailIdentity <$> arbitrary, + PhoneIdentity <$> arbitrary, + SSOIdentity <$> arbitrary <*> arbitrary <*> arbitrary + ] instance Arbitrary UserSSOId where arbitrary = UserSSOId <$> arbitrary <*> arbitrary @@ -154,289 +145,297 @@ instance Arbitrary AssetSize where instance Arbitrary Asset where arbitrary = ImageAsset <$> arbitrary <*> arbitrary - -- TODO: since new team members do not get serialized, we zero them here. it may be worth looking -- into how this can be solved on in the types. instance Arbitrary BindingNewTeamUser where - arbitrary = BindingNewTeamUser - <$> (BindingNewTeam . (newTeamMembers .~ Nothing) <$> arbitrary @(NewTeam ())) - <*> arbitrary - shrink (BindingNewTeamUser (BindingNewTeam nt) cur) = - BindingNewTeamUser <$> (BindingNewTeam <$> shrink nt) <*> [cur] + arbitrary = + BindingNewTeamUser + <$> (BindingNewTeam . (newTeamMembers .~ Nothing) <$> arbitrary @(NewTeam ())) + <*> arbitrary + shrink (BindingNewTeamUser (BindingNewTeam nt) cur) = + BindingNewTeamUser <$> (BindingNewTeam <$> shrink nt) <*> [cur] instance Arbitrary Alpha where - arbitrary = genEnumBounded + arbitrary = genEnumBounded instance Arbitrary (NewTeam ()) where - arbitrary = NewTeam <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - shrink (NewTeam x0 x1 x2 x3) = NewTeam <$> shrink x0 <*> shrink x1 <*> shrink x2 <*> shrink x3 + arbitrary = NewTeam <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + shrink (NewTeam x0 x1 x2 x3) = NewTeam <$> shrink x0 <*> shrink x1 <*> shrink x2 <*> shrink x3 instance Arbitrary CheckHandles where - arbitrary = CheckHandles <$> arbitrary <*> arbitrary + arbitrary = CheckHandles <$> arbitrary <*> arbitrary instance Arbitrary CompletePasswordReset where - arbitrary = CompletePasswordReset <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = CompletePasswordReset <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary PasswordResetCode where - arbitrary = PasswordResetCode . fromRange <$> genRangeAsciiBase64Url @6 @1024 + arbitrary = PasswordResetCode . fromRange <$> genRangeAsciiBase64Url @6 @1024 instance Arbitrary PasswordResetIdentity where - arbitrary = oneof - [ PasswordResetIdentityKey . PasswordResetKey <$> arbitrary - , PasswordResetEmailIdentity <$> arbitrary - , PasswordResetPhoneIdentity <$> arbitrary - ] + arbitrary = + oneof + [ PasswordResetIdentityKey . PasswordResetKey <$> arbitrary, + PasswordResetEmailIdentity <$> arbitrary, + PasswordResetPhoneIdentity <$> arbitrary + ] instance Arbitrary AsciiBase64Url where - arbitrary = encodeBase64Url <$> arbitrary + arbitrary = encodeBase64Url <$> arbitrary instance Arbitrary ReAuthUser where - arbitrary = ReAuthUser <$> arbitrary + arbitrary = ReAuthUser <$> arbitrary instance Arbitrary DeleteUser where - arbitrary = DeleteUser <$> arbitrary + arbitrary = DeleteUser <$> arbitrary instance Arbitrary DeletionCodeTimeout where - arbitrary = DeletionCodeTimeout <$> arbitrary + arbitrary = DeletionCodeTimeout <$> arbitrary instance Arbitrary Timeout where - arbitrary = Timeout . fromIntegral <$> arbitrary @Int + arbitrary = Timeout . fromIntegral <$> arbitrary @Int instance Arbitrary EmailRemove where - arbitrary = EmailRemove <$> arbitrary + arbitrary = EmailRemove <$> arbitrary instance Arbitrary EmailUpdate where - arbitrary = EmailUpdate <$> arbitrary + arbitrary = EmailUpdate <$> arbitrary instance Arbitrary HandleUpdate where - arbitrary = HandleUpdate <$> arbitrary + arbitrary = HandleUpdate <$> arbitrary instance Arbitrary LocaleUpdate where - arbitrary = LocaleUpdate <$> arbitrary + arbitrary = LocaleUpdate <$> arbitrary instance Arbitrary ManagedByUpdate where - arbitrary = ManagedByUpdate <$> arbitrary + arbitrary = ManagedByUpdate <$> arbitrary instance Arbitrary NewPasswordReset where - arbitrary = NewPasswordReset <$> arbitrary + arbitrary = NewPasswordReset <$> arbitrary instance Arbitrary NewUser where - arbitrary = do - newUserIdentity <- arbitrary - teamid <- arbitrary - let hasSSOId = case newUserIdentity of - Just SSOIdentity {} -> True - _ -> False - ssoOrigin = Just (NewUserOriginTeamUser (NewTeamMemberSSO teamid)) - isSsoOrigin (Just (NewUserOriginTeamUser (NewTeamMemberSSO _))) = True - isSsoOrigin _ = False - newUserOrigin <- if hasSSOId then pure ssoOrigin else arbitrary `suchThat` (not . isSsoOrigin) - let isTeamUser = case newUserOrigin of - Just (NewUserOriginTeamUser _) -> True - _ -> False - newUserName <- arbitrary - newUserUUID <- elements [Just nil, Nothing] - newUserPict <- arbitrary - newUserAssets <- arbitrary - newUserAccentId <- arbitrary - newUserEmailCode <- arbitrary - newUserPhoneCode <- arbitrary - newUserLabel <- arbitrary - newUserLocale <- arbitrary - newUserPassword <- if isTeamUser && not hasSSOId then Just <$> arbitrary else arbitrary - newUserExpiresIn <- if isJust newUserIdentity then pure Nothing else arbitrary - newUserManagedBy <- arbitrary - pure NewUser{..} + arbitrary = do + newUserIdentity <- arbitrary + teamid <- arbitrary + let hasSSOId = case newUserIdentity of + Just SSOIdentity {} -> True + _ -> False + ssoOrigin = Just (NewUserOriginTeamUser (NewTeamMemberSSO teamid)) + isSsoOrigin (Just (NewUserOriginTeamUser (NewTeamMemberSSO _))) = True + isSsoOrigin _ = False + newUserOrigin <- if hasSSOId then pure ssoOrigin else arbitrary `suchThat` (not . isSsoOrigin) + let isTeamUser = case newUserOrigin of + Just (NewUserOriginTeamUser _) -> True + _ -> False + newUserName <- arbitrary + newUserUUID <- elements [Just nil, Nothing] + newUserPict <- arbitrary + newUserAssets <- arbitrary + newUserAccentId <- arbitrary + newUserEmailCode <- arbitrary + newUserPhoneCode <- arbitrary + newUserLabel <- arbitrary + newUserLocale <- arbitrary + newUserPassword <- if isTeamUser && not hasSSOId then Just <$> arbitrary else arbitrary + newUserExpiresIn <- if isJust newUserIdentity then pure Nothing else arbitrary + newUserManagedBy <- arbitrary + pure NewUser {..} instance Arbitrary UTCTimeMillis where - arbitrary = toUTCTimeMillis <$> arbitrary + arbitrary = toUTCTimeMillis <$> arbitrary instance Arbitrary NewUserOrigin where - arbitrary = oneof - [ NewUserOriginInvitationCode <$> arbitrary - , NewUserOriginTeamUser <$> arbitrary - ] + arbitrary = + oneof + [ NewUserOriginInvitationCode <$> arbitrary, + NewUserOriginTeamUser <$> arbitrary + ] instance Arbitrary Pict where -- ('Pict' is DEPRECATED) - arbitrary = pure $ Pict [] + arbitrary = pure $ Pict [] instance Arbitrary ActivationCode where - arbitrary = ActivationCode <$> arbitrary - shrink (ActivationCode x) = ActivationCode <$> shrink x + arbitrary = ActivationCode <$> arbitrary + shrink (ActivationCode x) = ActivationCode <$> shrink x instance Arbitrary InvitationCode where - arbitrary = InvitationCode <$> arbitrary - shrink (InvitationCode x) = InvitationCode <$> shrink x + arbitrary = InvitationCode <$> arbitrary + shrink (InvitationCode x) = InvitationCode <$> shrink x instance Arbitrary CookieLabel where - arbitrary = CookieLabel <$> arbitrary - shrink (CookieLabel x) = CookieLabel <$> shrink x + arbitrary = CookieLabel <$> arbitrary + shrink (CookieLabel x) = CookieLabel <$> shrink x instance Arbitrary NewTeamUser where - arbitrary = oneof - [ NewTeamMember <$> arbitrary - , NewTeamCreator <$> arbitrary - , NewTeamMemberSSO <$> arbitrary - ] + arbitrary = + oneof + [ NewTeamMember <$> arbitrary, + NewTeamCreator <$> arbitrary, + NewTeamMemberSSO <$> arbitrary + ] instance Arbitrary TeamMember where - arbitrary = newTeamMember <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = newTeamMember <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary PasswordChange where - arbitrary = PasswordChange <$> arbitrary <*> arbitrary + arbitrary = PasswordChange <$> arbitrary <*> arbitrary instance Arbitrary PhoneRemove where - arbitrary = PhoneRemove <$> arbitrary + arbitrary = PhoneRemove <$> arbitrary instance Arbitrary PhoneUpdate where - arbitrary = PhoneUpdate <$> arbitrary + arbitrary = PhoneUpdate <$> arbitrary instance Arbitrary SelfProfile where - arbitrary = SelfProfile <$> arbitrary + arbitrary = SelfProfile <$> arbitrary instance Arbitrary UserHandleInfo where - arbitrary = UserHandleInfo <$> arbitrary + arbitrary = UserHandleInfo <$> arbitrary instance Arbitrary UserProfile where - arbitrary = UserProfile - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + arbitrary = + UserProfile + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary instance Arbitrary RichField where - arbitrary = - RichField + arbitrary = + RichField <$> arbitrary <*> (arbitrary `suchThat` (/= "")) -- This is required because FromJSON calls @normalizeRichInfo@ and roundtrip tests fail instance Arbitrary RichInfo where - arbitrary = do - richInfoAssocList <- nubOn richFieldType <$> arbitrary - richInfoMap <- arbitrary - pure RichInfo{..} + arbitrary = do + richInfoAssocList <- nubOn richFieldType <$> arbitrary + richInfoMap <- arbitrary + pure RichInfo {..} instance Arbitrary RichInfoAssocList where arbitrary = RichInfoAssocList <$> nubOn richFieldType <$> arbitrary instance Arbitrary RichInfoUpdate where - arbitrary = RichInfoUpdate <$> arbitrary + arbitrary = RichInfoUpdate <$> arbitrary instance Arbitrary ServiceRef where - arbitrary = ServiceRef <$> arbitrary <*> arbitrary + arbitrary = ServiceRef <$> arbitrary <*> arbitrary instance Arbitrary UserUpdate where - arbitrary = UserUpdate - <$> arbitrary - <*> pure Nothing - <*> arbitrary - <*> arbitrary + arbitrary = + UserUpdate + <$> arbitrary + <*> pure Nothing + <*> arbitrary + <*> arbitrary instance Arbitrary User where - arbitrary = User - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + arbitrary = + User + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary instance Arbitrary VerifyDeleteUser where - arbitrary = VerifyDeleteUser <$> arbitrary <*> arbitrary + arbitrary = VerifyDeleteUser <$> arbitrary <*> arbitrary instance Arbitrary Key where - arbitrary = Key <$> genRangeAsciiBase64Url @20 @20 + arbitrary = Key <$> genRangeAsciiBase64Url @20 @20 instance Arbitrary Brig.Types.Code.Value where - arbitrary = Value <$> genRangeAsciiBase64Url @6 @20 + arbitrary = Value <$> genRangeAsciiBase64Url @6 @20 instance Arbitrary Locale where - arbitrary = Locale <$> arbitrary <*> arbitrary + arbitrary = Locale <$> arbitrary <*> arbitrary instance Arbitrary Language where - arbitrary = Language <$> genEnumBounded + arbitrary = Language <$> genEnumBounded -- | deriving instance Bounded ISO639_1 instance Arbitrary Country where - arbitrary = Country <$> genEnumBounded + arbitrary = Country <$> genEnumBounded instance Arbitrary UpdateServiceWhitelist where - arbitrary = UpdateServiceWhitelist <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = UpdateServiceWhitelist <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary InvitationList where - arbitrary = InvitationList <$> listOf arbitrary <*> arbitrary + arbitrary = InvitationList <$> listOf arbitrary <*> arbitrary instance Arbitrary Invitation where - arbitrary = Invitation <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = Invitation <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary Permissions where - arbitrary = maybe (error "instance Arbitrary Permissions") pure =<< do - selfperms <- arbitrary - copyperms <- Set.intersection selfperms <$> arbitrary - pure $ newPermissions selfperms copyperms + arbitrary = maybe (error "instance Arbitrary Permissions") pure =<< do + selfperms <- arbitrary + copyperms <- Set.intersection selfperms <$> arbitrary + pure $ newPermissions selfperms copyperms instance Arbitrary Perm where - arbitrary = elements [minBound..] + arbitrary = elements [minBound ..] instance Arbitrary InvitationRequest where - arbitrary = InvitationRequest <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = InvitationRequest <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary Role where - arbitrary = elements [minBound..] + arbitrary = elements [minBound ..] instance Arbitrary ManagedBy where - arbitrary = elements [minBound..] + arbitrary = elements [minBound ..] ---------------------------------------------------------------------- -- utilities instance (KnownNat n, KnownNat m, LTE n m) => Arbitrary (Range n m ST.Text) where - arbitrary = genRangeText arbitrary - shrink (fromRange -> txt) = [unsafeRange @ST.Text @n @m $ ST.take (fromKnownNat (Proxy @n)) txt] + arbitrary = genRangeText arbitrary + shrink (fromRange -> txt) = [unsafeRange @ST.Text @n @m $ ST.take (fromKnownNat (Proxy @n)) txt] instance (KnownNat n, KnownNat m, LTE n m) => Arbitrary (Range n m Integer) where - arbitrary = arbitraryIntegral + arbitrary = arbitraryIntegral instance (KnownNat n, KnownNat m, LTE n m) => Arbitrary (Range n m Word) where - arbitrary = arbitraryIntegral + arbitrary = arbitraryIntegral instance (KnownNat n, KnownNat m, LTE n m, Arbitrary a, Show a) => Arbitrary (Range n m [a]) where - arbitrary = genRangeList @n @m @a arbitrary + arbitrary = genRangeList @n @m @a arbitrary -arbitraryIntegral :: forall n m i. - (KnownNat n, KnownNat m, LTE n m, Integral i, Show i, Bounds i, System.Random.Random i) - => Gen (Range n m i) +arbitraryIntegral :: + forall n m i. + (KnownNat n, KnownNat m, LTE n m, Integral i, Show i, Bounds i, System.Random.Random i) => + Gen (Range n m i) arbitraryIntegral = unsafeRange @i @n @m <$> choose (fromKnownNat (Proxy @n), fromKnownNat (Proxy @m)) fromKnownNat :: forall (k :: Nat) (i :: *). (Num i, KnownNat k) => Proxy k -> i fromKnownNat p = fromIntegral $ natVal p -- (can we implement this also in terms of 'genRange'?) -genRangeAsciiBase64Url :: forall (n :: Nat) (m :: Nat). - (HasCallStack, KnownNat n, KnownNat m, LTE n m) - => Gen (Range n m AsciiBase64Url) +genRangeAsciiBase64Url :: + forall (n :: Nat) (m :: Nat). + (HasCallStack, KnownNat n, KnownNat m, LTE n m) => + Gen (Range n m AsciiBase64Url) genRangeAsciiBase64Url = do - txt <- fromRange <$> genRangeText @n @m genBase64UrlChar - case validateBase64Url txt of - Right ascii -> pure $ unsafeRange @AsciiBase64Url @n @m ascii - Left msg -> error msg + txt <- fromRange <$> genRangeText @n @m genBase64UrlChar + case validateBase64Url txt of + Right ascii -> pure $ unsafeRange @AsciiBase64Url @n @m ascii + Left msg -> error msg genBase64UrlChar :: Gen Char genBase64UrlChar = elements $ alphaNumChars <> "_-=" @@ -445,108 +444,111 @@ genAlphaNum :: Gen Char genAlphaNum = elements $ alphaNumChars <> "_" alphaNumChars :: [Char] -alphaNumChars = ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9'] +alphaNumChars = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] genEnumBounded :: (Enum a, Bounded a) => Gen a -genEnumBounded = elements [minBound..] +genEnumBounded = elements [minBound ..] instance Arbitrary UserLegalHoldStatusResponse where - arbitrary = UserLegalHoldStatusResponse <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = UserLegalHoldStatusResponse <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary LegalHoldStatus where - arbitrary = genEnumBounded + arbitrary = genEnumBounded instance Arbitrary LegalHoldTeamConfig where - arbitrary = LegalHoldTeamConfig <$> arbitrary + arbitrary = LegalHoldTeamConfig <$> arbitrary instance Arbitrary NewLegalHoldService where - arbitrary = NewLegalHoldService <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = NewLegalHoldService <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary LegalHoldService where - arbitrary = LegalHoldService <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = LegalHoldService <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary ViewLegalHoldService where - arbitrary = oneof - [ ViewLegalHoldService <$> arbitrary - , pure ViewLegalHoldServiceNotConfigured - , pure ViewLegalHoldServiceDisabled - ] + arbitrary = + oneof + [ ViewLegalHoldService <$> arbitrary, + pure ViewLegalHoldServiceNotConfigured, + pure ViewLegalHoldServiceDisabled + ] instance Arbitrary ViewLegalHoldServiceInfo where - arbitrary = ViewLegalHoldServiceInfo <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = ViewLegalHoldServiceInfo <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary HttpsUrl where - arbitrary = pure $ HttpsUrl [uri|https://example.com|] + arbitrary = pure $ HttpsUrl [uri|https://example.com|] instance Arbitrary ServiceKeyType where - arbitrary = genEnumBounded + arbitrary = genEnumBounded instance Arbitrary ServiceKey where - arbitrary = ServiceKey <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = ServiceKey <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary ServiceKeyPEM where - arbitrary = pure $ ServiceKeyPEM k - where Right [k] = pemParseBS . BS.unlines $ - [ "-----BEGIN PUBLIC KEY-----" - , "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAu+Kg/PHHU3atXrUbKnw0" - , "G06FliXcNt3lMwl2os5twEDcPPFw/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPH" - , "WvUBdiLfGrZqJO223DB6D8K2Su/odmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKV" - , "VPOaOzgtAB21XKRiQ4ermqgi3/njr03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiS" - , "bUKr/BeArYRcjzr/h5m1In6fG/if9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg8" - , "7X883H+LA/d6X5CTiPv1VMxXdBUiGPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7la" - , "nQIDAQAB" - , "-----END PUBLIC KEY-----" - ] + arbitrary = pure $ ServiceKeyPEM k + where + Right [k] = + pemParseBS . BS.unlines $ + [ "-----BEGIN PUBLIC KEY-----", + "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAu+Kg/PHHU3atXrUbKnw0", + "G06FliXcNt3lMwl2os5twEDcPPFw/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPH", + "WvUBdiLfGrZqJO223DB6D8K2Su/odmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKV", + "VPOaOzgtAB21XKRiQ4ermqgi3/njr03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiS", + "bUKr/BeArYRcjzr/h5m1In6fG/if9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg8", + "7X883H+LA/d6X5CTiPv1VMxXdBUiGPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7la", + "nQIDAQAB", + "-----END PUBLIC KEY-----" + ] instance Arbitrary (Fingerprint Rsa) where - arbitrary = pure $ Fingerprint + arbitrary = + pure $ + Fingerprint "\138\140\183\EM\226#\129\EOTl\161\183\246\DLE\161\142\220\239&\171\241h|\\GF\172\180O\129\DC1!\159" instance Arbitrary ServiceToken where - arbitrary = ServiceToken <$> arbitrary + arbitrary = ServiceToken <$> arbitrary instance Arbitrary RequestNewLegalHoldClient where - arbitrary = RequestNewLegalHoldClient <$> arbitrary <*> arbitrary + arbitrary = RequestNewLegalHoldClient <$> arbitrary <*> arbitrary instance Arbitrary NewLegalHoldClient where - arbitrary = NewLegalHoldClient <$> arbitrary <*> arbitrary + arbitrary = NewLegalHoldClient <$> arbitrary <*> arbitrary instance Arbitrary LegalHoldClientRequest where - arbitrary = - LegalHoldClientRequest - <$> arbitrary - <*> arbitrary + arbitrary = + LegalHoldClientRequest + <$> arbitrary + <*> arbitrary instance Arbitrary LegalHoldServiceConfirm where - arbitrary = - LegalHoldServiceConfirm - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary + arbitrary = + LegalHoldServiceConfirm + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary instance Arbitrary RemoveLegalHoldSettingsRequest where - arbitrary = RemoveLegalHoldSettingsRequest <$> arbitrary + arbitrary = RemoveLegalHoldSettingsRequest <$> arbitrary instance Arbitrary DisableLegalHoldForUserRequest where - arbitrary = DisableLegalHoldForUserRequest <$> arbitrary + arbitrary = DisableLegalHoldForUserRequest <$> arbitrary instance Arbitrary ApproveLegalHoldForUserRequest where - arbitrary = ApproveLegalHoldForUserRequest <$> arbitrary + arbitrary = ApproveLegalHoldForUserRequest <$> arbitrary instance Arbitrary LastPrekey where - arbitrary = lastPrekey <$> arbitrary + arbitrary = lastPrekey <$> arbitrary instance Arbitrary Prekey where - arbitrary = Prekey <$> arbitrary <*> arbitrary + arbitrary = Prekey <$> arbitrary <*> arbitrary instance Arbitrary PrekeyId where - arbitrary = PrekeyId <$> arbitrary + arbitrary = PrekeyId <$> arbitrary instance Arbitrary CustomBackend where - arbitrary = - CustomBackend - <$> arbitrary - <*> arbitrary - -#endif + arbitrary = + CustomBackend + <$> arbitrary + <*> arbitrary diff --git a/libs/brig-types/src/Brig/Types/User.hs b/libs/brig-types/src/Brig/Types/User.hs index 5b58d155ecd..f98cfccc0e6 100644 --- a/libs/brig-types/src/Brig/Types/User.hs +++ b/libs/brig-types/src/Brig/Types/User.hs @@ -24,6 +24,7 @@ import Data.ByteString.Conversion import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Data.Currency as Currency +import Data.Handle (Handle) import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HashMap import Data.Hashable (Hashable) diff --git a/libs/brig-types/src/Brig/Types/User/Auth.hs b/libs/brig-types/src/Brig/Types/User/Auth.hs index fd3c8f71c8d..b02c506f1f9 100644 --- a/libs/brig-types/src/Brig/Types/User/Auth.hs +++ b/libs/brig-types/src/Brig/Types/User/Auth.hs @@ -10,6 +10,7 @@ import Brig.Types.Common import Data.Aeson import qualified Data.Aeson.Types as Aeson import Data.ByteString.Conversion +import Data.Handle (Handle) import Data.Id (UserId) import Data.Misc (PlainTextPassword (..)) import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) diff --git a/libs/brig-types/test/unit/Test/Brig/Types/Common.hs b/libs/brig-types/test/unit/Test/Brig/Types/Common.hs index 1f78a285ea0..b0be05ba42e 100644 --- a/libs/brig-types/test/unit/Test/Brig/Types/Common.hs +++ b/libs/brig-types/test/unit/Test/Brig/Types/Common.hs @@ -28,8 +28,7 @@ tests :: TestTree tests = testGroup "Common (types vs. aeson)" - [ run @Handle, - run @Name, + [ run @Name, run @ColourId, run @Email, run @Phone, diff --git a/libs/galley-types/package.yaml b/libs/galley-types/package.yaml index 00f2c88c474..8c24178b295 100644 --- a/libs/galley-types/package.yaml +++ b/libs/galley-types/package.yaml @@ -19,14 +19,14 @@ library: - base64-bytestring >=1.0 - bytestring >=0.9 - bytestring-conversion >=0.2 + - cassandra-util - containers >=0.5 - currency-codes >=2.0 - data-default >=0.5 - - email-validate >=2.0 - - gundeck-types >=1.15.13 - - hashable - errors - exceptions >=0.10.0 + - gundeck-types >=1.15.13 + - hashable - lens >=4.12 - protobuf >=0.2 - string-conversions @@ -38,11 +38,6 @@ library: - unordered-containers >=0.2 - uri-bytestring >=0.2 - uuid >=1.3 - when: - - condition: flag(cql) - cpp-options: -DWITH_CQL - dependencies: - - cassandra-util tests: galley-types-tests: main: Main.hs @@ -58,8 +53,3 @@ tests: - tasty-hunit - types-common - containers -flags: - cql: - description: Enable cql instances - manual: true - default: false diff --git a/libs/galley-types/src/Galley/Types.hs b/libs/galley-types/src/Galley/Types.hs index a80169cc44b..59440f0b874 100644 --- a/libs/galley-types/src/Galley/Types.hs +++ b/libs/galley-types/src/Galley/Types.hs @@ -45,8 +45,6 @@ module Galley.Types ConversationMessageTimerUpdate (..), ConvType (..), CustomBackend (..), - EmailDomain (emailDomainText), - mkEmailDomain, Invite (..), NewConv (..), NewConvManaged (..), @@ -67,8 +65,6 @@ where import Control.Lens ((.~)) import Data.Aeson import Data.Aeson.Types (Parser) -import qualified Data.Attoparsec.ByteString as Atto -import Data.Bifunctor (bimap) import Data.ByteString.Conversion import qualified Data.Code as Code import qualified Data.HashMap.Strict as HashMap @@ -84,7 +80,6 @@ import Galley.Types.Bot.Service (ServiceRef) import Galley.Types.Conversations.Roles import Gundeck.Types.Push (Priority) import Imports -import qualified Text.Email.Validate as Email import URI.ByteString -- Conversations ------------------------------------------------------------ @@ -220,7 +215,7 @@ data ConvTeamInfo data NewConv = NewConv - { newConvUsers :: ![UserId], + { newConvUsers :: ![OpaqueUserId], newConvName :: !(Maybe Text), newConvAccess :: !(Set Access), newConvAccessRole :: !(Maybe AccessRole), @@ -276,7 +271,7 @@ create managed conversations anyway. newtype UserClientMap a = UserClientMap - { userClientMap :: Map UserId (Map ClientId a) + { userClientMap :: Map OpaqueUserId (Map ClientId a) } deriving ( Eq, @@ -301,7 +296,7 @@ newtype OtrRecipients Monoid ) -foldrOtrRecipients :: (UserId -> ClientId -> Text -> a -> a) -> a -> OtrRecipients -> a +foldrOtrRecipients :: (OpaqueUserId -> ClientId -> Text -> a -> a) -> a -> OtrRecipients -> a foldrOtrRecipients f a = Map.foldrWithKey go a . userClientMap @@ -318,10 +313,10 @@ data OtrFilterMissing OtrReportAllMissing | -- | Complain only about missing -- recipients who are /not/ on this list - OtrIgnoreMissing (Set UserId) + OtrIgnoreMissing (Set OpaqueUserId) | -- | Complain only about missing -- recipients who /are/ on this list - OtrReportMissing (Set UserId) + OtrReportMissing (Set OpaqueUserId) data NewOtrMessage = NewOtrMessage @@ -335,7 +330,7 @@ data NewOtrMessage newtype UserClients = UserClients - { userClients :: Map UserId (Set ClientId) + { userClients :: Map OpaqueUserId (Set ClientId) } deriving (Eq, Show, Semigroup, Monoid, Generic) @@ -435,11 +430,11 @@ deriving instance Show OtherMemberUpdate data Invite = Invite - { invUsers :: !(List1 UserId), + { invUsers :: !(List1 OpaqueUserId), invRoleName :: !RoleName -- This role name is to be applied to all users } -newInvite :: List1 UserId -> Invite +newInvite :: List1 OpaqueUserId -> Invite newInvite us = Invite us roleNameWireAdmin deriving instance Eq Invite @@ -475,6 +470,9 @@ data EventType | Typing deriving (Eq, Show, Generic) +-- FUTUREWORK(federation): +-- A lot of information in the events can contain remote IDs, but the +-- receiver might be on another backend, so mapped IDs don't work for them. data EventData = EdMembersJoin !SimpleMembers | EdMembersLeave !UserIdList @@ -581,26 +579,6 @@ data CustomBackend } deriving (Eq, Show) -newtype EmailDomain - = EmailDomain - { emailDomainText :: Text - } - deriving (Eq, Generic, Show) - -mkEmailDomain :: ByteString -> Either String EmailDomain -mkEmailDomain = bimap show EmailDomain . T.decodeUtf8' <=< validateDomain - where - -- this is a slightly hacky way of validating an email domain, - -- but Text.Email.Validate doesn't expose the parser for the domain. - validateDomain = fmap Email.domainPart . Email.validate . ("local-part@" <>) - -instance FromByteString EmailDomain where - parser = do - bs <- Atto.takeByteString - case mkEmailDomain bs of - Left err -> fail ("Failed parsing ByteString as EmailDomain: " <> err) - Right domain -> pure domain - -- Instances ---------------------------------------------------------------- -- JSON diff --git a/libs/galley-types/src/Galley/Types/Bot/Service/Internal.hs b/libs/galley-types/src/Galley/Types/Bot/Service/Internal.hs index a6f63d3bc1b..eda0d49c65f 100644 --- a/libs/galley-types/src/Galley/Types/Bot/Service/Internal.hs +++ b/libs/galley-types/src/Galley/Types/Bot/Service/Internal.hs @@ -1,28 +1,27 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Galley.Types.Bot.Service.Internal where -import Imports +import Cassandra.CQL import Control.Lens (makeLenses) import Data.Aeson import Data.ByteString.Conversion import Data.Id -import Data.Misc (Fingerprint, Rsa, HttpsUrl) +import Data.Misc (Fingerprint, HttpsUrl, Rsa) import Data.Text.Ascii -#ifdef WITH_CQL -import Cassandra.CQL -#endif +import Imports -- ServiceRef ----------------------------------------------------------------- -- | A fully-qualified reference to a service. -data ServiceRef = ServiceRef - { _serviceRefId :: !ServiceId - , _serviceRefProvider :: !ProviderId - } deriving (Ord, Eq, Show, Generic) +data ServiceRef + = ServiceRef + { _serviceRefId :: !ServiceId, + _serviceRefProvider :: !ProviderId + } + deriving (Ord, Eq, Show, Generic) makeLenses ''ServiceRef @@ -30,34 +29,34 @@ newServiceRef :: ServiceId -> ProviderId -> ServiceRef newServiceRef = ServiceRef instance FromJSON ServiceRef where - parseJSON = withObject "ServiceRef" $ \o -> - ServiceRef <$> o .: "id" <*> o .: "provider" + parseJSON = withObject "ServiceRef" $ \o -> + ServiceRef <$> o .: "id" <*> o .: "provider" instance ToJSON ServiceRef where - toJSON r = object - [ "id" .= _serviceRefId r - , "provider" .= _serviceRefProvider r - ] + toJSON r = + object + [ "id" .= _serviceRefId r, + "provider" .= _serviceRefProvider r + ] -- Service -------------------------------------------------------------------- -- | A /secret/ bearer token used to authenticate and authorise requests @towards@ -- a 'Service' via inclusion in the HTTP 'Authorization' header. newtype ServiceToken = ServiceToken AsciiBase64Url - deriving (Eq, Show, ToByteString, FromByteString, FromJSON, ToJSON, Generic) + deriving (Eq, Show, ToByteString, FromByteString, FromJSON, ToJSON, Generic) -#ifdef WITH_CQL deriving instance Cql ServiceToken -#endif -- | Service connection information that is needed by galley. -data Service = Service - { _serviceRef :: !ServiceRef - , _serviceUrl :: !HttpsUrl - , _serviceToken :: !ServiceToken - , _serviceFingerprints :: ![Fingerprint Rsa] - , _serviceEnabled :: !Bool - } +data Service + = Service + { _serviceRef :: !ServiceRef, + _serviceUrl :: !HttpsUrl, + _serviceToken :: !ServiceToken, + _serviceFingerprints :: ![Fingerprint Rsa], + _serviceEnabled :: !Bool + } makeLenses ''Service @@ -65,18 +64,19 @@ newService :: ServiceRef -> HttpsUrl -> ServiceToken -> [Fingerprint Rsa] -> Ser newService ref url tok fps = Service ref url tok fps True instance FromJSON Service where - parseJSON = withObject "Service" $ \o -> - Service <$> o .: "ref" - <*> o .: "base_url" - <*> o .: "auth_token" - <*> o .: "fingerprints" - <*> o .: "enabled" + parseJSON = withObject "Service" $ \o -> + Service <$> o .: "ref" + <*> o .: "base_url" + <*> o .: "auth_token" + <*> o .: "fingerprints" + <*> o .: "enabled" instance ToJSON Service where - toJSON s = object - [ "ref" .= _serviceRef s - , "base_url" .= _serviceUrl s - , "auth_token" .= _serviceToken s - , "fingerprints" .= _serviceFingerprints s - , "enabled" .= _serviceEnabled s - ] + toJSON s = + object + [ "ref" .= _serviceRef s, + "base_url" .= _serviceUrl s, + "auth_token" .= _serviceToken s, + "fingerprints" .= _serviceFingerprints s, + "enabled" .= _serviceEnabled s + ] diff --git a/libs/galley-types/src/Galley/Types/Conversations/Roles.hs b/libs/galley-types/src/Galley/Types/Conversations/Roles.hs index 90589148a57..83889b9e8fa 100644 --- a/libs/galley-types/src/Galley/Types/Conversations/Roles.hs +++ b/libs/galley-types/src/Galley/Types/Conversations/Roles.hs @@ -1,63 +1,59 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} -- | This module contains the analog of some of the team-level roles & permissions types in -- "Galley.Types.Teams". module Galley.Types.Conversations.Roles - ( ConversationRole - , convRoleWireAdmin - , convRoleWireMember - , wireConvRoles - - , RoleName - , roleNameWireAdmin - , roleNameWireMember - , wireConvRoleNames - - , Action (..) - , Actions (..) - , ConversationRolesList (..) - - , isActionAllowed - , roleNameToActions - ) + ( ConversationRole, + convRoleWireAdmin, + convRoleWireMember, + wireConvRoles, + RoleName, + roleNameWireAdmin, + roleNameWireMember, + wireConvRoleNames, + Action (..), + Actions (..), + ConversationRolesList (..), + isActionAllowed, + roleNameToActions, + ) where -import Imports -#ifdef WITH_CQL import Cassandra.CQL hiding (Set) -#endif import Control.Applicative (optional) import Data.Aeson import Data.Aeson.TH import Data.Attoparsec.Text import Data.ByteString.Conversion import Data.Hashable -import qualified Data.Set as Set +import qualified Data.Set as Set import qualified Data.Text as T +import Imports -- | These conversation-level permissions. Analogous to the team-level permissions called -- 'Perm' (or 'Permissions'). -data Action = - AddConversationMember - | RemoveConversationMember - | ModifyConversationName - | ModifyConversationMessageTimer - | ModifyConversationReceiptMode - | ModifyConversationAccess - | ModifyOtherConversationMember - | LeaveConversation - | DeleteConversation - deriving (Eq, Ord, Show, Enum, Bounded, Generic) - -deriveJSON defaultOptions{ constructorTagModifier = camelTo2 '_' } ''Action - -newtype Actions = Actions - { allowedActions :: Set Action - } deriving (Eq, Ord, Show, Generic) +data Action + = AddConversationMember + | RemoveConversationMember + | ModifyConversationName + | ModifyConversationMessageTimer + | ModifyConversationReceiptMode + | ModifyConversationAccess + | ModifyOtherConversationMember + | LeaveConversation + | DeleteConversation + deriving (Eq, Ord, Show, Enum, Bounded, Generic) + +deriveJSON defaultOptions {constructorTagModifier = camelTo2 '_'} ''Action + +newtype Actions + = Actions + { allowedActions :: Set Action + } + deriving (Eq, Ord, Show, Generic) -- | A conversation role is associated to a user in the scope of a conversation and implies -- with a set of 'Action's. Conversation-level analog to what 'Role' is on the team-level. @@ -65,10 +61,11 @@ newtype Actions = Actions -- Do not expose the constructors directly, use smart -- constructors instead to ensure that all validation -- is performed -data ConversationRole = ConvRoleWireAdmin - | ConvRoleWireMember - | ConvRoleCustom RoleName Actions - deriving (Eq, Show) +data ConversationRole + = ConvRoleWireAdmin + | ConvRoleWireMember + | ConvRoleCustom RoleName Actions + deriving (Eq, Show) -- Given an action and a RoleName, three possible outcomes: -- Just True: Yes, the action is allowed @@ -76,57 +73,61 @@ data ConversationRole = ConvRoleWireAdmin -- Nothing: Not enough information, this is a custom role isActionAllowed :: Action -> RoleName -> Maybe Bool isActionAllowed action rn - | isCustomRoleName rn = Nothing - | otherwise = pure $ maybe False (action `elem`) (roleNameToActions rn) + | isCustomRoleName rn = Nothing + | otherwise = pure $ maybe False (action `elem`) (roleNameToActions rn) instance ToJSON ConversationRole where - toJSON cr = object - [ "conversation_role" .= roleToRoleName cr - , "actions" .= roleActions cr - ] + toJSON cr = + object + [ "conversation_role" .= roleToRoleName cr, + "actions" .= roleActions cr + ] instance FromJSON ConversationRole where - parseJSON = withObject "conversationRole" $ \o -> do - role <- o .: "conversation_role" - actions <- o .: "actions" - case (toConvRole role (Just $ Actions actions)) of - Just cr -> return cr - Nothing -> fail ("Failed to parse: " ++ show o) - -data ConversationRolesList = ConversationRolesList - { convRolesList :: [ConversationRole] - } deriving (Eq, Show) + parseJSON = withObject "conversationRole" $ \o -> do + role <- o .: "conversation_role" + actions <- o .: "actions" + case (toConvRole role (Just $ Actions actions)) of + Just cr -> return cr + Nothing -> fail ("Failed to parse: " ++ show o) + +data ConversationRolesList + = ConversationRolesList + { convRolesList :: [ConversationRole] + } + deriving (Eq, Show) instance ToJSON ConversationRolesList where - toJSON (ConversationRolesList r) = object - [ "conversation_roles" .= r - ] + toJSON (ConversationRolesList r) = + object + [ "conversation_roles" .= r + ] instance FromJSON ConversationRolesList where - parseJSON = withObject "conversation-roles-list" $ \o -> - ConversationRolesList <$> o .: "convesation_roles" + parseJSON = withObject "conversation-roles-list" $ \o -> + ConversationRolesList <$> o .: "convesation_roles" -- RoleNames with `wire_` prefix are reserved -- and cannot be created by externals. Therefore, never -- expose this constructor outside of this module. -newtype RoleName = RoleName { fromRoleName :: Text } - deriving (Eq, Show, ToJSON, ToByteString, Hashable, Generic) +newtype RoleName = RoleName {fromRoleName :: Text} + deriving (Eq, Show, ToJSON, ToByteString, Hashable, Generic) -#ifdef WITH_CQL deriving instance Cql RoleName -#endif instance FromByteString RoleName where - parser = parser >>= maybe (fail "Invalid RoleName") return . parseRoleName + parser = parser >>= maybe (fail "Invalid RoleName") return . parseRoleName instance FromJSON RoleName where - parseJSON = withText "RoleName" $ - maybe (fail "Invalid RoleName") pure . parseRoleName + parseJSON = + withText "RoleName" $ + maybe (fail "Invalid RoleName") pure . parseRoleName wireConvRoles :: [ConversationRole] -wireConvRoles = [ ConvRoleWireAdmin - , ConvRoleWireMember - ] +wireConvRoles = + [ ConvRoleWireAdmin, + ConvRoleWireMember + ] wireConvRoleNames :: [RoleName] wireConvRoleNames = [roleNameWireAdmin, roleNameWireMember] @@ -151,20 +152,21 @@ convRoleWireMember = ConvRoleWireMember -- convRoleCustom r a -- | isCustomRoleName r = Just (ConvRoleCustom r a) -- | otherwise = Nothing - parseRoleName :: Text -> Maybe RoleName parseRoleName t - | isValidRoleName t = Just (RoleName t) - | otherwise = Nothing + | isValidRoleName t = Just (RoleName t) + | otherwise = Nothing -- All RoleNames should have 2-128 chars isValidRoleName :: Text -> Bool -isValidRoleName = either (const False) (const True) - . parseOnly customRoleName +isValidRoleName = + either (const False) (const True) + . parseOnly customRoleName where - customRoleName = count 2 (satisfy chars) - *> count 126 (optional (satisfy chars)) - *> endOfInput + customRoleName = + count 2 (satisfy chars) + *> count 126 (optional (satisfy chars)) + *> endOfInput chars = inClass "a-z0-9_" -- * Custom RoleNames _must not_ start with `wire_` @@ -172,25 +174,26 @@ isCustomRoleName :: RoleName -> Bool isCustomRoleName (RoleName r) = isValidRoleName r && (not $ "wire_" `T.isPrefixOf` r) roleToRoleName :: ConversationRole -> RoleName -roleToRoleName ConvRoleWireAdmin = roleNameWireAdmin -roleToRoleName ConvRoleWireMember = roleNameWireMember +roleToRoleName ConvRoleWireAdmin = roleNameWireAdmin +roleToRoleName ConvRoleWireMember = roleNameWireMember roleToRoleName (ConvRoleCustom l _) = l toConvRole :: RoleName -> Maybe Actions -> Maybe ConversationRole -toConvRole (RoleName "wire_admin") _ = Just ConvRoleWireAdmin -toConvRole (RoleName "wire_member") _ = Just ConvRoleWireMember -toConvRole x (Just as) = Just (ConvRoleCustom x as) -toConvRole _ _ = Nothing +toConvRole (RoleName "wire_admin") _ = Just ConvRoleWireAdmin +toConvRole (RoleName "wire_member") _ = Just ConvRoleWireMember +toConvRole x (Just as) = Just (ConvRoleCustom x as) +toConvRole _ _ = Nothing roleNameToActions :: RoleName -> Maybe (Set Action) roleNameToActions r = roleActions <$> toConvRole r Nothing allActions :: Actions -allActions = Actions $ Set.fromList [ minBound..maxBound ] +allActions = Actions $ Set.fromList [minBound .. maxBound] roleActions :: ConversationRole -> Set Action -roleActions ConvRoleWireAdmin = allowedActions allActions -roleActions ConvRoleWireMember = Set.fromList +roleActions ConvRoleWireAdmin = allowedActions allActions +roleActions ConvRoleWireMember = + Set.fromList [ LeaveConversation ] roleActions (ConvRoleCustom _ (Actions actions)) = actions diff --git a/libs/galley-types/src/Galley/Types/Proto.hs b/libs/galley-types/src/Galley/Types/Proto.hs index 027a548143d..4f82be464eb 100644 --- a/libs/galley-types/src/Galley/Types/Proto.hs +++ b/libs/galley-types/src/Galley/Types/Proto.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- FUTUREWORK: generate this file module Galley.Types.Proto ( UserId, userId, @@ -52,7 +53,7 @@ import Imports newtype UserId = UserId - { _user :: Required 1 (Value Id.UserId) + { _user :: Required 1 (Value Id.OpaqueUserId) } deriving (Eq, Show, Generic) @@ -60,10 +61,10 @@ instance Encode UserId instance Decode UserId -fromUserId :: Id.UserId -> UserId +fromUserId :: Id.OpaqueUserId -> UserId fromUserId u = UserId {_user = putField u} -userId :: Functor f => (Id.UserId -> f Id.UserId) -> UserId -> f UserId +userId :: Functor f => (Id.OpaqueUserId -> f Id.OpaqueUserId) -> UserId -> f UserId userId f c = (\x -> c {_user = x}) <$> field f (_user c) -- ClientId ------------------------------------------------------------------ diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 1a1ffc29e70..111c3051531 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -1,153 +1,138 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} module Galley.Types.Teams - ( Team - , TeamBinding (..) - , newTeam - , teamId - , teamCreator - , teamName - , teamIcon - , teamIconKey - , teamBinding - , TeamCreationTime (..) - , tcTime - - , FeatureFlags(..), flagSSO, flagLegalHold - , FeatureSSO(..) - , FeatureLegalHold(..) - - , TeamList - , newTeamList - , teamListTeams - , teamListHasMore - - , TeamMember - , newTeamMember - , newTeamMemberRaw - , userId - , permissions - , invitation - , legalHoldStatus - , teamMemberJson - , canSeePermsOf - - , TeamMemberList - , notTeamMember - , findTeamMember - , isTeamMember - , newTeamMemberList - , teamMembers - , teamMemberListJson - - , TeamConversation - , newTeamConversation - , conversationId - , managedConversation - - , TeamConversationList - , newTeamConversationList - , teamConversations - - , Permissions - , newPermissions - , fullPermissions - , noPermissions - , serviceWhitelistPermissions - , hasPermission - , mayGrantPermission - , isTeamOwner - , self - , copy - - , Perm (..) - , permToInt - , permsToInt - , intToPerm - , intToPerms - - , HiddenPerm(..) - , IsPerm - - , Role (..) - , defaultRole - , rolePermissions - - , BindingNewTeam (..) - , NonBindingNewTeam (..) - , NewTeam - , newNewTeam - , newTeamName - , newTeamIcon - , newTeamIconKey - , newTeamMembers - - , NewTeamMember - , newNewTeamMember - , ntmNewTeamMember - - , Event - , newEvent - , eventType - , eventTime - , eventTeam - , eventData - - , EventType (..) - , EventData (..) - - , TeamUpdateData - , newTeamUpdateData - , nameUpdate - , iconUpdate - , iconKeyUpdate - - , TeamMemberDeleteData - , tmdAuthPassword - , newTeamMemberDeleteData - , TeamDeleteData - , tdAuthPassword - , newTeamDeleteData - ) where + ( Team, + TeamBinding (..), + newTeam, + teamId, + teamCreator, + teamName, + teamIcon, + teamIconKey, + teamBinding, + TeamCreationTime (..), + tcTime, + FeatureFlags (..), + flagSSO, + flagLegalHold, + FeatureSSO (..), + FeatureLegalHold (..), + TeamList, + newTeamList, + teamListTeams, + teamListHasMore, + TeamMember, + newTeamMember, + newTeamMemberRaw, + userId, + permissions, + invitation, + legalHoldStatus, + teamMemberJson, + canSeePermsOf, + TeamMemberList, + notTeamMember, + findTeamMember, + isTeamMember, + newTeamMemberList, + teamMembers, + teamMemberListJson, + TeamConversation, + newTeamConversation, + conversationId, + managedConversation, + TeamConversationList, + newTeamConversationList, + teamConversations, + Permissions, + newPermissions, + fullPermissions, + noPermissions, + serviceWhitelistPermissions, + hasPermission, + mayGrantPermission, + isTeamOwner, + self, + copy, + Perm (..), + permToInt, + permsToInt, + intToPerm, + intToPerms, + HiddenPerm (..), + IsPerm, + Role (..), + defaultRole, + rolePermissions, + BindingNewTeam (..), + NonBindingNewTeam (..), + NewTeam, + newNewTeam, + newTeamName, + newTeamIcon, + newTeamIconKey, + newTeamMembers, + NewTeamMember, + newNewTeamMember, + ntmNewTeamMember, + Event, + newEvent, + eventType, + eventTime, + eventTeam, + eventData, + EventType (..), + EventData (..), + TeamUpdateData, + newTeamUpdateData, + nameUpdate, + iconUpdate, + iconKeyUpdate, + TeamMemberDeleteData, + tmdAuthPassword, + newTeamMemberDeleteData, + TeamDeleteData, + tdAuthPassword, + newTeamDeleteData, + ) +where -import Imports -import Control.Exception (ErrorCall(ErrorCall)) -import Control.Lens (makeLenses, view, (^.), to) +import qualified Cassandra as Cql +import qualified Control.Error.Util as Err +import Control.Exception (ErrorCall (ErrorCall)) +import Control.Lens ((^.), makeLenses, to, view) import Control.Monad.Catch import Data.Aeson -import Data.Aeson.Types (Parser, Pair) -import Data.Bits (testBit, (.|.)) -import Data.Id (TeamId, ConvId, UserId) +import Data.Aeson.Types (Pair, Parser) +import Data.Bits ((.|.), testBit) +import qualified Data.HashMap.Strict as HashMap +import Data.Id (ConvId, TeamId, UserId) import Data.Json.Util +import Data.LegalHold (UserLegalHoldStatus (..)) +import qualified Data.Maybe as Maybe import Data.Misc (PlainTextPassword (..)) import Data.Range +import qualified Data.Set as Set import Data.String.Conversions (cs) import Data.Time (UTCTime) -import Data.LegalHold (UserLegalHoldStatus(..)) import Galley.Types.Teams.Internal +import Imports -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Maybe as Maybe -import qualified Data.Set as Set -#ifdef WITH_CQL -import qualified Control.Error.Util as Err -import qualified Cassandra as Cql -#endif - -data Event = Event - { _eventType :: EventType - , _eventTeam :: TeamId - , _eventTime :: UTCTime - , _eventData :: Maybe EventData - } deriving (Eq, Generic) +data Event + = Event + { _eventType :: EventType, + _eventTeam :: TeamId, + _eventTime :: UTCTime, + _eventData :: Maybe EventData + } + deriving (Eq, Generic) -- Note [whitelist events] -- ~~~~~~~~~~~~~~~ @@ -183,187 +168,213 @@ data Event = Event -- arguably the code would be simpler if they were in Brig, so we should -- think about that if we want to get them in. -data EventType = - TeamCreate - | TeamDelete - | TeamUpdate - | MemberJoin - | MemberLeave - | MemberUpdate - | ConvCreate - | ConvDelete - deriving (Eq, Show, Generic) - -data EventData = - EdTeamCreate Team - | EdTeamUpdate TeamUpdateData - | EdMemberJoin UserId - | EdMemberLeave UserId - | EdMemberUpdate UserId (Maybe Permissions) - | EdConvCreate ConvId - | EdConvDelete ConvId - deriving (Eq, Show, Generic) - -data TeamUpdateData = TeamUpdateData - { _nameUpdate :: Maybe (Range 1 256 Text) - , _iconUpdate :: Maybe (Range 1 256 Text) - , _iconKeyUpdate :: Maybe (Range 1 256 Text) - } deriving (Eq, Show, Generic) - -data TeamList = TeamList - { _teamListTeams :: [Team] - , _teamListHasMore :: Bool - } deriving (Show, Generic) - -data TeamMember = TeamMember - { _userId :: UserId - , _permissions :: Permissions - , _invitation :: Maybe (UserId, UTCTimeMillis) - , _legalHoldStatus :: UserLegalHoldStatus - } deriving (Eq, Ord, Show, Generic) - -newtype TeamMemberList = TeamMemberList - { _teamMembers :: [TeamMember] - } deriving (Semigroup, Monoid, Generic) - -data TeamConversation = TeamConversation - { _conversationId :: ConvId - , _managedConversation :: Bool - } - -newtype TeamConversationList = TeamConversationList - { _teamConversations :: [TeamConversation] - } - -data Permissions = Permissions - { _self :: Set Perm - , _copy :: Set Perm - } deriving (Eq, Ord, Show, Generic) +data EventType + = TeamCreate + | TeamDelete + | TeamUpdate + | MemberJoin + | MemberLeave + | MemberUpdate + | ConvCreate + | ConvDelete + deriving (Eq, Show, Generic) + +data EventData + = EdTeamCreate Team + | EdTeamUpdate TeamUpdateData + | EdMemberJoin UserId + | EdMemberLeave UserId + | EdMemberUpdate UserId (Maybe Permissions) + | EdConvCreate ConvId + | EdConvDelete ConvId + deriving (Eq, Show, Generic) + +data TeamUpdateData + = TeamUpdateData + { _nameUpdate :: Maybe (Range 1 256 Text), + _iconUpdate :: Maybe (Range 1 256 Text), + _iconKeyUpdate :: Maybe (Range 1 256 Text) + } + deriving (Eq, Show, Generic) + +data TeamList + = TeamList + { _teamListTeams :: [Team], + _teamListHasMore :: Bool + } + deriving (Show, Generic) + +data TeamMember + = TeamMember + { _userId :: UserId, + _permissions :: Permissions, + _invitation :: Maybe (UserId, UTCTimeMillis), + _legalHoldStatus :: UserLegalHoldStatus + } + deriving (Eq, Ord, Show, Generic) + +newtype TeamMemberList + = TeamMemberList + { _teamMembers :: [TeamMember] + } + deriving (Semigroup, Monoid, Generic) + +data TeamConversation + = TeamConversation + { _conversationId :: ConvId, + _managedConversation :: Bool + } + +newtype TeamConversationList + = TeamConversationList + { _teamConversations :: [TeamConversation] + } + +data Permissions + = Permissions + { _self :: Set Perm, + _copy :: Set Perm + } + deriving (Eq, Ord, Show, Generic) -- | Team-level permission. Analog to conversation-level 'Action'. -data Perm = - CreateConversation - | DoNotUseDeprecatedDeleteConversation -- NOTE: This gets now overruled by conv level checks - | AddTeamMember - | RemoveTeamMember - | DoNotUseDeprecatedAddRemoveConvMember -- NOTE: This gets now overruled by conv level checks - | DoNotUseDeprecatedModifyConvName -- NOTE: This gets now overruled by conv level checks - | GetBilling - | SetBilling - | SetTeamData - | GetMemberPermissions - | SetMemberPermissions - | GetTeamConversations - | DeleteTeam - -- FUTUREWORK: make the verbs in the roles more consistent - -- (CRUD vs. Add,Remove vs; Get,Set vs. Create,Delete etc). - -- If you ever think about adding a new permission flag, - -- read Note [team roles] first. - deriving (Eq, Ord, Show, Enum, Bounded, Generic) +data Perm + = CreateConversation + | DoNotUseDeprecatedDeleteConversation -- NOTE: This gets now overruled by conv level checks + | AddTeamMember + | RemoveTeamMember + | DoNotUseDeprecatedAddRemoveConvMember -- NOTE: This gets now overruled by conv level checks + | DoNotUseDeprecatedModifyConvName -- NOTE: This gets now overruled by conv level checks + | GetBilling + | SetBilling + | SetTeamData + | GetMemberPermissions + | SetMemberPermissions + | GetTeamConversations + | DeleteTeam + -- FUTUREWORK: make the verbs in the roles more consistent + -- (CRUD vs. Add,Remove vs; Get,Set vs. Create,Delete etc). + -- If you ever think about adding a new permission flag, + -- read Note [team roles] first. + deriving (Eq, Ord, Show, Enum, Bounded, Generic) -- | Team-level role. Analog to conversation-level 'ConversationRole'. data Role = RoleOwner | RoleAdmin | RoleMember | RoleExternalPartner - deriving (Eq, Ord, Show, Enum, Bounded, Generic) + deriving (Eq, Ord, Show, Enum, Bounded, Generic) defaultRole :: Role defaultRole = RoleMember rolePermissions :: Role -> Permissions -rolePermissions role = Permissions p p where p = rolePerms role +rolePermissions role = Permissions p p where p = rolePerms role -- | Internal function for 'rolePermissions'. (It works iff the two sets in 'Permissions' are -- identical for every 'Role', otherwise it'll need to be specialized for the resp. sides.) rolePerms :: Role -> Set Perm -rolePerms RoleOwner = rolePerms RoleAdmin <> Set.fromList - [ GetBilling - , SetBilling - , DeleteTeam - ] -rolePerms RoleAdmin = rolePerms RoleMember <> Set.fromList - [ AddTeamMember - , RemoveTeamMember - , SetTeamData - , SetMemberPermissions - ] -rolePerms RoleMember = rolePerms RoleExternalPartner <> Set.fromList - [ DoNotUseDeprecatedDeleteConversation - , DoNotUseDeprecatedAddRemoveConvMember - , DoNotUseDeprecatedModifyConvName - , GetMemberPermissions - ] -rolePerms RoleExternalPartner = Set.fromList - [ CreateConversation - , GetTeamConversations +rolePerms RoleOwner = + rolePerms RoleAdmin + <> Set.fromList + [ GetBilling, + SetBilling, + DeleteTeam + ] +rolePerms RoleAdmin = + rolePerms RoleMember + <> Set.fromList + [ AddTeamMember, + RemoveTeamMember, + SetTeamData, + SetMemberPermissions + ] +rolePerms RoleMember = + rolePerms RoleExternalPartner + <> Set.fromList + [ DoNotUseDeprecatedDeleteConversation, + DoNotUseDeprecatedAddRemoveConvMember, + DoNotUseDeprecatedModifyConvName, + GetMemberPermissions + ] +rolePerms RoleExternalPartner = + Set.fromList + [ CreateConversation, + GetTeamConversations ] newtype BindingNewTeam = BindingNewTeam (NewTeam ()) - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic) -- | FUTUREWORK: this is dead code! remove! newtype NonBindingNewTeam = NonBindingNewTeam (NewTeam (Range 1 127 [TeamMember])) - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic) -newtype NewTeamMember = NewTeamMember - { _ntmNewTeamMember :: TeamMember - } +newtype NewTeamMember + = NewTeamMember + { _ntmNewTeamMember :: TeamMember + } -newtype TeamMemberDeleteData = TeamMemberDeleteData - { _tmdAuthPassword :: Maybe PlainTextPassword - } +newtype TeamMemberDeleteData + = TeamMemberDeleteData + { _tmdAuthPassword :: Maybe PlainTextPassword + } -newtype TeamDeleteData = TeamDeleteData - { _tdAuthPassword :: Maybe PlainTextPassword - } +newtype TeamDeleteData + = TeamDeleteData + { _tdAuthPassword :: Maybe PlainTextPassword + } -- This is the cassandra timestamp of writetime(binding) -newtype TeamCreationTime = TeamCreationTime - { _tcTime :: Int64 - } - -data FeatureFlags = FeatureFlags - { _flagSSO :: !FeatureSSO - , _flagLegalHold :: !FeatureLegalHold - } - deriving (Eq, Show, Generic) +newtype TeamCreationTime + = TeamCreationTime + { _tcTime :: Int64 + } + +data FeatureFlags + = FeatureFlags + { _flagSSO :: !FeatureSSO, + _flagLegalHold :: !FeatureLegalHold + } + deriving (Eq, Show, Generic) data FeatureSSO - = FeatureSSOEnabledByDefault - | FeatureSSODisabledByDefault - deriving (Eq, Ord, Show, Enum, Bounded, Generic) + = FeatureSSOEnabledByDefault + | FeatureSSODisabledByDefault + deriving (Eq, Ord, Show, Enum, Bounded, Generic) data FeatureLegalHold - = FeatureLegalHoldDisabledPermanently - | FeatureLegalHoldDisabledByDefault - deriving (Eq, Ord, Show, Enum, Bounded, Generic) + = FeatureLegalHoldDisabledPermanently + | FeatureLegalHoldDisabledByDefault + deriving (Eq, Ord, Show, Enum, Bounded, Generic) instance FromJSON FeatureFlags where - parseJSON = withObject "FeatureFlags" $ \obj -> FeatureFlags - <$> (obj .: "sso") - <*> (obj .: "legalhold") + parseJSON = withObject "FeatureFlags" $ \obj -> + FeatureFlags + <$> (obj .: "sso") + <*> (obj .: "legalhold") instance ToJSON FeatureFlags where - toJSON (FeatureFlags sso legalhold) = object $ - [ "sso" .= sso - , "legalhold" .= legalhold - ] + toJSON (FeatureFlags sso legalhold) = + object $ + [ "sso" .= sso, + "legalhold" .= legalhold + ] instance FromJSON FeatureSSO where - parseJSON (String "enabled-by-default") = pure FeatureSSOEnabledByDefault - parseJSON (String "disabled-by-default") = pure FeatureSSODisabledByDefault - parseJSON bad = fail $ "FeatureSSO: " <> cs (encode bad) + parseJSON (String "enabled-by-default") = pure FeatureSSOEnabledByDefault + parseJSON (String "disabled-by-default") = pure FeatureSSODisabledByDefault + parseJSON bad = fail $ "FeatureSSO: " <> cs (encode bad) instance ToJSON FeatureSSO where - toJSON FeatureSSOEnabledByDefault = String "enabled-by-default" - toJSON FeatureSSODisabledByDefault = String "disabled-by-default" + toJSON FeatureSSOEnabledByDefault = String "enabled-by-default" + toJSON FeatureSSODisabledByDefault = String "disabled-by-default" instance FromJSON FeatureLegalHold where - parseJSON (String "disabled-permanently") = pure $ FeatureLegalHoldDisabledPermanently - parseJSON (String "disabled-by-default") = pure $ FeatureLegalHoldDisabledByDefault - parseJSON bad = fail $ "FeatureLegalHold: " <> cs (encode bad) + parseJSON (String "disabled-permanently") = pure $ FeatureLegalHoldDisabledPermanently + parseJSON (String "disabled-by-default") = pure $ FeatureLegalHoldDisabledByDefault + parseJSON bad = fail $ "FeatureLegalHold: " <> cs (encode bad) instance ToJSON FeatureLegalHold where - toJSON FeatureLegalHoldDisabledPermanently = String "disabled-permanently" - toJSON FeatureLegalHoldDisabledByDefault = String "disabled-by-default" + toJSON FeatureLegalHoldDisabledPermanently = String "disabled-permanently" + toJSON FeatureLegalHoldDisabledByDefault = String "disabled-by-default" newTeam :: TeamId -> UserId -> Text -> Text -> TeamBinding -> Team newTeam tid uid nme ico bnd = Team tid uid nme ico Nothing bnd @@ -371,26 +382,28 @@ newTeam tid uid nme ico bnd = Team tid uid nme ico Nothing bnd newTeamList :: [Team] -> Bool -> TeamList newTeamList = TeamList -newTeamMember :: UserId - -> Permissions - -> Maybe (UserId, UTCTimeMillis) - -> TeamMember +newTeamMember :: + UserId -> + Permissions -> + Maybe (UserId, UTCTimeMillis) -> + TeamMember newTeamMember uid perm invitation = TeamMember uid perm invitation UserLegalHoldDisabled -- | For being called in "Galley.Data". Throws an exception if one of invitation timestamp -- and inviter is 'Nothing' and the other is 'Just', which can only be caused by inconsistent -- database content. -newTeamMemberRaw :: MonadThrow m - => UserId - -> Permissions - -> Maybe UserId - -> Maybe UTCTimeMillis - -> UserLegalHoldStatus - -> m TeamMember +newTeamMemberRaw :: + MonadThrow m => + UserId -> + Permissions -> + Maybe UserId -> + Maybe UTCTimeMillis -> + UserLegalHoldStatus -> + m TeamMember newTeamMemberRaw uid perms (Just invu) (Just invt) lhStatus = - pure $ TeamMember uid perms (Just (invu, invt)) lhStatus + pure $ TeamMember uid perms (Just (invu, invt)) lhStatus newTeamMemberRaw uid perms Nothing Nothing lhStatus = - pure $ TeamMember uid perms Nothing lhStatus + pure $ TeamMember uid perms Nothing lhStatus newTeamMemberRaw _ _ _ _ _ = throwM $ ErrorCall "TeamMember with incomplete metadata." newTeamMemberList :: [TeamMember] -> TeamMemberList @@ -421,21 +434,34 @@ newTeamDeleteData :: Maybe PlainTextPassword -> TeamDeleteData newTeamDeleteData = TeamDeleteData makeLenses ''Team + makeLenses ''TeamList + makeLenses ''TeamMember + makeLenses ''TeamMemberList + makeLenses ''TeamConversation + makeLenses ''TeamConversationList + makeLenses ''Permissions + makeLenses ''NewTeam + makeLenses ''NewTeamMember + makeLenses ''Event + makeLenses ''TeamUpdateData + makeLenses ''TeamMemberDeleteData + makeLenses ''TeamDeleteData + makeLenses ''TeamCreationTime -makeLenses ''FeatureFlags +makeLenses ''FeatureFlags -- Note [hidden team roles] -- @@ -449,18 +475,21 @@ makeLenses ''FeatureFlags -- | See Note [hidden team roles] data HiddenPerm - = ChangeLegalHoldTeamSettings - | ViewLegalHoldTeamSettings - | ChangeLegalHoldUserSettings - | ViewLegalHoldUserSettings - | ViewSSOTeamSettings -- (change is only allowed via customer support backoffice) - deriving (Eq, Ord, Show, Enum, Bounded) + = ChangeLegalHoldTeamSettings + | ViewLegalHoldTeamSettings + | ChangeLegalHoldUserSettings + | ViewLegalHoldUserSettings + | ViewSSOTeamSettings -- (change is only allowed via customer support backoffice) + | ViewSameTeamEmails + deriving (Eq, Ord, Show, Enum, Bounded) -- | See Note [hidden team roles] -data HiddenPermissions = HiddenPermissions - { _hself :: Set HiddenPerm - , _hcopy :: Set HiddenPerm - } deriving (Eq, Ord, Show) +data HiddenPermissions + = HiddenPermissions + { _hself :: Set HiddenPerm, + _hcopy :: Set HiddenPerm + } + deriving (Eq, Ord, Show) makeLenses ''HiddenPermissions @@ -468,52 +497,56 @@ makeLenses ''HiddenPermissions -- 'Permissions' matches no 'Role', return no hidden permission bits. hiddenPermissionsFromPermissions :: Permissions -> HiddenPermissions hiddenPermissionsFromPermissions = - maybe (HiddenPermissions mempty mempty) roleHiddenPermissions . permissionsRole + maybe (HiddenPermissions mempty mempty) roleHiddenPermissions . permissionsRole where permissionsRole :: Permissions -> Maybe Role permissionsRole (Permissions p p') | p /= p' = Nothing permissionsRole (Permissions p _) = permsRole p where permsRole :: Set Perm -> Maybe Role - permsRole perms = Maybe.listToMaybe - [ role | role <- [minBound..], rolePerms role == perms ] - + permsRole perms = + Maybe.listToMaybe + [role | role <- [minBound ..], rolePerms role == perms] roleHiddenPermissions :: Role -> HiddenPermissions roleHiddenPermissions role = HiddenPermissions p p where p = roleHiddenPerms role - roleHiddenPerms :: Role -> Set HiddenPerm roleHiddenPerms RoleOwner = roleHiddenPerms RoleAdmin - roleHiddenPerms RoleAdmin = (roleHiddenPerms RoleMember <>) $ - Set.fromList [ ChangeLegalHoldTeamSettings - , ChangeLegalHoldUserSettings - ] - roleHiddenPerms RoleMember = roleHiddenPerms RoleExternalPartner + roleHiddenPerms RoleAdmin = + (roleHiddenPerms RoleMember <>) $ + Set.fromList + [ ChangeLegalHoldTeamSettings, + ChangeLegalHoldUserSettings + ] + roleHiddenPerms RoleMember = + (roleHiddenPerms RoleExternalPartner <>) $ + Set.fromList [ViewSameTeamEmails] roleHiddenPerms RoleExternalPartner = - Set.fromList [ ViewLegalHoldTeamSettings - , ViewLegalHoldUserSettings - , ViewSSOTeamSettings - ] + Set.fromList + [ ViewLegalHoldTeamSettings, + ViewLegalHoldUserSettings, + ViewSSOTeamSettings + ] -- | See Note [hidden team roles] class IsPerm perm where - hasPermission :: TeamMember -> perm -> Bool - mayGrantPermission :: TeamMember -> perm -> Bool + hasPermission :: TeamMember -> perm -> Bool + mayGrantPermission :: TeamMember -> perm -> Bool instance IsPerm Perm where - hasPermission tm p = p `Set.member` (tm^.permissions.self) - mayGrantPermission tm p = p `Set.member` (tm^.permissions.copy) + hasPermission tm p = p `Set.member` (tm ^. permissions . self) + mayGrantPermission tm p = p `Set.member` (tm ^. permissions . copy) instance IsPerm HiddenPerm where - hasPermission tm p = - p `Set.member` (tm ^. permissions . to hiddenPermissionsFromPermissions . hself) - mayGrantPermission tm p = - p `Set.member` (tm ^. permissions . to hiddenPermissionsFromPermissions . hcopy) - + hasPermission tm p = + p `Set.member` (tm ^. permissions . to hiddenPermissionsFromPermissions . hself) + mayGrantPermission tm p = + p `Set.member` (tm ^. permissions . to hiddenPermissionsFromPermissions . hcopy) notTeamMember :: [UserId] -> [TeamMember] -> [UserId] -notTeamMember uids tmms = Set.toList $ +notTeamMember uids tmms = + Set.toList $ Set.fromList uids `Set.difference` Set.fromList (map (view userId) tmms) isTeamMember :: Foldable m => UserId -> m TeamMember -> Bool @@ -522,14 +555,16 @@ isTeamMember u = isJust . findTeamMember u findTeamMember :: Foldable m => UserId -> m TeamMember -> Maybe TeamMember findTeamMember u = find ((u ==) . view userId) -newPermissions - :: Set Perm -- ^ User's permissions - -> Set Perm -- ^ Permissions that the user will be able to - -- grant to other users (must be a subset) - -> Maybe Permissions +newPermissions :: + -- | User's permissions + Set Perm -> + -- | Permissions that the user will be able to + -- grant to other users (must be a subset) + Set Perm -> + Maybe Permissions newPermissions a b - | b `Set.isSubsetOf` a = Just (Permissions a b) - | otherwise = Nothing + | b `Set.isSubsetOf` a = Just (Permissions a b) + | otherwise = Nothing fullPermissions :: Permissions fullPermissions = let p = intToPerms maxBound in Permissions p p @@ -540,13 +575,14 @@ noPermissions = Permissions mempty mempty -- | Permissions that a user needs to be considered a "service whitelist -- admin" (can add and remove services from the whitelist). serviceWhitelistPermissions :: Set Perm -serviceWhitelistPermissions = Set.fromList - [ AddTeamMember, RemoveTeamMember - , DoNotUseDeprecatedAddRemoveConvMember - , SetTeamData +serviceWhitelistPermissions = + Set.fromList + [ AddTeamMember, + RemoveTeamMember, + DoNotUseDeprecatedAddRemoveConvMember, + SetTeamData ] - -- Note [team roles] -- ~~~~~~~~~~~~ -- @@ -585,22 +621,22 @@ serviceWhitelistPermissions = Set.fromList -- don't fit into one of those three team roles, we're screwed. isTeamOwner :: TeamMember -> Bool -isTeamOwner tm = fullPermissions == (tm^.permissions) +isTeamOwner tm = fullPermissions == (tm ^. permissions) permToInt :: Perm -> Word64 -permToInt CreateConversation = 0x0001 -permToInt DoNotUseDeprecatedDeleteConversation = 0x0002 -permToInt AddTeamMember = 0x0004 -permToInt RemoveTeamMember = 0x0008 +permToInt CreateConversation = 0x0001 +permToInt DoNotUseDeprecatedDeleteConversation = 0x0002 +permToInt AddTeamMember = 0x0004 +permToInt RemoveTeamMember = 0x0008 permToInt DoNotUseDeprecatedAddRemoveConvMember = 0x0010 -permToInt DoNotUseDeprecatedModifyConvName = 0x0020 -permToInt GetBilling = 0x0040 -permToInt SetBilling = 0x0080 -permToInt SetTeamData = 0x0100 -permToInt GetMemberPermissions = 0x0200 -permToInt GetTeamConversations = 0x0400 -permToInt DeleteTeam = 0x0800 -permToInt SetMemberPermissions = 0x1000 +permToInt DoNotUseDeprecatedModifyConvName = 0x0020 +permToInt GetBilling = 0x0040 +permToInt SetBilling = 0x0080 +permToInt SetTeamData = 0x0100 +permToInt GetMemberPermissions = 0x0200 +permToInt GetTeamConversations = 0x0400 +permToInt DeleteTeam = 0x0800 +permToInt SetMemberPermissions = 0x1000 intToPerm :: Word64 -> Maybe Perm intToPerm 0x0001 = Just CreateConversation @@ -616,303 +652,306 @@ intToPerm 0x0200 = Just GetMemberPermissions intToPerm 0x0400 = Just GetTeamConversations intToPerm 0x0800 = Just DeleteTeam intToPerm 0x1000 = Just SetMemberPermissions -intToPerm _ = Nothing +intToPerm _ = Nothing intToPerms :: Word64 -> Set Perm intToPerms n = - let perms = [ 2^i | i <- [0 .. 62], n `testBit` i ] in - Set.fromList (mapMaybe intToPerm perms) + let perms = [2 ^ i | i <- [0 .. 62], n `testBit` i] + in Set.fromList (mapMaybe intToPerm perms) permsToInt :: Set Perm -> Word64 permsToInt = Set.foldr' (\p n -> n .|. permToInt p) 0 instance ToJSON TeamList where - toJSON t = object - $ "teams" .= _teamListTeams t + toJSON t = + object $ + "teams" .= _teamListTeams t # "has_more" .= _teamListHasMore t # [] instance FromJSON TeamList where - parseJSON = withObject "teamlist" $ \o -> do - TeamList <$> o .: "teams" - <*> o .: "has_more" + parseJSON = withObject "teamlist" $ \o -> do + TeamList <$> o .: "teams" + <*> o .: "has_more" instance ToJSON TeamMember where - toJSON = teamMemberJson (const True) + toJSON = teamMemberJson (const True) -- | Show 'Permissions' conditionally. The condition takes the member that will receive the result -- into account. See 'canSeePermsOf'. teamMemberJson :: (TeamMember -> Bool) -> TeamMember -> Value -teamMemberJson withPerms m = object $ - [ "user" .= _userId m ] <> - [ "permissions" .= _permissions m | withPerms m ] <> - [ "created_by" .= (fst <$> _invitation m) ] <> - [ "created_at" .= (snd <$> _invitation m) ] <> - [ "legalhold_status" .= _legalHoldStatus m ] +teamMemberJson withPerms m = + object $ + ["user" .= _userId m] + <> ["permissions" .= _permissions m | withPerms m] + <> ["created_by" .= (fst <$> _invitation m)] + <> ["created_at" .= (snd <$> _invitation m)] + <> ["legalhold_status" .= _legalHoldStatus m] -- | Use this to construct the condition expected by 'teamMemberJson', 'teamMemberListJson' canSeePermsOf :: TeamMember -> TeamMember -> Bool canSeePermsOf seeer seeee = - seeer `hasPermission` GetMemberPermissions || seeer == seeee + seeer `hasPermission` GetMemberPermissions || seeer == seeee parseTeamMember :: Value -> Parser TeamMember parseTeamMember = withObject "team-member" $ \o -> - TeamMember <$> o .: "user" - <*> o .: "permissions" - <*> parseInvited o - -- Default to disabled if missing - <*> o .:? "legalhold_status" .!= UserLegalHoldDisabled + TeamMember <$> o .: "user" + <*> o .: "permissions" + <*> parseInvited o + -- Default to disabled if missing + <*> o .:? "legalhold_status" .!= UserLegalHoldDisabled where parseInvited :: Object -> Parser (Maybe (UserId, UTCTimeMillis)) parseInvited o = do - invby <- o .:? "created_by" - invat <- o .:? "created_at" - case (invby, invat) of - (Just b, Just a) -> pure $ Just (b, a) - (Nothing, Nothing) -> pure $ Nothing - _ -> fail "created_by, created_at" + invby <- o .:? "created_by" + invat <- o .:? "created_at" + case (invby, invat) of + (Just b, Just a) -> pure $ Just (b, a) + (Nothing, Nothing) -> pure $ Nothing + _ -> fail "created_by, created_at" instance ToJSON TeamMemberList where - toJSON = teamMemberListJson (const True) + toJSON = teamMemberListJson (const True) -- | Show a list of team members using 'teamMemberJson'. teamMemberListJson :: (TeamMember -> Bool) -> TeamMemberList -> Value teamMemberListJson withPerms l = - object [ "members" .= map (teamMemberJson withPerms) (_teamMembers l) ] + object ["members" .= map (teamMemberJson withPerms) (_teamMembers l)] instance FromJSON TeamMember where - parseJSON = parseTeamMember + parseJSON = parseTeamMember instance FromJSON TeamMemberList where - parseJSON = withObject "team member list" $ \o -> - TeamMemberList <$> o .: "members" + parseJSON = withObject "team member list" $ \o -> + TeamMemberList <$> o .: "members" instance ToJSON TeamConversation where - toJSON t = object - [ "conversation" .= _conversationId t - , "managed" .= _managedConversation t - ] + toJSON t = + object + [ "conversation" .= _conversationId t, + "managed" .= _managedConversation t + ] instance FromJSON TeamConversation where - parseJSON = withObject "team conversation" $ \o -> - TeamConversation <$> o .: "conversation" <*> o .: "managed" + parseJSON = withObject "team conversation" $ \o -> + TeamConversation <$> o .: "conversation" <*> o .: "managed" instance ToJSON TeamConversationList where - toJSON t = object ["conversations" .= _teamConversations t] + toJSON t = object ["conversations" .= _teamConversations t] instance FromJSON TeamConversationList where - parseJSON = withObject "team conversation list" $ \o -> do - TeamConversationList <$> o .: "conversations" + parseJSON = withObject "team conversation list" $ \o -> do + TeamConversationList <$> o .: "conversations" instance ToJSON Permissions where - toJSON p = object - $ "self" .= permsToInt (_self p) + toJSON p = + object $ + "self" .= permsToInt (_self p) # "copy" .= permsToInt (_copy p) # [] instance FromJSON Permissions where - parseJSON = withObject "permissions" $ \o -> do - s <- intToPerms <$> o .: "self" - d <- intToPerms <$> o .: "copy" - case newPermissions s d of - Nothing -> fail "invalid permissions" - Just ps -> pure ps + parseJSON = withObject "permissions" $ \o -> do + s <- intToPerms <$> o .: "self" + d <- intToPerms <$> o .: "copy" + case newPermissions s d of + Nothing -> fail "invalid permissions" + Just ps -> pure ps instance ToJSON Role where - toJSON RoleOwner = "owner" - toJSON RoleAdmin = "admin" - toJSON RoleMember = "member" - toJSON RoleExternalPartner = "partner" + toJSON RoleOwner = "owner" + toJSON RoleAdmin = "admin" + toJSON RoleMember = "member" + toJSON RoleExternalPartner = "partner" instance FromJSON Role where - parseJSON = withText "Role" $ \case - "owner" -> pure RoleOwner - "admin" -> pure RoleAdmin - "member" -> pure RoleMember - "partner" -> pure RoleExternalPartner - "collaborator" -> pure RoleExternalPartner - -- 'collaborator' was used for a short period of time on staging. if you are - -- wondering about this, it's probably safe to remove. - -- ~fisx, Wed Jan 23 16:38:52 CET 2019 - bad -> fail $ "not a role: " <> show bad + parseJSON = withText "Role" $ \case + "owner" -> pure RoleOwner + "admin" -> pure RoleAdmin + "member" -> pure RoleMember + "partner" -> pure RoleExternalPartner + "collaborator" -> pure RoleExternalPartner + -- 'collaborator' was used for a short period of time on staging. if you are + -- wondering about this, it's probably safe to remove. + -- ~fisx, Wed Jan 23 16:38:52 CET 2019 + bad -> fail $ "not a role: " <> show bad newTeamJson :: NewTeam a -> [Pair] newTeamJson (NewTeam n i ik _) = - "name" .= fromRange n - # "icon" .= fromRange i - # "icon_key" .= (fromRange <$> ik) - # [] + "name" .= fromRange n + # "icon" .= fromRange i + # "icon_key" .= (fromRange <$> ik) + # [] instance ToJSON BindingNewTeam where - toJSON (BindingNewTeam t) = object $ newTeamJson t + toJSON (BindingNewTeam t) = object $ newTeamJson t instance ToJSON NonBindingNewTeam where - toJSON (NonBindingNewTeam t) = - object - $ "members" .= (fromRange <$> _newTeamMembers t) + toJSON (NonBindingNewTeam t) = + object $ + "members" .= (fromRange <$> _newTeamMembers t) # newTeamJson t deriving instance FromJSON BindingNewTeam + deriving instance FromJSON NonBindingNewTeam instance ToJSON NewTeamMember where - toJSON t = object ["member" .= _ntmNewTeamMember t] + toJSON t = object ["member" .= _ntmNewTeamMember t] instance FromJSON NewTeamMember where - parseJSON = withObject "add team member" $ \o -> - NewTeamMember <$> o .: "member" + parseJSON = withObject "add team member" $ \o -> + NewTeamMember <$> o .: "member" instance ToJSON EventType where - toJSON TeamCreate = String "team.create" - toJSON TeamDelete = String "team.delete" - toJSON TeamUpdate = String "team.update" - toJSON MemberJoin = String "team.member-join" - toJSON MemberUpdate = String "team.member-update" - toJSON MemberLeave = String "team.member-leave" - toJSON ConvCreate = String "team.conversation-create" - toJSON ConvDelete = String "team.conversation-delete" + toJSON TeamCreate = String "team.create" + toJSON TeamDelete = String "team.delete" + toJSON TeamUpdate = String "team.update" + toJSON MemberJoin = String "team.member-join" + toJSON MemberUpdate = String "team.member-update" + toJSON MemberLeave = String "team.member-leave" + toJSON ConvCreate = String "team.conversation-create" + toJSON ConvDelete = String "team.conversation-delete" instance FromJSON EventType where - parseJSON (String "team.create") = pure TeamCreate - parseJSON (String "team.delete") = pure TeamDelete - parseJSON (String "team.update") = pure TeamUpdate - parseJSON (String "team.member-join") = pure MemberJoin - parseJSON (String "team.member-update") = pure MemberUpdate - parseJSON (String "team.member-leave") = pure MemberLeave - parseJSON (String "team.conversation-create") = pure ConvCreate - parseJSON (String "team.conversation-delete") = pure ConvDelete - parseJSON other = fail $ "Unknown event type: " <> show other + parseJSON (String "team.create") = pure TeamCreate + parseJSON (String "team.delete") = pure TeamDelete + parseJSON (String "team.update") = pure TeamUpdate + parseJSON (String "team.member-join") = pure MemberJoin + parseJSON (String "team.member-update") = pure MemberUpdate + parseJSON (String "team.member-leave") = pure MemberLeave + parseJSON (String "team.conversation-create") = pure ConvCreate + parseJSON (String "team.conversation-delete") = pure ConvDelete + parseJSON other = fail $ "Unknown event type: " <> show other instance ToJSON Event where - toJSON = Object . toJSONObject + toJSON = Object . toJSONObject instance ToJSONObject Event where - toJSONObject e = HashMap.fromList - [ "type" .= _eventType e - , "team" .= _eventTeam e - , "time" .= _eventTime e - , "data" .= _eventData e - ] + toJSONObject e = + HashMap.fromList + [ "type" .= _eventType e, + "team" .= _eventTeam e, + "time" .= _eventTime e, + "data" .= _eventData e + ] instance FromJSON Event where - parseJSON = withObject "event" $ \o -> do - ty <- o .: "type" - dt <- o .:? "data" - Event ty <$> o .: "team" - <*> o .: "time" - <*> parseEventData ty dt + parseJSON = withObject "event" $ \o -> do + ty <- o .: "type" + dt <- o .:? "data" + Event ty <$> o .: "team" + <*> o .: "time" + <*> parseEventData ty dt instance ToJSON EventData where - toJSON (EdTeamCreate tem) = toJSON tem - toJSON (EdMemberJoin usr) = object ["user" .= usr] - toJSON (EdMemberUpdate usr mPerm) = object $ "user" .= usr - # "permissions" .= mPerm - # [] - toJSON (EdMemberLeave usr) = object ["user" .= usr] - toJSON (EdConvCreate cnv) = object ["conv" .= cnv] - toJSON (EdConvDelete cnv) = object ["conv" .= cnv] - toJSON (EdTeamUpdate upd) = toJSON upd + toJSON (EdTeamCreate tem) = toJSON tem + toJSON (EdMemberJoin usr) = object ["user" .= usr] + toJSON (EdMemberUpdate usr mPerm) = + object $ + "user" .= usr + # "permissions" .= mPerm + # [] + toJSON (EdMemberLeave usr) = object ["user" .= usr] + toJSON (EdConvCreate cnv) = object ["conv" .= cnv] + toJSON (EdConvDelete cnv) = object ["conv" .= cnv] + toJSON (EdTeamUpdate upd) = toJSON upd parseEventData :: EventType -> Maybe Value -> Parser (Maybe EventData) -parseEventData MemberJoin Nothing = fail "missing event data for type 'team.member-join'" +parseEventData MemberJoin Nothing = fail "missing event data for type 'team.member-join'" parseEventData MemberJoin (Just j) = do - let f o = Just . EdMemberJoin <$> o .: "user" - withObject "member join data" f j - -parseEventData MemberUpdate Nothing = fail "missing event data for type 'team.member-update" + let f o = Just . EdMemberJoin <$> o .: "user" + withObject "member join data" f j +parseEventData MemberUpdate Nothing = fail "missing event data for type 'team.member-update" parseEventData MemberUpdate (Just j) = do - let f o = Just <$> (EdMemberUpdate <$> o .: "user" <*> o .:? "permissions") - withObject "member update data" f j - -parseEventData MemberLeave Nothing = fail "missing event data for type 'team.member-leave'" + let f o = Just <$> (EdMemberUpdate <$> o .: "user" <*> o .:? "permissions") + withObject "member update data" f j +parseEventData MemberLeave Nothing = fail "missing event data for type 'team.member-leave'" parseEventData MemberLeave (Just j) = do - let f o = Just . EdMemberLeave <$> o .: "user" - withObject "member leave data" f j - -parseEventData ConvCreate Nothing = fail "missing event data for type 'team.conversation-create" + let f o = Just . EdMemberLeave <$> o .: "user" + withObject "member leave data" f j +parseEventData ConvCreate Nothing = fail "missing event data for type 'team.conversation-create" parseEventData ConvCreate (Just j) = do - let f o = Just . EdConvCreate <$> o .: "conv" - withObject "conversation create data" f j - -parseEventData ConvDelete Nothing = fail "missing event data for type 'team.conversation-delete" + let f o = Just . EdConvCreate <$> o .: "conv" + withObject "conversation create data" f j +parseEventData ConvDelete Nothing = fail "missing event data for type 'team.conversation-delete" parseEventData ConvDelete (Just j) = do - let f o = Just . EdConvDelete <$> o .: "conv" - withObject "conversation delete data" f j - -parseEventData TeamCreate Nothing = fail "missing event data for type 'team.create'" + let f o = Just . EdConvDelete <$> o .: "conv" + withObject "conversation delete data" f j +parseEventData TeamCreate Nothing = fail "missing event data for type 'team.create'" parseEventData TeamCreate (Just j) = Just . EdTeamCreate <$> parseJSON j - -parseEventData TeamUpdate Nothing = fail "missing event data for type 'team.update'" +parseEventData TeamUpdate Nothing = fail "missing event data for type 'team.update'" parseEventData TeamUpdate (Just j) = Just . EdTeamUpdate <$> parseJSON j - -parseEventData _ Nothing = pure Nothing +parseEventData _ Nothing = pure Nothing parseEventData t (Just _) = fail $ "unexpected event data for type " <> show t instance ToJSON TeamUpdateData where - toJSON u = object - $ "name" .= _nameUpdate u - # "icon" .= _iconUpdate u + toJSON u = + object $ + "name" .= _nameUpdate u + # "icon" .= _iconUpdate u # "icon_key" .= _iconKeyUpdate u # [] instance FromJSON TeamUpdateData where - parseJSON = withObject "team update data" $ \o -> do - name <- o .:? "name" - icon <- o .:? "icon" - icon_key <- o .:? "icon_key" - when (isNothing name && isNothing icon && isNothing icon_key) $ - fail "TeamUpdateData: no update data specified" - either fail pure $ TeamUpdateData <$> maybe (pure Nothing) (fmap Just . checkedEitherMsg "name") name - <*> maybe (pure Nothing) (fmap Just . checkedEitherMsg "icon") icon - <*> maybe (pure Nothing) (fmap Just . checkedEitherMsg "icon_key") icon_key + parseJSON = withObject "team update data" $ \o -> do + name <- o .:? "name" + icon <- o .:? "icon" + icon_key <- o .:? "icon_key" + when (isNothing name && isNothing icon && isNothing icon_key) $ + fail "TeamUpdateData: no update data specified" + either fail pure $ + TeamUpdateData <$> maybe (pure Nothing) (fmap Just . checkedEitherMsg "name") name + <*> maybe (pure Nothing) (fmap Just . checkedEitherMsg "icon") icon + <*> maybe (pure Nothing) (fmap Just . checkedEitherMsg "icon_key") icon_key instance FromJSON TeamMemberDeleteData where - parseJSON = withObject "team-member-delete-data" $ \o -> - TeamMemberDeleteData <$> (o .:? "password") + parseJSON = withObject "team-member-delete-data" $ \o -> + TeamMemberDeleteData <$> (o .:? "password") instance ToJSON TeamMemberDeleteData where - toJSON tmd = object - [ "password" .= _tmdAuthPassword tmd - ] + toJSON tmd = + object + [ "password" .= _tmdAuthPassword tmd + ] instance FromJSON TeamDeleteData where - parseJSON = withObject "team-delete-data" $ \o -> - TeamDeleteData <$> o .: "password" + parseJSON = withObject "team-delete-data" $ \o -> + TeamDeleteData <$> o .: "password" instance ToJSON TeamDeleteData where - toJSON tdd = object - [ "password" .= _tdAuthPassword tdd - ] + toJSON tdd = + object + [ "password" .= _tdAuthPassword tdd + ] -#ifdef WITH_CQL instance Cql.Cql Role where - ctype = Cql.Tagged Cql.IntColumn + ctype = Cql.Tagged Cql.IntColumn - toCql RoleOwner = Cql.CqlInt 1 - toCql RoleAdmin = Cql.CqlInt 2 - toCql RoleMember = Cql.CqlInt 3 - toCql RoleExternalPartner = Cql.CqlInt 4 + toCql RoleOwner = Cql.CqlInt 1 + toCql RoleAdmin = Cql.CqlInt 2 + toCql RoleMember = Cql.CqlInt 3 + toCql RoleExternalPartner = Cql.CqlInt 4 - fromCql (Cql.CqlInt i) = case i of - 1 -> return RoleOwner - 2 -> return RoleAdmin - 3 -> return RoleMember - 4 -> return RoleExternalPartner - n -> fail $ "Unexpected Role value: " ++ show n - fromCql _ = fail "Role value: int expected" + fromCql (Cql.CqlInt i) = case i of + 1 -> return RoleOwner + 2 -> return RoleAdmin + 3 -> return RoleMember + 4 -> return RoleExternalPartner + n -> fail $ "Unexpected Role value: " ++ show n + fromCql _ = fail "Role value: int expected" instance Cql.Cql Permissions where - ctype = Cql.Tagged $ Cql.UdtColumn "permissions" [("self", Cql.BigIntColumn), ("copy", Cql.BigIntColumn)] - - toCql p = - let f = Cql.CqlBigInt . fromIntegral . permsToInt in - Cql.CqlUdt [("self", f (p^.self)), ("copy", f (p^.copy))] - - fromCql (Cql.CqlUdt p) = do - let f = intToPerms . fromIntegral :: Int64 -> Set.Set Perm - s <- Err.note "missing 'self' permissions" ("self" `lookup` p) >>= Cql.fromCql - d <- Err.note "missing 'copy' permissions" ("copy" `lookup` p) >>= Cql.fromCql - r <- Err.note "invalid permissions" (newPermissions (f s) (f d)) - pure r - fromCql _ = fail "permissions: udt expected" -#endif + ctype = Cql.Tagged $ Cql.UdtColumn "permissions" [("self", Cql.BigIntColumn), ("copy", Cql.BigIntColumn)] + + toCql p = + let f = Cql.CqlBigInt . fromIntegral . permsToInt + in Cql.CqlUdt [("self", f (p ^. self)), ("copy", f (p ^. copy))] + + fromCql (Cql.CqlUdt p) = do + let f = intToPerms . fromIntegral :: Int64 -> Set.Set Perm + s <- Err.note "missing 'self' permissions" ("self" `lookup` p) >>= Cql.fromCql + d <- Err.note "missing 'copy' permissions" ("copy" `lookup` p) >>= Cql.fromCql + r <- Err.note "invalid permissions" (newPermissions (f s) (f d)) + pure r + fromCql _ = fail "permissions: udt expected" diff --git a/libs/libzauth/.gitignore b/libs/libzauth/.gitignore deleted file mode 100644 index 9db9d280889..00000000000 --- a/libs/libzauth/.gitignore +++ /dev/null @@ -1 +0,0 @@ -libzauth-c/deb/usr diff --git a/libs/sodium-crypto-sign/package.yaml b/libs/sodium-crypto-sign/package.yaml index dfc16043d21..37067a26429 100644 --- a/libs/sodium-crypto-sign/package.yaml +++ b/libs/sodium-crypto-sign/package.yaml @@ -2,18 +2,13 @@ defaults: local: ../../package-defaults.yaml name: sodium-crypto-sign version: '0.1.2' -synopsis: FFI to some of libsodium's crypto_sign_* functions. -description: ! 'FFI bindings to some of libsodium''s cryptographic signature - - functions which are based on Ed25519.' +synopsis: FFI to some of the libsodium crypto_sign_* functions. +description: FFI bindings to some of the libsodium cryptographic signature functions which are based on Ed25519. category: Cryptography author: Wire Swiss GmbH maintainer: Wire Swiss GmbH copyright: (c) 2017 Wire Swiss GmbH license: AGPL-3 -ghc-prof-options: -- -prof -- -fprof-auto dependencies: - base >=4.6 && <5 - base64-bytestring >=1.0 diff --git a/libs/types-common-journal/src/.gitignore b/libs/types-common-journal/src/.gitignore deleted file mode 100644 index e69de29bb2d..00000000000 diff --git a/libs/types-common/package.yaml b/libs/types-common/package.yaml index ebeecd958d5..e216d1511dd 100644 --- a/libs/types-common/package.yaml +++ b/libs/types-common/package.yaml @@ -15,29 +15,35 @@ library: source-dirs: src ghc-prof-options: -fprof-auto-exported dependencies: - - attoparsec >=0.11 - aeson >=1.0 - - base ==4.* + - attoparsec >=0.11 - base16-bytestring >=0.1 + - base ==4.* - base64-bytestring >=1.0 - bytestring >=0.10 - bytestring-conversion >=0.2 + - cassandra-util - containers >=0.5 - cryptohash-md5 >=0.11.7.2 - cryptohash-sha1 >=0.11.7.2 - data-default >=0.5 - deepseq >=1.4 - directory >=1.2 + - email-validate >=2.3 - errors >=2.0 - ghc-prim - hashable >=1.2 - iproute >=1.5 - - optparse-applicative >=0.10 - lens >=4.10 - lens-datetime >=0.3 - - semigroups >=0.12 + - optparse-applicative >=0.10 + - protobuf >=0.2 + - QuickCheck >=2.9 + - quickcheck-instances >=0.3.16 - safe >=0.3 - scientific >=0.3.4 + - semigroups >=0.12 + - servant >=0.16 - singletons >=2.0 - string-conversions - swagger >=0.3 @@ -47,28 +53,15 @@ library: - time >=1.6 - time-locale-compat >=0.1 - transformers >=0.3 + - unix - unordered-containers >=0.2 - uri-bytestring >=0.2 - uuid >=1.3.11 - - unix - vector >=0.11 - yaml >=0.8.22 when: - condition: impl(ghc >=8) - ghc-options: -fno-warn-redundant-constraints - - condition: flag(cql) - cpp-options: -DWITH_CQL - dependencies: - - cassandra-util - - condition: flag(protobuf) - cpp-options: -DWITH_PROTOBUF - dependencies: - - protobuf >=0.2 - - condition: flag(arbitrary) - cpp-options: -DWITH_ARBITRARY - dependencies: - - QuickCheck >=2.9 - - quickcheck-instances >=0.3.16 + ghc-options: -fno-warn-redundant-constraints # TODO: move this to package-defaults? what is this about? tests: tests: main: Main.hs @@ -93,16 +86,3 @@ tests: - types-common - unordered-containers - uuid -flags: - arbitrary: - description: Enable quickcheck's arbitrary instances - manual: true - default: false - protobuf: - description: Enable protocol buffers instances - manual: true - default: false - cql: - description: Enable cql instances - manual: true - default: false diff --git a/libs/types-common/src/Data/Code.hs b/libs/types-common/src/Data/Code.hs index d7cd8fbf500..c6f2e84dc10 100644 --- a/libs/types-common/src/Data/Code.hs +++ b/libs/types-common/src/Data/Code.hs @@ -1,69 +1,69 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} -- | Types for verification codes. module Data.Code where -import Imports +import Cassandra hiding (Value) import Data.Aeson hiding (Value) import Data.Aeson.TH import Data.ByteString.Conversion +import Data.Json.Util import Data.Range import Data.Scientific (toBoundedInteger) -import Data.Json.Util import Data.Text.Ascii import Data.Time.Clock -#ifdef WITH_CQL -import Cassandra hiding (Value) -#endif +import Imports -- | A scoped identifier for a 'Value' with an associated 'Timeout'. -newtype Key = Key { asciiKey :: Range 20 20 AsciiBase64Url } - deriving (Eq, Show, FromJSON, ToJSON, FromByteString, ToByteString) +newtype Key = Key {asciiKey :: Range 20 20 AsciiBase64Url} + deriving (Eq, Show, FromJSON, ToJSON, FromByteString, ToByteString) -- | A secret value bound to a 'Key' and a 'Timeout'. -newtype Value = Value { asciiValue :: Range 6 20 AsciiBase64Url } - deriving (Eq, Show, FromJSON, ToJSON, FromByteString, ToByteString) +newtype Value = Value {asciiValue :: Range 6 20 AsciiBase64Url} + deriving (Eq, Show, FromJSON, ToJSON, FromByteString, ToByteString) -newtype Timeout = Timeout - { timeoutDiffTime :: NominalDiffTime } - deriving (Eq, Show, Ord, Enum, Num, Fractional, Real, RealFrac) +newtype Timeout + = Timeout + {timeoutDiffTime :: NominalDiffTime} + deriving (Eq, Show, Ord, Enum, Num, Fractional, Real, RealFrac) -- | A 'Timeout' is rendered as an integer representing the number of seconds remaining. instance ToByteString Timeout where - builder (Timeout t) = builder (round t :: Int32) + builder (Timeout t) = builder (round t :: Int32) -- | A 'Timeout' is rendered in JSON as an integer representing the -- number of seconds remaining. instance ToJSON Timeout where - toJSON (Timeout t) = toJSON (round t :: Int32) + toJSON (Timeout t) = toJSON (round t :: Int32) -- | A 'Timeout' is parsed from JSON as an integer representing the -- number of seconds remaining. instance FromJSON Timeout where - parseJSON = withScientific "Timeout" $ \n -> - let t = toBoundedInteger n :: Maybe Int32 in - maybe (fail "Invalid timeout value") - (pure . Timeout . fromIntegral) - t + parseJSON = withScientific "Timeout" $ \n -> + let t = toBoundedInteger n :: Maybe Int32 + in maybe + (fail "Invalid timeout value") + (pure . Timeout . fromIntegral) + t -#ifdef WITH_CQL deriving instance Cql Key + deriving instance Cql Value -#endif -- | A key/value pair. This would actually more accurately if the value would actually -- be a "value" but since we use "key" and "code" already in quite a few place in the API -- (but without a type, using plain fields). This will make it easier to re-use a key/value -- pair in the API, keeping "code" in the JSON for backwards compatibility -data KeyValuePair = KeyValuePair - { kcKey :: !Key - , kcCode :: !Value - } deriving (Eq, Generic, Show) +data KeyValuePair + = KeyValuePair + { kcKey :: !Key, + kcCode :: !Value + } + deriving (Eq, Generic, Show) deriveJSON toJSONFieldName ''KeyValuePair diff --git a/libs/types-common/src/Data/Domain.hs b/libs/types-common/src/Data/Domain.hs new file mode 100644 index 00000000000..213c90e0923 --- /dev/null +++ b/libs/types-common/src/Data/Domain.hs @@ -0,0 +1,54 @@ +module Data.Domain where + +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) +import qualified Data.Aeson as Aeson +import qualified Data.Attoparsec.ByteString as Atto +import Data.Bifunctor (bimap, first) +import Data.ByteString.Conversion +import qualified Data.Text.Encoding as Text.E +import Imports +import Test.QuickCheck (Arbitrary (arbitrary), elements) +import qualified Text.Email.Validate as Email + +-- | FUTUREWORK: move this type upstream into the email-validate package? +-- or become independent of email validation. +newtype Domain + = Domain {_domainText :: Text} + deriving (Eq, Generic, Show) + +domainText :: Domain -> Text +domainText = _domainText + +mkDomain :: Text -> Either String Domain +mkDomain = + bimap show Domain . Text.E.decodeUtf8' + <=< validateDomain . Text.E.encodeUtf8 + where + -- this is a slightly hacky way of validating a domain, + -- but Text.Email.Validate doesn't expose the parser for the domain. + validateDomain = fmap Email.domainPart . Email.validate . ("local-part@" <>) + +instance FromByteString Domain where + parser = do + bs <- Atto.takeByteString + case mkDomain =<< first show (Text.E.decodeUtf8' bs) of + Left err -> fail ("Failed parsing ByteString as Domain: " <> err) + Right domain -> pure domain + +instance ToJSON Domain where + toJSON = Aeson.String . domainText + +instance FromJSON Domain where + parseJSON = Aeson.withText "Domain" $ either fail pure . mkDomain + +instance Arbitrary Domain where + arbitrary = + either (error "arbitrary @Domain") id . mkDomain + <$> elements + [ "example.com", + "beispiel.com" + -- unicode domains are not supported, sadly: + -- "例.com", + -- "مثال.com", + -- "dæmi.com" + ] diff --git a/libs/types-common/src/Data/Handle.hs b/libs/types-common/src/Data/Handle.hs new file mode 100644 index 00000000000..7d499e7db60 --- /dev/null +++ b/libs/types-common/src/Data/Handle.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Handle where + +import Control.Applicative (optional) +import Data.Aeson hiding (()) +import Data.Attoparsec.Text +import Data.ByteString.Conversion +import Data.Hashable (Hashable) +import qualified Data.Text as Text +import Imports +import Test.QuickCheck (Arbitrary (arbitrary), choose, elements) + +-------------------------------------------------------------------------------- +-- Handle + +-- | Also called username. +newtype Handle + = Handle + {fromHandle :: Text} + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, ToByteString, Hashable) + +instance FromByteString Handle where + parser = parser >>= maybe (fail "Invalid handle") return . parseHandle + +instance FromJSON Handle where + parseJSON = + withText "Handle" $ + maybe (fail "Invalid handle") pure . parseHandle + +parseHandle :: Text -> Maybe Handle +parseHandle t + | isValidHandle t = Just (Handle t) + | otherwise = Nothing + +isValidHandle :: Text -> Bool +isValidHandle t = + either (const False) (const True) $ + parseOnly handle t + where + handle = + count 2 (satisfy chars) + *> count 254 (optional (satisfy chars)) + *> endOfInput + -- NOTE: Ensure that characters such as `@` and `+` should _NOT_ + -- be used so that "phone numbers", "emails", and "handles" remain + -- disjoint sets. + -- The rationale behind max size here relates to the max length of + -- an email address as defined here: + -- http://www.rfc-editor.org/errata_search.php?rfc=3696&eid=1690 + -- with the intent that in the enterprise world handle =~ email address + chars = inClass "a-z0-9_.-" + +instance Arbitrary Handle where + arbitrary = Handle . Text.pack <$> do + let many n = replicateM n (elements $ ['a' .. 'z'] <> ['0' .. '9'] <> ['_'] <> ['-'] <> ['.']) + ((<>) <$> many 2 <*> (many =<< choose (0, 254))) diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index ac0b61539f0..3eb66ec1261 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -1,59 +1,101 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for UUID instances +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- for UUID instances module Data.Id where -import Imports +import Cassandra hiding (S) import Data.Aeson import Data.Aeson.Encoding (text) import Data.Aeson.Types (Parser) import Data.Attoparsec.ByteString (takeByteString) import Data.ByteString.Builder (byteString) import Data.ByteString.Conversion -import Data.Default (Default(..)) +import qualified Data.ByteString.Lazy as L +import Data.Default (Default (..)) import Data.Hashable (Hashable) +import Data.ProtocolBuffers.Internal import Data.String.Conversions (cs) +import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder import Data.Text.Lazy.Builder.Int import Data.UUID +import qualified Data.UUID as UUID import Data.UUID.V4 -#ifdef WITH_CQL -import Cassandra hiding (S) -#endif -#ifdef WITH_ARBITRARY +import Imports import Test.QuickCheck import Test.QuickCheck.Instances () -#endif -#ifdef WITH_PROTOBUF -import qualified Data.ByteString.Lazy as L -import Data.ProtocolBuffers.Internal -#endif - -import qualified Data.Text as T -import qualified Data.UUID as UUID data A + data C + data I + data U + data P + data S + data T + data STo -type AssetId = Id A -type ConvId = Id C +data Mapped a + +data Opaque a + +type AssetId = Id A + type InvitationId = Id I -type UserId = Id U -type ProviderId = Id P -type ServiceId = Id S -type TeamId = Id T -type ScimTokenId = Id STo + +-- | A local conversation ID +type ConvId = Id C + +-- | A UUID local to this backend, for which we know a mapping to a +-- remote qualified conversation ID exists. +-- These IDs should never leak to other backends or their clients. +type MappedConvId = Id (Mapped C) + +-- | A UUID local to this backend, which can either be a local or a mapped conversation ID. +-- Which one it is can be found out by checking whether there exists a corresponding +-- local conversation or mapping in the database. +-- This is how clients refer to conversations, they don't need to know about the mapping. +type OpaqueConvId = Id (Opaque C) + +-- | A local user ID +type UserId = Id U + +-- | A UUID local to this backend, for which we know a mapping to a +-- remote qualified user ID exists. +-- These IDs should never leak to other backends or their clients. +type MappedUserId = Id (Mapped U) + +-- | A UUID local to this backend, which can either be a local or a mapped user ID. +-- Which one it is can be found out by checking whether there exists a corresponding +-- local user or mapping in the database. +-- This is how clients refer to users, they don't need to know about the mapping. +type OpaqueUserId = Id (Opaque U) + +makeIdOpaque :: Id a -> Id (Opaque a) +makeIdOpaque (Id userId) = Id userId + +makeMappedIdOpaque :: Id (Mapped a) -> Id (Opaque a) +makeMappedIdOpaque (Id userId) = Id userId + +type ProviderId = Id P + +type ServiceId = Id S + +type TeamId = Id T + +type ScimTokenId = Id STo -- Id ------------------------------------------------------------------------- @@ -61,42 +103,44 @@ data NoId = NoId deriving (Eq, Show, Generic) instance NFData NoId where rnf a = seq a () -newtype Id a = Id - { toUUID :: UUID - } deriving (Eq, Ord, NFData, Hashable, Generic) +newtype Id a + = Id + { toUUID :: UUID + } + deriving (Eq, Ord, NFData, Hashable, Generic) -- REFACTOR: non-derived, custom show instances break pretty-show and violate the law -- that @show . read == id@. can we derive Show here? instance Show (Id a) where - show = toString . toUUID + show = toString . toUUID instance Read (Id a) where - readsPrec n = map (\(a, x) -> (Id a, x)) . readsPrec n + readsPrec n = map (\(a, x) -> (Id a, x)) . readsPrec n instance FromByteString (Id a) where - parser = do - x <- takeByteString - case fromASCIIBytes x of - Nothing -> fail "Invalid UUID" - Just ui -> return (Id ui) + parser = do + x <- takeByteString + case fromASCIIBytes x of + Nothing -> fail "Invalid UUID" + Just ui -> return (Id ui) instance ToByteString (Id a) where - builder = byteString . toASCIIBytes . toUUID + builder = byteString . toASCIIBytes . toUUID randomId :: (Functor m, MonadIO m) => m (Id a) randomId = Id <$> liftIO nextRandom instance ToJSON (Id a) where - toJSON (Id uuid) = toJSON $ UUID.toText uuid + toJSON (Id uuid) = toJSON $ UUID.toText uuid instance FromJSON (Id a) where - parseJSON = withText "Id a" idFromText + parseJSON = withText "Id a" idFromText instance ToJSONKey (Id a) where - toJSONKey = ToJSONKeyText idToText (text . idToText) + toJSONKey = ToJSONKeyText idToText (text . idToText) instance FromJSONKey (Id a) where - fromJSONKey = FromJSONKeyTextParser idFromText + fromJSONKey = FromJSONKeyTextParser idFromText idFromText :: Text -> Parser (Id a) idFromText = maybe (fail "UUID.fromText failed") (pure . Id) . UUID.fromText @@ -104,33 +148,27 @@ idFromText = maybe (fail "UUID.fromText failed") (pure . Id) . UUID.fromText idToText :: Id a -> Text idToText = UUID.toText . toUUID -#ifdef WITH_CQL instance Cql (Id a) where - ctype = retag (ctype :: Tagged UUID ColumnType) - toCql = toCql . toUUID - fromCql c = Id <$> fromCql c -#endif + ctype = retag (ctype :: Tagged UUID ColumnType) + toCql = toCql . toUUID + fromCql c = Id <$> fromCql c -#ifdef WITH_PROTOBUF instance EncodeWire (Id a) where - encodeWire t = encodeWire t . toUUID + encodeWire t = encodeWire t . toUUID instance DecodeWire (Id a) where - decodeWire = fmap Id . decodeWire + decodeWire = fmap Id . decodeWire instance EncodeWire UUID where - encodeWire t = encodeWire t . L.toStrict . UUID.toByteString + encodeWire t = encodeWire t . L.toStrict . UUID.toByteString instance DecodeWire UUID where - decodeWire (DelimitedField _ bs) = - maybe (fail "Invalid UUID") pure . UUID.fromByteString . L.fromStrict $ bs - decodeWire _ = fail "Invalid UUID" -#endif + decodeWire (DelimitedField _ bs) = + maybe (fail "Invalid UUID") pure . UUID.fromByteString . L.fromStrict $ bs + decodeWire _ = fail "Invalid UUID" -#ifdef WITH_ARBITRARY instance Arbitrary (Id a) where - arbitrary = Id <$> arbitrary -#endif + arbitrary = Id <$> arbitrary -- ConnId ---------------------------------------------------------------------- @@ -139,140 +177,139 @@ instance Arbitrary (Id a) where -- encryption, but there are still situations in which 'ClientId' is not applicable (See also: -- 'Presence'). Used by Cannon and Gundeck to identify a websocket connection, but also in other -- places. -newtype ConnId = ConnId - { fromConnId :: ByteString - } deriving ( Eq - , Ord - , Read - , Show - , FromByteString - , ToByteString - , Hashable - , NFData - , Generic - ) +newtype ConnId + = ConnId + { fromConnId :: ByteString + } + deriving + ( Eq, + Ord, + Read, + Show, + FromByteString, + ToByteString, + Hashable, + NFData, + Generic + ) instance ToJSON ConnId where - toJSON (ConnId c) = String (decodeUtf8 c) + toJSON (ConnId c) = String (decodeUtf8 c) instance FromJSON ConnId where - parseJSON x = ConnId . encodeUtf8 <$> withText "ConnId" pure x + parseJSON x = ConnId . encodeUtf8 <$> withText "ConnId" pure x -- ClientId -------------------------------------------------------------------- -- | Handle for a device. Corresponds to the device fingerprints exposed in the UI. It is unique -- only together with a 'UserId', stored in C*, and used as a handle for end-to-end encryption. It -- lives as long as the device is registered. See also: 'ConnId'. -newtype ClientId = ClientId - { client :: Text - } deriving (Eq, Ord, Show, ToByteString, Hashable, NFData, ToJSON, ToJSONKey, Generic) +newtype ClientId + = ClientId + { client :: Text + } + deriving (Eq, Ord, Show, ToByteString, Hashable, NFData, ToJSON, ToJSONKey, Generic) newClientId :: Word64 -> ClientId newClientId = ClientId . toStrict . toLazyText . hexadecimal clientIdFromByteString :: Text -> Either String ClientId -clientIdFromByteString txt = if T.length txt <= 20 && T.all isHexDigit txt - then Right $ ClientId txt - else Left "Invalid ClientId" +clientIdFromByteString txt = + if T.length txt <= 20 && T.all isHexDigit txt + then Right $ ClientId txt + else Left "Invalid ClientId" instance FromByteString ClientId where - parser = do - bs <- takeByteString - either fail pure $ clientIdFromByteString (cs bs) + parser = do + bs <- takeByteString + either fail pure $ clientIdFromByteString (cs bs) instance FromJSON ClientId where - parseJSON = withText "ClientId" $ either fail pure . clientIdFromByteString + parseJSON = withText "ClientId" $ either fail pure . clientIdFromByteString instance FromJSONKey ClientId where - fromJSONKey = FromJSONKeyTextParser $ either fail pure . clientIdFromByteString + fromJSONKey = FromJSONKeyTextParser $ either fail pure . clientIdFromByteString -#ifdef WITH_CQL deriving instance Cql ClientId -#endif -#ifdef WITH_ARBITRARY instance Arbitrary ClientId where - arbitrary = newClientId <$> arbitrary -#endif + arbitrary = newClientId <$> arbitrary -#ifdef WITH_PROTOBUF instance EncodeWire ClientId where - encodeWire t = encodeWire t . client + encodeWire t = encodeWire t . client instance DecodeWire ClientId where - decodeWire (DelimitedField _ x) = either fail return (runParser parser x) - decodeWire _ = fail "Invalid ClientId" -#endif + decodeWire (DelimitedField _ x) = either fail return (runParser parser x) + decodeWire _ = fail "Invalid ClientId" -- BotId ----------------------------------------------------------------------- -newtype BotId = BotId - { botUserId :: UserId } - deriving ( Eq - , Ord - , FromByteString - , ToByteString - , Hashable - , NFData - , FromJSON - , ToJSON - , Generic - ) +newtype BotId + = BotId + {botUserId :: UserId} + deriving + ( Eq, + Ord, + FromByteString, + ToByteString, + Hashable, + NFData, + FromJSON, + ToJSON, + Generic + ) instance Show BotId where - show = show . botUserId + show = show . botUserId instance Read BotId where - readsPrec n = map (\(a, x) -> (BotId a, x)) . readsPrec n + readsPrec n = map (\(a, x) -> (BotId a, x)) . readsPrec n -#ifdef WITH_CQL deriving instance Cql BotId -#endif -#ifdef WITH_ARBITRARY instance Arbitrary BotId where - arbitrary = BotId <$> arbitrary -#endif + arbitrary = BotId <$> arbitrary -- RequestId ------------------------------------------------------------------- -newtype RequestId = RequestId - { unRequestId :: ByteString - } deriving ( Eq - , Show - , Read - , FromByteString - , ToByteString - , Hashable - , NFData - , Generic - ) +newtype RequestId + = RequestId + { unRequestId :: ByteString + } + deriving + ( Eq, + Show, + Read, + FromByteString, + ToByteString, + Hashable, + NFData, + Generic + ) -- | Returns "N/A" instance Default RequestId where - def = RequestId "N/A" + def = RequestId "N/A" instance ToJSON RequestId where - toJSON (RequestId r) = String (decodeUtf8 r) + toJSON (RequestId r) = String (decodeUtf8 r) instance FromJSON RequestId where - parseJSON = withText "RequestId" (pure . RequestId . encodeUtf8) + parseJSON = withText "RequestId" (pure . RequestId . encodeUtf8) -#ifdef WITH_PROTOBUF instance EncodeWire RequestId where - encodeWire t = encodeWire t . unRequestId + encodeWire t = encodeWire t . unRequestId instance DecodeWire RequestId where - decodeWire = fmap RequestId . decodeWire -#endif + decodeWire = fmap RequestId . decodeWire -- Rendering Id values in JSON objects ----------------------------------------- -newtype IdObject a = IdObject { fromIdObject :: a } +newtype IdObject a = IdObject {fromIdObject :: a} deriving (Eq, Show, Generic) instance FromJSON a => FromJSON (IdObject a) where - parseJSON = withObject "Id" $ \o -> IdObject <$> (o .: "id") + parseJSON = withObject "Id" $ \o -> IdObject <$> (o .: "id") instance ToJSON a => ToJSON (IdObject a) where - toJSON (IdObject a) = object [ "id" .= a ] + toJSON (IdObject a) = object ["id" .= a] diff --git a/libs/types-common/src/Data/IdMapping.hs b/libs/types-common/src/Data/IdMapping.hs new file mode 100644 index 00000000000..7afb56bae29 --- /dev/null +++ b/libs/types-common/src/Data/IdMapping.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE StrictData #-} + +module Data.IdMapping where + +import Data.Id +import Data.Qualified +import Imports +import Test.QuickCheck (Arbitrary (arbitrary), oneof) + +data MappedOrLocalId a + = Mapped (IdMapping a) + | Local (Id a) + deriving (Show) + +opaqueIdFromMappedOrLocal :: MappedOrLocalId a -> Id (Opaque a) +opaqueIdFromMappedOrLocal = \case + Local localId -> makeIdOpaque localId + Mapped IdMapping {idMappingLocal} -> makeMappedIdOpaque idMappingLocal + +data IdMapping a + = IdMapping + { idMappingLocal :: Id (Mapped a), + idMappingGlobal :: Qualified (Id a) + } + deriving (Show) + +---------------------------------------------------------------------- +-- ARBITRARY + +instance Arbitrary a => Arbitrary (MappedOrLocalId a) where + arbitrary = oneof [Mapped <$> arbitrary, Local <$> arbitrary] + +instance Arbitrary a => Arbitrary (IdMapping a) where + arbitrary = IdMapping <$> arbitrary <*> arbitrary diff --git a/libs/types-common/src/Data/Json/Util.hs b/libs/types-common/src/Data/Json/Util.hs index 1318a704c4c..3c8f1211ac2 100644 --- a/libs/types-common/src/Data/Json/Util.hs +++ b/libs/types-common/src/Data/Json/Util.hs @@ -1,41 +1,43 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NumDecimals #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NumDecimals #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeSynonymInstances #-} module Data.Json.Util - ( append - , toJSONFieldName - , (#) - , UTCTimeMillis, toUTCTimeMillis, fromUTCTimeMillis, showUTCTimeMillis, readUTCTimeMillis - , ToJSONObject (..) - , Base64ByteString (..) - ) where + ( append, + toJSONFieldName, + (#), + UTCTimeMillis, + toUTCTimeMillis, + fromUTCTimeMillis, + showUTCTimeMillis, + readUTCTimeMillis, + ToJSONObject (..), + Base64ByteString (..), + ) +where -import Imports -import Control.Lens ((%~), coerced) -#ifdef WITH_CQL import qualified Cassandra as CQL -#endif +import Control.Lens ((%~), coerced) import Data.Aeson import Data.Aeson.Types +import qualified Data.ByteString.Base64.Lazy as EL import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 -import qualified Data.ByteString.Base64.Lazy as EL import Data.Fixed +import Data.Text (pack) +import qualified Data.Text.Encoding +import qualified Data.Text.Encoding.Error import Data.Time.Clock import Data.Time.Format (formatTime, parseTimeM) import qualified Data.Time.Lens as TL import Data.Time.Locale.Compat (defaultTimeLocale) -import Data.Text (pack) -import qualified Data.Text.Encoding -import qualified Data.Text.Encoding.Error +import Imports append :: Pair -> [Pair] -> [Pair] append (_, Null) pp = pp -append p pp = p:pp +append p pp = p : pp {-# INLINE append #-} infixr 5 # @@ -53,7 +55,7 @@ infixr 5 # -- millisecond precision instead of the default picosecond precision. -- Construct values using 'toUTCTimeMillis'; deconstruct with 'fromUTCTimeMillis'. -- Unlike with 'UTCTime', 'Show' renders ISO string. -newtype UTCTimeMillis = UTCTimeMillis { fromUTCTimeMillis :: UTCTime } +newtype UTCTimeMillis = UTCTimeMillis {fromUTCTimeMillis :: UTCTime} deriving (Eq, Ord, Generic) {-# INLINE toUTCTimeMillis #-} @@ -71,29 +73,27 @@ formatUTCTimeMillis :: String formatUTCTimeMillis = "%FT%T%QZ" instance Show UTCTimeMillis where - showsPrec d = showParen (d > 10) . showString . showUTCTimeMillis + showsPrec d = showParen (d > 10) . showString . showUTCTimeMillis instance ToJSON UTCTimeMillis where - toJSON = String . pack . showUTCTimeMillis + toJSON = String . pack . showUTCTimeMillis instance FromJSON UTCTimeMillis where - parseJSON = fmap UTCTimeMillis . parseJSON + parseJSON = fmap UTCTimeMillis . parseJSON -#ifdef WITH_CQL instance CQL.Cql UTCTimeMillis where - ctype = CQL.Tagged CQL.TimestampColumn - toCql = CQL.toCql . fromUTCTimeMillis - fromCql = fmap toUTCTimeMillis . CQL.fromCql -#endif + ctype = CQL.Tagged CQL.TimestampColumn + toCql = CQL.toCql . fromUTCTimeMillis + fromCql = fmap toUTCTimeMillis . CQL.fromCql ----------------------------------------------------------------------------- -- ToJSONObject class ToJSONObject a where - toJSONObject :: a -> Object + toJSONObject :: a -> Object instance ToJSONObject Object where - toJSONObject = id + toJSONObject = id ----------------------------------------------------------------------------- -- toJSONFieldName @@ -109,7 +109,7 @@ instance ToJSONObject Object where -- would generate {To/From}JSON instances where -- the field name is "team_name" toJSONFieldName :: Options -toJSONFieldName = defaultOptions{ fieldLabelModifier = camelTo2 '_' . dropPrefix } +toJSONFieldName = defaultOptions {fieldLabelModifier = camelTo2 '_' . dropPrefix} where dropPrefix :: String -> String dropPrefix = dropWhile (not . isUpper) @@ -119,23 +119,26 @@ toJSONFieldName = defaultOptions{ fieldLabelModifier = camelTo2 '_' . dropPrefix -- | Lazy 'ByteString' with base64 json encoding. Relevant discussion: -- . See test suite for more details. -newtype Base64ByteString = Base64ByteString { fromBase64ByteString :: L.ByteString } +newtype Base64ByteString = Base64ByteString {fromBase64ByteString :: L.ByteString} deriving (Eq, Show, Generic) instance FromJSON Base64ByteString where parseJSON (String st) = handleError . EL.decode . stToLbs $ st where stToLbs = L.fromChunks . pure . Data.Text.Encoding.encodeUtf8 - handleError = either (fail "parse Base64ByteString: invalid base64 encoding") - (pure . Base64ByteString) + handleError = + either + (fail "parse Base64ByteString: invalid base64 encoding") + (pure . Base64ByteString) parseJSON _ = fail "parse Base64ByteString: not a string" instance ToJSON Base64ByteString where toJSON (Base64ByteString lbs) = String . lbsToSt . EL.encode $ lbs where - lbsToSt = Data.Text.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode - . mconcat - . L.toChunks + lbsToSt = + Data.Text.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode + . mconcat + . L.toChunks instance IsString Base64ByteString where fromString = Base64ByteString . L8.pack diff --git a/libs/types-common/src/Data/LegalHold.hs b/libs/types-common/src/Data/LegalHold.hs index dfb56a03fbd..17fe9bb8fb7 100644 --- a/libs/types-common/src/Data/LegalHold.hs +++ b/libs/types-common/src/Data/LegalHold.hs @@ -1,54 +1,42 @@ -{-# LANGUAGE CPP #-} module Data.LegalHold where -import Imports +import Cassandra.CQL import Data.Aeson - import qualified Data.Text as T - -#ifdef WITH_CQL -import Cassandra.CQL -#endif - -#ifdef WITH_ARBITRARY +import Imports import Test.QuickCheck -#endif data UserLegalHoldStatus - = UserLegalHoldDisabled - | UserLegalHoldPending - | UserLegalHoldEnabled - deriving stock (Show, Eq, Ord, Bounded, Enum, Generic) + = UserLegalHoldDisabled + | UserLegalHoldPending + | UserLegalHoldEnabled + deriving stock (Show, Eq, Ord, Bounded, Enum, Generic) instance ToJSON UserLegalHoldStatus where - toJSON UserLegalHoldDisabled = "disabled" - toJSON UserLegalHoldPending = "pending" - toJSON UserLegalHoldEnabled = "enabled" + toJSON UserLegalHoldDisabled = "disabled" + toJSON UserLegalHoldPending = "pending" + toJSON UserLegalHoldEnabled = "enabled" instance FromJSON UserLegalHoldStatus where - parseJSON = withText "UserLegalHoldStatus" $ \case - "disabled" -> pure UserLegalHoldDisabled - "pending" -> pure UserLegalHoldPending - "enabled" -> pure UserLegalHoldEnabled - x -> fail $ "unexpected status type: " <> T.unpack x + parseJSON = withText "UserLegalHoldStatus" $ \case + "disabled" -> pure UserLegalHoldDisabled + "pending" -> pure UserLegalHoldPending + "enabled" -> pure UserLegalHoldEnabled + x -> fail $ "unexpected status type: " <> T.unpack x -#ifdef WITH_CQL instance Cql UserLegalHoldStatus where - ctype = Tagged IntColumn + ctype = Tagged IntColumn - fromCql (CqlInt n) = case n of - 0 -> pure $ UserLegalHoldDisabled - 1 -> pure $ UserLegalHoldPending - 2 -> pure $ UserLegalHoldEnabled - _ -> fail "fromCql: Invalid UserLegalHoldStatus" - fromCql _ = fail "fromCql: UserLegalHoldStatus: CqlInt expected" + fromCql (CqlInt n) = case n of + 0 -> pure $ UserLegalHoldDisabled + 1 -> pure $ UserLegalHoldPending + 2 -> pure $ UserLegalHoldEnabled + _ -> fail "fromCql: Invalid UserLegalHoldStatus" + fromCql _ = fail "fromCql: UserLegalHoldStatus: CqlInt expected" - toCql UserLegalHoldDisabled = CqlInt 0 - toCql UserLegalHoldPending = CqlInt 1 - toCql UserLegalHoldEnabled = CqlInt 2 -#endif + toCql UserLegalHoldDisabled = CqlInt 0 + toCql UserLegalHoldPending = CqlInt 1 + toCql UserLegalHoldEnabled = CqlInt 2 -#ifdef WITH_ARBITRARY instance Arbitrary UserLegalHoldStatus where - arbitrary = elements [minBound..] -#endif + arbitrary = elements [minBound ..] diff --git a/libs/types-common/src/Data/List1.hs b/libs/types-common/src/Data/List1.hs index d80068362a4..180fb4bacde 100644 --- a/libs/types-common/src/Data/List1.hs +++ b/libs/types-common/src/Data/List1.hs @@ -1,32 +1,32 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.List1 where -import Imports -import Data.List.NonEmpty (NonEmpty) -import Data.Aeson -#ifdef WITH_CQL import Cassandra -#endif - +import Data.Aeson +import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as N -import qualified Data.Vector as V +import qualified Data.Vector as V +import Imports -newtype List1 a = List1 - { toNonEmpty :: NonEmpty a - } deriving ( Monad - , Functor - , Applicative - , Foldable - , Traversable - , Eq - , Ord - , Read - , Show - , Semigroup ) +newtype List1 a + = List1 + { toNonEmpty :: NonEmpty a + } + deriving + ( Monad, + Functor, + Applicative, + Foldable, + Traversable, + Eq, + Ord, + Read, + Show, + Semigroup + ) infixr 5 <| @@ -51,22 +51,20 @@ head = N.head . toNonEmpty {-# INLINE head #-} instance ToJSON a => ToJSON (List1 a) where - toJSON = toJSON . toList - toEncoding = toEncoding . toList + toJSON = toJSON . toList + toEncoding = toEncoding . toList instance FromJSON a => FromJSON (List1 a) where - parseJSON a@(Array v) - | V.length v >= 1 = List1 . N.fromList <$> parseJSON a - | otherwise = fail "At least 1 element in list required." - parseJSON _ = mzero + parseJSON a@(Array v) + | V.length v >= 1 = List1 . N.fromList <$> parseJSON a + | otherwise = fail "At least 1 element in list required." + parseJSON _ = mzero -#ifdef WITH_CQL instance (Cql a) => Cql (List1 a) where - ctype = Tagged (ListColumn (untag (ctype :: Tagged a ColumnType))) + ctype = Tagged (ListColumn (untag (ctype :: Tagged a ColumnType))) - toCql = CqlList . map toCql . toList + toCql = CqlList . map toCql . toList - fromCql (CqlList []) = fail "At least 1 element in list required." - fromCql (CqlList l) = List1 . N.fromList <$> mapM fromCql l - fromCql _ = Left "Expected CqlList." -#endif + fromCql (CqlList []) = fail "At least 1 element in list required." + fromCql (CqlList l) = List1 . N.fromList <$> mapM fromCql l + fromCql _ = Left "Expected CqlList." diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index b9fa4e1b9c7..7d414a378e3 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -1,167 +1,170 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module Data.Misc - ( -- * IpAddr / Port - IpAddr (..) - , Port (..) + ( -- * IpAddr / Port + IpAddr (..), + Port (..), + + -- * Location + Location, + location, + latitude, + longitude, + Latitude (..), + Longitude (..), + + -- * Time + Milliseconds (..), + + -- * HttpsUrl + HttpsUrl (..), + mkHttpsUrl, + + -- * Fingerprint + Fingerprint (..), + Rsa, + + -- * PlainTextPassword + PlainTextPassword (..), + + -- * Functor infix ops + (<$$>), + (<$$$>), + ) +where - -- * Location - , Location - , location - , latitude - , longitude - , Latitude (..) - , Longitude (..) - - -- * Time - , Milliseconds (..) - - -- * HttpsUrl - , HttpsUrl (..), mkHttpsUrl - - -- * Fingerprint - , Fingerprint (..) - , Rsa - - -- * PlainTextPassword - , PlainTextPassword (..) - - -- * Functor infix ops - , (<$$>), (<$$$>) - ) where - -import Imports +import Cassandra import Control.Lens ((^.), makeLenses) import Data.Aeson +import qualified Data.Aeson.Types as Json +import qualified Data.Attoparsec.ByteString.Char8 as Chars +import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Builder import Data.ByteString.Char8 (unpack) import Data.ByteString.Conversion -import Data.Int (Int64) +import Data.ByteString.Lazy (toStrict) import Data.IP (IP) +import Data.Int (Int64) import Data.Range +import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8) -#ifdef WITH_CQL -import Data.ByteString.Lazy (toStrict) -import Cassandra -#endif -#ifdef WITH_ARBITRARY -import Test.QuickCheck (Arbitrary(..)) -#endif +import Imports +import Test.QuickCheck (Arbitrary (..)) import Text.Read (Read (..)) import URI.ByteString hiding (Port) -import qualified Data.Aeson.Types as Json -import qualified Data.Attoparsec.ByteString.Char8 as Chars -import qualified Data.ByteString.Base64 as B64 -import qualified Data.Text as Text - -------------------------------------------------------------------------------- -- IpAddr / Port -newtype IpAddr = IpAddr { ipAddr :: IP } deriving (Eq, Ord, Show, Generic) +newtype IpAddr = IpAddr {ipAddr :: IP} deriving (Eq, Ord, Show, Generic) instance FromByteString IpAddr where - parser = do - s <- Chars.takeWhile1 (not . isSpace) - case readMaybe (unpack s) of - Nothing -> fail "Failed parsing bytestring as IpAddr." - Just ip -> return (IpAddr ip) + parser = do + s <- Chars.takeWhile1 (not . isSpace) + case readMaybe (unpack s) of + Nothing -> fail "Failed parsing bytestring as IpAddr." + Just ip -> return (IpAddr ip) instance ToByteString IpAddr where - builder = string8 . show . ipAddr + builder = string8 . show . ipAddr instance Read IpAddr where - readPrec = IpAddr <$> readPrec + readPrec = IpAddr <$> readPrec instance NFData IpAddr where rnf (IpAddr a) = seq a () -newtype Port = Port - { portNumber :: Word16 - } deriving (Eq, Ord, Show, Real, Enum, Num, Integral, NFData, Generic) +newtype Port + = Port + { portNumber :: Word16 + } + deriving (Eq, Ord, Show, Real, Enum, Num, Integral, NFData, Generic) instance Read Port where - readsPrec n = map (\x -> (Port (fst x), snd x)) . readsPrec n + readsPrec n = map (\x -> (Port (fst x), snd x)) . readsPrec n instance ToJSON IpAddr where - toJSON (IpAddr ip) = String (Text.pack $ show ip) + toJSON (IpAddr ip) = String (Text.pack $ show ip) instance FromJSON IpAddr where - parseJSON = withText "IpAddr" $ \txt -> - case readMaybe (Text.unpack txt) of - Nothing -> fail "Failed parsing IP address." - Just ip -> return (IpAddr ip) + parseJSON = withText "IpAddr" $ \txt -> + case readMaybe (Text.unpack txt) of + Nothing -> fail "Failed parsing IP address." + Just ip -> return (IpAddr ip) instance ToJSON Port where - toJSON (Port p) = toJSON p + toJSON (Port p) = toJSON p instance FromJSON Port where - parseJSON = fmap Port . parseJSON + parseJSON = fmap Port . parseJSON -------------------------------------------------------------------------------- -- Location -data Location = Location - { _latitude :: !Double - , _longitude :: !Double - } deriving (Eq, Ord, Generic) +data Location + = Location + { _latitude :: !Double, + _longitude :: !Double + } + deriving (Eq, Ord, Generic) instance Show Location where - show p = showString "{latitude=" - . shows (_latitude p) - . showString ", longitude=" - . shows (_longitude p) - $ "}" + show p = + showString "{latitude=" + . shows (_latitude p) + . showString ", longitude=" + . shows (_longitude p) + $ "}" instance NFData Location makeLenses ''Location -newtype Latitude = Latitude Double deriving (NFData, Generic) +newtype Latitude = Latitude Double deriving (NFData, Generic) + newtype Longitude = Longitude Double deriving (NFData, Generic) location :: Latitude -> Longitude -> Location location (Latitude lat) (Longitude lon) = - Location { _latitude = lat, _longitude = lon } + Location {_latitude = lat, _longitude = lon} instance ToJSON Location where - toJSON p = object [ "lat" .= (p^.latitude), "lon" .= (p^.longitude) ] + toJSON p = object ["lat" .= (p ^. latitude), "lon" .= (p ^. longitude)] instance FromJSON Location where - parseJSON = withObject "Location" $ \o -> - location <$> (Latitude <$> o .: "lat") - <*> (Longitude <$> o .: "lon") + parseJSON = withObject "Location" $ \o -> + location <$> (Latitude <$> o .: "lat") + <*> (Longitude <$> o .: "lon") -#ifdef WITH_CQL instance Cql Latitude where - ctype = Tagged DoubleColumn + ctype = Tagged DoubleColumn - toCql (Latitude x) = CqlDouble x + toCql (Latitude x) = CqlDouble x - fromCql (CqlDouble x) = return (Latitude x) - fromCql _ = fail "Latitude: Expected CqlDouble." + fromCql (CqlDouble x) = return (Latitude x) + fromCql _ = fail "Latitude: Expected CqlDouble." instance Cql Longitude where - ctype = Tagged DoubleColumn + ctype = Tagged DoubleColumn - toCql (Longitude x) = CqlDouble x + toCql (Longitude x) = CqlDouble x - fromCql (CqlDouble x) = return (Longitude x) - fromCql _ = fail "Longitude: Expected CqlDouble." -#endif + fromCql (CqlDouble x) = return (Longitude x) + fromCql _ = fail "Longitude: Expected CqlDouble." -------------------------------------------------------------------------------- -- Time -newtype Milliseconds = Ms - { ms :: Word64 - } deriving (Eq, Ord, Show, Num, Generic) +newtype Milliseconds + = Ms + { ms :: Word64 + } + deriving (Eq, Ord, Show, Num, Generic) -- | Convert milliseconds to 'Int64', with clipping if it doesn't fit. msToInt64 :: Milliseconds -> Int64 @@ -172,56 +175,56 @@ int64ToMs :: Int64 -> Milliseconds int64ToMs = Ms . fromIntegral . max 0 instance ToJSON Milliseconds where - toJSON = toJSON . msToInt64 + toJSON = toJSON . msToInt64 instance FromJSON Milliseconds where - parseJSON = fmap int64ToMs . parseJSON + parseJSON = fmap int64ToMs . parseJSON -#ifdef WITH_CQL instance Cql Milliseconds where - ctype = Tagged BigIntColumn - toCql = CqlBigInt . msToInt64 - fromCql = \case - CqlBigInt i -> pure $ int64ToMs i - _ -> fail "Milliseconds: expected CqlBigInt" -#endif + ctype = Tagged BigIntColumn + toCql = CqlBigInt . msToInt64 + fromCql = \case + CqlBigInt i -> pure $ int64ToMs i + _ -> fail "Milliseconds: expected CqlBigInt" -------------------------------------------------------------------------------- -- HttpsUrl -newtype HttpsUrl = HttpsUrl - { httpsUrl :: URIRef Absolute - } deriving (Eq, Generic) +newtype HttpsUrl + = HttpsUrl + { httpsUrl :: URIRef Absolute + } + deriving (Eq, Generic) mkHttpsUrl :: URIRef Absolute -> Either String HttpsUrl -mkHttpsUrl uri = if uri ^. uriSchemeL . schemeBSL == "https" - then Right $ HttpsUrl uri - else Left $ "Non-HTTPS URL: " ++ show uri +mkHttpsUrl uri = + if uri ^. uriSchemeL . schemeBSL == "https" + then Right $ HttpsUrl uri + else Left $ "Non-HTTPS URL: " ++ show uri instance Show HttpsUrl where - showsPrec i = showsPrec i . httpsUrl + showsPrec i = showsPrec i . httpsUrl instance ToByteString HttpsUrl where - builder = serializeURIRef . httpsUrl + builder = serializeURIRef . httpsUrl instance FromByteString HttpsUrl where - parser = either fail pure . mkHttpsUrl =<< uriParser strictURIParserOptions + parser = either fail pure . mkHttpsUrl =<< uriParser strictURIParserOptions instance FromJSON HttpsUrl where - parseJSON = withText "HttpsUrl" $ - either fail return . runParser parser . encodeUtf8 + parseJSON = + withText "HttpsUrl" $ + either fail return . runParser parser . encodeUtf8 instance ToJSON HttpsUrl where - toJSON = toJSON . decodeUtf8 . toByteString' + toJSON = toJSON . decodeUtf8 . toByteString' -#ifdef WITH_CQL instance Cql HttpsUrl where - ctype = Tagged BlobColumn - toCql = CqlBlob . toByteString + ctype = Tagged BlobColumn + toCql = CqlBlob . toByteString - fromCql (CqlBlob t) = runParser parser (toStrict t) - fromCql _ = fail "HttpsUrl: Expected CqlBlob" -#endif + fromCql (CqlBlob t) = runParser parser (toStrict t) + fromCql _ = fail "HttpsUrl: Expected CqlBlob" -------------------------------------------------------------------------------- -- Fingerprint @@ -229,45 +232,46 @@ instance Cql HttpsUrl where -- Tag for Rsa encoded fingerprints data Rsa -newtype Fingerprint a = Fingerprint - { fingerprintBytes :: ByteString - } deriving (Eq, Show, FromByteString, ToByteString, NFData, Generic) +newtype Fingerprint a + = Fingerprint + { fingerprintBytes :: ByteString + } + deriving (Eq, Show, FromByteString, ToByteString, NFData, Generic) instance FromJSON (Fingerprint Rsa) where - parseJSON = withText "Fingerprint" $ - either fail (pure . Fingerprint) . B64.decode . encodeUtf8 + parseJSON = + withText "Fingerprint" $ + either fail (pure . Fingerprint) . B64.decode . encodeUtf8 instance ToJSON (Fingerprint Rsa) where - toJSON = String . decodeUtf8 . B64.encode . fingerprintBytes + toJSON = String . decodeUtf8 . B64.encode . fingerprintBytes -#ifdef WITH_CQL instance Cql (Fingerprint a) where - ctype = Tagged BlobColumn - toCql = CqlBlob . toByteString + ctype = Tagged BlobColumn + toCql = CqlBlob . toByteString - fromCql (CqlBlob b) = return (Fingerprint (toStrict b)) - fromCql _ = fail "Fingerprint: Expected CqlBlob" -#endif + fromCql (CqlBlob b) = return (Fingerprint (toStrict b)) + fromCql _ = fail "Fingerprint: Expected CqlBlob" -------------------------------------------------------------------------------- -- Password -newtype PlainTextPassword = PlainTextPassword - { fromPlainTextPassword :: Text } - deriving (Eq, ToJSON, Generic) +newtype PlainTextPassword + = PlainTextPassword + {fromPlainTextPassword :: Text} + deriving (Eq, ToJSON, Generic) instance Show PlainTextPassword where - show _ = "PlainTextPassword " + show _ = "PlainTextPassword " instance FromJSON PlainTextPassword where - parseJSON x = PlainTextPassword . fromRange - <$> (parseJSON x :: Json.Parser (Range 6 1024 Text)) + parseJSON x = + PlainTextPassword . fromRange + <$> (parseJSON x :: Json.Parser (Range 6 1024 Text)) -#ifdef WITH_ARBITRARY instance Arbitrary PlainTextPassword where - -- TODO: why 6..1024? For tests we might want invalid passwords as well, e.g. 3 chars - arbitrary = PlainTextPassword . fromRange <$> genRangeText @6 @1024 arbitrary -#endif + -- TODO: why 6..1024? For tests we might want invalid passwords as well, e.g. 3 chars + arbitrary = PlainTextPassword . fromRange <$> genRangeText @6 @1024 arbitrary ---------------------------------------------------------------------- -- Functor diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs new file mode 100644 index 00000000000..484953f9903 --- /dev/null +++ b/libs/types-common/src/Data/Qualified.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE StrictData #-} + +module Data.Qualified where + +import Data.Aeson (FromJSON, ToJSON, withText) +import qualified Data.Aeson as Aeson +import Data.Bifunctor (first) +import qualified Data.ByteString.Conversion as BS.C +import Data.Domain (Domain, domainText, mkDomain) +import Data.Handle (Handle (..)) +import Data.Id (Id (toUUID)) +import Data.String.Conversions (cs) +import qualified Data.Text as Text +import qualified Data.UUID as UUID +import Imports hiding (local) +import Servant.API (FromHttpApiData (parseUrlPiece)) +import Test.QuickCheck (Arbitrary (arbitrary)) + +data Qualified a + = Qualified + { _qLocalPart :: a, + _qDomain :: Domain + } + deriving (Eq, Show, Generic) + +renderQualified :: (a -> Text) -> Qualified a -> Text +renderQualified renderLocal (Qualified localPart domain) = + renderLocal localPart <> "@" <> domainText domain + +-- | The string to parse must contain exactly one @"@"@ to separate local part from domain. +mkQualified :: (Text -> Either String a) -> Text -> Either String (Qualified a) +mkQualified mkLocal txt = + -- FUTUREWORK: this should be done in a less hacky way + case Text.split (== '@') txt of + [local, domain] -> do + _qDomain <- mkDomain domain + _qLocalPart <- mkLocal local + pure Qualified {_qLocalPart, _qDomain} + [_one] -> + Left "not a qualified identifier: no '@'" + _more -> + Left "not a qualified identifier: multiple '@'s" + +instance ToJSON (Qualified (Id a)) where + toJSON = Aeson.String . renderQualified (cs . UUID.toString . toUUID) + +instance FromJSON (Qualified (Id a)) where + parseJSON = + withText "QualifiedUserId" $ + either fail pure + . mkQualified (first cs . BS.C.runParser BS.C.parser . cs) + . cs + +instance FromHttpApiData (Qualified (Id a)) where + parseUrlPiece = first cs . mkQualified (BS.C.runParser BS.C.parser . cs) + +instance ToJSON (Qualified Handle) where + toJSON = Aeson.String . renderQualified fromHandle + +instance FromJSON (Qualified Handle) where + parseJSON = + withText "QualifiedHandle" $ + either fail pure + . mkQualified (BS.C.runParser BS.C.parser . cs) + . cs + +instance FromHttpApiData (Qualified Handle) where + parseUrlPiece = first cs . mkQualified (BS.C.runParser BS.C.parser . cs) + +---------------------------------------------------------------------- +-- ARBITRARY + +instance Arbitrary a => Arbitrary (Qualified a) where + arbitrary = Qualified <$> arbitrary <*> arbitrary diff --git a/libs/types-common/src/Data/Range.hs b/libs/types-common/src/Data/Range.hs index 03ec96a2b2a..f3f944e42c2 100644 --- a/libs/types-common/src/Data/Range.hs +++ b/libs/types-common/src/Data/Range.hs @@ -1,142 +1,139 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Data.Range - ( Range - , LTE - , Within - , Bounds (..) - , checked - , checkedEither - , checkedEitherMsg - , errorMsg - , unsafeRange - , fromRange - , rcast - , rnil - , rcons, (<|) - , rinc - , rappend - , rsingleton - -#ifdef WITH_ARBITRARY + ( Range, + LTE, + Within, + Bounds (..), + checked, + checkedEither, + checkedEitherMsg, + errorMsg, + unsafeRange, + fromRange, + rcast, + rnil, + rcons, + (<|), + rinc, + rappend, + rsingleton, + -- * 'Arbitrary' generators - , genRangeList - , genRangeText - , genRange -#endif - ) where + genRangeList, + genRangeText, + genRange, + ) +where -import Imports +import Cassandra hiding (Set) import Data.Aeson import Data.Aeson.Types as Aeson +import qualified Data.Attoparsec.ByteString as Atto +import qualified Data.ByteString as B import Data.ByteString.Conversion +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as N import Data.List1 (List1, toNonEmpty) +import qualified Data.Map as Map import Data.Sequence (Seq) -import Data.Singletons.Prelude.Num +import qualified Data.Sequence as Seq +import qualified Data.Set as Set import Data.Singletons +import Data.Singletons.Prelude.Num import Data.Singletons.Prelude.Ord import Data.Singletons.TypeLits +import qualified Data.Text as T import Data.Text.Ascii (AsciiText) -#ifdef WITH_CQL -import Cassandra hiding (Set) -#endif +import qualified Data.Text.Ascii as Ascii +import qualified Data.Text.Lazy as TL +import Imports import Numeric.Natural -#ifdef WITH_ARBITRARY import Test.QuickCheck (Gen, choose) -#endif - -import qualified Data.Attoparsec.ByteString as Atto -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet as HashSet -import qualified Data.List.NonEmpty as N -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.Text.Ascii as Ascii -import qualified Data.Text.Lazy as TL -import qualified Data.Set as Set -import qualified Data.Sequence as Seq ----------------------------------------------------------------------------- -newtype Range (n :: Nat) (m :: Nat) a = Range - { fromRange :: a - } deriving (Eq, Ord, Show) +newtype Range (n :: Nat) (m :: Nat) a + = Range + { fromRange :: a + } + deriving (Eq, Ord, Show) instance NFData (Range n m a) where rnf (Range a) = seq a () instance ToJSON a => ToJSON (Range n m a) where - toJSON = toJSON . fromRange + toJSON = toJSON . fromRange instance (Within a n m, FromJSON a) => FromJSON (Range n m a) where - parseJSON v = parseJSON v >>= maybe (msg sing sing) return . checked - where - msg :: Bounds a => SNat n -> SNat m -> Aeson.Parser (Range n m a) - msg sn sm = fail (errorMsg (fromSing sn) (fromSing sm) "") + parseJSON v = parseJSON v >>= maybe (msg sing sing) return . checked + where + msg :: Bounds a => SNat n -> SNat m -> Aeson.Parser (Range n m a) + msg sn sm = fail (errorMsg (fromSing sn) (fromSing sm) "") -#ifdef WITH_CQL instance (Within a n m, Cql a) => Cql (Range n m a) where - ctype = retag (ctype :: Tagged a ColumnType) - toCql = toCql . fromRange - fromCql c = fromCql c >>= maybe (msg sing sing) return . checked - where - msg :: Bounds a => SNat n -> SNat m -> Either String (Range n m a) - msg sn sm = Left (errorMsg (fromSing sn) (fromSing sm) "") -#endif - -type LTE (n :: Nat) (m :: Nat) = (SingI n, SingI m, (n <= m) ~ 'True) + ctype = retag (ctype :: Tagged a ColumnType) + toCql = toCql . fromRange + fromCql c = fromCql c >>= maybe (msg sing sing) return . checked + where + msg :: Bounds a => SNat n -> SNat m -> Either String (Range n m a) + msg sn sm = Left (errorMsg (fromSing sn) (fromSing sm) "") + +type LTE (n :: Nat) (m :: Nat) = (SingI n, SingI m, (n <= m) ~ 'True) + type Within a (n :: Nat) (m :: Nat) = (Bounds a, LTE n m) mk :: Bounds a => a -> SNat n -> SNat m -> Maybe (Range n m a) mk a sn sm = - let n = fromSing sn - m = fromSing sm - in if within a (toInteger n) (toInteger m) - then Just (Range a) - else Nothing + let n = fromSing sn + m = fromSing sm + in if within a (toInteger n) (toInteger m) + then Just (Range a) + else Nothing checked :: Within a n m => a -> Maybe (Range n m a) checked x = mk x sing sing errorMsg :: (Show a, Show b) => a -> b -> ShowS -errorMsg n m = showString "outside range [" - . shows n - . showString ", " - . shows m - . showString "]" - -checkedEitherMsg :: forall a n m. Within a n m => String -> a -> Either String (Range n m a) +errorMsg n m = + showString "outside range [" + . shows n + . showString ", " + . shows m + . showString "]" + +checkedEitherMsg :: forall a n m. Within a n m => String -> a -> Either String (Range n m a) checkedEitherMsg msg x = do - let sn = sing :: SNat n - sm = sing :: SNat m - case mk x sn sm of - Nothing -> Left $ showString msg . showString ": " . errorMsg (fromSing sn) (fromSing sm) $ "" - Just r -> Right r + let sn = sing :: SNat n + sm = sing :: SNat m + case mk x sn sm of + Nothing -> Left $ showString msg . showString ": " . errorMsg (fromSing sn) (fromSing sm) $ "" + Just r -> Right r -checkedEither :: forall a n m . Within a n m => a -> Either String (Range n m a) +checkedEither :: forall a n m. Within a n m => a -> Either String (Range n m a) checkedEither x = do - let sn = sing :: SNat n - sm = sing :: SNat m - case mk x sn sm of - Nothing -> Left (errorMsg (fromSing sn) (fromSing sm) "") - Just r -> Right r + let sn = sing :: SNat n + sm = sing :: SNat m + case mk x sn sm of + Nothing -> Left (errorMsg (fromSing sn) (fromSing sm) "") + Just r -> Right r unsafeRange :: (Show a, Within a n m) => a -> Range n m a unsafeRange x = fromMaybe (msg sing sing) (checked x) where msg :: SNat n -> SNat m -> Range n m a - msg sn sm = error - . shows x - . showString " " - . errorMsg (fromSing sn) (fromSing sm) - $ "" + msg sn sm = + error + . shows x + . showString " " + . errorMsg (fromSing sn) (fromSing sm) + $ "" rcast :: (LTE n m, (m <= m') ~ 'True, (n >= n') ~ 'True) => Range n m a -> Range n' m' a rcast (Range a) = Range a @@ -145,12 +142,13 @@ rnil :: Monoid a => Range 0 0 a rnil = Range mempty rcons, (<|) :: LTE n m => a -> Range n m [a] -> Range n (m + 1) [a] -rcons a (Range aa) = Range (a:aa) +rcons a (Range aa) = Range (a : aa) infixr 5 <| + (<|) = rcons -rinc :: (Integral a, LTE n m ) => Range n m a -> Range n (m + 1) a +rinc :: (Integral a, LTE n m) => Range n m a -> Range n (m + 1) a rinc (Range a) = Range (a + 1) rappend :: (LTE n m, LTE n' m', Monoid a) => Range n m a -> Range n' m' a -> Range n (m + m') a @@ -162,113 +160,130 @@ rsingleton = Range . pure ----------------------------------------------------------------------------- class Bounds a where - within :: a -> Integer -> Integer -> Bool + within :: a -> Integer -> Integer -> Bool rangeCheck :: (Integral a, Integral x, Integral y) => a -> x -> y -> Bool rangeCheck a x y = a >= fromIntegral x && a <= fromIntegral y {-# INLINE rangeCheck #-} instance Bounds Integer where within = rangeCheck -instance Bounds Int where within = rangeCheck -instance Bounds Int8 where within = rangeCheck -instance Bounds Int16 where within = rangeCheck -instance Bounds Int32 where within = rangeCheck -instance Bounds Int64 where within = rangeCheck + +instance Bounds Int where within = rangeCheck + +instance Bounds Int8 where within = rangeCheck + +instance Bounds Int16 where within = rangeCheck + +instance Bounds Int32 where within = rangeCheck + +instance Bounds Int64 where within = rangeCheck + instance Bounds Natural where within = rangeCheck -instance Bounds Word where within = rangeCheck -instance Bounds Word8 where within = rangeCheck -instance Bounds Word16 where within = rangeCheck -instance Bounds Word32 where within = rangeCheck -instance Bounds Word64 where within = rangeCheck + +instance Bounds Word where within = rangeCheck + +instance Bounds Word8 where within = rangeCheck + +instance Bounds Word16 where within = rangeCheck + +instance Bounds Word32 where within = rangeCheck + +instance Bounds Word64 where within = rangeCheck instance Bounds T.Text where - within x y z = rangeCheck (T.length (T.take (fromIntegral z + 1) x)) y z + within x y z = rangeCheck (T.length (T.take (fromIntegral z + 1) x)) y z instance Bounds TL.Text where - within x y z = rangeCheck (TL.length (TL.take (fromIntegral z + 1) x)) y z + within x y z = rangeCheck (TL.length (TL.take (fromIntegral z + 1) x)) y z instance Bounds B.ByteString where - within x = rangeCheck (B.length x) + within x = rangeCheck (B.length x) instance Bounds BL.ByteString where - within x y z = rangeCheck (BL.length (BL.take (fromIntegral z + 1) x)) y z + within x y z = rangeCheck (BL.length (BL.take (fromIntegral z + 1) x)) y z instance Bounds [a] where - within x y z = rangeCheck (length (take (fromIntegral z + 1) x)) y z + within x y z = rangeCheck (length (take (fromIntegral z + 1) x)) y z instance Bounds (NonEmpty a) where - within x y z = rangeCheck (length (N.take (fromIntegral z + 1) x)) y z + within x y z = rangeCheck (length (N.take (fromIntegral z + 1) x)) y z instance Bounds (List a) where - within x = within (fromList x) + within x = within (fromList x) instance Bounds (List1 a) where - within x = within (toNonEmpty x) + within x = within (toNonEmpty x) instance Bounds (Set a) where - within x y z = rangeCheck (Set.size x) y z + within x y z = rangeCheck (Set.size x) y z instance Bounds (Seq a) where - within x y z = rangeCheck (Seq.length x) y z + within x y z = rangeCheck (Seq.length x) y z instance Bounds (Map k a) where - within x y z = rangeCheck (Map.size x) y z + within x y z = rangeCheck (Map.size x) y z instance Bounds (HashMap k a) where - within x y z = rangeCheck (length (take (fromIntegral z + 1) (HashMap.toList x))) y z + within x y z = rangeCheck (length (take (fromIntegral z + 1) (HashMap.toList x))) y z instance Bounds (HashSet a) where - within x y z = rangeCheck (length (take (fromIntegral z + 1) (HashSet.toList x))) y z + within x y z = rangeCheck (length (take (fromIntegral z + 1) (HashSet.toList x))) y z instance Bounds a => Bounds (Maybe a) where - within Nothing _ _ = True - within (Just x) y z = within x y z + within Nothing _ _ = True + within (Just x) y z = within x y z instance Bounds (AsciiText r) where - within x y z = within (Ascii.toText x) y z + within x y z = within (Ascii.toText x) y z ----------------------------------------------------------------------------- instance (Within a n m, Read a) => Read (Range n m a) where - readsPrec p s = fromMaybe [] $ foldr f (Just []) (readsPrec p s) - where - f :: (Within a n m, Read a) => (a, String) -> Maybe [(Range n m a, String)] -> Maybe [(Range n m a, String)] - f _ Nothing = Nothing - f (a, t) (Just acc) = (\a' -> (a',t):acc) <$> checked a + readsPrec p s = fromMaybe [] $ foldr f (Just []) (readsPrec p s) + where + f :: (Within a n m, Read a) => (a, String) -> Maybe [(Range n m a, String)] -> Maybe [(Range n m a, String)] + f _ Nothing = Nothing + f (a, t) (Just acc) = (\a' -> (a', t) : acc) <$> checked a ----------------------------------------------------------------------------- instance (Within a n m, FromByteString a) => FromByteString (Range n m a) where - parser = parser >>= maybe (msg sing sing) return . checked - where - msg :: Bounds a => SNat n -> SNat m -> Atto.Parser (Range n m a) - msg sn sm = fail (errorMsg (fromSing sn) (fromSing sm) "") + parser = parser >>= maybe (msg sing sing) return . checked + where + msg :: Bounds a => SNat n -> SNat m -> Atto.Parser (Range n m a) + msg sn sm = fail (errorMsg (fromSing sn) (fromSing sm) "") instance ToByteString a => ToByteString (Range n m a) where - builder = builder . fromRange - -#ifdef WITH_ARBITRARY + builder = builder . fromRange ---------------------------------------------------------------------------- -- Arbitrary generators -genRangeList :: forall (n :: Nat) (m :: Nat) (a :: *). - (Show a, KnownNat n, KnownNat m, LTE n m) - => Gen a -> Gen (Range n m [a]) +genRangeList :: + forall (n :: Nat) (m :: Nat) (a :: *). + (Show a, KnownNat n, KnownNat m, LTE n m) => + Gen a -> + Gen (Range n m [a]) genRangeList = genRange id -genRangeText :: forall (n :: Nat) (m :: Nat). (KnownNat n, KnownNat m, LTE n m) - => Gen Char -> Gen (Range n m Text) +genRangeText :: + forall (n :: Nat) (m :: Nat). + (KnownNat n, KnownNat m, LTE n m) => + Gen Char -> + Gen (Range n m Text) genRangeText = genRange fromString -genRange :: forall (n :: Nat) (m :: Nat) (a :: *) (b :: *). - (Show b, Bounds b, KnownNat n, KnownNat m, LTE n m) - => ([a] -> b) -> Gen a -> Gen (Range n m b) -genRange pack_ gc = unsafeRange @b @n @m . pack_ - <$> grange (fromIntegral (natVal (Proxy @n))) - (fromIntegral (natVal (Proxy @m))) - gc +genRange :: + forall (n :: Nat) (m :: Nat) (a :: *) (b :: *). + (Show b, Bounds b, KnownNat n, KnownNat m, LTE n m) => + ([a] -> b) -> + Gen a -> + Gen (Range n m b) +genRange pack_ gc = + unsafeRange @b @n @m . pack_ + <$> grange + (fromIntegral (natVal (Proxy @n))) + (fromIntegral (natVal (Proxy @m))) + gc where grange mi ma gelem = (`replicateM` gelem) =<< choose (mi, ma) - -#endif diff --git a/libs/types-common/src/Data/Text/Ascii.hs b/libs/types-common/src/Data/Text/Ascii.hs index 156b436b3c3..76d6894e735 100644 --- a/libs/types-common/src/Data/Text/Ascii.hs +++ b/libs/types-common/src/Data/Text/Ascii.hs @@ -1,145 +1,148 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} -- | Text containing (extensible) subsets of the ASCII character set, -- captured in distinct types. module Data.Text.Ascii - ( AsciiText - , toText - , AsciiChars (Subset, validate, contains) - - -- * Standard Characters - , Standard (..) - , Ascii - , validateStandard - - -- * Printable Characters - , Printable (..) - , AsciiPrintable - , validatePrintable - - -- * Base64 Characters - , Base64 (..) - , AsciiBase64 - , validateBase64 - , encodeBase64 - , decodeBase64 - - -- * Url-Safe Base64 Characters - , Base64Url (..) - , AsciiBase64Url - , validateBase64Url - , encodeBase64Url - , decodeBase64Url - - -- * Base16 (Hex) Characters - , Base16 (..) - , AsciiBase16 - , validateBase16 - , encodeBase16 - , decodeBase16 - - -- * Safe Widening - , widen - - -- * Unsafe Construction - , unsafeFromText - , unsafeFromByteString - ) where + ( AsciiText, + toText, + AsciiChars (Subset, validate, contains), + + -- * Standard Characters + Standard (..), + Ascii, + validateStandard, + + -- * Printable Characters + Printable (..), + AsciiPrintable, + validatePrintable, + + -- * Base64 Characters + Base64 (..), + AsciiBase64, + validateBase64, + encodeBase64, + decodeBase64, + + -- * Url-Safe Base64 Characters + Base64Url (..), + AsciiBase64Url, + validateBase64Url, + encodeBase64Url, + decodeBase64Url, + + -- * Base16 (Hex) Characters + Base16 (..), + AsciiBase16, + validateBase16, + encodeBase16, + decodeBase16, + + -- * Safe Widening + widen, + + -- * Unsafe Construction + unsafeFromText, + unsafeFromByteString, + ) +where -import Imports +import Cassandra hiding (Ascii) import Data.Aeson import Data.Attoparsec.ByteString (Parser) +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64.URL as B64Url +import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion import Data.Hashable (Hashable) +import qualified Data.Text as Text import Data.Text.Encoding (decodeLatin1, decodeUtf8') -#ifdef WITH_CQL -import Cassandra hiding (Ascii) -#endif -#ifdef WITH_ARBITRARY +import Imports import Test.QuickCheck -#endif - -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Base64.URL as B64Url -import qualified Data.Text as Text -- | 'AsciiText' is text that is known to contain only the subset -- of ASCII characters indicated by its character set @c@. -newtype AsciiText c = AsciiText { toText :: Text } - deriving (Eq, Ord, Show, Semigroup, Monoid, NFData, ToByteString, - FromJSONKey, ToJSONKey, Generic, Hashable) +newtype AsciiText c = AsciiText {toText :: Text} + deriving + ( Eq, + Ord, + Show, + Semigroup, + Monoid, + NFData, + ToByteString, + FromJSONKey, + ToJSONKey, + Generic, + Hashable + ) -- | Class of types representing subsets of ASCII characters. class AsciiChars c where - -- | Type-level subset relations between ASCII character sets. - type Subset c c' :: Bool - - -- | Validate that all characters in a 'Text' are contained in - -- the character set. Instances should ensure that - -- - -- @validate ('toText' a) == Right ('widen' a :: 'Ascii')@ - -- - -- holds for any @a :: AsciiText c@. - validate :: Text -> Either String (AsciiText c) - - -- | Check whether a character is in the character set. - -- Instances should ensure that - -- - -- @contains c a ==> contains 'Standard' a@ - -- - -- holds for any @a :: Char@. - contains :: c -> Char -> Bool + -- | Type-level subset relations between ASCII character sets. + type Subset c c' :: Bool + + -- | Validate that all characters in a 'Text' are contained in + -- the character set. Instances should ensure that + -- + -- @validate ('toText' a) == Right ('widen' a :: 'Ascii')@ + -- + -- holds for any @a :: AsciiText c@. + validate :: Text -> Either String (AsciiText c) + + -- | Check whether a character is in the character set. + -- Instances should ensure that + -- + -- @contains c a ==> contains 'Standard' a@ + -- + -- holds for any @a :: Char@. + contains :: c -> Char -> Bool -- | Note: Assumes UTF8 encoding. If the bytestring is known to -- be in a different encoding, 'validate' the text after decoding it with -- the correct encoding instead of using this instance. instance AsciiChars c => FromByteString (AsciiText c) where - parser = parseBytes validate + parser = parseBytes validate -- | Note: 'fromString' is a partial function that will 'error' when given -- a string containing characters not in the set @c@. It is only intended to be used -- via the @OverloadedStrings@ extension, i.e. for known ASCII string literals. instance AsciiChars c => IsString (AsciiText c) where - fromString = unsafeString validate + fromString = unsafeString validate instance ToJSON (AsciiText r) where - toJSON = String . toText + toJSON = String . toText instance AsciiChars c => FromJSON (AsciiText c) where - parseJSON = withText "ASCII" $ either fail pure . validate + parseJSON = withText "ASCII" $ either fail pure . validate -#ifdef WITH_CQL instance AsciiChars c => Cql (AsciiText c) where - ctype = Tagged AsciiColumn - toCql = CqlAscii . toText - fromCql = fmap (unsafeFromText . fromAscii) . fromCql -#endif + ctype = Tagged AsciiColumn + toCql = CqlAscii . toText + fromCql = fmap (unsafeFromText . fromAscii) . fromCql -#ifdef WITH_ARBITRARY instance Arbitrary Ascii where - arbitrary = fromString <$> arbitrary `suchThat` all isAscii -#endif + arbitrary = fromString <$> arbitrary `suchThat` all isAscii -------------------------------------------------------------------------------- -- Standard -- | The standard ASCII character set. data Standard = Standard + type Ascii = AsciiText Standard instance AsciiChars Standard where - type Subset Standard Standard = 'True - validate = check "Invalid ASCII characters" (contains Standard) - contains Standard = isAscii - {-# INLINE contains #-} + type Subset Standard Standard = 'True + validate = check "Invalid ASCII characters" (contains Standard) + contains Standard = isAscii + {-# INLINE contains #-} validateStandard :: Text -> Either String Ascii validateStandard = validate @@ -149,14 +152,15 @@ validateStandard = validate -- | The character set of all printable ASCII characters. data Printable = Printable + type AsciiPrintable = AsciiText Printable instance AsciiChars Printable where - type Subset Printable Printable = 'True - type Subset Printable Standard = 'True - validate = check "Invalid printable ASCII characters" (contains Printable) - contains Printable c = isAscii c && isPrint c - {-# INLINE contains #-} + type Subset Printable Printable = 'True + type Subset Printable Standard = 'True + validate = check "Invalid printable ASCII characters" (contains Printable) + contains Printable c = isAscii c && isPrint c + {-# INLINE contains #-} validatePrintable :: Text -> Either String AsciiPrintable validatePrintable = validate @@ -171,20 +175,22 @@ validatePrintable = validate -- have intermittent padding characters or might not be a multiple of -- 4 bytes in length. data Base64 = Base64 + type AsciiBase64 = AsciiText Base64 instance AsciiChars Base64 where - type Subset Base64 Standard = 'True - type Subset Base64 Printable = 'True - type Subset Base64 Base64 = 'True - validate = check "Invalid base-64 characters" (contains Base64) - contains Base64 c = isAsciiLower c - || isAsciiUpper c - || isDigit c - || c == '+' - || c == '/' - || c == '=' - {-# INLINE contains #-} + type Subset Base64 Standard = 'True + type Subset Base64 Printable = 'True + type Subset Base64 Base64 = 'True + validate = check "Invalid base-64 characters" (contains Base64) + contains Base64 c = + isAsciiLower c + || isAsciiUpper c + || isDigit c + || c == '+' + || c == '/' + || c == '=' + {-# INLINE contains #-} validateBase64 :: Text -> Either String AsciiBase64 validateBase64 = validate @@ -211,20 +217,22 @@ decodeBase64 = either (const Nothing) Just . B64.decode . toByteString' -- it might have intermittent padding characters or might not be a multiple of -- 4 bytes in length. data Base64Url = Base64Url + type AsciiBase64Url = AsciiText Base64Url instance AsciiChars Base64Url where - type Subset Base64Url Standard = 'True - type Subset Base64Url Printable = 'True - type Subset Base64Url Base64Url = 'True - validate = check "Invalid url-safe base-64 characters" (contains Base64Url) - contains Base64Url c = isAsciiLower c - || isAsciiUpper c - || isDigit c - || c == '-' - || c == '_' - || c == '=' - {-# INLINE contains #-} + type Subset Base64Url Standard = 'True + type Subset Base64Url Printable = 'True + type Subset Base64Url Base64Url = 'True + validate = check "Invalid url-safe base-64 characters" (contains Base64Url) + contains Base64Url c = + isAsciiLower c + || isAsciiUpper c + || isDigit c + || c == '-' + || c == '_' + || c == '=' + {-# INLINE contains #-} validateBase64Url :: Text -> Either String AsciiBase64Url validateBase64Url = validate @@ -246,17 +254,18 @@ decodeBase64Url = either (const Nothing) Just . B64Url.decode . toByteString' -- | The character set used in base16 (aka hex) encoding. data Base16 = Base16 + type AsciiBase16 = AsciiText Base16 instance AsciiChars Base16 where - type Subset Base16 Standard = 'True - type Subset Base16 Printable = 'True - type Subset Base16 Base64 = 'True - type Subset Base16 Base64Url = 'True - type Subset Base16 Base16 = 'True - validate = check "Invalid base-16 (hex) characters" (contains Base16) - contains Base16 = isHexDigit - {-# INLINE contains #-} + type Subset Base16 Standard = 'True + type Subset Base16 Printable = 'True + type Subset Base16 Base64 = 'True + type Subset Base16 Base64Url = 'True + type Subset Base16 Base16 = 'True + validate = check "Invalid base-16 (hex) characters" (contains Base16) + contains Base16 = isHexDigit + {-# INLINE contains #-} validateBase16 :: Text -> Either String AsciiBase16 validateBase16 = validate @@ -270,8 +279,8 @@ encodeBase16 = unsafeFromByteString . B16.encode -- Decoding only succeeds if the text is a multiple of 2 bytes in length. decodeBase16 :: AsciiBase16 -> Maybe ByteString decodeBase16 t = case B16.decode (toByteString' t) of - (b, r) | r == mempty -> Just b - (_, _) -> Nothing + (b, r) | r == mempty -> Just b + (_, _) -> Nothing -------------------------------------------------------------------------------- -- Safe Widening @@ -300,18 +309,19 @@ unsafeFromByteString = AsciiText . decodeLatin1 -- Internal check :: String -> (Char -> Bool) -> Text -> Either String (AsciiText c) -check m f t | Text.all f t = Right (AsciiText t) - | otherwise = Left m +check m f t + | Text.all f t = Right (AsciiText t) + | otherwise = Left m parseBytes :: (Text -> Either String a) -> Parser a parseBytes f = parser >>= \bs -> - case decodeUtf8' bs of - Left _ -> fail $ "Invalid ASCII characters in: " ++ C8.unpack bs - Right t -> case f t of - Left e -> fail $ e ++ ": " ++ Text.unpack t - Right a -> pure a + case decodeUtf8' bs of + Left _ -> fail $ "Invalid ASCII characters in: " ++ C8.unpack bs + Right t -> case f t of + Left e -> fail $ e ++ ": " ++ Text.unpack t + Right a -> pure a unsafeString :: (Text -> Either String a) -> String -> a unsafeString f s = case f (Text.pack s) of - Right a -> a - Left e -> error $ "Data.Text.Ascii.fromString: " ++ e ++ ": " ++ s + Right a -> a + Left e -> error $ "Data.Text.Ascii.fromString: " ++ e ++ ": " ++ s diff --git a/libs/types-common/test/Test/Properties.hs b/libs/types-common/test/Test/Properties.hs index 62c293430ae..b2dea64d455 100644 --- a/libs/types-common/test/Test/Properties.hs +++ b/libs/types-common/test/Test/Properties.hs @@ -8,10 +8,13 @@ module Test.Properties ) where -import Data.Aeson as Aeson +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion import Data.ByteString.Lazy as L +import Data.Handle (Handle) import Data.Id import qualified Data.Json.Util as Util import Data.ProtocolBuffers.Internal @@ -25,6 +28,7 @@ import Imports import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck +import Type.Reflection (typeRep) tests :: TestTree tests = @@ -138,6 +142,10 @@ tests = ("1918-04-14T09:58:58.12Z", "1918-04-14T09:58:58.120Z") ] ], + testGroup + "Handle" + [ jsonRoundtrip @Handle + ], testGroup "UUID" [ testProperty "decode . encode = id" $ @@ -178,6 +186,17 @@ tests = roundtrip :: (EncodeWire a, DecodeWire a) => Tag' -> a -> Either String a roundtrip (Tag' t) = runGet (getWireField >>= decodeWire) . runPut . encodeWire t +jsonRoundtrip :: + forall a. + (Arbitrary a, Typeable a, ToJSON a, FromJSON a, Eq a, Show a) => + TestTree +jsonRoundtrip = testProperty msg trip + where + msg = show (typeRep @a) + trip (v :: a) = + counterexample (show $ toJSON v) $ + Right v === (Aeson.parseEither parseJSON . toJSON) v + newtype Tag' = Tag' Tag deriving (Eq, Show) diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs index b407a89fad2..f110d9608ee 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs @@ -41,6 +41,16 @@ parseBody' r = either thrw pure =<< runExceptT (parseBody r) where thrw msg = throwM $ Wai.Error status400 "bad-request" msg +parseOptionalBody :: + (MonadIO m, FromJSON a) => + OptionalJsonRequest a -> + ExceptT LText m (Maybe a) +parseOptionalBody r = + hoistEither . fmapL Text.pack . traverse eitherDecode' . nonEmptyBody =<< readBody r + where + nonEmptyBody "" = Nothing + nonEmptyBody ne = Just ne + lookupRequestId :: HasRequest r => r -> Maybe ByteString lookupRequestId = lookup "Request-Id" . requestHeaders . getRequest @@ -57,11 +67,24 @@ jsonRequest = contentType "application" "json" .&> (return . JsonRequest . getRequest) +newtype OptionalJsonRequest body = OptionalJsonRequest {fromOptionalJsonRequest :: Request} + +optionalJsonRequest :: + forall body r. + (HasRequest r, HasHeaders r) => + Predicate r Error (OptionalJsonRequest body) +optionalJsonRequest = + opt (contentType "application" "json") + .&> (return . OptionalJsonRequest . getRequest) + ---------------------------------------------------------------------------- -- Instances instance HasRequest (JsonRequest a) where getRequest = fromJsonRequest +instance HasRequest (OptionalJsonRequest a) where + getRequest = fromOptionalJsonRequest + instance HasRequest Request where getRequest = id diff --git a/nix/default.nix b/nix/default.nix new file mode 100644 index 00000000000..00a7df196fa --- /dev/null +++ b/nix/default.nix @@ -0,0 +1,14 @@ +let + sources = import ./sources.nix; + pkgs = import sources.nixpkgs { + config.allowUnfree = true; + overlays = [ + # the tool we use for versioning (The thing that generates sources.json) + (_: _: { niv = (import sources.niv {}).niv; }) + # All wire-server specific packages + (import ./overlays/wire-server.nix) + + ]; + }; +in + pkgs diff --git a/nix/overlays/wire-server.nix b/nix/overlays/wire-server.nix new file mode 100644 index 00000000000..9b1a1e5a983 --- /dev/null +++ b/nix/overlays/wire-server.nix @@ -0,0 +1,59 @@ +self: super: { + # TODO: Do not use buildRustPackage. Ces't horrible + cryptobox = self.callPackage ( + { fetchFromGitHub, rustPlatform, pkgconfig, libsodium }: + rustPlatform.buildRustPackage rec { + name = "cryptobox-c-${version}"; + version = "2019-06-17"; + buildInputs = [ pkgconfig libsodium ]; + src = fetchFromGitHub { + owner = "wireapp"; + repo = "cryptobox-c"; + rev = "4067ad96b125942545dbdec8c1a89f1e1b65d013"; + sha256 = "1i9dlhw0xk1viglyhail9fb36v1awrypps8jmhrkz8k1bhx98ci3"; + }; + cargoSha256 = "0m85c49hvvxxv7jdipfcaydy4n8iw4h6myzv63v7qc0fxnp1vfm8"; + postInstall = '' + mkdir -p $out/include + cp src/cbox.h $out/include + ''; + } + ) {}; + + zauth = self.callPackage ( + { fetchFromGitHub, rustPlatform, pkgconfig, libsodium }: + rustPlatform.buildRustPackage rec { + name = "libzauth-${version}"; + version = "3.0.0"; + buildInputs = [ libsodium pkgconfig ]; + src = self.nix-gitignore.gitignoreSourcePure [ ../../.gitignore ] ../../libs/libzauth; + sourceRoot = "libzauth/libzauth-c"; + + cargoSha256 = "01yj1rchqmjnpj5cb9wl7vdzrycjwjhm60xh1jghw02n8jhl51p2"; # self.lib.fakeSha256; + postInstall = '' + mkdir -p $out/lib/pkgconfig + mkdir -p $out/include + cp src/zauth.h $out/include + sed -e "s~<>~${version}~" \ + -e "s~<>~$out~" \ + src/libzauth.pc > $out/lib/pkgconfig/libzauth.pc + cp target/release/libzauth.so $out/lib/ + ''; + } + ) {}; + + nginxModules = super.nginxModules // { + zauth = { + src = ../../services/nginz/third_party/nginx-zauth-module; + inputs = [ self.pkg-config self.zauth ]; + }; + }; + + nginz = super.nginx.override { + modules = [ + self.nginxModules.vts + self.nginxModules.moreheaders + self.nginxModules.zauth + ]; + }; +} diff --git a/nix/sources.json b/nix/sources.json new file mode 100644 index 00000000000..e4ab45d9d5f --- /dev/null +++ b/nix/sources.json @@ -0,0 +1,26 @@ +{ + "niv": { + "branch": "master", + "description": "Easy dependency management for Nix projects", + "homepage": "https://github.com/nmattia/niv", + "owner": "nmattia", + "repo": "niv", + "rev": "50600603b51432839c4b6267fd6a0d00ae6b0451", + "sha256": "1rrhlscbqdn9a77ws49acl536n3mz6bai68z08mpg8qqa4ahr2sn", + "type": "tarball", + "url": "https://github.com/nmattia/niv/archive/50600603b51432839c4b6267fd6a0d00ae6b0451.tar.gz", + "url_template": "https://github.com///archive/.tar.gz" + }, + "nixpkgs": { + "branch": "nixos-19.09", + "description": "A read-only mirror of NixOS/nixpkgs tracking the released channels. Send issues and PRs to", + "homepage": "https://github.com/NixOS/nixpkgs", + "owner": "NixOS", + "repo": "nixpkgs-channels", + "rev": "8731aaaf8b30888bc24994096db830993090d7c4", + "sha256": "1hcc89rxi47nb0mpk05nl9rbbb04kfw97xfydhpmmgh57yrp3zqa", + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs-channels/archive/8731aaaf8b30888bc24994096db830993090d7c4.tar.gz", + "url_template": "https://github.com///archive/.tar.gz" + } +} diff --git a/nix/sources.nix b/nix/sources.nix new file mode 100644 index 00000000000..4c0351c062a --- /dev/null +++ b/nix/sources.nix @@ -0,0 +1,128 @@ +# This file has been generated by Niv. + +let + + # + # The fetchers. fetch_ fetches specs of type . + # + + fetch_file = spec: + if spec.builtin or true then + builtins_fetchurl { inherit (spec) url sha256; } + else + pkgs.fetchurl { inherit (spec) url sha256; }; + + fetch_tarball = spec: + if spec.builtin or true then + builtins_fetchTarball { inherit (spec) url sha256; } + else + pkgs.fetchzip { inherit (spec) url sha256; }; + + fetch_git = spec: + builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; }; + + fetch_builtin-tarball = spec: + builtins.trace + '' + WARNING: + The niv type "builtin-tarball" will soon be deprecated. You should + instead use `builtin = true`. + + $ niv modify -a type=tarball -a builtin=true + '' + builtins_fetchTarball { inherit (spec) url sha256; }; + + fetch_builtin-url = spec: + builtins.trace + '' + WARNING: + The niv type "builtin-url" will soon be deprecated. You should + instead use `builtin = true`. + + $ niv modify -a type=file -a builtin=true + '' + (builtins_fetchurl { inherit (spec) url sha256; }); + + # + # The sources to fetch. + # + + sources = builtins.fromJSON (builtins.readFile ./sources.json); + + # + # Various helpers + # + + # The set of packages used when specs are fetched using non-builtins. + pkgs = + if hasNixpkgsPath + then + if hasThisAsNixpkgsPath + then import (builtins_fetchTarball { inherit (sources_nixpkgs) url sha256; }) {} + else import {} + else + import (builtins_fetchTarball { inherit (sources_nixpkgs) url sha256; }) {}; + + sources_nixpkgs = + if builtins.hasAttr "nixpkgs" sources + then sources.nixpkgs + else abort + '' + Please specify either (through -I or NIX_PATH=nixpkgs=...) or + add a package called "nixpkgs" to your sources.json. + ''; + + hasNixpkgsPath = (builtins.tryEval ).success; + hasThisAsNixpkgsPath = + (builtins.tryEval ).success && == ./.; + + # The actual fetching function. + fetch = name: spec: + + if ! builtins.hasAttr "type" spec then + abort "ERROR: niv spec ${name} does not have a 'type' attribute" + else if spec.type == "file" then fetch_file spec + else if spec.type == "tarball" then fetch_tarball spec + else if spec.type == "git" then fetch_git spec + else if spec.type == "builtin-tarball" then fetch_builtin-tarball spec + else if spec.type == "builtin-url" then fetch_builtin-url spec + else + abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; + + # Ports of functions for older nix versions + + # a Nix version of mapAttrs if the built-in doesn't exist + mapAttrs = builtins.mapAttrs or ( + f: set: with builtins; + listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) + ); + + # fetchTarball version that is compatible between all the versions of Nix + builtins_fetchTarball = { url, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchTarball; + in + if lessThan nixVersion "1.12" then + fetchTarball { inherit url; } + else + fetchTarball attrs; + + # fetchurl version that is compatible between all the versions of Nix + builtins_fetchurl = { url, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchurl; + in + if lessThan nixVersion "1.12" then + fetchurl { inherit url; } + else + fetchurl attrs; + +in +mapAttrs ( + name: spec: + if builtins.hasAttr "outPath" spec + then abort + "The values in sources.json should not have an 'outPath' attribute" + else + spec // { outPath = fetch name spec; } +) sources diff --git a/services/brig/.gitignore b/services/brig/.gitignore deleted file mode 100644 index c4544c0f7b1..00000000000 --- a/services/brig/.gitignore +++ /dev/null @@ -1,43 +0,0 @@ -*# -*.aux* -*.chi -*.chs.h -*.db -*.gz -*.hi -*.hp* -*.o -*.org -*.prof* -*.ps* -*.pyc -*.pyc -*.tar -*.tmp -*.un~ -*~ -.#* -.*.sw[a-z] -.DS_Store -.bench -.devel -.metadata -.shelly -.test -.cabal-sandbox -.stack-work -cabal.sandbox.config -Setup.hs -TAGS -\#*# -__pycache__ -cabal-dev -dist -gen-hs -log -tags -tmp -vendor -virtualenv -.env.private - diff --git a/services/brig/Makefile b/services/brig/Makefile index 6bb6b722dd5..b161ae2f53d 100644 --- a/services/brig/Makefile +++ b/services/brig/Makefile @@ -15,6 +15,7 @@ DEB_INDEX := dist/$(NAME)-index_$(VERSION)+$(BUILD)_amd64.deb EXECUTABLES := $(NAME) $(NAME)-integration $(NAME)-schema $(NAME)-index DOCKER_USER ?= quay.io/wire DOCKER_TAG ?= local +INTEGRATION_USE_NGINZ ?= 1 guard-%: @ if [ "${${*}}" = "" ]; then \ @@ -85,18 +86,18 @@ $(DEB_INDEX): install .PHONY: i i: - INTEGRATION_USE_NGINZ=1 ../integration.sh $(EXE_IT) -s $(NAME).integration.yaml -i ../integration.yaml $(WIRE_INTEGRATION_TEST_OPTIONS) + INTEGRATION_USE_NGINZ=$(INTEGRATION_USE_NGINZ) ../integration.sh $(EXE_IT) -s $(NAME).integration.yaml -i ../integration.yaml $(WIRE_INTEGRATION_TEST_OPTIONS) .PHONY: i-aws i-aws: - INTEGRATION_USE_REAL_AWS=1 INTEGRATION_USE_NGINZ=1 ../integration.sh $(EXE_IT) -s $(NAME).integration-aws.yaml -i ../integration.yaml $(WIRE_INTEGRATION_TEST_OPTIONS) + INTEGRATION_USE_REAL_AWS=1 INTEGRATION_USE_NGINZ=$(INTEGRATION_USE_NGINZ) ../integration.sh $(EXE_IT) -s $(NAME).integration-aws.yaml -i ../integration.yaml $(WIRE_INTEGRATION_TEST_OPTIONS) .PHONY: i-list i-list: $(EXE_IT) -s $(NAME).integration.yaml -i ../integration.yaml -l i-%: - INTEGRATION_USE_NGINZ=1 ../integration.sh $(EXE_IT) -s $(NAME).integration.yaml -i ../integration.yaml -p "$*" $(WIRE_INTEGRATION_TEST_OPTIONS) + INTEGRATION_USE_NGINZ=$(INTEGRATION_USE_NGINZ) ../integration.sh $(EXE_IT) -s $(NAME).integration.yaml -i ../integration.yaml -p "$*" $(WIRE_INTEGRATION_TEST_OPTIONS) .PHONY: integration integration: fast i diff --git a/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs index 1a70bca76e9..f1a5ef32c3b 100644 --- a/services/brig/src/Brig/API.hs +++ b/services/brig/src/Brig/API.hs @@ -36,6 +36,7 @@ import Control.Lens ((^.), view) import Data.Aeson hiding (json) import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy +import Data.Handle (Handle, parseHandle) import Data.Id import qualified Data.List1 as List1 import qualified Data.Map.Strict as Map @@ -809,15 +810,16 @@ sitemap o = do Doc.notes "DEPRECATED: Use 'POST /password-reset/complete'." --- - post "/onboarding/v3" (continue onboardingH) $ + post "/onboarding/v3" (continue deprecatedOnboardingH) $ accept "application" "json" .&. header "Z-User" - .&. jsonRequest @AddressBook + .&. jsonRequest @Value document "POST" "onboardingV3" $ do - Doc.summary "Upload contacts and invoke matching. Returns the list of Matches" - Doc.body (Doc.ref Doc.addressBook) $ Doc.description "Address book" - Doc.returns (Doc.ref Doc.onboardingMatches) - Doc.response 200 "Matches" Doc.end + Doc.deprecated + Doc.summary "Upload contacts and invoke matching." + Doc.notes + "DEPRECATED: the feature has been turned off, the end-point does \ + \nothing and always returns '{\"results\":[],\"auto-connects\":[]}'." ----- Provider.routes @@ -895,7 +897,7 @@ getMultiPrekeyBundles body = do maxSize <- fromIntegral . setMaxConvSize <$> view settings when (Map.size (userClients body) > maxSize) $ throwStd tooManyClients - lift (API.claimMultiPrekeyBundles body) + API.claimMultiPrekeyBundles body addClientH :: JsonRequest NewClient ::: UserId ::: ConnId ::: Maybe IpAddr ::: JSON -> Handler Response addClientH (req ::: usr ::: con ::: ip ::: _) = do @@ -959,7 +961,8 @@ internalListClientsH (_ ::: req) = do internalListClients :: UserSet -> AppIO UserClients internalListClients (UserSet usrs) = do - UserClients . Map.fromList <$> (API.lookupUsersClientIds $ Set.toList usrs) + UserClients . Map.mapKeys makeIdOpaque . Map.fromList + <$> (API.lookupUsersClientIds $ Set.toList usrs) getClientH :: UserId ::: ClientId ::: JSON -> Handler Response getClientH (usr ::: clt ::: _) = lift $ do @@ -1345,17 +1348,6 @@ sendActivationCode SendActivationCode {..} = do changeSelfEmailH :: UserId ::: ConnId ::: JsonRequest EmailUpdate -> Handler Response changeSelfEmailH (u ::: _ ::: req) = changeEmail u req True --- Deprecated and to be removed after new versions of brig and galley are --- deployed. Reason for deprecation: it returns N^2 things (which is not --- needed), it doesn't scale, and it accepts everything in URL parameters, --- which doesn't work when the list of users is long. -deprecatedGetConnectionsStatusH :: List UserId ::: Maybe Relation -> Handler Response -deprecatedGetConnectionsStatusH (users ::: flt) = do - r <- lift $ API.lookupConnectionStatus (fromList users) (fromList users) - return . json $ maybe r (filterByRelation r) flt - where - filterByRelation l rel = filter ((== rel) . csStatus) l - getConnectionsStatusH :: JSON ::: JsonRequest ConnectionsStatusRequest ::: Maybe Relation -> Handler Response @@ -1509,11 +1501,6 @@ verifyDeleteUserH (r ::: _) = do API.verifyDeleteUser body !>> deleteUserError return (setStatus status200 empty) -onboardingH :: JSON ::: UserId ::: JsonRequest AddressBook -> Handler Response -onboardingH (_ ::: uid ::: r) = do - ab <- parseJsonBody r - json <$> API.onboarding uid ab !>> connError - getContactListH :: JSON ::: UserId -> Handler Response getContactListH (_ ::: uid) = do contacts <- lift $ API.lookupContactList uid @@ -1557,6 +1544,29 @@ respFromActivationRespWithStatus = \case -- Deprecated +-- Deprecated and to be removed after new versions of brig and galley are +-- deployed. Reason for deprecation: it returns N^2 things (which is not +-- needed), it doesn't scale, and it accepts everything in URL parameters, +-- which doesn't work when the list of users is long. +deprecatedGetConnectionsStatusH :: List UserId ::: Maybe Relation -> Handler Response +deprecatedGetConnectionsStatusH (users ::: flt) = do + r <- lift $ API.lookupConnectionStatus (fromList users) (fromList users) + return . json $ maybe r (filterByRelation r) flt + where + filterByRelation l rel = filter ((== rel) . csStatus) l + +deprecatedOnboardingH :: JSON ::: UserId ::: JsonRequest Value -> Handler Response +deprecatedOnboardingH (_ ::: _ ::: _) = pure $ json DeprecatedMatchingResult + +data DeprecatedMatchingResult = DeprecatedMatchingResult + +instance ToJSON DeprecatedMatchingResult where + toJSON DeprecatedMatchingResult = + object + [ "results" .= ([] :: [()]), + "auto-connects" .= ([] :: [()]) + ] + deprecatedCompletePasswordResetH :: JSON ::: PasswordResetKey ::: JsonRequest PasswordReset -> Handler Response deprecatedCompletePasswordResetH (_ ::: k ::: req) = do pwr <- parseJsonBody req diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index d7192ee48e7..938c4ff7d90 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -20,7 +20,10 @@ module Brig.API.Client ) where +import Brig.API.Error (federationNotImplemented, throwStd) +import Brig.API.Handler (Handler) import Brig.API.Types +import Brig.API.Util (resolveOpaqueUserId) import Brig.App import qualified Brig.Data.Client as Data import qualified Brig.Data.User as Data @@ -32,12 +35,15 @@ import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) import qualified Brig.User.Auth.Cookie as Auth import Brig.User.Email import Brig.User.Event -import Control.Concurrent.Async (mapConcurrently) import Control.Error import Control.Lens (view) +import Data.Bitraversable (bitraverse) import Data.ByteString.Conversion import Data.IP (IP) -import Data.Id (ClientId, ConnId, UserId) +import qualified Data.Id as Id +import Data.Id (ClientId, ConnId, UserId, makeIdOpaque) +import Data.IdMapping +import Data.List.NonEmpty (nonEmpty) import Data.List.Split (chunksOf) import qualified Data.Map.Strict as Map import Data.Misc (PlainTextPassword (..)) @@ -46,6 +52,7 @@ import Imports import Network.Wai.Utilities import System.Logger.Class (field, msg, val, (~~)) import qualified System.Logger.Class as Log +import UnliftIO.Async (Concurrently (Concurrently, runConcurrently)) -- nb. We must ensure that the set of clients known to brig is always -- a superset of the clients known to galley. @@ -106,20 +113,35 @@ claimPrekeyBundle u = do clients <- map clientId <$> Data.lookupClients u PrekeyBundle u . catMaybes <$> mapM (Data.claimPrekey u) clients -claimMultiPrekeyBundles :: UserClients -> AppIO (UserClientMap (Maybe Prekey)) -claimMultiPrekeyBundles (UserClients x) = do - e <- ask - m <- liftIO $ forM chunks (mapConcurrently $ runAppT e . outer) - return $ UserClientMap (Map.fromList (concat m)) +claimMultiPrekeyBundles :: UserClients -> Handler (UserClientMap (Maybe Prekey)) +claimMultiPrekeyBundles (UserClients clientMap) = do + resolved <- traverse (bitraverse resolveOpaqueUserId pure) $ Map.toList clientMap + let (localUsers, remoteUsers) = partitionEithers $ map localOrRemoteUser resolved + for_ (nonEmpty remoteUsers) $ + throwStd . federationNotImplemented . fmap fst + -- FUTUREWORK(federation): claim keys from other backends, merge maps + lift $ UserClientMap . Map.mapKeys makeIdOpaque <$> claimLocalPrekeyBundles localUsers where - chunks = chunksOf 16 (Map.toList x) - outer (u, c) = do - keymap <- foldrM (inner u) Map.empty c - return (u, keymap) - inner u c m = do + localOrRemoteUser :: (MappedOrLocalId Id.U, a) -> Either (UserId, a) (IdMapping Id.U, a) + localOrRemoteUser (mappedOrLocal, x) = + case mappedOrLocal of + Local localId -> Left (localId, x) + Mapped mapping -> Right (mapping, x) + +claimLocalPrekeyBundles :: [(UserId, Set ClientId)] -> AppIO (Map UserId (Map ClientId (Maybe Prekey))) +claimLocalPrekeyBundles = foldMap getChunk . fmap Map.fromList . chunksOf 16 + where + getChunk :: Map UserId (Set ClientId) -> AppIO (Map UserId (Map ClientId (Maybe Prekey))) + getChunk = + runConcurrently . Map.traverseWithKey (\u -> Concurrently . getUserKeys u) + getUserKeys :: UserId -> Set ClientId -> AppIO (Map ClientId (Maybe Prekey)) + getUserKeys u = + sequenceA . Map.fromSet (getClientKeys u) + getClientKeys :: UserId -> ClientId -> AppIO (Maybe Prekey) + getClientKeys u c = do key <- fmap prekeyData <$> Data.claimPrekey u c when (isNothing key) $ noPrekeys u c - return (Map.insert c key m) + return key -- Utilities diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index b683086a610..8274fc3385a 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -14,9 +14,6 @@ module Brig.API.Connection Data.lookupConnection, Data.lookupConnectionStatus, Data.lookupContactList, - - -- * Onboarding - onboarding, ) where @@ -24,20 +21,16 @@ import Brig.API.Types import Brig.App import qualified Brig.Data.Connection as Data import qualified Brig.Data.User as Data -import qualified Brig.Data.UserKey as Data import qualified Brig.IO.Intra as Intra import Brig.Options (setUserMaxConnections) import Brig.Types import Brig.Types.Intra import Brig.User.Event import qualified Brig.User.Event.Log as Log -import Control.Concurrent.Async (mapConcurrently) import Control.Error import Control.Lens ((^.), view) import Data.Id -import Data.List.Split (chunksOf) import Data.Range -import Data.Set (fromList) import qualified Data.Set as Set import Galley.Types (ConvType (..), cnvType) import qualified Galley.Types.Teams as Team @@ -285,40 +278,6 @@ lookupConnections from start size = do rs <- Data.lookupConnections from start size return $! UserConnectionList (Data.resultList rs) (Data.resultHasMore rs) -onboarding :: UserId -> AddressBook -> ExceptT ConnectionError AppIO MatchingResult -onboarding uid ab = do - -- The choice of 25 is arbitrary and is here only to avoid having a user - -- auto-connect to too many users; thus the upper limit - ms <- lift $ collectMatches 25 [] (chunksOf 25 (abCards ab)) - autos <- autoConnect uid (fromList $ map fst ms) Nothing - let connected = map ucTo $ filter ((== uid) . ucFrom) autos - return $ MatchingResult (toMatches connected ms) connected - where - collectMatches :: Int -> [(UserId, Maybe CardId)] -> [[Card]] -> AppIO [(UserId, Maybe CardId)] - collectMatches 0 acc _ = return acc - collectMatches _ acc [] = return acc - collectMatches n acc cards = do - -- Make 4 parallel requests, each will have at most 25 keys to look up - let (cur, rest) = splitAt 4 cards - e <- ask - ms <- - take n <$> filter ((/= uid) . fst) . join - <$> liftIO (mapConcurrently (runAppT e . lookupHashes) cur) - collectMatches (n - length ms) (acc ++ ms) rest - lookupHashes :: [Card] -> AppIO [(UserId, Maybe CardId)] - lookupHashes xs = - concatMap findCards - <$> Data.lookupPhoneHashes (map abEntrySha256 (concatMap cEntries xs)) - where - findCards :: (ByteString, UserId) -> [(UserId, Maybe CardId)] - findCards (h, u) = - map ((u,) . cCardId) $ - filter ((h `elem`) . (map abEntrySha256 . cEntries)) xs - toMatches :: [UserId] -> [(UserId, Maybe CardId)] -> [Match] - toMatches uids = - map (\(u, c) -> Match u c (maybeToList c)) - . filter ((`elem` uids) . fst) - -- Helpers checkLimit :: UserId -> ExceptT ConnectionError AppIO () diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index b0fc5c3894c..f9deb68680a 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -8,11 +8,18 @@ import Control.Monad.Error.Class hiding (Error) import Data.Aeson import Data.ByteString.Conversion import qualified Data.HashMap.Strict as HashMap +import Data.Id (idToText) +import Data.IdMapping (IdMapping (IdMapping, idMappingGlobal, idMappingLocal)) +import Data.List.NonEmpty (NonEmpty) +import Data.Qualified (renderQualified) +import Data.String.Conversions (cs) +import qualified Data.Text.Lazy as LT import qualified Data.ZAuth.Validation as ZAuth import Imports import Network.HTTP.Types.Header import Network.HTTP.Types.Status import qualified Network.Wai.Utilities.Error as Wai +import Type.Reflection (Typeable, typeRep) data Error where StdError :: !Wai.Error -> Error @@ -445,3 +452,15 @@ can'tAddLegalHoldClient = legalHoldNotEnabled :: Wai.Error legalHoldNotEnabled = Wai.Error status403 "legalhold-not-enabled" "LegalHold must be enabled and configured on the team first" + +federationNotImplemented :: forall a. Typeable a => NonEmpty (IdMapping a) -> Wai.Error +federationNotImplemented qualified = + Wai.Error + status501 + "federation-not-implemented" + ("Federation is not implemented, but global qualified IDs (" <> idType <> ") found: " <> rendered) + where + idType = cs (show (typeRep @a)) + rendered = LT.intercalate ", " . toList . fmap (LT.fromStrict . renderMapping) $ qualified + renderMapping IdMapping {idMappingLocal, idMappingGlobal} = + idToText idMappingLocal <> " -> " <> renderQualified idToText idMappingGlobal diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index b3fea3c95dd..5407d95678b 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -103,10 +103,12 @@ import Control.Lens ((^.), view) import Control.Monad.Catch import Data.ByteString.Conversion import qualified Data.Currency as Currency +import Data.Handle (Handle) import Data.Id import Data.Json.Util import Data.List1 (List1) import qualified Data.Map.Strict as Map +import Data.Misc ((<$$>)) import Data.Misc (PlainTextPassword (..)) import Data.Time.Clock (diffUTCTime) import Data.UUID.V4 (nextRandom) @@ -875,44 +877,71 @@ lookupProfile :: UserId -> UserId -> AppIO (Maybe UserProfile) lookupProfile self other = listToMaybe <$> lookupProfiles self [other] -- | Obtain user profiles for a list of users as they can be seen by --- a given user 'A'. User 'A' can see the 'FullProfile' of any other user 'B', --- if the reverse relation (B -> A) is either 'Accepted' or 'Sent'. --- Otherwise only the 'PublicProfile' is accessible for user 'A'. +-- a given user 'self'. User 'self' can see the 'FullProfile' of any other user 'other', +-- if the reverse relation (other -> self) is either 'Accepted' or 'Sent'. +-- Otherwise only the 'PublicProfile' is accessible for user 'self'. +-- If 'self' is an unknown 'UserId', return '[]'. lookupProfiles :: - -- | User 'A' on whose behalf the profiles are requested. + -- | User 'self' on whose behalf the profiles are requested. UserId -> - -- | The users ('B's) for which to obtain the profiles. + -- | The users ('others') for which to obtain the profiles. [UserId] -> AppIO [UserProfile] lookupProfiles self others = do users <- Data.lookupUsers others >>= mapM userGC css <- toMap <$> Data.lookupConnectionStatus (map userId users) [self] emailVisibility' <- view (settings . emailVisibility) - return $ map (toProfile emailVisibility' css) users + emailVisibility'' <- case emailVisibility' of + EmailVisibleIfOnTeam -> pure EmailVisibleIfOnTeam' + EmailVisibleIfOnSameTeam -> EmailVisibleIfOnSameTeam' <$> getSelfInfo + EmailVisibleToSelf -> pure EmailVisibleToSelf' + return $ map (toProfile emailVisibility'' css) users where toMap :: [ConnectionStatus] -> Map UserId Relation toMap = Map.fromList . map (csFrom &&& csStatus) - toProfile :: EmailVisibility -> Map UserId Relation -> User -> UserProfile - toProfile emailVisibility' css u = + -- + getSelfInfo :: AppIO (Maybe (TeamId, Team.TeamMember)) + getSelfInfo = do + -- FUTUREWORK: it is an internal error for the two lookups (for 'User' and 'TeamMember') + -- to return 'Nothing'. we could throw errors here if that happens, rather than just + -- returning an empty profile list from 'lookupProfiles'. + mUser <- Data.lookupUser self + case userTeam =<< mUser of + Nothing -> pure Nothing + Just tid -> (tid,) <$$> Intra.getTeamMember self tid + -- + toProfile :: EmailVisibility' -> Map UserId Relation -> User -> UserProfile + toProfile emailVisibility'' css u = let cs = Map.lookup (userId u) css - profileEmail' = getEmailForProfile u emailVisibility' + profileEmail' = getEmailForProfile u emailVisibility'' baseProfile = if userId u == self || cs == Just Accepted || cs == Just Sent then connectedProfile u else publicProfile u in baseProfile {profileEmail = profileEmail'} +data EmailVisibility' + = EmailVisibleIfOnTeam' + | EmailVisibleIfOnSameTeam' (Maybe (TeamId, Team.TeamMember)) + | EmailVisibleToSelf' + -- | Gets the email if it's visible to the requester according to configured settings getEmailForProfile :: - -- | The user who's profile is being requested User -> - EmailVisibility -> + EmailVisibility' -> Maybe Email -getEmailForProfile _ EmailVisibleToSelf = Nothing -getEmailForProfile u EmailVisibleIfOnTeam = - if isJust (userTeam u) - then userEmail u +getEmailForProfile profileOwner EmailVisibleIfOnTeam' = + if isJust (userTeam profileOwner) + then userEmail profileOwner + else Nothing +getEmailForProfile profileOwner (EmailVisibleIfOnSameTeam' (Just (viewerTeamId, viewerTeamMember))) = + if ( Just viewerTeamId == userTeam profileOwner + && Team.hasPermission viewerTeamMember Team.ViewSameTeamEmails + ) + then userEmail profileOwner else Nothing +getEmailForProfile _ (EmailVisibleIfOnSameTeam' Nothing) = Nothing +getEmailForProfile _ EmailVisibleToSelf' = Nothing -- | Obtain a profile for a user as he can see himself. lookupSelfProfile :: UserId -> AppIO (Maybe SelfProfile) diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 8fbceaaf9e6..36353156488 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -4,7 +4,8 @@ import Brig.API.Handler import qualified Brig.Data.User as Data import Brig.Types import Control.Monad -import Data.Id +import Data.Id as Id +import Data.IdMapping (MappedOrLocalId (Local)) import Data.Maybe import Imports @@ -14,3 +15,9 @@ lookupProfilesMaybeFilterSameTeamOnly self us = do return $ case selfTeam of Just team -> filter (\x -> profileTeam x == Just team) us Nothing -> us + +-- | this exists as a shim to find and mark places where we need to handle 'OpaqueUserId's. +resolveOpaqueUserId :: Monad m => OpaqueUserId -> m (MappedOrLocalId Id.U) +resolveOpaqueUserId (Id opaque) = + -- FUTUREWORK(federation): implement database lookup + pure . Local $ Id opaque diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 6273a1903b5..b2922ee0815 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StrictData #-} @@ -399,7 +400,7 @@ newtype AppT m a = AppT { unAppT :: ReaderT Env m a } - deriving + deriving newtype ( Functor, Applicative, Monad, @@ -409,6 +410,11 @@ newtype AppT m a MonadMask, MonadReader Env ) + deriving + ( Semigroup, + Monoid + ) + via (Ap (AppT m) a) type AppIO = AppT IO diff --git a/services/brig/src/Brig/Data/Instances.hs b/services/brig/src/Brig/Data/Instances.hs index 9e9c73f17a0..aa7042a4666 100644 --- a/services/brig/src/Brig/Data/Instances.hs +++ b/services/brig/src/Brig/Data/Instances.hs @@ -13,6 +13,7 @@ import Cassandra.CQL import Control.Error (note) import Data.Aeson (eitherDecode, encode) import qualified Data.Aeson as JSON +import Data.Handle (Handle (..)) import Data.Id () import Data.Range () import Data.String.Conversions (LBS, ST, cs) diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index d3ce24805af..1b6928daca2 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -63,6 +63,7 @@ import Cassandra import Control.Error import Control.Lens hiding (from) import Data.Conduit (ConduitM) +import Data.Handle (Handle) import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Misc (PlainTextPassword (..)) diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 08d9babd0a7..c43404ae247 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -11,6 +11,7 @@ import Brig.Whitelist (Whitelist (..)) import qualified Brig.ZAuth as ZAuth import qualified Control.Lens as Lens import Data.Aeson (withText) +import qualified Data.Aeson as Aeson import Data.Aeson.Types (typeMismatch) import Data.Id import Data.Scientific (toBoundedInteger) @@ -293,21 +294,26 @@ data EmailVisibility -- This may sound strange; but certain on-premise hosters have many different teams -- and still want them to see each-other's emails. EmailVisibleIfOnTeam + | -- | Anyone on your team with at least 'Member' privileges can see your email address. + EmailVisibleIfOnSameTeam | -- | Show your email only to yourself EmailVisibleToSelf - deriving (Eq, Show) + deriving (Eq, Show, Bounded, Enum) instance FromJSON EmailVisibility where parseJSON = withText "EmailVisibility" $ \case "visible_if_on_team" -> pure EmailVisibleIfOnTeam + "visible_if_on_same_team" -> pure EmailVisibleIfOnSameTeam "visible_to_self" -> pure EmailVisibleToSelf _ -> fail $ "unexpected value for EmailVisibility settings: " - <> "expected one of [visible_if_on_team, visible_to_self]" + <> "expected one of " + <> show (Aeson.encode <$> [(minBound :: EmailVisibility) ..]) instance ToJSON EmailVisibility where toJSON EmailVisibleIfOnTeam = "visible_if_on_team" + toJSON EmailVisibleIfOnSameTeam = "visible_if_on_same_team" toJSON EmailVisibleToSelf = "visible_to_self" -- | Options that are consumed on startup diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index e97733f1178..91313bc3ff3 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -881,7 +881,7 @@ botClaimUsersPrekeys body = do maxSize <- fromIntegral . setMaxConvSize <$> view settings when (Map.size (userClients body) > maxSize) $ throwStd tooManyClients - lift (Client.claimMultiPrekeyBundles body) + Client.claimMultiPrekeyBundles body botListUserProfilesH :: List UserId -> Handler Response botListUserProfilesH uids = do diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index a2f74718cce..f7aae9053d5 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -42,6 +42,7 @@ import qualified Brig.ZAuth as ZAuth import Control.Error hiding (bool) import Control.Lens (to, view) import Data.ByteString.Conversion (toByteString) +import Data.Handle (Handle) import Data.Id import Data.List1 (singleton) import Data.Misc (PlainTextPassword (..)) diff --git a/services/brig/src/Brig/User/Event.hs b/services/brig/src/Brig/User/Event.hs index c70775cac23..612a064e523 100644 --- a/services/brig/src/Brig/User/Event.hs +++ b/services/brig/src/Brig/User/Event.hs @@ -4,6 +4,7 @@ module Brig.User.Event where import Brig.Types import Brig.Types.Intra +import Data.Handle (Handle) import Data.Id import Imports diff --git a/services/brig/src/Brig/User/Handle.hs b/services/brig/src/Brig/User/Handle.hs index ab0676daf10..acd440b8819 100644 --- a/services/brig/src/Brig/User/Handle.hs +++ b/services/brig/src/Brig/User/Handle.hs @@ -10,10 +10,10 @@ where import Brig.App import Brig.Data.Instances () import qualified Brig.Data.User as User -import Brig.Types.Common import Brig.Types.User import Brig.Unique import Cassandra +import Data.Handle (Handle, fromHandle) import Data.Id import Imports diff --git a/services/brig/src/Brig/User/Handle/Blacklist.hs b/services/brig/src/Brig/User/Handle/Blacklist.hs index 5c542ebbf02..3a91b8cdf6a 100644 --- a/services/brig/src/Brig/User/Handle/Blacklist.hs +++ b/services/brig/src/Brig/User/Handle/Blacklist.hs @@ -1,6 +1,6 @@ module Brig.User.Handle.Blacklist (isBlacklistedHandle) where -import Brig.Types.Common (Handle (..)) +import Data.Handle (Handle (Handle)) import qualified Data.HashSet as HashSet import Imports diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index 54ccf9de439..ef91a219ca1 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -42,6 +42,7 @@ import Data.Aeson.Encoding import Data.Aeson.Lens import Data.ByteString.Builder (Builder, toLazyByteString) import qualified Data.ByteString.Conversion as Bytes +import Data.Handle (Handle, fromHandle) import Data.Id import qualified Data.Map as Map import Data.Metrics diff --git a/services/brig/src/Brig/User/Search/Index/Types.hs b/services/brig/src/Brig/User/Search/Index/Types.hs index ab8e845f341..983f8510469 100644 --- a/services/brig/src/Brig/User/Search/Index/Types.hs +++ b/services/brig/src/Brig/User/Search/Index/Types.hs @@ -5,6 +5,7 @@ module Brig.User.Search.Index.Types where import Brig.Types.User import Control.Lens (makeLenses) import Data.Aeson +import Data.Handle (Handle) import Data.Id import Data.Json.Util ((#)) import Database.V5.Bloodhound hiding (key) diff --git a/services/brig/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 427436fa2d0..ddc2421065c 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -28,6 +28,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Conversion import qualified Data.ByteString.Lazy.Char8 as LC8 +import Data.Handle (Handle (Handle)) import qualified Data.HashMap.Strict as HashMap import Data.Id hiding (client) import Data.List1 (List1) @@ -1254,7 +1255,7 @@ createConv g u us = . contentJson . body (RequestBodyLBS (encode (NewConvUnmanaged conv))) where - conv = NewConv us Nothing Set.empty Nothing Nothing Nothing Nothing roleNameWireAdmin + conv = NewConv (makeIdOpaque <$> us) Nothing Set.empty Nothing Nothing Nothing Nothing roleNameWireAdmin postMessage :: Galley -> diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index 2f7c54b61ad..95764977892 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -3,6 +3,7 @@ module API.Search (tests) where import API.Search.Util import Bilge import Brig.Types +import Data.Handle (fromHandle) import Imports import Network.HTTP.Client (Manager) import Test.Tasty diff --git a/services/brig/test/integration/API/Search/Util.hs b/services/brig/test/integration/API/Search/Util.hs index a08524f8593..f381b32a640 100644 --- a/services/brig/test/integration/API/Search/Util.hs +++ b/services/brig/test/integration/API/Search/Util.hs @@ -6,6 +6,7 @@ import Brig.Types import Control.Monad.Catch (MonadCatch) import Control.Monad.Fail (MonadFail) import Data.Aeson (decode, encode) +import Data.Handle (Handle (Handle)) import Data.Id import Data.Text.Encoding (encodeUtf8) import Imports diff --git a/services/brig/test/integration/API/Settings.hs b/services/brig/test/integration/API/Settings.hs index 71fb9d46926..12d21c18166 100644 --- a/services/brig/test/integration/API/Settings.hs +++ b/services/brig/test/integration/API/Settings.hs @@ -35,45 +35,60 @@ tests defOpts manager brig galley = return $ do "setEmailVisibility" [ testGroup "/users/" - [ testCase "EmailVisibleIfOnTeam" - . runHttpT manager - $ testUsersEmailVisibleIffExpected defOpts brig galley Opt.EmailVisibleIfOnTeam, - testCase "EmailVisibleToSelf" - . runHttpT manager - $ testUsersEmailVisibleIffExpected defOpts brig galley Opt.EmailVisibleToSelf - ], + $ ((,) <$> [minBound ..] <*> [minBound ..]) + <&> \(viewingUserIs, visibility) -> do + testCase (show (viewingUserIs, visibility)) + . runHttpT manager + $ testUsersEmailVisibleIffExpected defOpts brig galley viewingUserIs visibility, testGroup "/users/:uid" - [ testCase "EmailVisibleIfOnTeam" - . runHttpT manager - $ testGetUserEmailShowsEmailsIffExpected defOpts brig galley Opt.EmailVisibleIfOnTeam, - testCase "EmailVisibleToSelf" - . runHttpT manager - $ testGetUserEmailShowsEmailsIffExpected defOpts brig galley Opt.EmailVisibleToSelf - ] + $ ((,) <$> [minBound ..] <*> [minBound ..]) + <&> \(viewingUserIs, visibility) -> do + testCase (show (viewingUserIs, visibility)) + . runHttpT manager + $ testGetUserEmailShowsEmailsIffExpected defOpts brig galley viewingUserIs visibility ] ] -data UserRelationship = SameTeam | DifferentTeam | NoTeam +-- | The user looking at users is always a team creator; the user looked falls into the +-- different categories enumerated here. +data ViewedUserIs = SameTeam | DifferentTeam | NoTeam -expectEmailVisible :: Opt.EmailVisibility -> UserRelationship -> Bool -expectEmailVisible Opt.EmailVisibleIfOnTeam SameTeam = True -expectEmailVisible Opt.EmailVisibleIfOnTeam DifferentTeam = True -expectEmailVisible Opt.EmailVisibleIfOnTeam NoTeam = False -expectEmailVisible Opt.EmailVisibleToSelf SameTeam = False -expectEmailVisible Opt.EmailVisibleToSelf DifferentTeam = False -expectEmailVisible Opt.EmailVisibleToSelf NoTeam = False +-- | Analog of 'ViewedUserIs' for the viewing user. +data ViewingUserIs = Creator | Member | Guest + deriving (Eq, Show, Enum, Bounded) + +expectEmailVisible :: Opt.EmailVisibility -> ViewingUserIs -> ViewedUserIs -> Bool +expectEmailVisible Opt.EmailVisibleIfOnTeam = \case + _ -> \case + SameTeam -> True + DifferentTeam -> True + NoTeam -> False +expectEmailVisible Opt.EmailVisibleIfOnSameTeam = \case + Creator -> \case + SameTeam -> True + DifferentTeam -> False + NoTeam -> False + Member -> \case + SameTeam -> True + DifferentTeam -> False + NoTeam -> False + Guest -> \case + SameTeam -> False + DifferentTeam -> False + NoTeam -> False +expectEmailVisible Opt.EmailVisibleToSelf = \case + _ -> \case + SameTeam -> False + DifferentTeam -> False + NoTeam -> False jsonField :: FromJSON a => Text -> Value -> Maybe a jsonField f u = u ^? key f >>= maybeFromJSON -testUsersEmailVisibleIffExpected :: Opts -> Brig -> Galley -> Opt.EmailVisibility -> Http () -testUsersEmailVisibleIffExpected opts brig galley visibilitySetting = do - (creatorId, tid) <- createUserWithTeam brig galley - (otherTeamCreatorId, otherTid) <- createUserWithTeam brig galley - userA <- createTeamMember brig galley creatorId tid Team.fullPermissions - userB <- createTeamMember brig galley otherTeamCreatorId otherTid Team.fullPermissions - nonTeamUser <- createUser "joe" brig +testUsersEmailVisibleIffExpected :: Opts -> Brig -> Galley -> ViewingUserIs -> Opt.EmailVisibility -> Http () +testUsersEmailVisibleIffExpected opts brig galley viewingUserIs visibilitySetting = do + (viewerId, userA, userB, nonTeamUser) <- setup brig galley viewingUserIs let uids = C8.intercalate "," $ toByteString' <$> [userId userA, userId userB, userId nonTeamUser] @@ -81,50 +96,46 @@ testUsersEmailVisibleIffExpected opts brig galley visibilitySetting = do expected = Set.fromList [ ( Just $ userId userA, - if expectEmailVisible visibilitySetting SameTeam + if expectEmailVisible visibilitySetting viewingUserIs SameTeam then userEmail userA else Nothing ), ( Just $ userId userB, - if expectEmailVisible visibilitySetting DifferentTeam + if expectEmailVisible visibilitySetting viewingUserIs DifferentTeam then userEmail userB else Nothing ), ( Just $ userId nonTeamUser, - if expectEmailVisible visibilitySetting NoTeam + if expectEmailVisible visibilitySetting viewingUserIs NoTeam then userEmail nonTeamUser else Nothing ) ] let newOpts = opts & Opt.optionSettings . Opt.emailVisibility .~ visibilitySetting withSettingsOverrides newOpts $ do - get (brig . zUser creatorId . path "users" . queryItem "ids" uids) !!! do + get (brig . zUser viewerId . path "users" . queryItem "ids" uids) !!! do const 200 === statusCode const (Just expected) === result where result r = Set.fromList . map (jsonField "id" &&& jsonField "email") <$> responseJsonMaybe r -testGetUserEmailShowsEmailsIffExpected :: Opts -> Brig -> Galley -> Opt.EmailVisibility -> Http () -testGetUserEmailShowsEmailsIffExpected opts brig galley visibilitySetting = do - (creatorId, tid) <- createUserWithTeam brig galley - (otherTeamCreatorId, otherTid) <- createUserWithTeam brig galley - userA <- createTeamMember brig galley creatorId tid Team.fullPermissions - userB <- createTeamMember brig galley otherTeamCreatorId otherTid Team.fullPermissions - nonTeamUser <- createUser "joe" brig +testGetUserEmailShowsEmailsIffExpected :: Opts -> Brig -> Galley -> ViewingUserIs -> Opt.EmailVisibility -> Http () +testGetUserEmailShowsEmailsIffExpected opts brig galley viewingUserIs visibilitySetting = do + (viewerId, userA, userB, nonTeamUser) <- setup brig galley viewingUserIs let expectations :: [(UserId, Maybe Email)] expectations = [ ( userId userA, - if expectEmailVisible visibilitySetting SameTeam + if expectEmailVisible visibilitySetting viewingUserIs SameTeam then userEmail userA else Nothing ), ( userId userB, - if expectEmailVisible visibilitySetting DifferentTeam + if expectEmailVisible visibilitySetting viewingUserIs DifferentTeam then userEmail userB else Nothing ), ( userId nonTeamUser, - if expectEmailVisible visibilitySetting NoTeam + if expectEmailVisible visibilitySetting viewingUserIs NoTeam then userEmail nonTeamUser else Nothing ) @@ -132,9 +143,22 @@ testGetUserEmailShowsEmailsIffExpected opts brig galley visibilitySetting = do let newOpts = opts & Opt.optionSettings . Opt.emailVisibility .~ visibilitySetting withSettingsOverrides newOpts $ do forM_ expectations $ \(uid, expectedEmail) -> - get (brig . zUser creatorId . paths ["users", toByteString' uid]) !!! do + get (brig . zUser viewerId . paths ["users", toByteString' uid]) !!! do const 200 === statusCode const expectedEmail === emailResult where emailResult :: Response (Maybe LByteString) -> Maybe Email emailResult r = responseJsonMaybe r >>= jsonField "email" + +setup :: Brig -> Galley -> ViewingUserIs -> Http (UserId, User, User, User) +setup brig galley viewingUserIs = do + (creatorId, tid) <- createUserWithTeam brig galley + (otherTeamCreatorId, otherTid) <- createUserWithTeam brig galley + userA <- createTeamMember brig galley creatorId tid Team.fullPermissions + userB <- createTeamMember brig galley otherTeamCreatorId otherTid Team.fullPermissions + nonTeamUser <- createUser "joe" brig + viewerId <- case viewingUserIs of + Creator -> pure creatorId + Member -> userId <$> createTeamMember brig galley creatorId tid (Team.rolePermissions Team.RoleOwner) + Guest -> userId <$> createTeamMember brig galley creatorId tid (Team.rolePermissions Team.RoleExternalPartner) + pure (viewerId, userA, userB, nonTeamUser) diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index a904bf5354a..b9af95c2332 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -14,6 +14,7 @@ import Control.Arrow ((&&&)) import Control.Lens hiding ((.=)) import Data.Aeson import Data.ByteString.Conversion +import Data.Handle (fromHandle) import Data.Id hiding (client) import Data.Json.Util (toUTCTimeMillis) import qualified Data.Text.Ascii as Ascii diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 27552ba8a31..25788aaa46e 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -117,7 +117,7 @@ createTeamConv g tid u us mtimer = do let tinfo = Just $ ConvTeamInfo tid False let conv = NewConvUnmanaged $ - NewConv us Nothing (Set.fromList []) Nothing tinfo mtimer Nothing roleNameWireAdmin + NewConv (makeIdOpaque <$> us) Nothing (Set.fromList []) Nothing tinfo mtimer Nothing roleNameWireAdmin r <- post ( g @@ -139,7 +139,7 @@ createManagedConv g tid u us mtimer = do let tinfo = Just $ ConvTeamInfo tid True let conv = NewConvManaged $ - NewConv us Nothing (Set.fromList []) Nothing tinfo mtimer Nothing roleNameWireAdmin + NewConv (makeIdOpaque <$> us) Nothing (Set.fromList []) Nothing tinfo mtimer Nothing roleNameWireAdmin r <- post ( g diff --git a/services/brig/test/integration/API/User.hs b/services/brig/test/integration/API/User.hs index a62b0427ffa..186e0b664d3 100644 --- a/services/brig/test/integration/API/User.hs +++ b/services/brig/test/integration/API/User.hs @@ -5,7 +5,6 @@ import qualified API.User.Auth import qualified API.User.Client import qualified API.User.Connection import qualified API.User.Handles -import qualified API.User.Onboarding import qualified API.User.PasswordReset import qualified API.User.Property import qualified API.User.RichInfo @@ -33,7 +32,6 @@ tests conf p b c ch g n aws = do API.User.Auth.tests conf p z b g n, API.User.Connection.tests cl at conf p b c g, API.User.Handles.tests cl at conf p b c g, - API.User.Onboarding.tests cl at conf p b c g, API.User.PasswordReset.tests cl at conf p b c g, API.User.Property.tests cl at conf p b c g, API.User.RichInfo.tests cl at conf p b c g diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 3d4c21bd0d0..5acab82df30 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -357,8 +357,11 @@ testActivateWithExpiry brig timeout = do testNonExistingUser :: Brig -> Http () testNonExistingUser brig = do - uid <- liftIO $ Id <$> UUID.nextRandom - get (brig . paths ["users", pack $ show uid] . zUser uid) + findingOne <- liftIO $ Id <$> UUID.nextRandom + foundOne <- liftIO $ Id <$> UUID.nextRandom + get (brig . paths ["users", pack $ show foundOne] . zUser findingOne) + !!! const 404 === statusCode + get (brig . paths ["users", pack $ show foundOne] . zUser foundOne) !!! const 404 === statusCode testExistingUser :: Brig -> Http () diff --git a/services/brig/test/integration/API/User/Auth.hs b/services/brig/test/integration/API/User/Auth.hs index f0a4e63da76..71cb53734da 100644 --- a/services/brig/test/integration/API/User/Auth.hs +++ b/services/brig/test/integration/API/User/Auth.hs @@ -26,6 +26,7 @@ import Data.Aeson.Lens import qualified Data.ByteString as BS import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy +import Data.Handle (Handle (Handle)) import Data.Id import Data.Misc (PlainTextPassword (..)) import Data.Proxy diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index 5a09f1265cd..b39f4abb256 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -11,6 +11,7 @@ import Control.Lens hiding ((#)) import Data.Aeson import Data.Aeson.Lens import Data.ByteString.Conversion +import Data.Handle (Handle (Handle)) import Data.Id hiding (client) import qualified Data.List1 as List1 import qualified Data.UUID as UUID diff --git a/services/brig/test/integration/API/User/Onboarding.hs b/services/brig/test/integration/API/User/Onboarding.hs deleted file mode 100644 index f17aa12bca6..00000000000 --- a/services/brig/test/integration/API/User/Onboarding.hs +++ /dev/null @@ -1,67 +0,0 @@ -module API.User.Onboarding (tests) where - -import API.User.Util -import Bilge hiding (accept, timeout) -import qualified Brig.Options as Opt -import Brig.Types -import Brig.Types.Intra -import Imports -import Test.Tasty hiding (Timeout) -import Util - -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree -tests _cl _at _conf p b _c _g = - testGroup - "onboarding" - [ test p "post /onboarding/v3 - 200" $ testOnboarding b - ] - -testOnboarding :: Brig -> Http () -testOnboarding brig = do - usr1 <- randomUser brig - let uid1 = userId usr1 - em1 = fromEmail $ fromMaybe (error "Should have an email!") (userEmail usr1) - (uid2, phn2) <- createRandomPhoneUser brig - -- We do not match on emails (nor on other phone numbers obviously) - ab2 <- liftIO $ toAddressBook [("random1", [em1]), ("random2", ["+0123456789"])] - let expect2 = toMatchingResult [] - uploadAddressBook brig uid1 ab2 expect2 - -- Simple test with a single user, single entry - ab3 <- liftIO $ toAddressBook [("random", [fromPhone phn2])] - let expect3 = toMatchingResult [(uid2, "random")] - uploadAddressBook brig uid1 ab3 expect3 - -- Ensure we really got auto-connected - assertConnections brig uid1 [ConnectionStatus uid1 uid2 Accepted] - assertConnections brig uid2 [ConnectionStatus uid2 uid1 Accepted] - -- Ensure we only auto-connect once - uploadAddressBook brig uid1 ab3 (toMatchingResult []) - -- Single user, multiple entries - (uid4, ph4) <- createRandomPhoneUser brig - ab4 <- - liftIO $ - toAddressBook - [ ("first", [fromPhone ph4]), - ("second", [fromPhone ph4]) - ] - let expect4 = toMatchingResult [(uid4, "first"), (uid4, "second")] - uploadAddressBook brig uid1 ab4 expect4 - -- Multiple user, multiple entries - (uid5, ph5) <- createRandomPhoneUser brig - (uid6, ph6) <- createRandomPhoneUser brig - ab5 <- - liftIO $ - toAddressBook - [ ("first", [fromPhone ph5]), - ("second", [fromPhone ph5]), - ("third", [fromPhone ph6]), - ("fourth", [fromPhone ph6]) - ] - let expect5 = - toMatchingResult - [ (uid5, "first"), - (uid5, "second"), - (uid6, "third"), - (uid6, "fourth") - ] - -- Check upload and results - uploadAddressBook brig uid1 ab5 expect5 diff --git a/services/brig/test/integration/API/User/Util.hs b/services/brig/test/integration/API/User/Util.hs index ce7eab5cebb..108b8144d06 100644 --- a/services/brig/test/integration/API/User/Util.hs +++ b/services/brig/test/integration/API/User/Util.hs @@ -21,10 +21,8 @@ import Data.Misc (PlainTextPassword (..)) import Data.Range (unsafeRange) import qualified Data.Set as Set import qualified Data.Text.Ascii as Ascii -import qualified Data.Text.Encoding as T import qualified Data.Vector as Vec import Imports -import OpenSSL.EVP.Digest (digestBS, getDigestByName) import Test.Tasty.HUnit import Util @@ -250,40 +248,6 @@ downloadAsset c usr ast = . zConn "conn" ) -uploadAddressBook :: HasCallStack => Brig -> UserId -> AddressBook -> MatchingResult -> Http () -uploadAddressBook b u a m = - post - ( b - . path "/onboarding/v3" - . contentJson - . zUser u - . body (RequestBodyLBS $ encode a) - ) - !!! do - const 200 === statusCode - const (Just (f m)) === (fmap f . responseJsonMaybe) - where - f :: MatchingResult -> MatchingResult - f (MatchingResult x y) = MatchingResult (sort x) (sort y) - --- Builds expectations on the matched users/cards -toMatchingResult :: [(UserId, Text)] -> MatchingResult -toMatchingResult xs = - MatchingResult - (map (\(u, c) -> Match u (Just (CardId c)) [CardId c]) xs) - (Set.toList $ Set.fromList (map fst xs)) - --- Hashes each entry and builds an appropriate address book -toAddressBook :: [(Text, [Text])] -> IO AddressBook -toAddressBook xs = do - Just sha <- liftIO $ getDigestByName "SHA256" - return . AddressBook $ fmap (toCard sha) xs - where - toCard sha (cardId, entries) = - Card - (Just $ CardId cardId) - (map (Entry . digestBS sha . T.encodeUtf8) entries) - requestLegalHoldDevice :: Brig -> UserId -> UserId -> LastPrekey -> Http ResponseLBS requestLegalHoldDevice brig requesterId targetUserId lastPrekey' = post $ diff --git a/services/cannon/src/Cannon/API.hs b/services/cannon/src/Cannon/API.hs index 6d81ab6b3cc..ae9d9811e4b 100644 --- a/services/cannon/src/Cannon/API.hs +++ b/services/cannon/src/Cannon/API.hs @@ -27,7 +27,7 @@ import qualified System.Logger.Class as LC sitemap :: Routes ApiBuilder Cannon () sitemap = do - get "/await" (continue await) $ + get "/await" (continue awaitH) $ header "Z-User" .&. header "Z-Connection" .&. opt (query "client") @@ -43,37 +43,37 @@ sitemap = do optional description "Client ID" response 426 "Upgrade required" end - get "/await/api-docs" (continue docs) $ + get "/await/api-docs" (continue docsH) $ accept "application" "json" .&. query "base_url" - post "/i/push/:user/:conn" (continue push) $ + post "/i/push/:user/:conn" (continue pushH) $ capture "user" .&. capture "conn" .&. request - post "/i/bulkpush" (continue bulkpush) $ + post "/i/bulkpush" (continue bulkpushH) $ request - head "/i/presences/:uid/:conn" (continue checkPresence) $ + head "/i/presences/:uid/:conn" (continue checkPresenceH) $ param "uid" .&. param "conn" get "/i/status" (continue (const $ return empty)) true head "/i/status" (continue (const $ return empty)) true -docs :: Media "application" "json" ::: Text -> Cannon Response -docs (_ ::: url) = do +docsH :: Media "application" "json" ::: Text -> Cannon Response +docsH (_ ::: url) = do let doc = mkSwaggerApi url [] sitemap return $ json doc -push :: UserId ::: ConnId ::: Request -> Cannon Response -push (user ::: conn ::: req) = +pushH :: UserId ::: ConnId ::: Request -> Cannon Response +pushH (user ::: conn ::: req) = singlePush (readBody req) (PushTarget user conn) >>= \case PushStatusOk -> return empty PushStatusGone -> return $ errorRs status410 "general" "client gone" -- | Parse the entire list of notifcations and targets, then call 'singlePush' on the each of them -- in order. -bulkpush :: Request -> Cannon Response -bulkpush req = json <$> (parseBody' (JsonRequest req) >>= bulkpush') +bulkpushH :: Request -> Cannon Response +bulkpushH req = json <$> (parseBody' (JsonRequest req) >>= bulkpush) -- | The typed part of 'bulkpush'. -bulkpush' :: BulkPushRequest -> Cannon BulkPushResponse -bulkpush' (BulkPushRequest notifs) = +bulkpush :: BulkPushRequest -> Cannon BulkPushResponse +bulkpush (BulkPushRequest notifs) = BulkPushResponse . mconcat . zipWith compileResp notifs <$> (uncurry doNotif `mapM` notifs) where doNotif :: Notification -> [PushTarget] -> Cannon [PushStatus] @@ -102,16 +102,16 @@ singlePush notification (PushTarget usrid conid) = do (sendMsg b k x >> return PushStatusOk) `catchAll` const (terminate k x >> return PushStatusGone) -checkPresence :: UserId ::: ConnId -> Cannon Response -checkPresence (u ::: c) = do +checkPresenceH :: UserId ::: ConnId -> Cannon Response +checkPresenceH (u ::: c) = do e <- wsenv registered <- runWS e $ isRemoteRegistered u c if registered then return empty else return $ errorRs status404 "not-found" "presence not registered" -await :: UserId ::: ConnId ::: Maybe ClientId ::: Request -> Cannon Response -await (u ::: a ::: c ::: r) = do +awaitH :: UserId ::: ConnId ::: Maybe ClientId ::: Request -> Cannon Response +awaitH (u ::: a ::: c ::: r) = do e <- wsenv case websocketsApp wsoptions (wsapp (mkKey u a) c e) r of Nothing -> return $ errorRs status426 "request-error" "websocket upgrade required" diff --git a/services/federator/Makefile b/services/federator/Makefile new file mode 100644 index 00000000000..e8781c4ae26 --- /dev/null +++ b/services/federator/Makefile @@ -0,0 +1,24 @@ +LANG := en_US.UTF-8 +SHELL := /usr/bin/env bash +NAME := federator + +default: fast + +init: + mkdir -p ../../dist + +.PHONY: install +install: init + stack install . --pedantic --test --bench --no-run-benchmarks --local-bin-path=dist $(WIRE_STACK_OPTIONS) + +.PHONY: fast +fast: init + stack install . --pedantic --test --bench --no-run-benchmarks --local-bin-path=dist --fast $(WIRE_STACK_OPTIONS) + +.PHONY: compile +compile: + stack build . --fast --test --bench --no-run-benchmarks --no-copy-bins + +.PHONY: run +run: fast + ./dist/federator -c federator.integration.yaml diff --git a/services/federator/README.md b/services/federator/README.md new file mode 100644 index 00000000000..1aecc44810c --- /dev/null +++ b/services/federator/README.md @@ -0,0 +1,3 @@ +## Federator + +The connector between different wire-server installations who trust each other do differing extents. diff --git a/services/federator/dist b/services/federator/dist new file mode 120000 index 00000000000..5f364310086 --- /dev/null +++ b/services/federator/dist @@ -0,0 +1 @@ +../../dist/ \ No newline at end of file diff --git a/services/federator/exec/Main.hs b/services/federator/exec/Main.hs new file mode 100644 index 00000000000..1ce833bc67a --- /dev/null +++ b/services/federator/exec/Main.hs @@ -0,0 +1,12 @@ +module Main (main) where + +import Federator.Run (run) +import Imports +import Util.Options (getOptions) + +main :: IO () +main = do + let desc = "Federation Service" + defaultPath = "/etc/wire/federator/conf/federator.yaml" + options <- getOptions desc Nothing defaultPath + run options diff --git a/services/federator/federator.integration.yaml b/services/federator/federator.integration.yaml new file mode 100644 index 00000000000..1fdaab5cdba --- /dev/null +++ b/services/federator/federator.integration.yaml @@ -0,0 +1,6 @@ +federator: + host: 0.0.0.0 + port: 8097 + +logLevel: Debug +logNetStrings: false diff --git a/services/federator/package.yaml b/services/federator/package.yaml new file mode 100644 index 00000000000..892fe7194c8 --- /dev/null +++ b/services/federator/package.yaml @@ -0,0 +1,54 @@ +defaults: + local: ../../package-defaults.yaml +name: federator +version: '1.0.0' +synopsis: Federation Service +category: Network +author: Wire Swiss GmbH +maintainer: Wire Swiss GmbH +copyright: (c) 2020 Wire Swiss GmbH +license: AGPL-3 +dependencies: +- aeson +- base +- bilge +- brig-types +- bytestring-conversion +- data-default +- email-validate +- errors +- exceptions +- extended +- galley-types +- imports +- lens +- metrics-core +- metrics-wai +- QuickCheck +- resourcet +- servant +- servant-mock +- servant-server +- servant-swagger +- string-conversions +- text +- tinylog +- types-common +- uuid +- wai +- wai-utilities +- warp +library: + source-dirs: src +executables: + federator: + main: Main.hs + source-dirs: exec + ghc-options: + - -threaded + - -with-rtsopts=-N1 + - -with-rtsopts=-T + - -rtsopts + dependencies: + - base + - federator diff --git a/services/federator/src/Federator/API.hs b/services/federator/src/Federator/API.hs new file mode 100644 index 00000000000..a7e7a077829 --- /dev/null +++ b/services/federator/src/Federator/API.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Federator.API where + +import Brig.Types.Client.Prekey +import Brig.Types.Test.Arbitrary () +import Data.Aeson.TH (deriveJSON) +import Data.Handle (Handle (..)) +import Data.Id (UserId) +import Data.Qualified +import Federator.Util +import Imports +import Servant.API +import Servant.API.Generic +import Test.QuickCheck + +data API route + = API + { _gapiSearch :: + route + :- "i" + :> "search" + -- QUESTION: what exactly should the query be? text + domain? + :> QueryParam' [Required, Strict] "q" (Qualified Handle) + :> Get '[JSON] FUser, + _gapiPrekeys :: + route + :- "i" + :> "users" + :> Capture "fqu" (Qualified UserId) + :> "prekeys" + :> Get '[JSON] PrekeyBundle + } + deriving (Generic) + +-- curl http://localhost:8097/i/search?q=wef@a.com; curl http://localhost:8097/i/users/`uuid`@example.com/prekeys + +---------------------------------------------------------------------- +-- TODO: add roundtrip tests for *HttpApiData, *JSON, ... +-- +-- TODO: the client ids in the 'PrekeyBundle' aren't really needed here. do we want to make a +-- new type for that, then? + +data FUser + = FUser + { _fuGlobalHandle :: !(Qualified Handle), + _fuFQU :: !(Qualified UserId) + } + deriving (Eq, Show, Generic) + +deriveJSON (wireJsonOptions "_fu") ''FUser + +instance Arbitrary FUser where + arbitrary = FUser <$> arbitrary <*> arbitrary + +---------------------------------------------------------------------- +-- ORPHANS + +instance Arbitrary PrekeyBundle where + arbitrary = PrekeyBundle <$> arbitrary <*> arbitrary + +instance Arbitrary ClientPrekey where + arbitrary = ClientPrekey <$> arbitrary <*> arbitrary diff --git a/services/federator/src/Federator/App.hs b/services/federator/src/Federator/App.hs new file mode 100644 index 00000000000..581ee125e19 --- /dev/null +++ b/services/federator/src/Federator/App.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} + +module Federator.App + ( app, + ) +where + +import Data.Proxy +import qualified Federator.API as API +import Federator.Types +import Network.Wai +import Servant.API.Generic +import Servant.Mock +import Servant.Server + +app :: Env -> Application +app _ = serve api (mock api Proxy) + where + api = Proxy @(ToServantApi API.API) diff --git a/services/federator/src/Federator/Options.hs b/services/federator/src/Federator/Options.hs new file mode 100644 index 00000000000..bb4d3ec4024 --- /dev/null +++ b/services/federator/src/Federator/Options.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Federator.Options where + +import Data.Aeson +import Imports +import System.Logger.Extended +import Util.Options + +data Opts + = Opts + { -- | Host and port + federator :: Endpoint, + -- | Log level (Debug, Info, etc) + logLevel :: Level, + -- | Use netstrings encoding (see ) + logNetStrings :: Maybe (Last Bool), + -- | Logformat to use + logFormat :: !(Maybe (Last LogFormat)) + } + deriving (Show, Generic) + +instance FromJSON Opts diff --git a/services/federator/src/Federator/Run.hs b/services/federator/src/Federator/Run.hs new file mode 100644 index 00000000000..d2884f486b1 --- /dev/null +++ b/services/federator/src/Federator/Run.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} + +module Federator.Run + ( run, + mkApp, + + -- * App Environment + newEnv, + closeEnv, + + -- * App Monad + AppT, + AppIO, + runAppT, + runAppResourceT, + ) +where + +import Bilge (RequestId (unRequestId)) +import Bilge.RPC (HasRequestId (..)) +import Control.Error +import Control.Lens ((^.), view) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Trans.Resource +import Data.Default (def) +import qualified Data.Metrics.Middleware as Metrics +import Data.Text (unpack) +import qualified Federator.App as App +import Federator.Options as Opt +import Federator.Types +import Imports +import Network.Wai (Application) +import qualified Network.Wai.Handler.Warp as Warp +import Network.Wai.Utilities.Server as Server +import System.Logger.Class as LC +import qualified System.Logger.Extended as Log +import Util.Options + +run :: Opts -> IO () +run opts = do + (app, env) <- mkApp opts + settings <- Server.newSettings (server env) + Warp.runSettings settings app + where + endpoint = federator opts + server env = defaultServer (unpack $ endpoint ^. epHost) (endpoint ^. epPort) (env ^. applog) (env ^. metrics) + +mkApp :: Opts -> IO (Application, Env) +mkApp opts = do + env <- newEnv opts + pure (App.app env, env) + +------------------------------------------------------------------------------- +-- Environment + +newEnv :: Opts -> IO Env +newEnv o = do + _metrics <- Metrics.metrics + _applog <- Log.mkLogger (Opt.logLevel o) (Opt.logNetStrings o) (Opt.logFormat o) + let _requestId = def + return Env {..} + +closeEnv :: Env -> IO () +closeEnv e = do + Log.flush $ e ^. applog + Log.close $ e ^. applog + +------------------------------------------------------------------------------- +-- App Monad + +-- FUTUREWORK: this code re-occurs in every service. introduce 'MkAppT' in types-common that +-- takes 'Env' as one more argument. +newtype AppT m a + = AppT + { unAppT :: ReaderT Env m a + } + deriving + ( Functor, + Applicative, + Monad, + MonadIO, + MonadThrow, + MonadCatch, + MonadMask, + MonadReader Env + ) + +type AppIO = AppT IO + +instance MonadIO m => LC.MonadLogger (AppT m) where + log l m = do + g <- view applog + r <- view requestId + Log.log g l $ field "request" (unRequestId r) ~~ m + +instance MonadIO m => LC.MonadLogger (ExceptT err (AppT m)) where + log l m = lift (LC.log l m) + +instance Monad m => HasRequestId (AppT m) where + getRequestId = view requestId + +instance MonadUnliftIO m => MonadUnliftIO (AppT m) where + withRunInIO inner = + AppT $ ReaderT $ \r -> + withRunInIO $ \runner -> + inner (runner . flip runReaderT r . unAppT) + +runAppT :: Env -> AppT m a -> m a +runAppT e (AppT ma) = runReaderT ma e + +runAppResourceT :: ResourceT AppIO a -> AppIO a +runAppResourceT ma = do + e <- ask + liftIO . runResourceT $ transResourceT (runAppT e) ma diff --git a/services/federator/src/Federator/Types.hs b/services/federator/src/Federator/Types.hs new file mode 100644 index 00000000000..7d638575834 --- /dev/null +++ b/services/federator/src/Federator/Types.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} + +module Federator.Types where + +import Bilge (RequestId) +import Control.Lens (makeLenses) +import Data.Metrics (Metrics) +import qualified System.Logger.Class as LC + +data Env + = Env + { _metrics :: Metrics, + _applog :: LC.Logger, + _requestId :: RequestId + } + +makeLenses ''Env diff --git a/services/federator/src/Federator/Util.hs b/services/federator/src/Federator/Util.hs new file mode 100644 index 00000000000..cae752aad15 --- /dev/null +++ b/services/federator/src/Federator/Util.hs @@ -0,0 +1,22 @@ +module Federator.Util + ( wireJsonOptions, + ) +where + +import Data.Aeson as Aeson +import Imports + +dropPrefix :: String -> String -> Maybe String +dropPrefix pfx str = + if length pfx > length str + then Nothing + else case splitAt (length pfx) str of + (pfx', sfx) -> + if pfx' /= pfx + then Nothing + else Just sfx + +-- | This is a partial function; totality of all calls must be verified by roundtrip tests on +-- the aeson instances involved. +wireJsonOptions :: String -> Options +wireJsonOptions pfx = defaultOptions {fieldLabelModifier = fromJust . dropPrefix pfx . fmap toLower} diff --git a/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index 1b5770ab50b..ad223669fc9 100644 --- a/services/galley/src/Galley/API.hs +++ b/services/galley/src/Galley/API.hs @@ -3,7 +3,7 @@ module Galley.API where import Brig.Types.Team.LegalHold import Data.Aeson (encode) import Data.ByteString.Conversion (fromByteString, fromList) -import Data.Id (ConvId, UserId) +import Data.Id (ConvId, OpaqueUserId) import qualified Data.Predicate as P import Data.Range import qualified Data.Set as Set @@ -43,7 +43,7 @@ import Network.Wai.Utilities.ZAuth sitemap :: Routes ApiBuilder Galley () sitemap = do - post "/teams" (continue createNonBindingTeam) $ + post "/teams" (continue createNonBindingTeamH) $ zauthUserId .&. zauthConnId .&. jsonRequest @NonBindingNewTeam @@ -54,7 +54,7 @@ sitemap = do description "JSON body" response 201 "Team ID as `Location` header value" end errorResponse Error.notConnected - put "/teams/:tid" (continue updateTeam) $ + put "/teams/:tid" (continue updateTeamH) $ zauthUserId .&. zauthConnId .&. capture "tid" @@ -70,7 +70,7 @@ sitemap = do errorResponse (Error.operationDenied SetTeamData) -- - get "/teams" (continue getManyTeams) $ + get "/teams" (continue getManyTeamsH) $ zauthUserId .&. opt (query "ids" ||| query "start") .&. def (unsafeRange 100) (query "size") @@ -81,7 +81,7 @@ sitemap = do response 200 "Teams list" end -- - get "/teams/:tid" (continue getTeam) $ + get "/teams/:tid" (continue getTeamH) $ zauthUserId .&. capture "tid" .&. accept "application" "json" @@ -94,12 +94,11 @@ sitemap = do errorResponse Error.teamNotFound -- - delete "/teams/:tid" (continue deleteTeam) $ + delete "/teams/:tid" (continue deleteTeamH) $ zauthUserId .&. zauthConnId .&. capture "tid" - .&. request - .&. opt (contentType "application" "json") + .&. optionalJsonRequest @TeamDeleteData .&. accept "application" "json" document "DELETE" "deleteTeam" $ do summary "Delete a team" @@ -116,7 +115,7 @@ sitemap = do errorResponse Error.teamNotFound -- - get "/teams/:tid/conversations/roles" (continue getTeamConversationRoles) $ + get "/teams/:tid/conversations/roles" (continue getTeamConversationRolesH) $ zauthUserId .&. capture "tid" .&. accept "application" "json" @@ -130,7 +129,7 @@ sitemap = do errorResponse Error.noTeamMember -- - get "/teams/:tid/members" (continue getTeamMembers) $ + get "/teams/:tid/members" (continue getTeamMembersH) $ zauthUserId .&. capture "tid" .&. accept "application" "json" @@ -143,7 +142,7 @@ sitemap = do errorResponse Error.noTeamMember -- - get "/teams/:tid/members/:uid" (continue getTeamMember) $ + get "/teams/:tid/members/:uid" (continue getTeamMemberH) $ zauthUserId .&. capture "tid" .&. capture "uid" @@ -160,7 +159,7 @@ sitemap = do errorResponse Error.teamMemberNotFound -- - post "/teams/:tid/members" (continue addTeamMember) $ + post "/teams/:tid/members" (continue addTeamMemberH) $ zauthUserId .&. zauthConnId .&. capture "tid" @@ -179,13 +178,12 @@ sitemap = do errorResponse Error.tooManyTeamMembers -- - delete "/teams/:tid/members/:uid" (continue deleteTeamMember) $ + delete "/teams/:tid/members/:uid" (continue deleteTeamMemberH) $ zauthUserId .&. zauthConnId .&. capture "tid" .&. capture "uid" - .&. request - .&. opt (contentType "application" "json") + .&. optionalJsonRequest @TeamMemberDeleteData .&. accept "application" "json" document "DELETE" "deleteTeamMember" $ do summary "Remove an existing team member" @@ -202,7 +200,7 @@ sitemap = do errorResponse Error.reAuthFailed -- - put "/teams/:tid/members" (continue updateTeamMember) $ + put "/teams/:tid/members" (continue updateTeamMemberH) $ zauthUserId .&. zauthConnId .&. capture "tid" @@ -219,7 +217,7 @@ sitemap = do errorResponse (Error.operationDenied SetMemberPermissions) -- - get "/teams/:tid/conversations" (continue getTeamConversations) $ + get "/teams/:tid/conversations" (continue getTeamConversationsH) $ zauthUserId .&. capture "tid" .&. accept "application" "json" @@ -233,7 +231,7 @@ sitemap = do errorResponse (Error.operationDenied GetTeamConversations) -- - get "/teams/:tid/conversations/:cid" (continue getTeamConversation) $ + get "/teams/:tid/conversations/:cid" (continue getTeamConversationH) $ zauthUserId .&. capture "tid" .&. capture "cid" @@ -251,7 +249,7 @@ sitemap = do errorResponse (Error.operationDenied GetTeamConversations) -- - delete "/teams/:tid/conversations/:cid" (continue deleteTeamConversation) $ + delete "/teams/:tid/conversations/:cid" (continue deleteTeamConversationH) $ zauthUserId .&. zauthConnId .&. capture "tid" @@ -273,37 +271,37 @@ sitemap = do -- abandon it entirely. get "/teams/api-docs" (continue . const . pure . json $ swagger) $ accept "application" "json" - post "/teams/:tid/legalhold/settings" (continue LegalHold.createSettings) $ + post "/teams/:tid/legalhold/settings" (continue LegalHold.createSettingsH) $ zauthUserId .&. capture "tid" .&. jsonRequest @NewLegalHoldService .&. accept "application" "json" - get "/teams/:tid/legalhold/settings" (continue LegalHold.getSettings) $ + get "/teams/:tid/legalhold/settings" (continue LegalHold.getSettingsH) $ zauthUserId .&. capture "tid" .&. accept "application" "json" - delete "/teams/:tid/legalhold/settings" (continue LegalHold.removeSettings) $ + delete "/teams/:tid/legalhold/settings" (continue LegalHold.removeSettingsH) $ zauthUserId .&. capture "tid" .&. jsonRequest @RemoveLegalHoldSettingsRequest .&. accept "application" "json" - get "/teams/:tid/legalhold/:uid" (continue LegalHold.getUserStatus) $ + get "/teams/:tid/legalhold/:uid" (continue LegalHold.getUserStatusH) $ zauthUserId .&. capture "tid" .&. capture "uid" .&. accept "application" "json" - post "/teams/:tid/legalhold/:uid" (continue LegalHold.requestDevice) $ + post "/teams/:tid/legalhold/:uid" (continue LegalHold.requestDeviceH) $ zauthUserId .&. capture "tid" .&. capture "uid" .&. accept "application" "json" - delete "/teams/:tid/legalhold/:uid" (continue LegalHold.disableForUser) $ + delete "/teams/:tid/legalhold/:uid" (continue LegalHold.disableForUserH) $ zauthUserId .&. capture "tid" .&. capture "uid" .&. jsonRequest @DisableLegalHoldForUserRequest .&. accept "application" "json" - put "/teams/:tid/legalhold/:uid/approve" (continue LegalHold.approveDevice) $ + put "/teams/:tid/legalhold/:uid/approve" (continue LegalHold.approveDeviceH) $ zauthUserId .&. capture "tid" .&. capture "uid" @@ -312,12 +310,12 @@ sitemap = do .&. accept "application" "json" --- - get "/bot/conversation" (continue getBotConversation) $ + get "/bot/conversation" (continue getBotConversationH) $ zauth ZAuthBot .&> zauthBotId .&. zauthConvId .&. accept "application" "json" - post "/bot/messages" (continue postBotMessage) $ + post "/bot/messages" (continue postBotMessageH) $ zauth ZAuthBot .&> zauthBotId .&. zauthConvId @@ -326,7 +324,7 @@ sitemap = do .&. accept "application" "json" -- - get "/conversations/:cnv" (continue getConversation) $ + get "/conversations/:cnv" (continue getConversationH) $ zauthUserId .&. capture "cnv" .&. accept "application" "json" @@ -339,7 +337,7 @@ sitemap = do errorResponse Error.convAccessDenied -- - get "/conversations/:cnv/roles" (continue getConversationRoles) $ + get "/conversations/:cnv/roles" (continue getConversationRolesH) $ zauthUserId .&. capture "cnv" .&. accept "application" "json" @@ -352,7 +350,7 @@ sitemap = do errorResponse Error.convNotFound --- - get "/conversations/ids" (continue getConversationIds) $ + get "/conversations/ids" (continue getConversationIdsH) $ zauthUserId .&. opt (query "start") .&. def (unsafeRange 1000) (query "size") @@ -369,7 +367,7 @@ sitemap = do returns (ref Model.conversationIds) --- - get "/conversations" (continue getConversations) $ + get "/conversations" (continue getConversationsH) $ zauthUserId .&. opt (query "ids" ||| query "start") .&. def (unsafeRange 100) (query "size") @@ -391,7 +389,7 @@ sitemap = do description "Max. number of conversations to return" --- - post "/conversations" (continue createGroupConversation) $ + post "/conversations" (continue createGroupConversationH) $ zauthUserId .&. zauthConnId .&. jsonRequest @NewConvUnmanaged @@ -406,9 +404,7 @@ sitemap = do errorResponse (Error.operationDenied CreateConversation) --- - post - "/conversations/self" - (continue createSelfConversation) + post "/conversations/self" (continue createSelfConversationH) $ zauthUserId document "POST" "createSelfConversation" $ do summary "Create a self-conversation" @@ -416,7 +412,7 @@ sitemap = do response 201 "Conversation created" end --- - post "/conversations/one2one" (continue createOne2OneConversation) $ + post "/conversations/one2one" (continue createOne2OneConversationH) $ zauthUserId .&. zauthConnId .&. jsonRequest @NewConvUnmanaged @@ -429,7 +425,7 @@ sitemap = do errorResponse Error.noManagedTeamConv --- - put "/conversations/:cnv/name" (continue updateConversationName) $ + put "/conversations/:cnv/name" (continue updateConversationNameH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -444,7 +440,7 @@ sitemap = do errorResponse Error.convNotFound --- - put "/conversations/:cnv" (continue updateConversationDeprecated) $ + put "/conversations/:cnv" (continue updateConversationDeprecatedH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -459,7 +455,7 @@ sitemap = do errorResponse Error.convNotFound --- - post "/conversations/:cnv/join" (continue joinConversationById) $ + post "/conversations/:cnv/join" (continue joinConversationByIdH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -473,7 +469,7 @@ sitemap = do errorResponse Error.convNotFound --- - post "/conversations/code-check" (continue checkReusableCode) $ + post "/conversations/code-check" (continue checkReusableCodeH) $ jsonRequest @ConversationCode document "POST" "checkConversationCode" $ do summary "Check validity of a conversation code" @@ -481,7 +477,7 @@ sitemap = do body (ref Model.conversationCode) $ description "JSON body" errorResponse Error.codeNotFound - post "/conversations/join" (continue joinConversationByReusableCode) $ + post "/conversations/join" (continue joinConversationByReusableCodeH) $ zauthUserId .&. zauthConnId .&. jsonRequest @ConversationCode @@ -496,7 +492,7 @@ sitemap = do errorResponse Error.tooManyMembers --- - post "/conversations/:cnv/code" (continue addCode) $ + post "/conversations/:cnv/code" (continue addCodeH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -512,7 +508,7 @@ sitemap = do errorResponse Error.invalidAccessOp --- - delete "/conversations/:cnv/code" (continue rmCode) $ + delete "/conversations/:cnv/code" (continue rmCodeH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -526,7 +522,7 @@ sitemap = do errorResponse Error.invalidAccessOp --- - get "/conversations/:cnv/code" (continue getCode) $ + get "/conversations/:cnv/code" (continue getCodeH) $ zauthUserId .&. capture "cnv" document "GET" "getConversationCode" $ do @@ -539,7 +535,7 @@ sitemap = do errorResponse Error.invalidAccessOp --- - put "/conversations/:cnv/access" (continue updateConversationAccess) $ + put "/conversations/:cnv/access" (continue updateConversationAccessH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -561,7 +557,7 @@ sitemap = do errorResponse Error.invalidConnectOp --- - put "/conversations/:cnv/receipt-mode" (continue updateConversationReceiptMode) $ + put "/conversations/:cnv/receipt-mode" (continue updateConversationReceiptModeH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -580,7 +576,7 @@ sitemap = do errorResponse Error.convAccessDenied --- - put "/conversations/:cnv/message-timer" (continue updateConversationMessageTimer) $ + put "/conversations/:cnv/message-timer" (continue updateConversationMessageTimerH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -601,7 +597,7 @@ sitemap = do errorResponse Error.invalidConnectOp --- - post "/conversations/:cnv/members" (continue addMembers) $ + post "/conversations/:cnv/members" (continue addMembersH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -621,7 +617,7 @@ sitemap = do errorResponse Error.convAccessDenied --- - get "/conversations/:cnv/self" (continue getMember) $ + get "/conversations/:cnv/self" (continue getSelfH) $ zauthUserId .&. capture "cnv" document "GET" "getSelf" $ do @@ -632,7 +628,7 @@ sitemap = do errorResponse Error.convNotFound --- - put "/conversations/:cnv/self" (continue updateSelfMember) $ + put "/conversations/:cnv/self" (continue updateSelfMemberH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -647,7 +643,7 @@ sitemap = do errorResponse Error.convNotFound --- - put "/conversations/:cnv/members/:usr" (continue updateOtherMember) $ + put "/conversations/:cnv/members/:usr" (continue updateOtherMemberH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -667,7 +663,7 @@ sitemap = do errorResponse Error.invalidTargetUserOp --- - post "/conversations/:cnv/typing" (continue isTyping) $ + post "/conversations/:cnv/typing" (continue isTypingH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -681,7 +677,7 @@ sitemap = do errorResponse Error.convNotFound --- - delete "/conversations/:cnv/members/:usr" (continue removeMember) $ + delete "/conversations/:cnv/members/:usr" (continue removeMemberH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -699,7 +695,7 @@ sitemap = do errorResponse $ Error.invalidOp "Conversation type does not allow removing members" --- - post "/broadcast/otr/messages" (continue postOtrBroadcast) $ + post "/broadcast/otr/messages" (continue postOtrBroadcastH) $ zauthUserId .&. zauthConnId .&. def OtrReportAllMissing filterMissing @@ -718,7 +714,7 @@ sitemap = do errorResponse Error.nonBindingTeam --- - post "/broadcast/otr/messages" (continue postProtoOtrBroadcast) $ + post "/broadcast/otr/messages" (continue postProtoOtrBroadcastH) $ zauthUserId .&. zauthConnId .&. def OtrReportAllMissing filterMissing @@ -750,7 +746,7 @@ sitemap = do errorResponse Error.nonBindingTeam --- - post "/conversations/:cnv/otr/messages" (continue postOtrMessage) $ + post "/conversations/:cnv/otr/messages" (continue postOtrMessageH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -783,7 +779,7 @@ sitemap = do errorResponse Error.convNotFound --- - post "/conversations/:cnv/otr/messages" (continue postProtoOtrMessage) $ + post "/conversations/:cnv/otr/messages" (continue postProtoOtrMessageH) $ zauthUserId .&. zauthConnId .&. capture "cnv" @@ -811,7 +807,7 @@ sitemap = do .&. query "base_url" --- team feature flags (public) - get "/teams/:tid/features/legalhold" (continue Teams.getLegalholdStatus) $ + get "/teams/:tid/features/legalhold" (continue Teams.getLegalholdStatusH) $ zauthUserId .&. capture "tid" .&. accept "application" "json" @@ -821,7 +817,7 @@ sitemap = do description "Team ID" returns (ref Model.legalHoldTeamConfig) response 200 "LegalHold status" end - get "/teams/:tid/features/sso" (continue Teams.getSSOStatus) $ + get "/teams/:tid/features/sso" (continue Teams.getSSOStatusH) $ zauthUserId .&. capture "tid" .&. accept "application" "json" @@ -831,7 +827,7 @@ sitemap = do description "Team ID" returns (ref Model.ssoTeamConfig) response 200 "SSO status" end - get "/custom-backend/by-domain/:domain" (continue CustomBackend.getCustomBackendByDomain) $ + get "/custom-backend/by-domain/:domain" (continue CustomBackend.getCustomBackendByDomainH) $ capture "domain" .&. accept "application" "json" document "GET" "getCustomBackendByDomain" $ do @@ -848,110 +844,108 @@ sitemap = do .&. request head "/i/status" (continue $ const (return empty)) true get "/i/status" (continue $ const (return empty)) true - get "/i/conversations/:cnv/members/:usr" (continue internalGetMember) $ + get "/i/conversations/:cnv/members/:usr" (continue internalGetMemberH) $ capture "cnv" .&. capture "usr" - post "/i/conversations/managed" (continue internalCreateManagedConversation) $ + post "/i/conversations/managed" (continue internalCreateManagedConversationH) $ zauthUserId .&. zauthConnId .&. jsonRequest @NewConvManaged - post "/i/conversations/connect" (continue createConnectConversation) $ + post "/i/conversations/connect" (continue createConnectConversationH) $ zauthUserId .&. opt zauthConnId .&. jsonRequest @Connect - put "/i/conversations/:cnv/accept/v2" (continue acceptConv) $ + put "/i/conversations/:cnv/accept/v2" (continue acceptConvH) $ zauthUserId .&. opt zauthConnId .&. capture "cnv" - put "/i/conversations/:cnv/block" (continue blockConv) $ + put "/i/conversations/:cnv/block" (continue blockConvH) $ zauthUserId .&. capture "cnv" - put "/i/conversations/:cnv/unblock" (continue unblockConv) $ + put "/i/conversations/:cnv/unblock" (continue unblockConvH) $ zauthUserId .&. opt zauthConnId .&. capture "cnv" - get "/i/conversations/:cnv/meta" (continue getConversationMeta) $ + get "/i/conversations/:cnv/meta" (continue getConversationMetaH) $ capture "cnv" - get "/i/teams/:tid" (continue getTeamInternal) $ + get "/i/teams/:tid" (continue getTeamInternalH) $ capture "tid" .&. accept "application" "json" - get "/i/teams/:tid/name" (continue getTeamNameInternal) $ + get "/i/teams/:tid/name" (continue getTeamNameInternalH) $ capture "tid" .&. accept "application" "json" - put "/i/teams/:tid" (continue createBindingTeam) $ + put "/i/teams/:tid" (continue createBindingTeamH) $ zauthUserId .&. capture "tid" .&. jsonRequest @BindingNewTeam .&. accept "application" "json" - put "/i/teams/:tid/status" (continue updateTeamStatus) $ + put "/i/teams/:tid/status" (continue updateTeamStatusH) $ capture "tid" .&. jsonRequest @TeamStatusUpdate .&. accept "application" "json" - post "/i/teams/:tid/members" (continue uncheckedAddTeamMember) $ + post "/i/teams/:tid/members" (continue uncheckedAddTeamMemberH) $ capture "tid" .&. jsonRequest @NewTeamMember .&. accept "application" "json" - get "/i/teams/:tid/members" (continue uncheckedGetTeamMembers) $ + get "/i/teams/:tid/members" (continue uncheckedGetTeamMembersH) $ capture "tid" .&. accept "application" "json" - get "/i/teams/:tid/members/:uid" (continue uncheckedGetTeamMember) $ + get "/i/teams/:tid/members/:uid" (continue uncheckedGetTeamMemberH) $ capture "tid" .&. capture "uid" .&. accept "application" "json" - get "/i/users/:uid/team/members" (continue getBindingTeamMembers) $ + get "/i/users/:uid/team/members" (continue getBindingTeamMembersH) $ capture "uid" - get "/i/users/:uid/team" (continue getBindingTeamId) $ + get "/i/users/:uid/team" (continue getBindingTeamIdH) $ capture "uid" -- Start of team features (internal); enabling this should only be -- possible internally. Viewing the status should be allowed -- for any admin - get "/i/teams/:tid/features/legalhold" (continue Teams.getLegalholdStatusInternal) $ + get "/i/teams/:tid/features/legalhold" (continue Teams.getLegalholdStatusInternalH) $ capture "tid" .&. accept "application" "json" - put "/i/teams/:tid/features/legalhold" (continue Teams.setLegalholdStatusInternal) $ + put "/i/teams/:tid/features/legalhold" (continue Teams.setLegalholdStatusInternalH) $ capture "tid" .&. jsonRequest @LegalHoldTeamConfig .&. accept "application" "json" - get "/i/teams/:tid/features/sso" (continue Teams.getSSOStatusInternal) $ + get "/i/teams/:tid/features/sso" (continue Teams.getSSOStatusInternalH) $ capture "tid" .&. accept "application" "json" - put "/i/teams/:tid/features/sso" (continue Teams.setSSOStatusInternal) $ + put "/i/teams/:tid/features/sso" (continue Teams.setSSOStatusInternalH) $ capture "tid" .&. jsonRequest @SSOTeamConfig .&. accept "application" "json" -- End of team features - get - "/i/test/clients" - (continue getClients) + get "/i/test/clients" (continue getClientsH) $ zauthUserId -- eg. https://github.com/wireapp/wire-server/blob/3bdca5fc8154e324773802a0deb46d884bd09143/services/brig/test/integration/API/User/Client.hs#L319 - post "/i/clients/:client" (continue addClient) $ + post "/i/clients/:client" (continue addClientH) $ zauthUserId .&. capture "client" - delete "/i/clients/:client" (continue rmClient) $ + delete "/i/clients/:client" (continue rmClientH) $ zauthUserId .&. capture "client" - delete "/i/user" (continue Internal.rmUser) $ + delete "/i/user" (continue Internal.rmUserH) $ zauthUserId .&. opt zauthConnId - post "/i/services" (continue addService) $ + post "/i/services" (continue addServiceH) $ jsonRequest @Service - delete "/i/services" (continue rmService) $ + delete "/i/services" (continue rmServiceH) $ jsonRequest @ServiceRef - post "/i/bots" (continue addBot) $ + post "/i/bots" (continue addBotH) $ zauthUserId .&. zauthConnId .&. jsonRequest @AddBot - delete "/i/bots" (continue rmBot) $ + delete "/i/bots" (continue rmBotH) $ zauthUserId .&. opt zauthConnId .&. jsonRequest @RemoveBot - put "/i/custom-backend/by-domain/:domain" (continue CustomBackend.internalPutCustomBackendByDomain) $ + put "/i/custom-backend/by-domain/:domain" (continue CustomBackend.internalPutCustomBackendByDomainH) $ capture "domain" .&. jsonRequest @CustomBackend - delete "/i/custom-backend/by-domain/:domain" (continue CustomBackend.internalDeleteCustomBackendByDomain) $ + delete "/i/custom-backend/by-domain/:domain" (continue CustomBackend.internalDeleteCustomBackendByDomainH) $ capture "domain" .&. accept "application" "json" @@ -974,7 +968,7 @@ filterMissing = (>>= go) <$> (query "ignore_missing" ||| query "report_missing") Just True -> return OtrReportAllMissing Just False -> return OtrIgnoreAllMissing Nothing -> OtrReportMissing <$> users "report_missing" rep - users :: ByteString -> ByteString -> P.Result P.Error (Set UserId) + users :: ByteString -> ByteString -> P.Result P.Error (Set OpaqueUserId) users src bs = case fromByteString bs of Nothing -> P.Fail $ P.setMessage "Boolean or list of user IDs expected." diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index f4c9f0a7df3..d24099c3f93 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -1,7 +1,7 @@ module Galley.API.Clients - ( getClients, - addClient, - rmClient, + ( getClientsH, + addClientH, + rmClientH, ) where @@ -17,21 +17,25 @@ import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Utilities -getClients :: UserId -> Galley Response +getClientsH :: UserId -> Galley Response +getClientsH usr = do + json <$> getClients usr + +getClients :: UserId -> Galley [ClientId] getClients usr = do isInternal <- view $ options . optSettings . setIntraListing clts <- if isInternal then fromUserClients <$> Intra.lookupClients [usr] else Data.lookupClients [usr] - return . json $ clientIds usr clts + return $ clientIds (makeIdOpaque usr) clts -addClient :: UserId ::: ClientId -> Galley Response -addClient (usr ::: clt) = do +addClientH :: UserId ::: ClientId -> Galley Response +addClientH (usr ::: clt) = do Data.updateClient True usr clt return empty -rmClient :: UserId ::: ClientId -> Galley Response -rmClient (usr ::: clt) = do +rmClientH :: UserId ::: ClientId -> Galley Response +rmClientH (usr ::: clt) = do Data.updateClient False usr clt return empty diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 4a76b8974a6..dbec4763053 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -1,15 +1,17 @@ module Galley.API.Create - ( createGroupConversation, - internalCreateManagedConversation, - createSelfConversation, - createOne2OneConversation, - createConnectConversation, + ( createGroupConversationH, + internalCreateManagedConversationH, + createSelfConversationH, + createOne2OneConversationH, + createConnectConversationH, ) where import Control.Lens hiding ((??)) import Control.Monad.Catch import Data.Id +import Data.IdMapping (MappedOrLocalId (Local, Mapped)) +import Data.List.NonEmpty (nonEmpty) import Data.List1 (list1) import Data.Range import qualified Data.Set as Set @@ -36,40 +38,68 @@ import Network.Wai.Utilities -- | The public-facing endpoint for creating group conversations. -- -- See Note [managed conversations]. -createGroupConversation :: UserId ::: ConnId ::: JsonRequest NewConvUnmanaged -> Galley Response -createGroupConversation (zusr ::: zcon ::: req) = do - wrapped@(NewConvUnmanaged body) <- fromJsonBody req +createGroupConversationH :: UserId ::: ConnId ::: JsonRequest NewConvUnmanaged -> Galley Response +createGroupConversationH (zusr ::: zcon ::: req) = do + newConv <- fromJsonBody req + handleConversationResponse <$> createGroupConversation zusr zcon newConv + +createGroupConversation :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse +createGroupConversation zusr zcon wrapped@(NewConvUnmanaged body) = do case newConvTeam body of Nothing -> createRegularGroupConv zusr zcon wrapped Just tinfo -> createTeamGroupConv zusr zcon tinfo body -- | An internal endpoint for creating managed group conversations. Will -- throw an error for everything else. -internalCreateManagedConversation :: - UserId ::: ConnId ::: JsonRequest NewConvManaged -> Galley Response -internalCreateManagedConversation (zusr ::: zcon ::: req) = do - NewConvManaged body <- fromJsonBody req +internalCreateManagedConversationH :: UserId ::: ConnId ::: JsonRequest NewConvManaged -> Galley Response +internalCreateManagedConversationH (zusr ::: zcon ::: req) = do + newConv <- fromJsonBody req + handleConversationResponse <$> internalCreateManagedConversation zusr zcon newConv + +internalCreateManagedConversation :: UserId -> ConnId -> NewConvManaged -> Galley ConversationResponse +internalCreateManagedConversation zusr zcon (NewConvManaged body) = do case newConvTeam body of Nothing -> throwM internalError Just tinfo -> createTeamGroupConv zusr zcon tinfo body -- | A helper for creating a regular (non-team) group conversation. -createRegularGroupConv :: UserId -> ConnId -> NewConvUnmanaged -> Galley Response +createRegularGroupConv :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do name <- rangeCheckedMaybe (newConvName body) uids <- checkedConvSize (newConvUsers body) ensureConnected zusr (fromConvSize uids) - c <- Data.createConversation zusr name (access body) (accessRole body) uids (newConvTeam body) (newConvMessageTimer body) (newConvReceiptMode body) (newConvUsersRole body) + (localUserIds, remoteUserIds) <- + partitionMappedOrLocalIds <$> traverse resolveOpaqueUserId (newConvUsers body) + -- FUTUREWORK(federation): notify remote users' backends about new conversation + for_ (nonEmpty remoteUserIds) $ + throwM . federationNotImplemented + localCheckedUsers <- checkedConvSize localUserIds + c <- + Data.createConversation + zusr + name + (access body) + (accessRole body) + localCheckedUsers + (newConvTeam body) + (newConvMessageTimer body) + (newConvReceiptMode body) + (newConvUsersRole body) notifyCreatedConversation Nothing zusr (Just zcon) c - conversationResponse status201 zusr c + conversationCreated zusr c -- | A helper for creating a team group conversation, used by the endpoint -- handlers above. Allows both unmanaged and managed conversations. -createTeamGroupConv :: UserId -> ConnId -> ConvTeamInfo -> NewConv -> Galley Response +createTeamGroupConv :: UserId -> ConnId -> ConvTeamInfo -> NewConv -> Galley ConversationResponse createTeamGroupConv zusr zcon tinfo body = do + (localUserIds, remoteUserIds) <- + partitionMappedOrLocalIds <$> traverse resolveOpaqueUserId (newConvUsers body) + -- for now, teams don't support conversations with remote members + for_ (nonEmpty remoteUserIds) $ + throwM . federationNotImplemented name <- rangeCheckedMaybe (newConvName body) teamMems <- Data.teamMembers (cnvTeamId tinfo) - ensureAccessRole (accessRole body) (newConvUsers body) (Just teamMems) + ensureAccessRole (accessRole body) localUserIds (Just teamMems) void $ permissionCheck zusr CreateConversation teamMems otherConvMems <- if cnvManaged tinfo @@ -77,7 +107,7 @@ createTeamGroupConv zusr zcon tinfo body = do let otherConvMems = filter (/= zusr) $ map (view userId) teamMems checkedConvSize otherConvMems else do - otherConvMems <- checkedConvSize (newConvUsers body) + otherConvMems <- checkedConvSize localUserIds -- In teams we don't have 1:1 conversations, only regular conversations. We want -- users without the 'AddRemoveConvMember' permission to still be able to create -- regular conversations, therefore we check for 'AddRemoveConvMember' only if @@ -92,31 +122,39 @@ createTeamGroupConv zusr zcon tinfo body = do void $ permissionCheck zusr DoNotUseDeprecatedAddRemoveConvMember teamMems -- Team members are always considered to be connected, so we only check -- 'ensureConnected' for non-team-members. - ensureConnected zusr (notTeamMember (fromConvSize otherConvMems) teamMems) + ensureConnected zusr (makeIdOpaque <$> notTeamMember (fromConvSize otherConvMems) teamMems) pure otherConvMems conv <- Data.createConversation zusr name (access body) (accessRole body) otherConvMems (newConvTeam body) (newConvMessageTimer body) (newConvReceiptMode body) (newConvUsersRole body) now <- liftIO getCurrentTime -- NOTE: We only send (conversation) events to members of the conversation notifyCreatedConversation (Just now) zusr (Just zcon) conv - conversationResponse status201 zusr conv + conversationCreated zusr conv ---------------------------------------------------------------------------- -- Other kinds of conversations -createSelfConversation :: UserId -> Galley Response +createSelfConversationH :: UserId -> Galley Response +createSelfConversationH zusr = do + handleConversationResponse <$> createSelfConversation zusr + +createSelfConversation :: UserId -> Galley ConversationResponse createSelfConversation zusr = do c <- Data.conversation (Id . toUUID $ zusr) - maybe create (conversationResponse status200 zusr) c + maybe create (conversationExisted zusr) c where create = do c <- Data.createSelfConversation zusr Nothing - conversationResponse status201 zusr c + conversationCreated zusr c + +createOne2OneConversationH :: UserId ::: ConnId ::: JsonRequest NewConvUnmanaged -> Galley Response +createOne2OneConversationH (zusr ::: zcon ::: req) = do + newConv <- fromJsonBody req + handleConversationResponse <$> createOne2OneConversation zusr zcon newConv -createOne2OneConversation :: UserId ::: ConnId ::: JsonRequest NewConvUnmanaged -> Galley Response -createOne2OneConversation (zusr ::: zcon ::: req) = do - NewConvUnmanaged j <- fromJsonBody req - other <- head . fromRange <$> (rangeChecked (newConvUsers j) :: Galley (Range 1 1 [UserId])) - (x, y) <- toUUIDs zusr other +createOne2OneConversation :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse +createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do + other <- head . fromRange <$> (rangeChecked (newConvUsers j) :: Galley (Range 1 1 [OpaqueUserId])) + (x, y) <- toUUIDs (makeIdOpaque zusr) other when (x == y) $ throwM $ invalidOp "Cannot create a 1-1 with yourself" @@ -127,9 +165,12 @@ createOne2OneConversation (zusr ::: zcon ::: req) = do Nothing -> ensureConnected zusr [other] n <- rangeCheckedMaybe (newConvName j) c <- Data.conversation (Data.one2OneConvId x y) - maybe (create x y n $ newConvTeam j) (conversationResponse status200 zusr) c + maybe (create x y n $ newConvTeam j) (conversationExisted zusr) c where - checkBindingTeamPermissions x y tid = do + checkBindingTeamPermissions x other tid = do + y <- resolveOpaqueUserId other >>= \case + Local l -> pure l + Mapped _ -> throwM noBindingTeamMembers -- remote user can't be in local team mems <- bindingTeamMembers tid void $ permissionCheck zusr CreateConversation mems unless (all (flip isTeamMember mems) [x, y]) $ @@ -137,17 +178,21 @@ createOne2OneConversation (zusr ::: zcon ::: req) = do create x y n tinfo = do c <- Data.createOne2OneConversation x y n (cnvTeamId <$> tinfo) notifyCreatedConversation Nothing zusr (Just zcon) c - conversationResponse status201 zusr c + conversationCreated zusr c -createConnectConversation :: UserId ::: Maybe ConnId ::: JsonRequest Connect -> Galley Response -createConnectConversation (usr ::: conn ::: req) = do +createConnectConversationH :: UserId ::: Maybe ConnId ::: JsonRequest Connect -> Galley Response +createConnectConversationH (usr ::: conn ::: req) = do j <- fromJsonBody req - (x, y) <- toUUIDs usr (cRecipient j) + handleConversationResponse <$> createConnectConversation usr conn j + +createConnectConversation :: UserId -> Maybe ConnId -> Connect -> Galley ConversationResponse +createConnectConversation usr conn j = do + (x, y) <- toUUIDs (makeIdOpaque usr) (makeIdOpaque (cRecipient j)) n <- rangeCheckedMaybe (cName j) conv <- Data.conversation (Data.one2OneConvId x y) - maybe (create x y n j) (update n j) conv + maybe (create x y n) (update n) conv where - create x y n j = do + create x y n = do (c, e) <- Data.createConnectConversation x y n j notifyCreatedConversation Nothing usr conn c for_ (newPush (evtFrom e) (ConvEvent e) (recipient <$> Data.convMembers c)) $ \p -> @@ -155,11 +200,11 @@ createConnectConversation (usr ::: conn ::: req) = do p & pushRoute .~ RouteDirect & pushConn .~ conn - conversationResponse status201 usr c - update n j conv = + conversationCreated usr c + update n conv = let mems = Data.convMembers conv - in conversationResponse status200 usr - =<< if | usr `isMember` mems -> connect n j conv + in conversationExisted usr + =<< if | makeIdOpaque usr `isMember` mems -> connect n conv | otherwise -> do now <- liftIO getCurrentTime mm <- snd <$> Data.addMember now (Data.convId conv) usr @@ -168,13 +213,13 @@ createConnectConversation (usr ::: conn ::: req) = do { Data.convMembers = Data.convMembers conv <> toList mm } if null mems - then connect n j conv' + then connect n conv' else do conv'' <- acceptOne2One usr conv' conn if Data.convType conv'' == ConnectConv - then connect n j conv'' + then connect n conv'' else return conv'' - connect n j conv + connect n conv | Data.convType conv == ConnectConv = do n' <- case n of Just x -> do @@ -194,10 +239,20 @@ createConnectConversation (usr ::: conn ::: req) = do ------------------------------------------------------------------------------- -- Helpers -conversationResponse :: Status -> UserId -> Data.Conversation -> Galley Response -conversationResponse s u c = do - a <- conversationView u c - return $ json a & setStatus s . location (cnvId a) +data ConversationResponse + = ConversationCreated !Conversation + | ConversationExisted !Conversation + +conversationCreated :: UserId -> Data.Conversation -> Galley ConversationResponse +conversationCreated usr cnv = ConversationCreated <$> conversationView usr cnv + +conversationExisted :: UserId -> Data.Conversation -> Galley ConversationResponse +conversationExisted usr cnv = ConversationExisted <$> conversationView usr cnv + +handleConversationResponse :: ConversationResponse -> Response +handleConversationResponse = \case + ConversationCreated cnv -> json cnv & setStatus status201 . location (cnvId cnv) + ConversationExisted cnv -> json cnv & setStatus status200 . location (cnvId cnv) notifyCreatedConversation :: Maybe UTCTime -> UserId -> Maybe ConnId -> Data.Conversation -> Galley () notifyCreatedConversation dtime usr conn c = do @@ -215,7 +270,7 @@ notifyCreatedConversation dtime usr conn c = do & pushConn .~ conn & pushRoute .~ route -toUUIDs :: UserId -> UserId -> Galley (U.UUID U.V4, U.UUID U.V4) +toUUIDs :: OpaqueUserId -> OpaqueUserId -> Galley (U.UUID U.V4, U.UUID U.V4) toUUIDs a b = do a' <- U.fromUUID (toUUID a) & ifNothing invalidUUID4 b' <- U.fromUUID (toUUID b) & ifNothing invalidUUID4 diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index 4cbf5f5af18..a52bf460d4d 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -1,11 +1,12 @@ module Galley.API.CustomBackend - ( getCustomBackendByDomain, - internalPutCustomBackendByDomain, - internalDeleteCustomBackendByDomain, + ( getCustomBackendByDomainH, + internalPutCustomBackendByDomainH, + internalDeleteCustomBackendByDomainH, ) where import Control.Monad.Catch +import Data.Domain (Domain) import Galley.API.Error import Galley.API.Util import Galley.App @@ -19,21 +20,26 @@ import Network.Wai.Utilities -- PUBLIC --------------------------------------------------------------------- -getCustomBackendByDomain :: EmailDomain ::: JSON -> Galley Response -getCustomBackendByDomain (domain ::: _) = +getCustomBackendByDomainH :: Domain ::: JSON -> Galley Response +getCustomBackendByDomainH (domain ::: _) = + json <$> getCustomBackendByDomain domain + +getCustomBackendByDomain :: Domain -> Galley CustomBackend +getCustomBackendByDomain domain = Data.getCustomBackend domain >>= \case Nothing -> throwM (customBackendNotFound domain) - Just customBackend -> pure (json customBackend) + Just customBackend -> pure customBackend -- INTERNAL ------------------------------------------------------------------- -internalPutCustomBackendByDomain :: EmailDomain ::: JsonRequest CustomBackend -> Galley Response -internalPutCustomBackendByDomain (domain ::: req) = do +internalPutCustomBackendByDomainH :: Domain ::: JsonRequest CustomBackend -> Galley Response +internalPutCustomBackendByDomainH (domain ::: req) = do customBackend <- fromJsonBody req + -- simple enough to not need a separate function Data.setCustomBackend domain customBackend pure (empty & setStatus status201) -internalDeleteCustomBackendByDomain :: EmailDomain ::: JSON -> Galley Response -internalDeleteCustomBackendByDomain (domain ::: _) = do +internalDeleteCustomBackendByDomainH :: Domain ::: JSON -> Galley Response +internalDeleteCustomBackendByDomainH (domain ::: _) = do Data.deleteCustomBackend domain pure (empty & setStatus status200) diff --git a/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 31bf6663d4d..4cdc4881fb9 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -1,13 +1,19 @@ module Galley.API.Error where +import Data.Domain (Domain, domainText) +import Data.Id (idToText) +import Data.IdMapping (IdMapping (IdMapping, idMappingGlobal, idMappingLocal)) +import Data.List.NonEmpty (NonEmpty) +import Data.Qualified (renderQualified) import Data.String.Conversions (cs) import Data.Text.Lazy as LT (pack) -import Galley.Types (EmailDomain (..)) +import qualified Data.Text.Lazy as LT import Galley.Types.Conversations.Roles (Action) import Galley.Types.Teams (IsPerm) import Imports import Network.HTTP.Types.Status import Network.Wai.Utilities.Error +import Type.Reflection (Typeable, typeRep) internalError :: Error internalError = Error status500 "internal-error" "internal error" @@ -182,9 +188,21 @@ disableSsoNotImplemented = \It is definitely feasible to change this. If you have a use case, please contact customer support, or\n\ \open an issue on https://github.com/wireapp/wire-server." -customBackendNotFound :: EmailDomain -> Error +customBackendNotFound :: Domain -> Error customBackendNotFound domain = Error status404 "custom-backend-not-found" - ("custom backend not found for domain: " <> cs (emailDomainText domain)) + ("custom backend not found for domain: " <> cs (domainText domain)) + +federationNotImplemented :: forall a. Typeable a => NonEmpty (IdMapping a) -> Error +federationNotImplemented qualified = + Error + status501 + "federation-not-implemented" + ("Federation is not implemented, but global qualified IDs (" <> idType <> ") found: " <> rendered) + where + idType = cs (show (typeRep @a)) + rendered = LT.intercalate ", " . toList . fmap (LT.fromStrict . renderMapping) $ qualified + renderMapping IdMapping {idMappingLocal, idMappingGlobal} = + idToText idMappingLocal <> " -> " <> renderQualified idToText idMappingGlobal diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 2102801404e..ab8239545ca 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -1,5 +1,5 @@ module Galley.API.Internal - ( rmUser, + ( rmUserH, deleteLoop, refreshMetrics, ) @@ -8,16 +8,18 @@ where import Cassandra import Control.Exception.Safe (catchAny) import Control.Lens hiding ((.=)) -import Control.Monad.Catch (MonadCatch) +import Control.Monad.Catch (MonadCatch, throwM) import Data.Id +import Data.IdMapping (MappedOrLocalId (Local)) import Data.List.NonEmpty (nonEmpty) import Data.List1 import Data.Metrics.Middleware as Metrics import Data.Range import Data.String.Conversions (cs) +import Galley.API.Error (federationNotImplemented) import Galley.API.Teams (uncheckedRemoveTeamMember) import qualified Galley.API.Teams as Teams -import Galley.API.Util (isMember) +import Galley.API.Util (isMember, partitionMappedOrLocalIds, resolveOpaqueConvId) import Galley.App import qualified Galley.Data as Data import qualified Galley.Intra.Push as Intra @@ -29,8 +31,12 @@ import Network.Wai.Predicate hiding (err, result) import Network.Wai.Utilities import System.Logger.Class -rmUser :: UserId ::: Maybe ConnId -> Galley Response -rmUser (user ::: conn) = do +rmUserH :: UserId ::: Maybe ConnId -> Galley Response +rmUserH (user ::: conn) = do + empty <$ rmUser user conn + +rmUser :: UserId -> Maybe ConnId -> Galley () +rmUser user conn = do let n = unsafeRange 100 :: Range 1 100 Int32 Data.ResultSet tids <- Data.teamIdsFrom user Nothing (rcast n) leaveTeams tids @@ -38,21 +44,27 @@ rmUser (user ::: conn) = do let u = list1 user [] leaveConversations u cids Data.eraseClients user - return empty where leaveTeams tids = for_ (result tids) $ \tid -> do Data.teamMembers tid >>= uncheckedRemoveTeamMember user conn tid user when (hasMore tids) $ leaveTeams =<< liftClient (nextPage tids) + leaveConversations :: List1 UserId -> Page OpaqueConvId -> Galley () leaveConversations u ids = do - cc <- Data.conversations (result ids) + (localConvIds, remoteConvIds) <- partitionMappedOrLocalIds <$> traverse resolveOpaqueConvId (result ids) + -- FUTUREWORK(federation): leave remote conversations. + -- If we could just get all conversation IDs at once and then leave conversations + -- in batches, it would make everything much easier. + for_ (nonEmpty remoteConvIds) $ + throwM . federationNotImplemented + cc <- Data.conversations localConvIds pp <- for cc $ \c -> case Data.convType c of SelfConv -> return Nothing One2OneConv -> Data.removeMember user (Data.convId c) >> return Nothing ConnectConv -> Data.removeMember user (Data.convId c) >> return Nothing RegularConv - | isMember user (Data.convMembers c) -> do - e <- Data.removeMembers c user u + | isMember (makeIdOpaque user) (Data.convMembers c) -> do + e <- Data.removeMembers c user (Local <$> u) return $ (Intra.newPush (evtFrom e) (Intra.ConvEvent e) (Intra.recipient <$> Data.convMembers c)) <&> set Intra.pushConn conn diff --git a/services/galley/src/Galley/API/LegalHold.hs b/services/galley/src/Galley/API/LegalHold.hs index 717d6b42a2d..12475d44246 100644 --- a/services/galley/src/Galley/API/LegalHold.hs +++ b/services/galley/src/Galley/API/LegalHold.hs @@ -1,4 +1,14 @@ -module Galley.API.LegalHold where +module Galley.API.LegalHold + ( createSettingsH, + getSettingsH, + removeSettingsH, + removeSettings', + getUserStatusH, + requestDeviceH, + approveDeviceH, + disableForUserH, + ) +where import Brig.Types.Client.Prekey import Brig.Types.Provider @@ -36,8 +46,13 @@ isLegalHoldEnabled tid = do Just LegalHoldDisabled -> False Nothing -> False -createSettings :: UserId ::: TeamId ::: JsonRequest NewLegalHoldService ::: JSON -> Galley Response -createSettings (zusr ::: tid ::: req ::: _) = do +createSettingsH :: UserId ::: TeamId ::: JsonRequest NewLegalHoldService ::: JSON -> Galley Response +createSettingsH (zusr ::: tid ::: req ::: _) = do + newService :: NewLegalHoldService <- fromJsonBody req + setStatus status201 . json <$> createSettings zusr tid newService + +createSettings :: UserId -> TeamId -> NewLegalHoldService -> Galley ViewLegalHoldService +createSettings zusr tid newService = do assertLegalHoldEnabled tid membs <- Data.teamMembers tid let zothers = map (view userId) membs @@ -45,29 +60,37 @@ createSettings (zusr ::: tid ::: req ::: _) = do Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "LegalHold.createSettings") void $ permissionCheck zusr ChangeLegalHoldTeamSettings membs - newService :: NewLegalHoldService <- - fromJsonBody req (key :: ServiceKey, fpr :: Fingerprint Rsa) <- LHService.validateServiceKey (newLegalHoldServiceKey newService) >>= maybe (throwM legalHoldServiceInvalidKey) pure LHService.checkLegalHoldServiceStatus fpr (newLegalHoldServiceUrl newService) let service = legalHoldService tid fpr newService key LegalHoldData.createSettings service - pure . setStatus status201 . json . viewLegalHoldService $ service + pure . viewLegalHoldService $ service + +getSettingsH :: UserId ::: TeamId ::: JSON -> Galley Response +getSettingsH (zusr ::: tid ::: _) = do + json <$> getSettings zusr tid -getSettings :: UserId ::: TeamId ::: JSON -> Galley Response -getSettings (zusr ::: tid ::: _) = do +getSettings :: UserId -> TeamId -> Galley ViewLegalHoldService +getSettings zusr tid = do membs <- Data.teamMembers tid void $ permissionCheck zusr ViewLegalHoldTeamSettings membs isenabled <- isLegalHoldEnabled tid mresult <- LegalHoldData.getSettings tid - pure . json $ case (isenabled, mresult) of + pure $ case (isenabled, mresult) of (False, _) -> ViewLegalHoldServiceDisabled (True, Nothing) -> ViewLegalHoldServiceNotConfigured (True, Just result) -> viewLegalHoldService result -removeSettings :: UserId ::: TeamId ::: JsonRequest RemoveLegalHoldSettingsRequest ::: JSON -> Galley Response -removeSettings (zusr ::: tid ::: req ::: _) = do +removeSettingsH :: UserId ::: TeamId ::: JsonRequest RemoveLegalHoldSettingsRequest ::: JSON -> Galley Response +removeSettingsH (zusr ::: tid ::: req ::: _) = do + removeSettingsRequest <- fromJsonBody req + removeSettings zusr tid removeSettingsRequest + pure noContent + +removeSettings :: UserId -> TeamId -> RemoveLegalHoldSettingsRequest -> Galley () +removeSettings zusr tid (RemoveLegalHoldSettingsRequest mPassword) = do assertLegalHoldEnabled tid membs <- Data.teamMembers tid let zothers = map (view userId) membs @@ -75,10 +98,8 @@ removeSettings (zusr ::: tid ::: req ::: _) = do Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "LegalHold.removeSettings") void $ permissionCheck zusr ChangeLegalHoldTeamSettings membs - RemoveLegalHoldSettingsRequest mPassword <- fromJsonBody req ensureReAuthorised zusr mPassword removeSettings' tid (Just membs) - pure noContent -- | Remove legal hold settings from team; also disabling for all users and removing LH devices removeSettings' :: @@ -106,8 +127,12 @@ removeSettings' tid mMembers = do -- | Learn whether a user has LH enabled and fetch pre-keys. -- Note that this is accessible to ANY authenticated user, even ones outside the team -getUserStatus :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response -getUserStatus (_zusr ::: tid ::: uid ::: _) = do +getUserStatusH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +getUserStatusH (_zusr ::: tid ::: uid ::: _) = do + json <$> getUserStatus tid uid + +getUserStatus :: TeamId -> UserId -> Galley UserLegalHoldStatusResponse +getUserStatus tid uid = do mTeamMember <- Data.teamMember tid uid teamMember <- maybe (throwM teamMemberNotFound) pure mTeamMember statusResponse <- case view legalHoldStatus teamMember of @@ -115,7 +140,7 @@ getUserStatus (_zusr ::: tid ::: uid ::: _) = do pure $ UserLegalHoldStatusResponse UserLegalHoldDisabled Nothing Nothing status@UserLegalHoldPending -> makeResponse status status@UserLegalHoldEnabled -> makeResponse status - pure . json $ statusResponse + pure $ statusResponse where makeResponse status = do mLastKey <- fmap snd <$> LegalHoldData.selectPendingPrekeys uid @@ -131,8 +156,18 @@ getUserStatus (_zusr ::: tid ::: uid ::: _) = do pure $ UserLegalHoldStatusResponse status (Just lastKey) (Just clientId) -- | Request to provision a device on the legal hold service for a user -requestDevice :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response -requestDevice (zusr ::: tid ::: uid ::: _) = do +requestDeviceH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +requestDeviceH (zusr ::: tid ::: uid ::: _) = do + requestDevice zusr tid uid <&> \case + RequestDeviceSuccess -> empty & setStatus status201 + RequestDeviceAlreadyPending -> empty & setStatus status204 + +data RequestDeviceResult + = RequestDeviceSuccess + | RequestDeviceAlreadyPending + +requestDevice :: UserId -> TeamId -> UserId -> Galley RequestDeviceResult +requestDevice zusr tid uid = do assertLegalHoldEnabled tid Log.debug $ Log.field "targets" (toByteString uid) @@ -142,18 +177,17 @@ requestDevice (zusr ::: tid ::: uid ::: _) = do userLHStatus <- fmap (view legalHoldStatus) <$> Data.teamMember tid uid case userLHStatus of Just UserLegalHoldEnabled -> throwM userLegalHoldAlreadyEnabled - Just UserLegalHoldPending -> provisionLHDevice <&> setStatus status204 - Just UserLegalHoldDisabled -> provisionLHDevice <&> setStatus status201 + Just UserLegalHoldPending -> RequestDeviceAlreadyPending <$ provisionLHDevice + Just UserLegalHoldDisabled -> RequestDeviceSuccess <$ provisionLHDevice Nothing -> throwM teamMemberNotFound where - provisionLHDevice :: Galley Response + provisionLHDevice :: Galley () provisionLHDevice = do (lastPrekey', prekeys) <- requestDeviceFromService -- We don't distinguish the last key here; brig will do so when the device is added LegalHoldData.insertPendingPrekeys uid (unpackLastPrekey lastPrekey' : prekeys) LegalHoldData.setUserLegalHoldStatus tid uid UserLegalHoldPending Client.notifyClientsAboutLegalHoldRequest zusr uid lastPrekey' - pure empty requestDeviceFromService :: Galley (LastPrekey, [Prekey]) requestDeviceFromService = do LegalHoldData.dropPendingPrekeys uid @@ -165,17 +199,22 @@ requestDevice (zusr ::: tid ::: uid ::: _) = do -- we don't delete pending prekeys during this flow just in case -- it gets interupted. There's really no reason to delete them anyways -- since they are replaced if needed when registering new LH devices. -approveDevice :: +approveDeviceH :: UserId ::: TeamId ::: UserId ::: ConnId ::: JsonRequest ApproveLegalHoldForUserRequest ::: JSON -> Galley Response -approveDevice (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do +approveDeviceH (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do + approve <- fromJsonBody req + approveDevice zusr tid uid connId approve + pure empty + +approveDevice :: UserId -> TeamId -> UserId -> ConnId -> ApproveLegalHoldForUserRequest -> Galley () +approveDevice zusr tid uid connId (ApproveLegalHoldForUserRequest mPassword) = do assertLegalHoldEnabled tid Log.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "LegalHold.approveDevice") unless (zusr == uid) (throwM accessDenied) assertOnTeam uid tid - ApproveLegalHoldForUserRequest mPassword <- fromJsonBody req ensureReAuthorised zusr mPassword assertUserLHPending mPreKeys <- LegalHoldData.selectPendingPrekeys uid @@ -192,10 +231,9 @@ approveDevice (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do -- FUTUREWORK: reduce double checks legalHoldAuthToken <- Client.getLegalHoldAuthToken uid mPassword LHService.confirmLegalHold clientId tid uid legalHoldAuthToken - LegalHoldData.setUserLegalHoldStatus tid uid UserLegalHoldEnabled -- TODO: send event at this point (see also: -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) - pure empty + LegalHoldData.setUserLegalHoldStatus tid uid UserLegalHoldEnabled where assertUserLHPending :: Galley () assertUserLHPending = do @@ -205,18 +243,29 @@ approveDevice (zusr ::: tid ::: uid ::: connId ::: req ::: _) = do Just UserLegalHoldPending -> pure () _ -> throwM userLegalHoldNotPending -disableForUser :: +disableForUserH :: UserId ::: TeamId ::: UserId ::: JsonRequest DisableLegalHoldForUserRequest ::: JSON -> Galley Response -disableForUser (zusr ::: tid ::: uid ::: req ::: _) = do +disableForUserH (zusr ::: tid ::: uid ::: req ::: _) = do + disable <- fromJsonBody req + disableForUser zusr tid uid disable <&> \case + DisableLegalHoldSuccess -> empty + DisableLegalHoldWasNotEnabled -> noContent + +data DisableLegalHoldForUserResponse + = DisableLegalHoldSuccess + | DisableLegalHoldWasNotEnabled + +disableForUser :: UserId -> TeamId -> UserId -> DisableLegalHoldForUserRequest -> Galley DisableLegalHoldForUserResponse +disableForUser zusr tid uid (DisableLegalHoldForUserRequest mPassword) = do Log.debug $ Log.field "targets" (toByteString uid) . Log.field "action" (Log.val "LegalHold.disableForUser") membs <- Data.teamMembers tid void $ permissionCheck zusr ChangeLegalHoldUserSettings membs if userLHNotDisabled membs - then disableLH >> pure empty - else pure noContent + then disableLH >> pure DisableLegalHoldSuccess + else pure DisableLegalHoldWasNotEnabled where -- If not enabled nor pending, then it's disabled userLHNotDisabled mems = do @@ -227,11 +276,10 @@ disableForUser (zusr ::: tid ::: uid ::: req ::: _) = do Just UserLegalHoldDisabled -> False Nothing -> False -- Never been set disableLH = do - DisableLegalHoldForUserRequest mPassword <- fromJsonBody req ensureReAuthorised zusr mPassword Client.removeLegalHoldClientFromUser uid LHService.removeLegalHold tid uid + -- TODO: send event at this point (see also: related TODO in this module in + -- 'approveDevice' and + -- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) LegalHoldData.setUserLegalHoldStatus tid uid UserLegalHoldDisabled --- TODO: send event at this point (see also: related TODO in this module in --- 'approveDevice' and --- https://github.com/wireapp/wire-server/pull/802#pullrequestreview-262280386) diff --git a/services/galley/src/Galley/API/Query.hs b/services/galley/src/Galley/API/Query.hs index 1290262daa8..af365c76fb6 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -1,7 +1,16 @@ -module Galley.API.Query where +module Galley.API.Query + ( getBotConversationH, + getConversationH, + getConversationRolesH, + getConversationIdsH, + getConversationsH, + getSelfH, + internalGetMemberH, + getConversationMetaH, + ) +where import Cassandra (hasMore, result) -import Data.Aeson (Value (Null)) import Data.ByteString.Conversion import Data.Id import Data.Range @@ -9,10 +18,10 @@ import Galley.API.Error import Galley.API.Mapping import Galley.API.Util import Galley.App -import Galley.Data as Data +import qualified Galley.Data as Data import qualified Galley.Data.Types as Data import Galley.Types -import Galley.Types.Bot (botConvView) +import Galley.Types.Bot (BotConvView, botConvView) import Galley.Types.Conversations.Roles import Imports import Network.HTTP.Types @@ -20,74 +29,104 @@ import Network.Wai import Network.Wai.Predicate hiding (result, setStatus) import Network.Wai.Utilities -getBotConversation :: BotId ::: ConvId ::: JSON -> Galley Response -getBotConversation (zbot ::: zcnv ::: _) = do - c <- getConversationAndCheckMembershipWithError convNotFound (botUserId zbot) zcnv +getBotConversationH :: BotId ::: ConvId ::: JSON -> Galley Response +getBotConversationH (zbot ::: zcnv ::: _) = do + json <$> getBotConversation zbot zcnv + +getBotConversation :: BotId -> ConvId -> Galley BotConvView +getBotConversation zbot zcnv = do + c <- getConversationAndCheckMembershipWithError convNotFound (botUserId zbot) (makeIdOpaque zcnv) let cmems = mapMaybe mkMember (toList (Data.convMembers c)) - let cview = botConvView zcnv (Data.convName c) cmems - return $ json cview + pure $ botConvView zcnv (Data.convName c) cmems where mkMember m | memId m /= botUserId zbot = Just (OtherMember (memId m) (memService m) (memConvRoleName m)) | otherwise = Nothing -getConversation :: UserId ::: ConvId ::: JSON -> Galley Response -getConversation (zusr ::: cnv ::: _) = do +getConversationH :: UserId ::: OpaqueConvId ::: JSON -> Galley Response +getConversationH (zusr ::: cnv ::: _) = do + json <$> getConversation zusr cnv + +getConversation :: UserId -> OpaqueConvId -> Galley Conversation +getConversation zusr cnv = do c <- getConversationAndCheckMembership zusr cnv - a <- conversationView zusr c - return $ json a + conversationView zusr c + +getConversationRolesH :: UserId ::: OpaqueConvId ::: JSON -> Galley Response +getConversationRolesH (zusr ::: cnv ::: _) = do + json <$> getConversationRoles zusr cnv -getConversationRoles :: UserId ::: ConvId ::: JSON -> Galley Response -getConversationRoles (zusr ::: cnv ::: _) = do +getConversationRoles :: UserId -> OpaqueConvId -> Galley ConversationRolesList +getConversationRoles zusr cnv = do void $ getConversationAndCheckMembership zusr cnv -- NOTE: If/when custom roles are added, these roles should -- be merged with the team roles (if they exist) - return . json $ ConversationRolesList wireConvRoles + pure $ ConversationRolesList wireConvRoles -getConversationIds :: UserId ::: Maybe ConvId ::: Range 1 1000 Int32 ::: JSON -> Galley Response -getConversationIds (zusr ::: start ::: size ::: _) = do - ResultSet ids <- Data.conversationIdsFrom zusr start size - return . json $ ConversationList (result ids) (hasMore ids) +getConversationIdsH :: UserId ::: Maybe OpaqueConvId ::: Range 1 1000 Int32 ::: JSON -> Galley Response +getConversationIdsH (zusr ::: start ::: size ::: _) = do + json <$> getConversationIds zusr start size -getConversations :: UserId ::: Maybe (Either (Range 1 32 (List ConvId)) ConvId) ::: Range 1 500 Int32 ::: JSON -> Galley Response -getConversations (zusr ::: range ::: size ::: _) = +getConversationIds :: UserId -> Maybe OpaqueConvId -> Range 1 1000 Int32 -> Galley (ConversationList OpaqueConvId) +getConversationIds zusr start size = do + Data.ResultSet ids <- Data.conversationIdsFrom zusr start size + pure $ ConversationList (result ids) (hasMore ids) + +getConversationsH :: UserId ::: Maybe (Either (Range 1 32 (List OpaqueConvId)) OpaqueConvId) ::: Range 1 500 Int32 ::: JSON -> Galley Response +getConversationsH (zusr ::: range ::: size ::: _) = + json <$> getConversations zusr range size + +getConversations :: UserId -> Maybe (Either (Range 1 32 (List OpaqueConvId)) OpaqueConvId) -> Range 1 500 Int32 -> Galley (ConversationList Conversation) +getConversations zusr range size = withConvIds zusr range size $ \more ids -> do + -- FUTUREWORK(federation): resolve IDs in batch + (localConvIds, _qualifiedConvIds) <- partitionMappedOrLocalIds <$> traverse resolveOpaqueConvId ids + -- FUTUREWORK(federation): fetch remote conversations from other backend cs <- - Data.conversations ids + Data.conversations localConvIds >>= filterM removeDeleted - >>= filterM (pure . isMember zusr . Data.convMembers) - json . flip ConversationList more <$> mapM (conversationView zusr) cs + >>= filterM (pure . isMember (makeIdOpaque zusr) . Data.convMembers) + flip ConversationList more <$> mapM (conversationView zusr) cs where removeDeleted c | Data.isConvDeleted c = Data.deleteConversation (Data.convId c) >> pure False | otherwise = pure True -getMember :: UserId ::: ConvId -> Galley Response -getMember (zusr ::: cnv) = do - alive <- Data.isConvAlive cnv - if alive - then json <$> Data.member cnv zusr - else do - Data.deleteConversation cnv - pure (json Null) +getSelfH :: UserId ::: ConvId -> Galley Response +getSelfH (zusr ::: cnv) = do + json <$> getSelf zusr cnv -internalGetMember :: ConvId ::: UserId -> Galley Response -internalGetMember (cnv ::: usr) = do +getSelf :: UserId -> ConvId -> Galley (Maybe Member) +getSelf zusr cnv = + internalGetMember cnv zusr + +internalGetMemberH :: ConvId ::: UserId -> Galley Response +internalGetMemberH (cnv ::: usr) = do + json <$> internalGetMember cnv usr + +internalGetMember :: ConvId -> UserId -> Galley (Maybe Member) +internalGetMember cnv usr = do alive <- Data.isConvAlive cnv if alive - then json <$> Data.member cnv usr + then Data.member cnv usr else do Data.deleteConversation cnv - pure (json Null) + pure Nothing + +getConversationMetaH :: ConvId -> Galley Response +getConversationMetaH cnv = do + getConversationMeta cnv <&> \case + Nothing -> setStatus status404 empty + Just meta -> json meta -getConversationMeta :: ConvId -> Galley Response +getConversationMeta :: ConvId -> Galley (Maybe ConversationMeta) getConversationMeta cnv = do alive <- Data.isConvAlive cnv if alive - then maybe (setStatus status404 empty) json <$> Data.conversationMeta cnv + then Data.conversationMeta cnv else do Data.deleteConversation cnv - pure (empty & setStatus status404) + pure Nothing ----------------------------------------------------------------------------- -- Internal @@ -104,16 +143,16 @@ getConversationMeta cnv = do -- always false if the third lookup-case is used). withConvIds :: UserId -> - Maybe (Either (Range 1 32 (List ConvId)) ConvId) -> + Maybe (Either (Range 1 32 (List OpaqueConvId)) OpaqueConvId) -> Range 1 500 Int32 -> - (Bool -> [ConvId] -> Galley Response) -> - Galley Response + (Bool -> [OpaqueConvId] -> Galley a) -> + Galley a withConvIds usr range size k = case range of Nothing -> do - ResultSet r <- Data.conversationIdsFrom usr Nothing (rcast size) + Data.ResultSet r <- Data.conversationIdsFrom usr Nothing (rcast size) k (hasMore r) (result r) Just (Right c) -> do - ResultSet r <- Data.conversationIdsFrom usr (Just c) (rcast size) + Data.ResultSet r <- Data.conversationIdsFrom usr (Just c) (rcast size) k (hasMore r) (result r) Just (Left cc) -> do ids <- Data.conversationIdsOf usr cc diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 68049612f7f..94a1c52b06f 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -1,34 +1,34 @@ module Galley.API.Teams - ( createBindingTeam, - createNonBindingTeam, - updateTeam, - updateTeamStatus, - getTeam, - getTeamInternal, - getTeamNameInternal, - getBindingTeamId, - getBindingTeamMembers, - getManyTeams, - deleteTeam, + ( createBindingTeamH, + createNonBindingTeamH, + updateTeamH, + updateTeamStatusH, + getTeamH, + getTeamInternalH, + getTeamNameInternalH, + getBindingTeamIdH, + getBindingTeamMembersH, + getManyTeamsH, + deleteTeamH, uncheckedDeleteTeam, - addTeamMember, - getTeamMembers, - getTeamMember, - deleteTeamMember, - getTeamConversations, - getTeamConversation, - getTeamConversationRoles, - deleteTeamConversation, - updateTeamMember, - getSSOStatus, - getSSOStatusInternal, - setSSOStatusInternal, - getLegalholdStatus, - getLegalholdStatusInternal, - setLegalholdStatusInternal, - uncheckedAddTeamMember, - uncheckedGetTeamMember, - uncheckedGetTeamMembers, + addTeamMemberH, + getTeamMembersH, + getTeamMemberH, + deleteTeamMemberH, + updateTeamMemberH, + getTeamConversationsH, + getTeamConversationH, + getTeamConversationRolesH, + deleteTeamConversationH, + getSSOStatusH, + getSSOStatusInternalH, + setSSOStatusInternalH, + getLegalholdStatusH, + getLegalholdStatusInternalH, + setLegalholdStatusInternalH, + uncheckedAddTeamMemberH, + uncheckedGetTeamMemberH, + uncheckedGetTeamMembersH, uncheckedRemoveTeamMember, withBindingTeam, ) @@ -64,7 +64,7 @@ import Galley.Options import qualified Galley.Queue as Q import qualified Galley.Types as Conv import Galley.Types.Conversations.Roles as Roles -import Galley.Types.Teams +import Galley.Types.Teams hiding (newTeam) import Galley.Types.Teams.Intra import Galley.Types.Teams.SSO import Imports @@ -75,23 +75,33 @@ import Network.Wai.Utilities import qualified System.Logger.Class as Log import UnliftIO (mapConcurrently) -getTeam :: UserId ::: TeamId ::: JSON -> Galley Response -getTeam (zusr ::: tid ::: _) = +getTeamH :: UserId ::: TeamId ::: JSON -> Galley Response +getTeamH (zusr ::: tid ::: _) = maybe (throwM teamNotFound) (pure . json) =<< lookupTeam zusr tid -getTeamInternal :: TeamId ::: JSON -> Galley Response -getTeamInternal (tid ::: _) = - maybe (throwM teamNotFound) (pure . json) =<< Data.team tid +getTeamInternalH :: TeamId ::: JSON -> Galley Response +getTeamInternalH (tid ::: _) = + maybe (throwM teamNotFound) (pure . json) =<< getTeamInternal tid -getTeamNameInternal :: TeamId ::: JSON -> Galley Response -getTeamNameInternal (tid ::: _) = - maybe (throwM teamNotFound) (pure . json . TeamName) =<< Data.teamName tid +getTeamInternal :: TeamId -> Galley (Maybe TeamData) +getTeamInternal = Data.team -getManyTeams :: UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> Galley Response -getManyTeams (zusr ::: range ::: size ::: _) = +getTeamNameInternalH :: TeamId ::: JSON -> Galley Response +getTeamNameInternalH (tid ::: _) = + maybe (throwM teamNotFound) (pure . json) =<< getTeamNameInternal tid + +getTeamNameInternal :: TeamId -> Galley (Maybe TeamName) +getTeamNameInternal = fmap (fmap TeamName) . Data.teamName + +getManyTeamsH :: UserId ::: Maybe (Either (Range 1 32 (List TeamId)) TeamId) ::: Range 1 100 Int32 ::: JSON -> Galley Response +getManyTeamsH (zusr ::: range ::: size ::: _) = + json <$> getManyTeams zusr range size + +getManyTeams :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> Galley TeamList +getManyTeams zusr range size = withTeamIds zusr range size $ \more ids -> do teams <- mapM (lookupTeam zusr) ids - pure (json $ newTeamList (catMaybes teams) more) + pure (newTeamList (catMaybes teams) more) lookupTeam :: UserId -> TeamId -> Galley (Maybe Team) lookupTeam zusr tid = do @@ -105,9 +115,14 @@ lookupTeam zusr tid = do pure (tdTeam <$> t) else pure Nothing -createNonBindingTeam :: UserId ::: ConnId ::: JsonRequest NonBindingNewTeam ::: JSON -> Galley Response -createNonBindingTeam (zusr ::: zcon ::: req ::: _) = do - NonBindingNewTeam body <- fromJsonBody req +createNonBindingTeamH :: UserId ::: ConnId ::: JsonRequest NonBindingNewTeam ::: JSON -> Galley Response +createNonBindingTeamH (zusr ::: zcon ::: req ::: _) = do + newTeam <- fromJsonBody req + newTeamId <- createNonBindingTeam zusr zcon newTeam + pure (empty & setStatus status201 . location newTeamId) + +createNonBindingTeam :: UserId -> ConnId -> NonBindingNewTeam -> Galley TeamId +createNonBindingTeam zusr zcon (NonBindingNewTeam body) = do let owner = newTeamMember zusr fullPermissions Nothing let others = filter ((zusr /=) . view userId) @@ -115,29 +130,38 @@ createNonBindingTeam (zusr ::: zcon ::: req ::: _) = do $ body ^. newTeamMembers let zothers = map (view userId) others ensureUnboundUsers (zusr : zothers) - ensureConnected zusr zothers + ensureConnected zusr (makeIdOpaque <$> zothers) Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "Teams.createNonBindingTeam") team <- Data.createTeam Nothing zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) NonBinding finishCreateTeam team owner others (Just zcon) -createBindingTeam :: UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley Response -createBindingTeam (zusr ::: tid ::: req ::: _) = do - BindingNewTeam body <- fromJsonBody req +createBindingTeamH :: UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley Response +createBindingTeamH (zusr ::: tid ::: req ::: _) = do + newTeam <- fromJsonBody req + newTeamId <- createBindingTeam zusr tid newTeam + pure (empty & setStatus status201 . location newTeamId) + +createBindingTeam :: UserId -> TeamId -> BindingNewTeam -> Galley TeamId +createBindingTeam zusr tid (BindingNewTeam body) = do let owner = newTeamMember zusr fullPermissions Nothing team <- Data.createTeam (Just tid) zusr (body ^. newTeamName) (body ^. newTeamIcon) (body ^. newTeamIconKey) Binding finishCreateTeam team owner [] Nothing -updateTeamStatus :: TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley Response -updateTeamStatus (tid ::: req ::: _) = do - TeamStatusUpdate to cur <- fromJsonBody req - from <- tdStatus <$> (Data.team tid >>= ifNothing teamNotFound) - valid <- validateTransition from to - when valid $ do - journal to cur - Data.updateTeamStatus tid to +updateTeamStatusH :: TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley Response +updateTeamStatusH (tid ::: req ::: _) = do + teamStatusUpdate <- fromJsonBody req + updateTeamStatus tid teamStatusUpdate return empty + +updateTeamStatus :: TeamId -> TeamStatusUpdate -> Galley () +updateTeamStatus tid (TeamStatusUpdate newStatus cur) = do + oldStatus <- tdStatus <$> (Data.team tid >>= ifNothing teamNotFound) + valid <- validateTransition oldStatus newStatus + when valid $ do + journal newStatus cur + Data.updateTeamStatus tid newStatus where journal Suspended _ = Journal.teamSuspend tid journal Active c = Data.teamMembers tid >>= \mems -> @@ -151,40 +175,55 @@ updateTeamStatus (tid ::: req ::: _) = do (Suspended, Suspended) -> return False (_, _) -> throwM invalidTeamStatusUpdate -updateTeam :: UserId ::: ConnId ::: TeamId ::: JsonRequest TeamUpdateData ::: JSON -> Galley Response -updateTeam (zusr ::: zcon ::: tid ::: req ::: _) = do - body <- fromJsonBody req +updateTeamH :: UserId ::: ConnId ::: TeamId ::: JsonRequest TeamUpdateData ::: JSON -> Galley Response +updateTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do + updateData <- fromJsonBody req + updateTeam zusr zcon tid updateData + pure empty + +updateTeam :: UserId -> ConnId -> TeamId -> TeamUpdateData -> Galley () +updateTeam zusr zcon tid updateData = do membs <- Data.teamMembers tid let zothers = map (view userId) membs Log.debug $ Log.field "targets" (toByteString . show $ toByteString <$> zothers) . Log.field "action" (Log.val "Teams.updateTeam") void $ permissionCheck zusr SetTeamData membs - Data.updateTeam tid body + Data.updateTeam tid updateData now <- liftIO getCurrentTime - let e = newEvent TeamUpdate tid now & eventData .~ Just (EdTeamUpdate body) + let e = newEvent TeamUpdate tid now & eventData .~ Just (EdTeamUpdate updateData) let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) membs) push1 $ newPush1 zusr (TeamEvent e) r & pushConn .~ Just zcon - pure empty -deleteTeam :: UserId ::: ConnId ::: TeamId ::: Request ::: Maybe JSON ::: JSON -> Galley Response -deleteTeam (zusr ::: zcon ::: tid ::: req ::: _ ::: _) = do +deleteTeamH :: UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest TeamDeleteData ::: JSON -> Galley Response +deleteTeamH (zusr ::: zcon ::: tid ::: req ::: _) = do + mBody <- fromOptionalJsonBody req + deleteTeam zusr zcon tid mBody + pure (empty & setStatus status202) + +-- | 'TeamDeleteData' is only required for binding teams +deleteTeam :: UserId -> ConnId -> TeamId -> Maybe TeamDeleteData -> Galley () +deleteTeam zusr zcon tid mBody = do team <- Data.team tid >>= ifNothing teamNotFound case tdStatus team of - Deleted -> throwM teamNotFound - PendingDelete -> queueDelete + Deleted -> + throwM teamNotFound + PendingDelete -> + queueDelete _ -> do + checkPermissions team + queueDelete + where + checkPermissions team = do void $ permissionCheck zusr DeleteTeam =<< Data.teamMembers tid when ((tdTeam team) ^. teamBinding == Binding) $ do - body <- fromJsonBody (JsonRequest req) + body <- mBody & ifNothing (invalidPayload "missing request body") ensureReAuthorised zusr (body ^. tdAuthPassword) - queueDelete - where queueDelete = do q <- view deleteQueue ok <- Q.tryPush q (TeamItem tid zusr (Just zcon)) if ok - then pure (empty & setStatus status202) + then pure () else throwM deleteQueueFull -- This function is "unchecked" because it does not validate that the user has the `DeleteTeam` permission. @@ -243,51 +282,75 @@ uncheckedDeleteTeam zusr zcon tid = do let pp' = maybe pp (\x -> (x & pushConn .~ zcon) : pp) p pure (pp', ee' ++ ee) -getTeamConversationRoles :: UserId ::: TeamId ::: JSON -> Galley Response -getTeamConversationRoles (zusr ::: tid ::: _) = do +getTeamConversationRolesH :: UserId ::: TeamId ::: JSON -> Galley Response +getTeamConversationRolesH (zusr ::: tid ::: _) = do + json <$> getTeamConversationRoles zusr tid + +getTeamConversationRoles :: UserId -> TeamId -> Galley ConversationRolesList +getTeamConversationRoles zusr tid = do mem <- Data.teamMember tid zusr case mem of Nothing -> throwM noTeamMember Just _ -> do -- NOTE: If/when custom roles are added, these roles should -- be merged with the team roles (if they exist) - return . json $ ConversationRolesList wireConvRoles + pure $ ConversationRolesList wireConvRoles -getTeamMembers :: UserId ::: TeamId ::: JSON -> Galley Response -getTeamMembers (zusr ::: tid ::: _) = do +getTeamMembersH :: UserId ::: TeamId ::: JSON -> Galley Response +getTeamMembersH (zusr ::: tid ::: _) = do + (memberList, withPerms) <- getTeamMembers zusr tid + pure . json $ teamMemberListJson withPerms memberList + +getTeamMembers :: UserId -> TeamId -> Galley (TeamMemberList, TeamMember -> Bool) +getTeamMembers zusr tid = do mems <- Data.teamMembers tid case findTeamMember zusr mems of Nothing -> throwM noTeamMember Just m -> do let withPerms = (m `canSeePermsOf`) - pure (json $ teamMemberListJson withPerms (newTeamMemberList mems)) + pure (newTeamMemberList mems, withPerms) + +getTeamMemberH :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response +getTeamMemberH (zusr ::: tid ::: uid ::: _) = do + (member, withPerms) <- getTeamMember zusr tid uid + pure . json $ teamMemberJson withPerms member -getTeamMember :: UserId ::: TeamId ::: UserId ::: JSON -> Galley Response -getTeamMember (zusr ::: tid ::: uid ::: _) = do +getTeamMember :: UserId -> TeamId -> UserId -> Galley (TeamMember, TeamMember -> Bool) +getTeamMember zusr tid uid = do mems <- Data.teamMembers tid case findTeamMember zusr mems of Nothing -> throwM noTeamMember Just m -> do let withPerms = (m `canSeePermsOf`) - let member = findTeamMember uid mems - maybe - (throwM teamMemberNotFound) - (pure . json . teamMemberJson withPerms) - member - -uncheckedGetTeamMember :: TeamId ::: UserId ::: JSON -> Galley Response -uncheckedGetTeamMember (tid ::: uid ::: _) = do - mem <- Data.teamMember tid uid >>= ifNothing teamMemberNotFound - return $ json mem - -uncheckedGetTeamMembers :: TeamId ::: JSON -> Galley Response -uncheckedGetTeamMembers (tid ::: _) = do + case findTeamMember uid mems of + Nothing -> throwM teamMemberNotFound + Just member -> pure (member, withPerms) + +uncheckedGetTeamMemberH :: TeamId ::: UserId ::: JSON -> Galley Response +uncheckedGetTeamMemberH (tid ::: uid ::: _) = do + json <$> uncheckedGetTeamMember tid uid + +uncheckedGetTeamMember :: TeamId -> UserId -> Galley TeamMember +uncheckedGetTeamMember tid uid = do + Data.teamMember tid uid >>= ifNothing teamMemberNotFound + +uncheckedGetTeamMembersH :: TeamId ::: JSON -> Galley Response +uncheckedGetTeamMembersH (tid ::: _) = do + json <$> uncheckedGetTeamMembers tid + +uncheckedGetTeamMembers :: TeamId -> Galley TeamMemberList +uncheckedGetTeamMembers tid = do mems <- Data.teamMembers tid - return . json $ newTeamMemberList mems + pure $ newTeamMemberList mems -addTeamMember :: UserId ::: ConnId ::: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response -addTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do +addTeamMemberH :: UserId ::: ConnId ::: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response +addTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do nmem <- fromJsonBody req + addTeamMember zusr zcon tid nmem + pure empty + +addTeamMember :: UserId -> ConnId -> TeamId -> NewTeamMember -> Galley () +addTeamMember zusr zcon tid nmem = do let uid = nmem ^. ntmNewTeamMember . userId Log.debug $ Log.field "targets" (toByteString uid) @@ -299,24 +362,31 @@ addTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do targetPermissions `ensureNotElevated` tmem ensureNonBindingTeam tid ensureUnboundUsers [uid] - ensureConnected zusr [uid] + ensureConnected zusr [makeIdOpaque uid] addTeamMemberInternal tid (Just zusr) (Just zcon) nmem mems -- This function is "unchecked" because there is no need to check for user binding (invite only). -uncheckedAddTeamMember :: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response -uncheckedAddTeamMember (tid ::: req ::: _) = do +uncheckedAddTeamMemberH :: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response +uncheckedAddTeamMemberH (tid ::: req ::: _) = do nmem <- fromJsonBody req + uncheckedAddTeamMember tid nmem + return empty + +uncheckedAddTeamMember :: TeamId -> NewTeamMember -> Galley () +uncheckedAddTeamMember tid nmem = do mems <- Data.teamMembers tid - rsp <- addTeamMemberInternal tid Nothing Nothing nmem mems + addTeamMemberInternal tid Nothing Nothing nmem mems Journal.teamUpdate tid (nmem ^. ntmNewTeamMember : mems) - return rsp -updateTeamMember :: - UserId ::: ConnId ::: TeamId ::: JsonRequest NewTeamMember ::: JSON -> - Galley Response -updateTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do +updateTeamMemberH :: UserId ::: ConnId ::: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response +updateTeamMemberH (zusr ::: zcon ::: tid ::: req ::: _) = do -- the team member to be updated targetMember <- view ntmNewTeamMember <$> fromJsonBody req + updateTeamMember zusr zcon tid targetMember + pure empty + +updateTeamMember :: UserId -> ConnId -> TeamId -> TeamMember -> Galley () +updateTeamMember zusr zcon tid targetMember = do let targetId = targetMember ^. userId targetPermissions = targetMember ^. permissions Log.debug $ @@ -352,10 +422,21 @@ updateTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do -- push to all members (user is privileged) let pushPriv = newPush zusr (TeamEvent ePriv) $ privilegedRecipients for_ pushPriv $ \p -> push1 $ p & pushConn .~ Just zcon - pure empty -deleteTeamMember :: UserId ::: ConnId ::: TeamId ::: UserId ::: Request ::: Maybe JSON ::: JSON -> Galley Response -deleteTeamMember (zusr ::: zcon ::: tid ::: remove ::: req ::: _ ::: _) = do +deleteTeamMemberH :: UserId ::: ConnId ::: TeamId ::: UserId ::: OptionalJsonRequest TeamMemberDeleteData ::: JSON -> Galley Response +deleteTeamMemberH (zusr ::: zcon ::: tid ::: remove ::: req ::: _) = do + mBody <- fromOptionalJsonBody req + deleteTeamMember zusr zcon tid remove mBody >>= \case + TeamMemberDeleteAccepted -> pure (empty & setStatus status202) + TeamMemberDeleteCompleted -> pure empty + +data TeamMemberDeleteResult + = TeamMemberDeleteAccepted + | TeamMemberDeleteCompleted + +-- | 'TeamMemberDeleteData' is only required for binding teams +deleteTeamMember :: UserId -> ConnId -> TeamId -> UserId -> Maybe TeamMemberDeleteData -> Galley TeamMemberDeleteResult +deleteTeamMember zusr zcon tid remove mBody = do Log.debug $ Log.field "targets" (toByteString remove) . Log.field "action" (Log.val "Teams.deleteTeamMember") @@ -366,14 +447,14 @@ deleteTeamMember (zusr ::: zcon ::: tid ::: remove ::: req ::: _ ::: _) = do team <- tdTeam <$> (Data.team tid >>= ifNothing teamNotFound) if team ^. teamBinding == Binding && isTeamMember remove mems then do - body <- fromJsonBody (JsonRequest req) + body <- mBody & ifNothing (invalidPayload "missing request body") ensureReAuthorised zusr (body ^. tmdAuthPassword) deleteUser remove Journal.teamUpdate tid (filter (\u -> u ^. userId /= remove) mems) - pure (empty & setStatus status202) + pure TeamMemberDeleteAccepted else do uncheckedRemoveTeamMember zusr (Just zcon) tid remove mems - pure empty + pure TeamMemberDeleteCompleted -- This function is "unchecked" because it does not validate that the user has the `RemoveTeamMember` permission. uncheckedRemoveTeamMember :: UserId -> Maybe ConnId -> TeamId -> UserId -> [TeamMember] -> Galley () @@ -387,7 +468,7 @@ uncheckedRemoveTeamMember zusr zcon tid remove mems = do let edata = Conv.EdMembersLeave (Conv.UserIdList [remove]) cc <- Data.teamConversations tid for_ cc $ \c -> Data.conversation (c ^. conversationId) >>= \conv -> - for_ conv $ \dc -> when (remove `isMember` Data.convMembers dc) $ do + for_ conv $ \dc -> when (makeIdOpaque remove `isMember` Data.convMembers dc) $ do Data.removeMember remove (c ^. conversationId) unless (c ^. managedConversation) $ pushEvent tmids edata now dc @@ -400,22 +481,35 @@ uncheckedRemoveTeamMember zusr zcon tid remove mems = do push1 $ p & pushConn .~ zcon void . forkIO $ void $ External.deliver (bots `zip` repeat y) -getTeamConversations :: UserId ::: TeamId ::: JSON -> Galley Response -getTeamConversations (zusr ::: tid ::: _) = do +getTeamConversationsH :: UserId ::: TeamId ::: JSON -> Galley Response +getTeamConversationsH (zusr ::: tid ::: _) = do + json <$> getTeamConversations zusr tid + +getTeamConversations :: UserId -> TeamId -> Galley TeamConversationList +getTeamConversations zusr tid = do tm <- Data.teamMember tid zusr >>= ifNothing noTeamMember unless (tm `hasPermission` GetTeamConversations) $ throwM (operationDenied GetTeamConversations) - json . newTeamConversationList <$> Data.teamConversations tid + newTeamConversationList <$> Data.teamConversations tid -getTeamConversation :: UserId ::: TeamId ::: ConvId ::: JSON -> Galley Response -getTeamConversation (zusr ::: tid ::: cid ::: _) = do +getTeamConversationH :: UserId ::: TeamId ::: ConvId ::: JSON -> Galley Response +getTeamConversationH (zusr ::: tid ::: cid ::: _) = do + json <$> getTeamConversation zusr tid cid + +getTeamConversation :: UserId -> TeamId -> ConvId -> Galley TeamConversation +getTeamConversation zusr tid cid = do tm <- Data.teamMember tid zusr >>= ifNothing noTeamMember unless (tm `hasPermission` GetTeamConversations) $ throwM (operationDenied GetTeamConversations) - Data.teamConversation tid cid >>= maybe (throwM convNotFound) (pure . json) + Data.teamConversation tid cid >>= maybe (throwM convNotFound) pure + +deleteTeamConversationH :: UserId ::: ConnId ::: TeamId ::: ConvId ::: JSON -> Galley Response +deleteTeamConversationH (zusr ::: zcon ::: tid ::: cid ::: _) = do + deleteTeamConversation zusr zcon tid cid + pure empty -deleteTeamConversation :: UserId ::: ConnId ::: TeamId ::: ConvId ::: JSON -> Galley Response -deleteTeamConversation (zusr ::: zcon ::: tid ::: cid ::: _) = do +deleteTeamConversation :: UserId -> ConnId -> TeamId -> ConvId -> Galley () +deleteTeamConversation zusr zcon tid cid = do (bots, cmems) <- botsAndUsers <$> Data.members cid ensureActionAllowed Roles.DeleteConversation =<< getSelfMember zusr cmems flip Data.deleteCode ReusableCode =<< mkKey cid @@ -428,7 +522,6 @@ deleteTeamConversation (zusr ::: zcon ::: tid ::: cid ::: _) = do -- TODO: we don't delete bots here, but we should do that, since every -- bot user can only be in a single conversation Data.removeTeamConv tid cid - pure empty -- Internal ----------------------------------------------------------------- @@ -446,8 +539,8 @@ withTeamIds :: UserId -> Maybe (Either (Range 1 32 (List TeamId)) TeamId) -> Range 1 100 Int32 -> - (Bool -> [TeamId] -> Galley Response) -> - Galley Response + (Bool -> [TeamId] -> Galley a) -> + Galley a withTeamIds usr range size k = case range of Nothing -> do Data.ResultSet r <- Data.teamIdsFrom usr Nothing (rcast size) @@ -487,7 +580,7 @@ ensureNotElevated targetPermissions member = ) $ throwM invalidPermissions -addTeamMemberInternal :: TeamId -> Maybe UserId -> Maybe ConnId -> NewTeamMember -> [TeamMember] -> Galley Response +addTeamMemberInternal :: TeamId -> Maybe UserId -> Maybe ConnId -> NewTeamMember -> [TeamMember] -> Galley () addTeamMemberInternal tid origin originConn newMem mems = do let new = newMem ^. ntmNewTeamMember Log.debug $ @@ -503,12 +596,11 @@ addTeamMemberInternal tid origin originConn newMem mems = do Data.addMember now (c ^. conversationId) (new ^. userId) let e = newEvent MemberJoin tid now & eventData .~ Just (EdMemberJoin (new ^. userId)) push1 $ newPush1 (new ^. userId) (TeamEvent e) (r origin new) & pushConn .~ originConn - pure empty where r (Just o) n = list1 (userRecipient o) (membersToRecipients (Just o) (n : mems)) r Nothing n = list1 (userRecipient (n ^. userId)) (membersToRecipients Nothing (n : mems)) -finishCreateTeam :: Team -> TeamMember -> [TeamMember] -> Maybe ConnId -> Galley Response +finishCreateTeam :: Team -> TeamMember -> [TeamMember] -> Maybe ConnId -> Galley TeamId finishCreateTeam team owner others zcon = do let zusr = owner ^. userId for_ (owner : others) $ @@ -517,7 +609,7 @@ finishCreateTeam team owner others zcon = do let e = newEvent TeamCreate (team ^. teamId) now & eventData .~ Just (EdTeamCreate team) let r = membersToRecipients Nothing others push1 $ newPush1 zusr (TeamEvent e) (list1 (userRecipient zusr) r) & pushConn .~ zcon - pure (empty & setStatus status201 . location (team ^. teamId)) + pure (team ^. teamId) withBindingTeam :: UserId -> (TeamId -> Galley b) -> Galley b withBindingTeam zusr callback = do @@ -527,69 +619,101 @@ withBindingTeam zusr callback = do Binding -> callback tid NonBinding -> throwM nonBindingTeam -getBindingTeamId :: UserId -> Galley Response -getBindingTeamId zusr = withBindingTeam zusr $ pure . json +getBindingTeamIdH :: UserId -> Galley Response +getBindingTeamIdH = fmap json . getBindingTeamId + +getBindingTeamId :: UserId -> Galley TeamId +getBindingTeamId zusr = withBindingTeam zusr pure -getBindingTeamMembers :: UserId -> Galley Response +getBindingTeamMembersH :: UserId -> Galley Response +getBindingTeamMembersH = fmap json . getBindingTeamMembers + +getBindingTeamMembers :: UserId -> Galley TeamMemberList getBindingTeamMembers zusr = withBindingTeam zusr $ \tid -> do members <- Data.teamMembers tid - pure . json $ newTeamMemberList members + pure $ newTeamMemberList members -- Public endpoints for feature checks -getSSOStatus :: UserId ::: TeamId ::: JSON -> Galley Response -getSSOStatus (uid ::: tid ::: ct) = do +getSSOStatusH :: UserId ::: TeamId ::: JSON -> Galley Response +getSSOStatusH (uid ::: tid ::: _) = do + json <$> getSSOStatus uid tid + +getSSOStatus :: UserId -> TeamId -> Galley SSOTeamConfig +getSSOStatus uid tid = do membs <- Data.teamMembers tid void $ permissionCheck uid ViewSSOTeamSettings membs - getSSOStatusInternal (tid ::: ct) + getSSOStatusInternal tid -getLegalholdStatus :: UserId ::: TeamId ::: JSON -> Galley Response -getLegalholdStatus (uid ::: tid ::: ct) = do +getLegalholdStatusH :: UserId ::: TeamId ::: JSON -> Galley Response +getLegalholdStatusH (uid ::: tid ::: _) = do + json <$> getLegalholdStatus uid tid + +getLegalholdStatus :: UserId -> TeamId -> Galley LegalHoldTeamConfig +getLegalholdStatus uid tid = do membs <- Data.teamMembers tid void $ permissionCheck uid ViewLegalHoldTeamSettings membs - getLegalholdStatusInternal (tid ::: ct) + getLegalholdStatusInternal tid -- Enable / Disable team features -- These endpoints are internal only and meant to be called -- only from authorized personnel (e.g., from a backoffice tool) -- | Get SSO status for a team. -getSSOStatusInternal :: TeamId ::: JSON -> Galley Response -getSSOStatusInternal (tid ::: _) = do - defConfig :: SSOTeamConfig <- do +getSSOStatusInternalH :: TeamId ::: JSON -> Galley Response +getSSOStatusInternalH (tid ::: _) = do + json <$> getSSOStatusInternal tid + +getSSOStatusInternal :: TeamId -> Galley SSOTeamConfig +getSSOStatusInternal tid = do + defConfig <- do featureSSO <- view (options . optSettings . setFeatureFlags . flagSSO) pure . SSOTeamConfig $ case featureSSO of FeatureSSOEnabledByDefault -> SSOEnabled FeatureSSODisabledByDefault -> SSODisabled - ssoTeamConfig :: Maybe SSOTeamConfig <- SSOData.getSSOTeamConfig tid - pure . json . fromMaybe defConfig $ ssoTeamConfig + ssoTeamConfig <- SSOData.getSSOTeamConfig tid + pure . fromMaybe defConfig $ ssoTeamConfig -- | Enable or disable SSO for a team. -setSSOStatusInternal :: TeamId ::: JsonRequest SSOTeamConfig ::: JSON -> Galley Response -setSSOStatusInternal (tid ::: req ::: _) = do - ssoTeamConfig :: SSOTeamConfig <- fromJsonBody req +setSSOStatusInternalH :: TeamId ::: JsonRequest SSOTeamConfig ::: JSON -> Galley Response +setSSOStatusInternalH (tid ::: req ::: _) = do + ssoTeamConfig <- fromJsonBody req + setSSOStatusInternal tid ssoTeamConfig + pure noContent + +setSSOStatusInternal :: TeamId -> SSOTeamConfig -> Galley () +setSSOStatusInternal tid ssoTeamConfig = do case ssoTeamConfigStatus ssoTeamConfig of SSODisabled -> throwM disableSsoNotImplemented SSOEnabled -> pure () -- this one is easy to implement :) SSOData.setSSOTeamConfig tid ssoTeamConfig - pure noContent -- | Get legal hold status for a team. -getLegalholdStatusInternal :: TeamId ::: JSON -> Galley Response -getLegalholdStatusInternal (tid ::: _) = do +getLegalholdStatusInternalH :: TeamId ::: JSON -> Galley Response +getLegalholdStatusInternalH (tid ::: _) = do + json <$> getLegalholdStatusInternal tid + +getLegalholdStatusInternal :: TeamId -> Galley LegalHoldTeamConfig +getLegalholdStatusInternal tid = do featureLegalHold <- view (options . optSettings . setFeatureFlags . flagLegalHold) case featureLegalHold of FeatureLegalHoldDisabledByDefault -> do legalHoldTeamConfig <- LegalHoldData.getLegalHoldTeamConfig tid - pure . json . fromMaybe disabledConfig $ legalHoldTeamConfig + pure (fromMaybe disabledConfig legalHoldTeamConfig) FeatureLegalHoldDisabledPermanently -> do - pure . json $ disabledConfig + pure disabledConfig where disabledConfig = LegalHoldTeamConfig LegalHoldDisabled -- | Enable or disable legal hold for a team. -setLegalholdStatusInternal :: TeamId ::: JsonRequest LegalHoldTeamConfig ::: JSON -> Galley Response -setLegalholdStatusInternal (tid ::: req ::: _) = do +setLegalholdStatusInternalH :: TeamId ::: JsonRequest LegalHoldTeamConfig ::: JSON -> Galley Response +setLegalholdStatusInternalH (tid ::: req ::: _) = do + legalHoldTeamConfig <- fromJsonBody req + setLegalholdStatusInternal tid legalHoldTeamConfig + pure noContent + +setLegalholdStatusInternal :: TeamId -> LegalHoldTeamConfig -> Galley () +setLegalholdStatusInternal tid legalHoldTeamConfig = do do featureLegalHold <- view (options . optSettings . setFeatureFlags . flagLegalHold) case featureLegalHold of @@ -597,9 +721,7 @@ setLegalholdStatusInternal (tid ::: req ::: _) = do pure () FeatureLegalHoldDisabledPermanently -> do throwM legalHoldFeatureFlagNotEnabled - legalHoldTeamConfig <- fromJsonBody req case legalHoldTeamConfigStatus legalHoldTeamConfig of LegalHoldDisabled -> removeSettings' tid Nothing LegalHoldEnabled -> pure () LegalHoldData.setLegalHoldTeamConfig tid legalHoldTeamConfig - pure noContent diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index c2eaa2b7594..bf4e880e6cb 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -1,39 +1,39 @@ module Galley.API.Update ( -- * Managing Conversations - acceptConv, - blockConv, - unblockConv, - checkReusableCode, - joinConversationById, - joinConversationByReusableCode, - addCode, - rmCode, - getCode, - updateConversationDeprecated, - updateConversationName, - updateConversationAccess, - updateConversationReceiptMode, - updateConversationMessageTimer, + acceptConvH, + blockConvH, + unblockConvH, + checkReusableCodeH, + joinConversationByIdH, + joinConversationByReusableCodeH, + addCodeH, + rmCodeH, + getCodeH, + updateConversationDeprecatedH, + updateConversationNameH, + updateConversationAccessH, + updateConversationReceiptModeH, + updateConversationMessageTimerH, -- * Managing Members - Galley.API.Update.addMembers, - updateSelfMember, - updateOtherMember, - removeMember, + Galley.API.Update.addMembersH, + updateSelfMemberH, + updateOtherMemberH, + removeMemberH, -- * Talking - postOtrMessage, - postProtoOtrMessage, - postOtrBroadcast, - postProtoOtrBroadcast, - isTyping, + postOtrMessageH, + postProtoOtrMessageH, + postOtrBroadcastH, + postProtoOtrBroadcastH, + isTypingH, -- * External Services - addService, - rmService, - Galley.API.Update.addBot, - rmBot, - postBotMessage, + addServiceH, + rmServiceH, + Galley.API.Update.addBotH, + rmBotH, + postBotMessageH, ) where @@ -43,7 +43,9 @@ import Control.Monad.Catch import Control.Monad.State import Data.Code import Data.Id +import Data.IdMapping import Data.List (delete) +import Data.List.NonEmpty (nonEmpty) import Data.List1 import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -55,14 +57,14 @@ import Galley.API.Util import Galley.App import qualified Galley.Data as Data import Galley.Data.Services as Data -import Galley.Data.Types +import Galley.Data.Types hiding (Conversation) import qualified Galley.External as External import qualified Galley.Intra.Client as Intra import Galley.Intra.Push import Galley.Intra.User import Galley.Options import Galley.Types -import Galley.Types.Bot +import Galley.Types.Bot hiding (addBot) import Galley.Types.Clients (Clients) import qualified Galley.Types.Clients as Clients import Galley.Types.Conversations.Roles (Action (..), RoleName, roleNameWireMember) @@ -76,36 +78,62 @@ import Network.Wai import Network.Wai.Predicate hiding (_1, _2, failure, setStatus) import Network.Wai.Utilities -acceptConv :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response -acceptConv (usr ::: conn ::: cnv) = do +acceptConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response +acceptConvH (usr ::: conn ::: cnv) = do + setStatus status200 . json <$> acceptConv usr conn cnv + +acceptConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation +acceptConv usr conn cnv = do conv <- Data.conversation cnv >>= ifNothing convNotFound conv' <- acceptOne2One usr conv conn - setStatus status200 . json <$> conversationView usr conv' + conversationView usr conv' + +blockConvH :: UserId ::: ConvId -> Galley Response +blockConvH (zusr ::: cnv) = do + empty <$ blockConv zusr cnv -blockConv :: UserId ::: ConvId -> Galley Response -blockConv (usr ::: cnv) = do +blockConv :: UserId -> ConvId -> Galley () +blockConv zusr cnv = do conv <- Data.conversation cnv >>= ifNothing convNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ throwM $ invalidOp "block: invalid conversation type" let mems = Data.convMembers conv - when (usr `isMember` mems) $ Data.removeMember usr cnv - return empty + when (makeIdOpaque zusr `isMember` mems) $ Data.removeMember zusr cnv + +unblockConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response +unblockConvH (usr ::: conn ::: cnv) = do + setStatus status200 . json <$> unblockConv usr conn cnv -unblockConv :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response -unblockConv (usr ::: conn ::: cnv) = do +unblockConv :: UserId -> Maybe ConnId -> ConvId -> Galley Conversation +unblockConv usr conn cnv = do conv <- Data.conversation cnv >>= ifNothing convNotFound unless (Data.convType conv `elem` [ConnectConv, One2OneConv]) $ throwM $ invalidOp "unblock: invalid conversation type" conv' <- acceptOne2One usr conv conn - setStatus status200 . json <$> conversationView usr conv' + conversationView usr conv' + +-- conversation updates + +data UpdateResult + = Updated Event + | Unchanged + +handleUpdateResult :: UpdateResult -> Response +handleUpdateResult = \case + Updated ev -> json ev & setStatus status200 + Unchanged -> empty & setStatus status204 + +updateConversationAccessH :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationAccessUpdate -> Galley Response +updateConversationAccessH (usr ::: zcon ::: cnv ::: req) = do + update <- fromJsonBody req + handleUpdateResult <$> updateConversationAccess usr zcon cnv update -updateConversationAccess :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationAccessUpdate -> Galley Response -updateConversationAccess (usr ::: zcon ::: cnv ::: req) = do - body <- fromJsonBody req - let targetAccess = Set.fromList (toList (cupAccess body)) - targetRole = cupAccessRole body +updateConversationAccess :: UserId -> ConnId -> ConvId -> ConversationAccessUpdate -> Galley UpdateResult +updateConversationAccess usr zcon cnv update = do + let targetAccess = Set.fromList (toList (cupAccess update)) + targetRole = cupAccessRole update -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and -- so on; users are not supposed to be able to make other conversations -- have 'PrivateAccessRole' @@ -129,17 +157,18 @@ updateConversationAccess (usr ::: zcon ::: cnv ::: req) = do let currentAccess = Set.fromList (toList $ Data.convAccess conv) currentRole = Data.convAccessRole conv if currentAccess == targetAccess && currentRole == targetRole - then return $ empty & setStatus status204 + then pure Unchanged else - uncheckedUpdateConversationAccess - body - usr - zcon - conv - (currentAccess, targetAccess) - (currentRole, targetRole) - users - bots + Updated + <$> uncheckedUpdateConversationAccess + update + usr + zcon + conv + (currentAccess, targetAccess) + (currentRole, targetRole) + users + bots where checkTeamConv tid self = do -- Access mode change for managed conversation is not allowed @@ -159,7 +188,7 @@ uncheckedUpdateConversationAccess :: (AccessRole, AccessRole) -> [Member] -> [BotMember] -> - Galley Response + Galley Event uncheckedUpdateConversationAccess body usr zcon conv (currentAccess, targetAccess) (currentRole, targetRole) users bots = do let cnv = convId conv -- Remove conversation codes if CodeAccess is revoked @@ -193,56 +222,65 @@ uncheckedUpdateConversationAccess body usr zcon conv (currentAccess, targetAcces case removedUsers of [] -> return () x : xs -> do - e <- Data.removeMembers conv usr (list1 x xs) + e <- Data.removeMembers conv usr (Local <$> list1 x xs) -- push event to all clients, including zconn -- since updateConversationAccess generates a second (member removal) event here for_ (newPush (evtFrom e) (ConvEvent e) (recipient <$> users)) $ \p -> push1 p void . forkIO $ void $ External.deliver (newBots `zip` repeat e) -- Return the event - return $ json accessEvent & setStatus status200 + pure accessEvent where usersL :: Lens' ([Member], [BotMember]) [Member] usersL = _1 botsL :: Lens' ([Member], [BotMember]) [BotMember] botsL = _2 -updateConversationReceiptMode :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationReceiptModeUpdate ::: JSON -> Galley Response -updateConversationReceiptMode (usr ::: zcon ::: cnv ::: req ::: _) = do - ConversationReceiptModeUpdate target <- fromJsonBody req +updateConversationReceiptModeH :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationReceiptModeUpdate ::: JSON -> Galley Response +updateConversationReceiptModeH (usr ::: zcon ::: cnv ::: req ::: _) = do + update <- fromJsonBody req + handleUpdateResult <$> updateConversationReceiptMode usr zcon cnv update + +updateConversationReceiptMode :: UserId -> ConnId -> ConvId -> ConversationReceiptModeUpdate -> Galley UpdateResult +updateConversationReceiptMode usr zcon cnv receiptModeUpdate@(ConversationReceiptModeUpdate target) = do (bots, users) <- botsAndUsers <$> Data.members cnv ensureActionAllowed ModifyConversationReceiptMode =<< getSelfMember usr users current <- Data.lookupReceiptMode cnv if current == Just target - then return $ empty & setStatus status204 - else update users bots target + then pure Unchanged + else Updated <$> update users bots where - update users bots mode = do + update users bots = do -- Update Cassandra & send an event - Data.updateConversationReceiptMode cnv mode + Data.updateConversationReceiptMode cnv target now <- liftIO getCurrentTime - let receiptEvent = Event ConvReceiptModeUpdate cnv usr now (Just $ EdConvReceiptModeUpdate (ConversationReceiptModeUpdate mode)) + let receiptEvent = Event ConvReceiptModeUpdate cnv usr now (Just $ EdConvReceiptModeUpdate receiptModeUpdate) pushEvent receiptEvent users bots zcon - return $ json receiptEvent & setStatus status200 + pure receiptEvent -updateConversationMessageTimer :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationMessageTimerUpdate -> Galley Response -updateConversationMessageTimer (usr ::: zcon ::: cnv ::: req) = do - body <- fromJsonBody req - let messageTimer = cupMessageTimer body +updateConversationMessageTimerH :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationMessageTimerUpdate -> Galley Response +updateConversationMessageTimerH (usr ::: zcon ::: cnv ::: req) = do + timerUpdate <- fromJsonBody req + handleUpdateResult <$> updateConversationMessageTimer usr zcon cnv timerUpdate + +updateConversationMessageTimer :: UserId -> ConnId -> ConvId -> ConversationMessageTimerUpdate -> Galley UpdateResult +updateConversationMessageTimer usr zcon cnv timerUpdate@(ConversationMessageTimerUpdate target) = do -- checks and balances (bots, users) <- botsAndUsers <$> Data.members cnv ensureActionAllowed ModifyConversationMessageTimer =<< getSelfMember usr users conv <- Data.conversation cnv >>= ifNothing convNotFound ensureGroupConv conv let currentTimer = Data.convMessageTimer conv - if currentTimer == messageTimer - then return $ empty & setStatus status204 - else do + if currentTimer == target + then pure Unchanged + else Updated <$> update users bots + where + update users bots = do -- update cassandra & send event now <- liftIO getCurrentTime - let e = Event ConvMessageTimerUpdate cnv usr now (Just $ EdConvMessageTimerUpdate body) - Data.updateConversationMessageTimer cnv messageTimer - pushEvent e users bots zcon - return $ json e & setStatus status200 + let timerEvent = Event ConvMessageTimerUpdate cnv usr now (Just $ EdConvMessageTimerUpdate timerUpdate) + Data.updateConversationMessageTimer cnv target + pushEvent timerEvent users bots zcon + pure timerEvent pushEvent :: Event -> [Member] -> [BotMember] -> ConnId -> Galley () pushEvent e users bots zcon = do @@ -250,8 +288,18 @@ pushEvent e users bots zcon = do push1 $ p & pushConn ?~ zcon void . forkIO $ void $ External.deliver (bots `zip` repeat e) -addCode :: UserId ::: ConnId ::: ConvId -> Galley Response -addCode (usr ::: zcon ::: cnv) = do +addCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response +addCodeH (usr ::: zcon ::: cnv) = do + addCode usr zcon cnv <&> \case + CodeAdded event -> json event & setStatus status201 + CodeAlreadyExisted conversationCode -> json conversationCode & setStatus status200 + +data AddCodeResult + = CodeAdded Event + | CodeAlreadyExisted ConversationCode + +addCode :: UserId -> ConnId -> ConvId -> Galley AddCodeResult +addCode usr zcon cnv = do conv <- Data.conversation cnv >>= ifNothing convNotFound ensureConvMember (Data.convMembers conv) usr ensureAccess conv CodeAccess @@ -260,24 +308,28 @@ addCode (usr ::: zcon ::: cnv) = do mCode <- Data.lookupCode key ReusableCode case mCode of Nothing -> do - c <- generate cnv ReusableCode (Timeout 3600 * 24 * 365) -- one year TODO: configurable - Data.insertCode c + code <- generate cnv ReusableCode (Timeout 3600 * 24 * 365) -- one year TODO: configurable + Data.insertCode code now <- liftIO getCurrentTime - res <- createCode c - let e = Event ConvCodeUpdate cnv usr now (Just $ EdConvCodeUpdate res) - pushEvent e users bots zcon - return $ json e & setStatus status201 - Just c -> do - res <- createCode c - return $ json res & setStatus status200 + conversationCode <- createCode code + let event = Event ConvCodeUpdate cnv usr now (Just $ EdConvCodeUpdate conversationCode) + pushEvent event users bots zcon + pure $ CodeAdded event + Just code -> do + conversationCode <- createCode code + pure $ CodeAlreadyExisted conversationCode where createCode :: Code -> Galley ConversationCode - createCode c = do + createCode code = do urlPrefix <- view $ options . optSettings . setConversationCodeURI - return $ mkConversationCode (codeKey c) (codeValue c) urlPrefix + return $ mkConversationCode (codeKey code) (codeValue code) urlPrefix + +rmCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response +rmCodeH (usr ::: zcon ::: cnv) = do + setStatus status200 . json <$> rmCode usr zcon cnv -rmCode :: UserId ::: ConnId ::: ConvId -> Galley Response -rmCode (usr ::: zcon ::: cnv) = do +rmCode :: UserId -> ConnId -> ConvId -> Galley Event +rmCode usr zcon cnv = do conv <- Data.conversation cnv >>= ifNothing convNotFound ensureConvMember (Data.convMembers conv) usr ensureAccess conv CodeAccess @@ -285,12 +337,16 @@ rmCode (usr ::: zcon ::: cnv) = do key <- mkKey cnv Data.deleteCode key ReusableCode now <- liftIO getCurrentTime - let e = Event ConvCodeDelete cnv usr now Nothing - pushEvent e users bots zcon - return $ json e & setStatus status200 + let event = Event ConvCodeDelete cnv usr now Nothing + pushEvent event users bots zcon + pure event -getCode :: UserId ::: ConvId -> Galley Response -getCode (usr ::: cnv) = do +getCodeH :: UserId ::: ConvId -> Galley Response +getCodeH (usr ::: cnv) = do + setStatus status200 . json <$> getCode usr cnv + +getCode :: UserId -> ConvId -> Galley ConversationCode +getCode usr cnv = do conv <- Data.conversation cnv >>= ifNothing convNotFound ensureAccess conv CodeAccess ensureConvMember (Data.convMembers conv) usr @@ -298,23 +354,20 @@ getCode (usr ::: cnv) = do c <- Data.lookupCode key ReusableCode >>= ifNothing codeNotFound returnCode c -returnCode :: Code -> Galley Response +returnCode :: Code -> Galley ConversationCode returnCode c = do urlPrefix <- view $ options . optSettings . setConversationCodeURI - let res = mkConversationCode (codeKey c) (codeValue c) urlPrefix - return $ setStatus status200 . json $ res + pure $ mkConversationCode (codeKey c) (codeValue c) urlPrefix -checkReusableCode :: JsonRequest ConversationCode -> Galley Response -checkReusableCode req = do +checkReusableCodeH :: JsonRequest ConversationCode -> Galley Response +checkReusableCodeH req = do convCode <- fromJsonBody req - void $ verifyReusableCode convCode - return empty + checkReusableCode convCode + pure empty -joinConversationByReusableCode :: UserId ::: ConnId ::: JsonRequest ConversationCode -> Galley Response -joinConversationByReusableCode (zusr ::: zcon ::: req) = do - convCode <- fromJsonBody req - c <- verifyReusableCode convCode - joinConversation zusr zcon (codeConversation c) CodeAccess +checkReusableCode :: ConversationCode -> Galley () +checkReusableCode convCode = do + void $ verifyReusableCode convCode verifyReusableCode :: ConversationCode -> Galley Code verifyReusableCode convCode = do @@ -323,123 +376,201 @@ verifyReusableCode convCode = do throwM codeNotFound return c -joinConversationById :: UserId ::: ConnId ::: ConvId ::: JSON -> Galley Response -joinConversationById (zusr ::: zcon ::: cnv ::: _) = joinConversation zusr zcon cnv LinkAccess +joinConversationByReusableCodeH :: UserId ::: ConnId ::: JsonRequest ConversationCode -> Galley Response +joinConversationByReusableCodeH (zusr ::: zcon ::: req) = do + convCode <- fromJsonBody req + handleUpdateResult <$> joinConversationByReusableCode zusr zcon convCode + +joinConversationByReusableCode :: UserId -> ConnId -> ConversationCode -> Galley UpdateResult +joinConversationByReusableCode zusr zcon convCode = do + c <- verifyReusableCode convCode + joinConversation zusr zcon (codeConversation c) CodeAccess + +joinConversationByIdH :: UserId ::: ConnId ::: ConvId ::: JSON -> Galley Response +joinConversationByIdH (zusr ::: zcon ::: cnv ::: _) = + handleUpdateResult <$> joinConversationById zusr zcon cnv -joinConversation :: UserId -> ConnId -> ConvId -> Access -> Galley Response +joinConversationById :: UserId -> ConnId -> ConvId -> Galley UpdateResult +joinConversationById zusr zcon cnv = + joinConversation zusr zcon cnv LinkAccess + +joinConversation :: UserId -> ConnId -> ConvId -> Access -> Galley UpdateResult joinConversation zusr zcon cnv access = do conv <- Data.conversation cnv >>= ifNothing convNotFound ensureAccess conv access mbTms <- traverse Data.teamMembers $ Data.convTeam conv ensureAccessRole (Data.convAccessRole conv) [zusr] mbTms - let newUsers = filter (notIsMember conv) [zusr] - ensureMemberLimit (toList $ Data.convMembers conv) newUsers + let newUsers = filter (notIsMember conv . makeIdOpaque) [zusr] + ensureMemberLimit (toList $ Data.convMembers conv) (makeIdOpaque <$> newUsers) -- NOTE: When joining conversations, all users become members -- as this is our desired behavior for these types of conversations -- where there is no way to control who joins, etc. addToConversation (botsAndUsers (Data.convMembers conv)) (zusr, roleNameWireMember) zcon ((,roleNameWireMember) <$> newUsers) conv -addMembers :: UserId ::: ConnId ::: ConvId ::: JsonRequest Invite -> Galley Response -addMembers (zusr ::: zcon ::: cid ::: req) = do - body <- fromJsonBody req - conv <- Data.conversation cid >>= ifNothing convNotFound - let mems = botsAndUsers (Data.convMembers conv) - self <- getSelfMember zusr (snd mems) - ensureActionAllowed AddConversationMember self - toAdd <- fromMemberSize <$> checkedMemberAddSize (toList $ invUsers body) - let newUsers = filter (notIsMember conv) (toList toAdd) - ensureMemberLimit (toList $ Data.convMembers conv) newUsers - ensureAccess conv InviteAccess - ensureConvRoleNotElevated self (invRoleName body) - case Data.convTeam conv of - Nothing -> do - ensureAccessRole (Data.convAccessRole conv) newUsers Nothing - ensureConnectedOrSameTeam zusr newUsers - Just ti -> teamConvChecks ti newUsers conv - addToConversation mems (zusr, memConvRoleName self) zcon ((,invRoleName body) <$> newUsers) conv +addMembersH :: UserId ::: ConnId ::: OpaqueConvId ::: JsonRequest Invite -> Galley Response +addMembersH (zusr ::: zcon ::: cid ::: req) = do + invite <- fromJsonBody req + handleUpdateResult <$> addMembers zusr zcon cid invite + +addMembers :: UserId -> ConnId -> OpaqueConvId -> Invite -> Galley UpdateResult +addMembers zusr zcon cid invite = do + resolveOpaqueConvId cid >>= \case + Mapped idMapping -> throwM . federationNotImplemented $ pure idMapping + Local localConvId -> addMembersToLocalConv localConvId where - teamConvChecks tid newUsers conv = do + addMembersToLocalConv convId = do + conv <- Data.conversation convId >>= ifNothing convNotFound + let mems = botsAndUsers (Data.convMembers conv) + self <- getSelfMember zusr (snd mems) + ensureActionAllowed AddConversationMember self + toAdd <- fromMemberSize <$> checkedMemberAddSize (toList $ invUsers invite) + let newOpaqueUsers = filter (notIsMember conv) (toList toAdd) + (newUsers, newQualifiedUsers) <- partitionMappedOrLocalIds <$> traverse resolveOpaqueUserId newOpaqueUsers + -- FUTUREWORK(federation): allow adding remote members + -- this one is a bit tricky because all of the checks that need to be done, + -- some of them on remote backends. + for_ (nonEmpty newQualifiedUsers) $ + throwM . federationNotImplemented + ensureMemberLimit (toList $ Data.convMembers conv) newOpaqueUsers + ensureAccess conv InviteAccess + ensureConvRoleNotElevated self (invRoleName invite) + case Data.convTeam conv of + Nothing -> do + ensureAccessRole (Data.convAccessRole conv) newUsers Nothing + ensureConnectedOrSameTeam zusr newUsers + Just ti -> teamConvChecks ti newUsers convId conv + addToConversation mems (zusr, memConvRoleName self) zcon ((,invRoleName invite) <$> newUsers) conv + teamConvChecks tid newUsers convId conv = do tms <- Data.teamMembersLimited tid newUsers ensureAccessRole (Data.convAccessRole conv) newUsers (Just tms) - tcv <- Data.teamConversation tid cid + tcv <- Data.teamConversation tid convId when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged ensureConnectedOrSameTeam zusr newUsers -updateSelfMember :: UserId ::: ConnId ::: ConvId ::: JsonRequest MemberUpdate -> Galley Response -updateSelfMember (zusr ::: zcon ::: cid ::: req) = do - conv <- getConversationAndCheckMembership zusr cid - body <- fromJsonBody req +updateSelfMemberH :: UserId ::: ConnId ::: ConvId ::: JsonRequest MemberUpdate -> Galley Response +updateSelfMemberH (zusr ::: zcon ::: cid ::: req) = do + update <- fromJsonBody req + updateSelfMember zusr zcon cid update + return empty + +updateSelfMember :: UserId -> ConnId -> ConvId -> MemberUpdate -> Galley () +updateSelfMember zusr zcon cid update = do + conv <- getConversationAndCheckMembership zusr (makeIdOpaque cid) m <- getSelfMember zusr (Data.convMembers conv) -- Ensure no self role upgrades - for_ (mupConvRoleName body) $ ensureConvRoleNotElevated m - void $ processUpdateMemberEvent zusr zcon cid [m] m body + for_ (mupConvRoleName update) $ ensureConvRoleNotElevated m + void $ processUpdateMemberEvent zusr zcon cid [m] m update + +updateOtherMemberH :: UserId ::: ConnId ::: ConvId ::: UserId ::: JsonRequest OtherMemberUpdate -> Galley Response +updateOtherMemberH (zusr ::: zcon ::: cid ::: victim ::: req) = do + update <- fromJsonBody req + updateOtherMember zusr zcon cid victim update return empty -updateOtherMember :: UserId ::: ConnId ::: ConvId ::: UserId ::: JsonRequest OtherMemberUpdate -> Galley Response -updateOtherMember (zusr ::: zcon ::: cid ::: victim ::: req) = do +updateOtherMember :: UserId -> ConnId -> ConvId -> UserId -> OtherMemberUpdate -> Galley () +updateOtherMember zusr zcon cid victim update = do when (zusr == victim) $ throwM invalidTargetUserOp - conv <- getConversationAndCheckMembership zusr cid + conv <- getConversationAndCheckMembership zusr (makeIdOpaque cid) let (bots, users) = botsAndUsers (Data.convMembers conv) - body <- fromJsonBody req ensureActionAllowed ModifyOtherConversationMember =<< getSelfMember zusr users memTarget <- getOtherMember victim users - e <- processUpdateMemberEvent zusr zcon cid users memTarget (memberUpdate {mupConvRoleName = omuConvRoleName body}) + e <- processUpdateMemberEvent zusr zcon cid users memTarget (memberUpdate {mupConvRoleName = omuConvRoleName update}) void . forkIO $ void $ External.deliver (bots `zip` repeat e) - return empty -removeMember :: UserId ::: ConnId ::: ConvId ::: UserId -> Galley Response -removeMember (zusr ::: zcon ::: cid ::: victim) = do - conv <- Data.conversation cid >>= ifNothing convNotFound - let (bots, users) = botsAndUsers (Data.convMembers conv) - genConvChecks conv users - case Data.convTeam conv of - Nothing -> pure () - Just ti -> teamConvChecks ti - if victim `isMember` users - then do - e <- Data.removeMembers conv zusr (singleton victim) - for_ (newPush (evtFrom e) (ConvEvent e) (recipient <$> users)) $ \p -> - push1 $ p & pushConn ?~ zcon - void . forkIO $ void $ External.deliver (bots `zip` repeat e) - return $ json e & setStatus status200 - else return $ empty & setStatus status204 +removeMemberH :: UserId ::: ConnId ::: OpaqueConvId ::: OpaqueUserId -> Galley Response +removeMemberH (zusr ::: zcon ::: cid ::: victim) = do + handleUpdateResult <$> removeMember zusr zcon cid victim + +removeMember :: UserId -> ConnId -> OpaqueConvId -> OpaqueUserId -> Galley UpdateResult +removeMember zusr zcon cid victim = do + resolveOpaqueConvId cid >>= \case + Mapped idMapping -> throwM . federationNotImplemented $ pure idMapping + Local localConvId -> removeMemberOfLocalConversation localConvId where + removeMemberOfLocalConversation convId = do + conv <- Data.conversation convId >>= ifNothing convNotFound + let (bots, users) = botsAndUsers (Data.convMembers conv) + genConvChecks conv users + case Data.convTeam conv of + Nothing -> pure () + Just ti -> teamConvChecks convId ti + if victim `isMember` users + then do + resolvedVictim <- resolveOpaqueUserId victim + event <- Data.removeMembers conv zusr (singleton resolvedVictim) + case resolvedVictim of + Mapped _ -> pure () -- FUTUREWORK(federation): notify victim + Local _ -> pure () -- nothing to do + -- FUTUREWORK(federation): users can be on other backend, how to notify it? + for_ (newPush (evtFrom event) (ConvEvent event) (recipient <$> users)) $ \p -> + push1 $ p & pushConn ?~ zcon + void . forkIO $ void $ External.deliver (bots `zip` repeat event) + pure $ Updated event + else pure Unchanged genConvChecks conv usrs = do ensureGroupConv conv - if zusr == victim + if makeIdOpaque zusr == victim then ensureActionAllowed LeaveConversation =<< getSelfMember zusr usrs else ensureActionAllowed RemoveConversationMember =<< getSelfMember zusr usrs - teamConvChecks tid = do - tcv <- Data.teamConversation tid cid + teamConvChecks convId tid = do + tcv <- Data.teamConversation tid convId when (maybe False (view managedConversation) tcv) $ throwM (invalidOp "Users can not be removed from managed conversations.") -postBotMessage :: BotId ::: ConvId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage ::: JSON -> Galley Response -postBotMessage (zbot ::: zcnv ::: val ::: req ::: _) = do - msg <- fromJsonBody req - postNewOtrMessage (botUserId zbot) Nothing zcnv val msg +-- OTR + +data OtrResult + = OtrSent !ClientMismatch + | OtrMissingRecipients !ClientMismatch + +handleOtrResult :: OtrResult -> Response +handleOtrResult = \case + OtrSent m -> json m & setStatus status201 + OtrMissingRecipients m -> json m & setStatus status412 + +postBotMessageH :: BotId ::: ConvId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage ::: JSON -> Galley Response +postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do + message <- fromJsonBody req + handleOtrResult <$> postBotMessage zbot zcnv val message + +postBotMessage :: BotId -> ConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postBotMessage zbot zcnv val message = do + postNewOtrMessage (botUserId zbot) Nothing (makeIdOpaque zcnv) val message -postProtoOtrMessage :: UserId ::: ConnId ::: ConvId ::: OtrFilterMissing ::: Request ::: Media "application" "x-protobuf" -> Galley Response -postProtoOtrMessage (zusr ::: zcon ::: cnv ::: val ::: req ::: _) = - Proto.toNewOtrMessage <$> fromProtoBody req - >>= postNewOtrMessage zusr (Just zcon) cnv val +postProtoOtrMessageH :: UserId ::: ConnId ::: OpaqueConvId ::: OtrFilterMissing ::: Request ::: Media "application" "x-protobuf" -> Galley Response +postProtoOtrMessageH (zusr ::: zcon ::: cnv ::: val ::: req ::: _) = do + message <- Proto.toNewOtrMessage <$> fromProtoBody req + handleOtrResult <$> postOtrMessage zusr zcon cnv val message -postOtrMessage :: UserId ::: ConnId ::: ConvId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage -> Galley Response -postOtrMessage (zusr ::: zcon ::: cnv ::: val ::: req) = - postNewOtrMessage zusr (Just zcon) cnv val =<< fromJsonBody req +postOtrMessageH :: UserId ::: ConnId ::: OpaqueConvId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage -> Galley Response +postOtrMessageH (zusr ::: zcon ::: cnv ::: val ::: req) = do + message <- fromJsonBody req + handleOtrResult <$> postOtrMessage zusr zcon cnv val message -postOtrBroadcast :: UserId ::: ConnId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage -> Galley Response -postOtrBroadcast (zusr ::: zcon ::: val ::: req) = - postNewOtrBroadcast zusr (Just zcon) val =<< fromJsonBody req +postOtrMessage :: UserId -> ConnId -> OpaqueConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postOtrMessage zusr zcon cnv val message = + postNewOtrMessage zusr (Just zcon) cnv val message -postProtoOtrBroadcast :: UserId ::: ConnId ::: OtrFilterMissing ::: Request ::: JSON -> Galley Response -postProtoOtrBroadcast (zusr ::: zcon ::: val ::: req ::: _) = - Proto.toNewOtrMessage <$> fromProtoBody req - >>= postNewOtrBroadcast zusr (Just zcon) val +postProtoOtrBroadcastH :: UserId ::: ConnId ::: OtrFilterMissing ::: Request ::: JSON -> Galley Response +postProtoOtrBroadcastH (zusr ::: zcon ::: val ::: req ::: _) = do + message <- Proto.toNewOtrMessage <$> fromProtoBody req + handleOtrResult <$> postOtrBroadcast zusr zcon val message -postNewOtrBroadcast :: UserId -> Maybe ConnId -> OtrFilterMissing -> NewOtrMessage -> Galley Response +postOtrBroadcastH :: UserId ::: ConnId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage -> Galley Response +postOtrBroadcastH (zusr ::: zcon ::: val ::: req) = do + message <- fromJsonBody req + handleOtrResult <$> postOtrBroadcast zusr zcon val message + +postOtrBroadcast :: UserId -> ConnId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postOtrBroadcast zusr zcon val message = + postNewOtrBroadcast zusr (Just zcon) val message + +-- internal OTR helpers + +-- | bots are not supported on broadcast +postNewOtrBroadcast :: UserId -> Maybe ConnId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult postNewOtrBroadcast usr con val msg = do let sender = newOtrSender msg let recvrs = newOtrRecipients msg @@ -448,19 +579,22 @@ postNewOtrBroadcast usr con val msg = do let (_, toUsers) = foldr (newMessage usr con Nothing msg now) ([], []) rs pushSome (catMaybes toUsers) --- bots are not supported on broadcast - -postNewOtrMessage :: UserId -> Maybe ConnId -> ConvId -> OtrFilterMissing -> NewOtrMessage -> Galley Response +postNewOtrMessage :: UserId -> Maybe ConnId -> OpaqueConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult postNewOtrMessage usr con cnv val msg = do - let sender = newOtrSender msg - let recvrs = newOtrRecipients msg - now <- liftIO getCurrentTime - withValidOtrRecipients usr sender cnv recvrs val now $ \rs -> do - let (toBots, toUsers) = foldr (newMessage usr con (Just cnv) msg now) ([], []) rs - pushSome (catMaybes toUsers) - void . forkIO $ do - gone <- External.deliver toBots - mapM_ (deleteBot cnv . botMemId) gone + resolveOpaqueConvId cnv >>= \case + Mapped idMapping -> throwM . federationNotImplemented $ pure idMapping + Local localConvId -> postToLocalConv localConvId + where + postToLocalConv localConvId = do + let sender = newOtrSender msg + let recvrs = newOtrRecipients msg + now <- liftIO getCurrentTime + withValidOtrRecipients usr sender localConvId recvrs val now $ \rs -> do + let (toBots, toUsers) = foldr (newMessage usr con (Just localConvId) msg now) ([], []) rs + pushSome (catMaybes toUsers) + void . forkIO $ do + gone <- External.deliver toBots + mapM_ (deleteBot localConvId . botMemId) gone newMessage :: UserId -> @@ -494,12 +628,18 @@ newMessage usr con cnv msg now (m, c, t) ~(toBots, toUsers) = . set pushTransient (newOtrTransient msg) in (toBots, p : toUsers) -updateConversationDeprecated :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationRename -> Galley Response -updateConversationDeprecated (zusr ::: zcon ::: cnv ::: req) = updateConversationName (zusr ::: zcon ::: cnv ::: req) +updateConversationDeprecatedH :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationRename -> Galley Response +updateConversationDeprecatedH (zusr ::: zcon ::: cnv ::: req) = do + convRename <- fromJsonBody req + setStatus status200 . json <$> updateConversationName zusr zcon cnv convRename -updateConversationName :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationRename -> Galley Response -updateConversationName (zusr ::: zcon ::: cnv ::: req) = do - body <- fromJsonBody req +updateConversationNameH :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationRename -> Galley Response +updateConversationNameH (zusr ::: zcon ::: cnv ::: req) = do + convRename <- fromJsonBody req + setStatus status200 . json <$> updateConversationName zusr zcon cnv convRename + +updateConversationName :: UserId -> ConnId -> ConvId -> ConversationRename -> Galley Event +updateConversationName zusr zcon cnv convRename = do alive <- Data.isConvAlive cnv unless alive $ do Data.deleteConversation cnv @@ -507,78 +647,90 @@ updateConversationName (zusr ::: zcon ::: cnv ::: req) = do (bots, users) <- botsAndUsers <$> Data.members cnv ensureActionAllowed ModifyConversationName =<< getSelfMember zusr users now <- liftIO getCurrentTime - cn <- rangeChecked (cupName body) + cn <- rangeChecked (cupName convRename) Data.updateConversation cnv cn - let e = Event ConvRename cnv zusr now (Just $ EdConvRename body) + let e = Event ConvRename cnv zusr now (Just $ EdConvRename convRename) for_ (newPush (evtFrom e) (ConvEvent e) (recipient <$> users)) $ \p -> push1 $ p & pushConn ?~ zcon void . forkIO $ void $ External.deliver (bots `zip` repeat e) - return $ json e & setStatus status200 + return e -isTyping :: UserId ::: ConnId ::: ConvId ::: JsonRequest TypingData -> Galley Response -isTyping (zusr ::: zcon ::: cnv ::: req) = do - body <- fromJsonBody req +isTypingH :: UserId ::: ConnId ::: ConvId ::: JsonRequest TypingData -> Galley Response +isTypingH (zusr ::: zcon ::: cnv ::: req) = do + typingData <- fromJsonBody req + isTyping zusr zcon cnv typingData + pure empty + +isTyping :: UserId -> ConnId -> ConvId -> TypingData -> Galley () +isTyping zusr zcon cnv typingData = do mm <- Data.members cnv - unless (zusr `isMember` mm) $ + unless (makeIdOpaque zusr `isMember` mm) $ throwM convNotFound now <- liftIO getCurrentTime - let e = Event Typing cnv zusr now (Just $ EdTyping body) + let e = Event Typing cnv zusr now (Just $ EdTyping typingData) for_ (newPush (evtFrom e) (ConvEvent e) (recipient <$> mm)) $ \p -> push1 $ p & pushConn ?~ zcon & pushRoute .~ RouteDirect & pushTransient .~ True - return empty -addService :: JsonRequest Service -> Galley Response -addService req = do +addServiceH :: JsonRequest Service -> Galley Response +addServiceH req = do Data.insertService =<< fromJsonBody req return empty -rmService :: JsonRequest ServiceRef -> Galley Response -rmService req = do +rmServiceH :: JsonRequest ServiceRef -> Galley Response +rmServiceH req = do Data.deleteService =<< fromJsonBody req return empty -addBot :: UserId ::: ConnId ::: JsonRequest AddBot -> Galley Response -addBot (zusr ::: zcon ::: req) = do - b <- fromJsonBody req +addBotH :: UserId ::: ConnId ::: JsonRequest AddBot -> Galley Response +addBotH (zusr ::: zcon ::: req) = do + bot <- fromJsonBody req + json <$> addBot zusr zcon bot + +addBot :: UserId -> ConnId -> AddBot -> Galley Event +addBot zusr zcon b = do c <- Data.conversation (b ^. addBotConv) >>= ifNothing convNotFound -- Check some preconditions on adding bots to a conversation for_ (Data.convTeam c) $ teamConvChecks (b ^. addBotConv) - (bots, users) <- regularConvChecks b c + (bots, users) <- regularConvChecks c t <- liftIO getCurrentTime Data.updateClient True (botUserId (b ^. addBotId)) (b ^. addBotClient) (e, bm) <- Data.addBotMember zusr (b ^. addBotService) (b ^. addBotId) (b ^. addBotConv) t for_ (newPush (evtFrom e) (ConvEvent e) (recipient <$> users)) $ \p -> push1 $ p & pushConn ?~ zcon void . forkIO $ void $ External.deliver ((bm : bots) `zip` repeat e) - return (json e) + pure e where - regularConvChecks b c = do + regularConvChecks c = do let (bots, users) = botsAndUsers (Data.convMembers c) - unless (zusr `isMember` users) $ + unless (makeIdOpaque zusr `isMember` users) $ throwM convNotFound ensureGroupConv c ensureActionAllowed AddConversationMember =<< getSelfMember zusr users unless (any ((== b ^. addBotId) . botMemId) bots) $ - ensureMemberLimit (toList $ Data.convMembers c) [botUserId (b ^. addBotId)] + ensureMemberLimit (toList $ Data.convMembers c) [makeIdOpaque (botUserId (b ^. addBotId))] return (bots, users) teamConvChecks cid tid = do tcv <- Data.teamConversation tid cid when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged -rmBot :: UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley Response -rmBot (zusr ::: zcon ::: req) = do - b <- fromJsonBody req +rmBotH :: UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley Response +rmBotH (zusr ::: zcon ::: req) = do + bot <- fromJsonBody req + handleUpdateResult <$> rmBot zusr zcon bot + +rmBot :: UserId -> Maybe ConnId -> RemoveBot -> Galley UpdateResult +rmBot zusr zcon b = do c <- Data.conversation (b ^. rmBotConv) >>= ifNothing convNotFound - unless (zusr `isMember` Data.convMembers c) $ + unless (makeIdOpaque zusr `isMember` Data.convMembers c) $ throwM convNotFound let (bots, users) = botsAndUsers (Data.convMembers c) if not (any ((== b ^. rmBotId) . botMemId) bots) - then return $ setStatus status204 empty + then pure Unchanged else do t <- liftIO getCurrentTime let evd = Just (EdMembersLeave (UserIdList [botUserId (b ^. rmBotId)])) @@ -588,13 +740,13 @@ rmBot (zusr ::: zcon ::: req) = do Data.removeMember (botUserId (b ^. rmBotId)) (Data.convId c) Data.eraseClients (botUserId (b ^. rmBotId)) void . forkIO $ void $ External.deliver (bots `zip` repeat e) - return (json e) + pure $ Updated e ------------------------------------------------------------------------------- -- Helpers -addToConversation :: ([BotMember], [Member]) -> (UserId, RoleName) -> ConnId -> [(UserId, RoleName)] -> Data.Conversation -> Galley Response -addToConversation _ _ _ [] _ = return $ empty & setStatus status204 +addToConversation :: ([BotMember], [Member]) -> (UserId, RoleName) -> ConnId -> [(UserId, RoleName)] -> Data.Conversation -> Galley UpdateResult +addToConversation _ _ _ [] _ = pure Unchanged addToConversation (bots, others) (usr, usrRole) conn xs c = do ensureGroupConv c mems <- checkedMemberAddSize xs @@ -603,7 +755,7 @@ addToConversation (bots, others) (usr, usrRole) conn xs c = do for_ (newPush (evtFrom e) (ConvEvent e) (recipient <$> allMembers (toList mm))) $ \p -> push1 $ p & pushConn ?~ conn void . forkIO $ void $ External.deliver (bots `zip` repeat e) - return $ json e & setStatus status200 + pure $ Updated e where allMembers new = foldl' fn new others where @@ -618,19 +770,19 @@ ensureGroupConv c = case Data.convType c of ConnectConv -> throwM invalidConnectOp _ -> return () -ensureMemberLimit :: [Member] -> [UserId] -> Galley () +ensureMemberLimit :: [Member] -> [OpaqueUserId] -> Galley () ensureMemberLimit old new = do o <- view options let maxSize = fromIntegral (o ^. optSettings . setMaxConvSize) when (length old + length new > maxSize) $ throwM tooManyMembers -notIsMember :: Data.Conversation -> UserId -> Bool +notIsMember :: Data.Conversation -> OpaqueUserId -> Bool notIsMember cc u = not $ isMember u (Data.convMembers cc) ensureConvMember :: [Member] -> UserId -> Galley () ensureConvMember users usr = - unless (usr `isMember` users) $ + unless (makeIdOpaque usr `isMember` users) $ throwM convNotFound ensureAccess :: Data.Conversation -> Access -> Galley () @@ -691,7 +843,7 @@ withValidOtrBroadcastRecipients :: OtrFilterMissing -> UTCTime -> ([(Member, ClientId, Text)] -> Galley ()) -> - Galley Response + Galley OtrResult withValidOtrBroadcastRecipients usr clt rcps val now go = Teams.withBindingTeam usr $ \tid -> do tMembers <- fmap (view userId) <$> Data.teamMembers tid contacts <- getContactList usr @@ -712,7 +864,7 @@ withValidOtrRecipients :: OtrFilterMissing -> UTCTime -> ([(Member, ClientId, Text)] -> Galley ()) -> - Galley Response + Galley OtrResult withValidOtrRecipients usr clt cnv rcps val now go = do alive <- Data.isConvAlive cnv unless alive $ do @@ -744,10 +896,10 @@ handleOtrResponse :: UTCTime -> -- | Callback if OtrRecipients are valid ([(Member, ClientId, Text)] -> Galley ()) -> - Galley Response + Galley OtrResult handleOtrResponse usr clt rcps membs clts val now go = case checkOtrRecipients usr clt rcps membs clts val now of - ValidOtrRecipients m r -> go r >> return (json m & setStatus status201) - MissingOtrRecipients m -> return (json m & setStatus status412) + ValidOtrRecipients m r -> go r >> pure (OtrSent m) + MissingOtrRecipients m -> pure (OtrMissingRecipients m) InvalidOtrSenderUser -> throwM convNotFound InvalidOtrSenderClient -> throwM unknownClient @@ -771,7 +923,7 @@ checkOtrRecipients :: -- | The current timestamp. UTCTime -> CheckedOtrRecipients -checkOtrRecipients usr sid prs vms vcs val now +checkOtrRecipients (makeIdOpaque -> usr) sid prs vms vcs val now | not (Map.member usr vmembers) = InvalidOtrSenderUser | not (Clients.contains usr sid vcs) = InvalidOtrSenderClient | not (Clients.null missing) = MissingOtrRecipients mismatch @@ -781,13 +933,14 @@ checkOtrRecipients usr sid prs vms vcs val now next u c t rs | Just m <- member u c = (m, c, t) : rs | otherwise = rs + member :: OpaqueUserId -> ClientId -> Maybe Member member u c | Just m <- Map.lookup u vmembers, Clients.contains u c vclients = Just m | otherwise = Nothing -- Valid recipient members & clients - vmembers = Map.fromList $ map (\m -> (memId m, m)) vms + vmembers = Map.fromList $ map (\m -> (makeIdOpaque (memId m), m)) vms vclients = Clients.rmClient usr sid vcs -- Proposed (given) recipients recipients = userClientMap (otrRecipientsMap prs) diff --git a/services/galley/src/Galley/API/Util.hs b/services/galley/src/Galley/API/Util.hs index 2bcbfeada4e..836db579e0f 100644 --- a/services/galley/src/Galley/API/Util.hs +++ b/services/galley/src/Galley/API/Util.hs @@ -5,7 +5,9 @@ import Brig.Types.Intra (ReAuthUser (..)) import Control.Lens ((.~), view) import Control.Monad.Catch import Data.ByteString.Conversion -import Data.Id +import Data.Id as Id +import Data.IdMapping (IdMapping (..), MappedOrLocalId (Local, Mapped)) +import Data.List.NonEmpty (nonEmpty) import Data.Misc (PlainTextPassword (..)) import qualified Data.Set as Set import qualified Data.Text.Lazy as LT @@ -55,21 +57,29 @@ ensureConnectedOrSameTeam u uids = do sameTeamUids <- forM uTeams $ \team -> fmap (view userId) <$> Data.teamMembersLimited team uids -- Do not check connections for users that are on the same team - ensureConnected u (uids \\ join sameTeamUids) + ensureConnected u (makeIdOpaque <$> uids \\ join sameTeamUids) -- | Check that the user is connected to everybody else. -- -- The connection has to be bidirectional (e.g. if A connects to B and later -- B blocks A, the status of A-to-B is still 'Accepted' but it doesn't mean -- that they are connected). -ensureConnected :: UserId -> [UserId] -> Galley () +ensureConnected :: UserId -> [OpaqueUserId] -> Galley () ensureConnected _ [] = pure () -ensureConnected u uids = do - (connsFrom, connsTo) <- - getConnections [u] uids (Just Accepted) - `concurrently` getConnections uids [u] (Just Accepted) - unless (length connsFrom == length uids && length connsTo == length uids) $ - throwM notConnected +ensureConnected u opaqueIds = do + (localUserIds, remoteUserIds) <- + partitionMappedOrLocalIds <$> traverse resolveOpaqueUserId opaqueIds + -- FUTUREWORK(federation): check remote connections + for_ (nonEmpty remoteUserIds) $ + throwM . federationNotImplemented + ensureConnectedToLocals localUserIds + where + ensureConnectedToLocals uids = do + (connsFrom, connsTo) <- + getConnections [u] uids (Just Accepted) + `concurrently` getConnections uids [u] (Just Accepted) + unless (length connsFrom == length uids && length connsTo == length uids) $ + throwM notConnected ensureReAuthorised :: UserId -> Maybe PlainTextPassword -> Galley () ensureReAuthorised u secret = do @@ -144,14 +154,14 @@ permissionCheckTeamConv zusr cnv perm = Data.conversation cnv >>= \case acceptOne2One :: UserId -> Data.Conversation -> Maybe ConnId -> Galley Data.Conversation acceptOne2One usr conv conn = case Data.convType conv of One2OneConv -> - if usr `isMember` mems + if makeIdOpaque usr `isMember` mems then return conv else do now <- liftIO getCurrentTime mm <- snd <$> Data.addMember now cid usr return $ conv {Data.convMembers = mems <> toList mm} ConnectConv -> case mems of - [_, _] | usr `isMember` mems -> promote + [_, _] | makeIdOpaque usr `isMember` mems -> promote [_, _] -> throwM convNotFound _ -> do when (length mems > 2) $ @@ -178,8 +188,8 @@ acceptOne2One usr conv conn = case Data.convType conv of isBot :: Member -> Bool isBot = isJust . memService -isMember :: Foldable m => UserId -> m Member -> Bool -isMember u = isJust . find ((u ==) . memId) +isMember :: Foldable m => OpaqueUserId -> m Member -> Bool +isMember u = isJust . find ((u ==) . makeIdOpaque . memId) findMember :: Data.Conversation -> UserId -> Maybe Member findMember c u = find ((u ==) . memId) (Data.convMembers c) @@ -224,15 +234,37 @@ getMember ex u ms = do Just m -> return m Nothing -> throwM ex -getConversationAndCheckMembership :: UserId -> ConvId -> Galley Data.Conversation +getConversationAndCheckMembership :: UserId -> OpaqueConvId -> Galley Data.Conversation getConversationAndCheckMembership = getConversationAndCheckMembershipWithError convAccessDenied -getConversationAndCheckMembershipWithError :: Error -> UserId -> ConvId -> Galley Data.Conversation +getConversationAndCheckMembershipWithError :: Error -> UserId -> OpaqueConvId -> Galley Data.Conversation getConversationAndCheckMembershipWithError ex zusr cnv = do - c <- Data.conversation cnv >>= ifNothing convNotFound - when (DataTypes.isConvDeleted c) $ do - Data.deleteConversation cnv - throwM convNotFound - unless (zusr `isMember` Data.convMembers c) $ - throwM ex - return c + resolveOpaqueConvId cnv >>= \case + Mapped idMapping -> + throwM . federationNotImplemented $ pure idMapping + Local convId -> do + -- should we merge resolving to qualified ID and looking up the conversation? + c <- Data.conversation convId >>= ifNothing convNotFound + when (DataTypes.isConvDeleted c) $ do + Data.deleteConversation convId + throwM convNotFound + unless (makeIdOpaque zusr `isMember` Data.convMembers c) $ + throwM ex + return c + +-- | this exists as a shim to find and mark places where we need to handle 'OpaqueUserId's. +resolveOpaqueUserId :: OpaqueUserId -> Galley (MappedOrLocalId Id.U) +resolveOpaqueUserId (Id opaque) = + -- FUTUREWORK(federation): implement database lookup + pure . Local $ Id opaque + +-- | this exists as a shim to find and mark places where we need to handle 'OpaqueConvId's. +resolveOpaqueConvId :: OpaqueConvId -> Galley (MappedOrLocalId Id.C) +resolveOpaqueConvId (Id opaque) = + -- FUTUREWORK(federation): implement database lookup + pure . Local $ Id opaque + +partitionMappedOrLocalIds :: Foldable f => f (MappedOrLocalId a) -> ([Id a], [IdMapping a]) +partitionMappedOrLocalIds = foldMap $ \case + Mapped mapping -> (mempty, [mapping]) + Local localId -> ([localId], mempty) diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 6a0841b4f48..66d5ff49bbf 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -27,6 +27,7 @@ module Galley.App -- * Utilities ifNothing, fromJsonBody, + fromOptionalJsonBody, fromProtoBody, initExtEnv, ) @@ -217,6 +218,10 @@ fromJsonBody :: FromJSON a => JsonRequest a -> Galley a fromJsonBody r = exceptT (throwM . invalidPayload) return (parseBody r) {-# INLINE fromJsonBody #-} +fromOptionalJsonBody :: FromJSON a => OptionalJsonRequest a -> Galley (Maybe a) +fromOptionalJsonBody r = exceptT (throwM . invalidPayload) return (parseOptionalBody r) +{-# INLINE fromOptionalJsonBody #-} + fromProtoBody :: Proto.Decode a => Request -> Galley a fromProtoBody r = do b <- readBody r diff --git a/services/galley/src/Galley/Data.hs b/services/galley/src/Galley/Data.hs index 297c1269e72..231075a3729 100644 --- a/services/galley/src/Galley/Data.hs +++ b/services/galley/src/Galley/Data.hs @@ -82,8 +82,10 @@ import Cassandra.Util import Control.Arrow (second) import Control.Lens hiding ((<|)) import Control.Monad.Catch (MonadThrow) +import Data.Bifunctor (first) import Data.ByteString.Conversion hiding (parser) -import Data.Id +import Data.Id as Id +import Data.IdMapping import Data.Json.Util (UTCTimeMillis (..)) import Data.LegalHold (UserLegalHoldStatus (..)) import qualified Data.List.Extra as List @@ -391,15 +393,15 @@ conversationMeta conv = where toConvMeta (t, c, a, r, n, i, _, mt, rm) = ConversationMeta conv t c (defAccess t a) (maybeRole t r) n i mt rm -conversationIdsFrom :: MonadClient m => UserId -> Maybe ConvId -> Range 1 1000 Int32 -> m (ResultSet ConvId) -conversationIdsFrom usr range (fromRange -> max) = - ResultSet . fmap runIdentity . strip <$> case range of +conversationIdsFrom :: MonadClient m => UserId -> Maybe OpaqueConvId -> Range 1 1000 Int32 -> m (ResultSet OpaqueConvId) +conversationIdsFrom usr start (fromRange -> max) = + ResultSet . fmap runIdentity . strip <$> case start of Just c -> paginate Cql.selectUserConvsFrom (paramsP Quorum (usr, c) (max + 1)) Nothing -> paginate Cql.selectUserConvs (paramsP Quorum (Identity usr) (max + 1)) where strip p = p {result = take (fromIntegral max) (result p)} -conversationIdsOf :: MonadClient m => UserId -> Range 1 32 (List ConvId) -> m [ConvId] +conversationIdsOf :: MonadClient m => UserId -> Range 1 32 (List OpaqueConvId) -> m [OpaqueConvId] conversationIdsOf usr (fromList . fromRange -> cids) = map runIdentity <$> retry x1 (query Cql.selectUserConvsIn (params Quorum (usr, cids))) @@ -419,7 +421,8 @@ createConversation usr name acc role others tinfo mtimer recpt othersConversatio conv <- Id <$> liftIO nextRandom now <- liftIO getCurrentTime retry x5 $ case tinfo of - Nothing -> write Cql.insertConv (params Quorum (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Nothing, mtimer, recpt)) + Nothing -> + write Cql.insertConv (params Quorum (conv, RegularConv, usr, Set (toList acc), role, fromRange <$> name, Nothing, mtimer, recpt)) Just ti -> batch $ do setType BatchLogged setConsistency Quorum @@ -643,22 +646,33 @@ updateMember cid uid mup = do misConvRoleName = mupConvRoleName mup } -removeMembers :: MonadClient m => Conversation -> UserId -> List1 UserId -> m Event +removeMembers :: MonadClient m => Conversation -> UserId -> List1 (MappedOrLocalId Id.U) -> m Event removeMembers conv orig victims = do t <- liftIO getCurrentTime retry x5 $ batch $ do setType BatchLogged setConsistency Quorum for_ (toList victims) $ \u -> do - addPrepQuery Cql.removeMember (convId conv, u) - addPrepQuery Cql.deleteUserConv (u, convId conv) - return $ Event MemberLeave (convId conv) orig t (Just . EdMembersLeave . UserIdList . toList $ victims) + addPrepQuery Cql.removeMember (convId conv, opaqueIdFromMappedOrLocal u) + case u of + Local localId -> + addPrepQuery Cql.deleteUserConv (localId, convId conv) + Mapped _ -> + -- the user's conversation has to be deleted on their own backend + pure () + return $ Event MemberLeave (convId conv) orig t (Just (EdMembersLeave leavingMembers)) + where + -- FUTUREWORK(federation): We need to tell clients about remote members leaving, too. + leavingMembers = UserIdList . mapMaybe localIdOrNothing . toList $ victims + localIdOrNothing = \case + Local localId -> Just localId + Mapped _ -> Nothing removeMember :: MonadClient m => UserId -> ConvId -> m () removeMember usr cnv = retry x5 $ batch $ do setType BatchLogged setConsistency Quorum - addPrepQuery Cql.removeMember (cnv, usr) + addPrepQuery Cql.removeMember (cnv, makeIdOpaque usr) addPrepQuery Cql.deleteUserConv (usr, cnv) newMember :: UserId -> Member @@ -725,7 +739,7 @@ lookupClients :: [UserId] -> m Clients lookupClients users = - Clients.fromList . concat . concat + Clients.fromList . fmap (first makeIdOpaque) . concat . concat <$> forM (chunksOf 2048 users) (mapConcurrently getClients . chunksOf 128) where getClients us = diff --git a/services/galley/src/Galley/Data/CustomBackend.hs b/services/galley/src/Galley/Data/CustomBackend.hs index 650ee86ff82..82fbe4908cf 100644 --- a/services/galley/src/Galley/Data/CustomBackend.hs +++ b/services/galley/src/Galley/Data/CustomBackend.hs @@ -8,22 +8,23 @@ module Galley.Data.CustomBackend where import Cassandra +import Data.Domain (Domain) import Galley.Data.Instances () import qualified Galley.Data.Queries as Cql import Galley.Types import Imports -getCustomBackend :: MonadClient m => EmailDomain -> m (Maybe CustomBackend) +getCustomBackend :: MonadClient m => Domain -> m (Maybe CustomBackend) getCustomBackend domain = fmap toCustomBackend <$> do retry x1 $ query1 Cql.selectCustomBackend (params Quorum (Identity domain)) where toCustomBackend (backendConfigJsonUrl, backendWebappWelcomeUrl) = CustomBackend {..} -setCustomBackend :: MonadClient m => EmailDomain -> CustomBackend -> m () +setCustomBackend :: MonadClient m => Domain -> CustomBackend -> m () setCustomBackend domain CustomBackend {..} = do retry x5 $ write Cql.updateCustomBackend (params Quorum (backendConfigJsonUrl, backendWebappWelcomeUrl, domain)) -deleteCustomBackend :: MonadClient m => EmailDomain -> m () +deleteCustomBackend :: MonadClient m => Domain -> m () deleteCustomBackend domain = do retry x5 $ write Cql.deleteCustomBackend (params Quorum (Identity domain)) diff --git a/services/galley/src/Galley/Data/Instances.hs b/services/galley/src/Galley/Data/Instances.hs index 9fdc1f5ab97..c0b7e54e80e 100644 --- a/services/galley/src/Galley/Data/Instances.hs +++ b/services/galley/src/Galley/Data/Instances.hs @@ -8,7 +8,7 @@ where import Cassandra.CQL import Control.Error (note) -import Data.Text.Encoding (encodeUtf8) +import Data.Domain (Domain, domainText, mkDomain) import Galley.Types import Galley.Types.Bot () import Galley.Types.Teams @@ -119,8 +119,8 @@ instance Cql SSOStatus where toCql SSODisabled = CqlInt 0 toCql SSOEnabled = CqlInt 1 -instance Cql EmailDomain where +instance Cql Domain where ctype = Tagged TextColumn - toCql = CqlText . emailDomainText - fromCql (CqlText txt) = either fail pure . mkEmailDomain $ encodeUtf8 txt - fromCql _ = fail "EmailDomain: Text expected" + toCql = CqlText . domainText + fromCql (CqlText txt) = either fail pure $ mkDomain txt + fromCql _ = fail "Domain: Text expected" diff --git a/services/galley/src/Galley/Data/Queries.hs b/services/galley/src/Galley/Data/Queries.hs index 2ae0aba2f2e..b8c12e956b9 100644 --- a/services/galley/src/Galley/Data/Queries.hs +++ b/services/galley/src/Galley/Data/Queries.hs @@ -6,6 +6,7 @@ import Brig.Types.Provider import Brig.Types.Team.LegalHold (LegalHoldStatus) import Cassandra as C hiding (Value) import Cassandra.Util (Writetime) +import Data.Domain (Domain) import Data.Id import Data.Json.Util import Data.LegalHold @@ -184,15 +185,16 @@ deleteCode = "DELETE FROM conversation_codes WHERE key = ? AND scope = ?" -- User Conversations ------------------------------------------------------- -selectUserConvs :: PrepQuery R (Identity UserId) (Identity ConvId) +selectUserConvs :: PrepQuery R (Identity UserId) (Identity OpaqueConvId) selectUserConvs = "select conv from user where user = ? order by conv" -selectUserConvsIn :: PrepQuery R (UserId, [ConvId]) (Identity ConvId) +selectUserConvsIn :: PrepQuery R (UserId, [OpaqueConvId]) (Identity OpaqueConvId) selectUserConvsIn = "select conv from user where user = ? and conv in ? order by conv" -selectUserConvsFrom :: PrepQuery R (UserId, ConvId) (Identity ConvId) +selectUserConvsFrom :: PrepQuery R (UserId, OpaqueConvId) (Identity OpaqueConvId) selectUserConvsFrom = "select conv from user where user = ? and conv > ? order by conv" +-- FUTUREWORK(federation): unify types with queries above insertUserConv :: PrepQuery W (UserId, ConvId) () insertUserConv = "insert into user (user, conv) values (?, ?)" @@ -212,7 +214,7 @@ selectMembers = "select conv, user, service, provider, status, otr_muted, otr_mu insertMember :: PrepQuery W (ConvId, UserId, Maybe ServiceId, Maybe ProviderId, RoleName) () insertMember = "insert into member (conv, user, service, provider, status, conversation_role) values (?, ?, ?, ?, 0, ?)" -removeMember :: PrepQuery W (ConvId, UserId) () +removeMember :: PrepQuery W (ConvId, OpaqueUserId) () removeMember = "delete from member where conv = ? and user = ?" updateOtrMemberMuted :: PrepQuery W (Bool, Maybe Text, ConvId, UserId) () @@ -332,14 +334,14 @@ updateSSOTeamConfig :: PrepQuery W (SSOStatus, TeamId) () updateSSOTeamConfig = "update team_features set sso_status = ? where team_id = ?" -selectCustomBackend :: PrepQuery R (Identity EmailDomain) (HttpsUrl, HttpsUrl) +selectCustomBackend :: PrepQuery R (Identity Domain) (HttpsUrl, HttpsUrl) selectCustomBackend = "select config_json_url, webapp_welcome_url from custom_backend where domain = ?" -updateCustomBackend :: PrepQuery W (HttpsUrl, HttpsUrl, EmailDomain) () +updateCustomBackend :: PrepQuery W (HttpsUrl, HttpsUrl, Domain) () updateCustomBackend = "update custom_backend set config_json_url = ?, webapp_welcome_url = ? where domain = ?" -deleteCustomBackend :: PrepQuery W (Identity EmailDomain) () +deleteCustomBackend :: PrepQuery W (Identity Domain) () deleteCustomBackend = "delete from custom_backend where domain = ?" diff --git a/services/galley/src/Galley/Types/Clients.hs b/services/galley/src/Galley/Types/Clients.hs index 3622a54d03d..82c1b67c74d 100644 --- a/services/galley/src/Galley/Types/Clients.hs +++ b/services/galley/src/Galley/Types/Clients.hs @@ -44,18 +44,18 @@ null = Map.null . (userClients . clients) nil :: Clients nil = Clients $ UserClients Map.empty -userIds :: Clients -> [UserId] +userIds :: Clients -> [OpaqueUserId] userIds = Map.keys . (userClients . clients) -clientIds :: UserId -> Clients -> [ClientId] +clientIds :: OpaqueUserId -> Clients -> [ClientId] clientIds u c = Set.toList $ fromMaybe Set.empty (Map.lookup u ((userClients . clients) c)) -toList :: Clients -> [(UserId, [ClientId])] +toList :: Clients -> [(OpaqueUserId, [ClientId])] toList = Map.foldrWithKey' fn [] . (userClients . clients) where fn u c a = (u, Set.toList c) : a -fromList :: [(UserId, [ClientId])] -> Clients +fromList :: [(OpaqueUserId, [ClientId])] -> Clients fromList = Clients . UserClients . foldr fn Map.empty where fn (u, c) = Map.insert u (Set.fromList c) @@ -63,27 +63,27 @@ fromList = Clients . UserClients . foldr fn Map.empty fromUserClients :: UserClients -> Clients fromUserClients ucs = Clients ucs -fromMap :: Map UserId (Set ClientId) -> Clients +fromMap :: Map OpaqueUserId (Set ClientId) -> Clients fromMap = Clients . UserClients -toMap :: Clients -> Map UserId (Set ClientId) +toMap :: Clients -> Map OpaqueUserId (Set ClientId) toMap = userClients . clients -singleton :: UserId -> [ClientId] -> Clients +singleton :: OpaqueUserId -> [ClientId] -> Clients singleton u c = Clients . UserClients $ Map.singleton u (Set.fromList c) -filter :: (UserId -> Bool) -> Clients -> Clients +filter :: (OpaqueUserId -> Bool) -> Clients -> Clients filter p = Clients . UserClients . Map.filterWithKey (\u _ -> p u) . (userClients . clients) -contains :: UserId -> ClientId -> Clients -> Bool +contains :: OpaqueUserId -> ClientId -> Clients -> Bool contains u c = maybe False (Set.member c) . Map.lookup u . (userClients . clients) -insert :: UserId -> ClientId -> Clients -> Clients +insert :: OpaqueUserId -> ClientId -> Clients -> Clients insert u c = Clients . UserClients . Map.insertWith Set.union u (Set.singleton c) @@ -97,7 +97,7 @@ diff (Clients (UserClients ca)) (Clients (UserClients cb)) = let d = a `Set.difference` b in if Set.null d then Nothing else Just d -rmClient :: UserId -> ClientId -> Clients -> Clients +rmClient :: OpaqueUserId -> ClientId -> Clients -> Clients rmClient u c (Clients (UserClients m)) = Clients . UserClients $ Map.update f u m where diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 0707d9cb822..d72ba758925 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -256,8 +256,8 @@ postCryptoMessage2 = do Map.lookup eve (userClientMap p) @=? Just [ec] + Map.keys (userClientMap p) @=? [makeIdOpaque eve] + Map.keys <$> Map.lookup (makeIdOpaque eve) (userClientMap p) @=? Just [ec] postCryptoMessage3 :: TestM () postCryptoMessage3 = do @@ -281,8 +281,8 @@ postCryptoMessage3 = do Map.lookup eve (userClientMap p) @=? Just [ec] + Map.keys (userClientMap p) @=? [makeIdOpaque eve] + Map.keys <$> Map.lookup (makeIdOpaque eve) (userClientMap p) @=? Just [ec] postCryptoMessage4 :: TestM () postCryptoMessage4 = do @@ -633,7 +633,7 @@ postConvO2OFailWithSelf :: TestM () postConvO2OFailWithSelf = do g <- view tsGalley alice <- randomUser - let inv = NewConvUnmanaged (NewConv [alice] Nothing mempty Nothing Nothing Nothing Nothing roleNameWireAdmin) + let inv = NewConvUnmanaged (NewConv [makeIdOpaque alice] Nothing mempty Nothing Nothing Nothing Nothing roleNameWireAdmin) post (g . path "/conversations/one2one" . zUser alice . zConn "conn" . zType "access" . json inv) !!! do const 403 === statusCode const (Just "invalid-op") === fmap label . responseJsonUnsafe diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index 5588e709c86..2e60e4efc19 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -521,7 +521,7 @@ testAddManagedConv = do let tinfo = ConvTeamInfo tid True let conv = NewConvManaged $ - NewConv [owner] (Just "blah") (Set.fromList []) Nothing (Just tinfo) Nothing Nothing roleNameWireAdmin + NewConv [makeIdOpaque owner] (Just "blah") (Set.fromList []) Nothing (Just tinfo) Nothing Nothing roleNameWireAdmin post ( g . path "/conversations" diff --git a/services/galley/test/integration/API/Teams/LegalHold.hs b/services/galley/test/integration/API/Teams/LegalHold.hs index ca363b12312..76bbd57db68 100644 --- a/services/galley/test/integration/API/Teams/LegalHold.hs +++ b/services/galley/test/integration/API/Teams/LegalHold.hs @@ -201,7 +201,7 @@ testApproveLegalHoldDevice = do liftIO $ do clients' <- Cql.runClient cassState $ Data.lookupClients [member] assertBool "Expect clientId to be saved on the user" $ - Clients.contains member someClientId clients' + Clients.contains (makeIdOpaque member) someClientId clients' UserLegalHoldStatusResponse userStatus _ _ <- getUserStatusTyped member tid liftIO $ assertEqual diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 51d10c34a7b..c3e8a7aacea 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -169,7 +169,7 @@ createTeamConvAccessRaw u tid us name acc role mtimer convRole = do let tinfo = ConvTeamInfo tid False let conv = NewConvUnmanaged $ - NewConv us name (fromMaybe (Set.fromList []) acc) role (Just tinfo) mtimer Nothing (fromMaybe roleNameWireAdmin convRole) + NewConv (makeIdOpaque <$> us) name (fromMaybe (Set.fromList []) acc) role (Just tinfo) mtimer Nothing (fromMaybe roleNameWireAdmin convRole) post ( g . path "/conversations" @@ -198,7 +198,7 @@ createManagedConv u tid us name acc mtimer = do let tinfo = ConvTeamInfo tid True let conv = NewConvManaged $ - NewConv us name (fromMaybe (Set.fromList []) acc) Nothing (Just tinfo) mtimer Nothing roleNameWireAdmin + NewConv (makeIdOpaque <$> us) name (fromMaybe (Set.fromList []) acc) Nothing (Just tinfo) mtimer Nothing roleNameWireAdmin r <- post ( g @@ -216,7 +216,7 @@ createOne2OneTeamConv u1 u2 n tid = do g <- view tsGalley let conv = NewConvUnmanaged $ - NewConv [u2] n mempty Nothing (Just $ ConvTeamInfo tid False) Nothing Nothing roleNameWireAdmin + NewConv [makeIdOpaque u2] n mempty Nothing (Just $ ConvTeamInfo tid False) Nothing Nothing roleNameWireAdmin post $ g . path "/conversations/one2one" . zUser u1 . zConn "conn" . zType "access" . json conv postConv :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> TestM ResponseLBS @@ -225,13 +225,13 @@ postConv u us name a r mtimer = postConvWithRole u us name a r mtimer roleNameWi postConvWithRole :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> RoleName -> TestM ResponseLBS postConvWithRole u us name a r mtimer role = do g <- view tsGalley - let conv = NewConvUnmanaged $ NewConv us name (Set.fromList a) r Nothing mtimer Nothing role + let conv = NewConvUnmanaged $ NewConv (makeIdOpaque <$> us) name (Set.fromList a) r Nothing mtimer Nothing role post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv postConvWithReceipt :: UserId -> [UserId] -> Maybe Text -> [Access] -> Maybe AccessRole -> Maybe Milliseconds -> ReceiptMode -> TestM ResponseLBS postConvWithReceipt u us name a r mtimer rcpt = do g <- view tsGalley - let conv = NewConvUnmanaged $ NewConv us name (Set.fromList a) r Nothing mtimer (Just rcpt) roleNameWireAdmin + let conv = NewConvUnmanaged $ NewConv (makeIdOpaque <$> us) name (Set.fromList a) r Nothing mtimer (Just rcpt) roleNameWireAdmin post $ g . path "/conversations" . zUser u . zConn "conn" . zType "access" . json conv postSelfConv :: UserId -> TestM ResponseLBS @@ -242,7 +242,7 @@ postSelfConv u = do postO2OConv :: UserId -> UserId -> Maybe Text -> TestM ResponseLBS postO2OConv u1 u2 n = do g <- view tsGalley - let conv = NewConvUnmanaged $ NewConv [u2] n mempty Nothing Nothing Nothing Nothing roleNameWireAdmin + let conv = NewConvUnmanaged $ NewConv [makeIdOpaque u2] n mempty Nothing Nothing Nothing Nothing roleNameWireAdmin post $ g . path "/conversations/one2one" . zUser u1 . zConn "conn" . zType "access" . json conv postConnectConv :: UserId -> UserId -> Text -> Text -> Maybe Text -> TestM ResponseLBS @@ -377,7 +377,7 @@ getConvIds u r s = do postMembers :: UserId -> List1 UserId -> ConvId -> TestM ResponseLBS postMembers u us c = do g <- view tsGalley - let i = newInvite us + let i = newInvite (makeIdOpaque <$> us) post $ g . paths ["conversations", toByteString' c, "members"] @@ -389,7 +389,7 @@ postMembers u us c = do postMembersWithRole :: UserId -> List1 UserId -> ConvId -> RoleName -> TestM ResponseLBS postMembersWithRole u us c r = do g <- view tsGalley - let i = (newInvite us) {invRoleName = r} + let i = (newInvite (makeIdOpaque <$> us)) {invRoleName = r} post $ g . paths ["conversations", toByteString' c, "members"] @@ -972,14 +972,17 @@ eqMismatch :: Bool eqMismatch _ _ _ Nothing = False eqMismatch mssd rdnt dltd (Just other) = - UserClients (Map.fromList mssd) == missingClients other - && UserClients (Map.fromList rdnt) == redundantClients other - && UserClients (Map.fromList dltd) == deletedClients other + userClients mssd == missingClients other + && userClients rdnt == redundantClients other + && userClients dltd == deletedClients other + where + userClients :: [(UserId, Set ClientId)] -> UserClients + userClients = UserClients . Map.mapKeys makeIdOpaque . Map.fromList otrRecipients :: [(UserId, [(ClientId, Text)])] -> OtrRecipients -otrRecipients = OtrRecipients . UserClientMap . Map.fromList . map toUserClientMap +otrRecipients = OtrRecipients . UserClientMap . buildMap where - toUserClientMap (u, css) = (u, Map.fromList css) + buildMap = fmap Map.fromList . Map.mapKeys makeIdOpaque . Map.fromList encodeCiphertext :: ByteString -> Text encodeCiphertext = decodeUtf8 . B64.encode diff --git a/services/gundeck/src/Gundeck/API.hs b/services/gundeck/src/Gundeck/API.hs index 14aac6ecef3..31780d40eaf 100644 --- a/services/gundeck/src/Gundeck/API.hs +++ b/services/gundeck/src/Gundeck/API.hs @@ -1,9 +1,14 @@ module Gundeck.API (sitemap) where +import Control.Lens ((^.)) +import Data.Id import Data.Range import Data.Swagger.Build.Api hiding (Response, def, min) import qualified Data.Swagger.Build.Api as Swagger import Data.Text.Encoding (decodeLatin1) +import qualified Data.Text.Encoding as Text +import Data.UUID as UUID +import qualified Data.UUID.Util as UUID import Gundeck.API.Error import qualified Gundeck.Client as Client import Gundeck.Monad @@ -12,19 +17,20 @@ import qualified Gundeck.Presence as Presence import qualified Gundeck.Push as Push import Gundeck.Types import qualified Gundeck.Types.Swagger as Model -import Imports hiding (head) +import Imports hiding (getLast, head) +import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Routing hiding (route) import Network.Wai.Utilities -import Network.Wai.Utilities.Response (json) +import Network.Wai.Utilities.Response (json, setStatus) import Network.Wai.Utilities.Swagger sitemap :: Routes ApiBuilder Gundeck () sitemap = do -- Push API ----------------------------------------------------------- - post "/push/tokens" (continue Push.addToken) $ + post "/push/tokens" (continue addTokenH) $ header "Z-User" .&. header "Z-Connection" .&. jsonRequest @PushToken @@ -36,7 +42,7 @@ sitemap = do returns (ref Model.pushToken) response 201 "Push token registered" end response 404 "App does not exist" end - delete "/push/tokens/:pid" (continue Push.deleteToken) $ + delete "/push/tokens/:pid" (continue deleteTokenH) $ header "Z-User" .&. param "pid" .&. accept "application" "json" @@ -46,18 +52,18 @@ sitemap = do description "The push token to delete" response 204 "Push token unregistered" end response 404 "Push token does not exist" end - get "/push/tokens" (continue Push.listTokens) $ + get "/push/tokens" (continue listTokensH) $ header "Z-User" .&. accept "application" "json" document "GET" "getPushTokens" $ do summary "List the user's registered push tokens." returns (ref Model.pushTokenList) response 200 "Object containing list of push tokens" end - post "/i/push/v2" (continue Push.push) $ + post "/i/push/v2" (continue pushH) $ request .&. accept "application" "json" -- Notification API -------------------------------------------------------- - get "/notifications" (continue Notification.paginate) $ + get "/notifications" (continue paginateH) $ accept "application" "json" .&. header "Z-User" .&. opt (query "since") @@ -77,7 +83,7 @@ sitemap = do returns (ref Model.notificationList) response 200 "Notification list" end errorResponse' notificationNotFound Model.notificationList - get "/notifications/:id" (continue Notification.getById) $ + get "/notifications/:id" (continue getByIdH) $ accept "application" "json" .&. header "Z-User" .&. capture "id" @@ -92,7 +98,7 @@ sitemap = do returns (ref Model.notification) response 200 "Notification found" end errorResponse notificationNotFound - get "/notifications/last" (continue Notification.getLast) $ + get "/notifications/last" (continue getLastH) $ accept "application" "json" .&. header "Z-User" .&. opt (query "client") @@ -116,13 +122,13 @@ sitemap = do param "uid" .&. param "did" .&. param "cannon" -- User-Client API ------------------------------------------------------- - delete "/i/clients/:cid" (continue Client.unregister) $ + delete "/i/clients/:cid" (continue unregisterClientH) $ header "Z-User" .&. param "cid" - delete "/i/user" (continue Client.removeUser) $ + delete "/i/user" (continue removeUserH) $ header "Z-User" -- Docs ------------------------------------------------------------------ - get "/push/api-docs" (continue docs) $ + get "/push/api-docs" (continue docsH) $ query "base_url" .&. accept "application" "json" -- Status & Monitoring --------------------------------------------------- @@ -131,7 +137,122 @@ sitemap = do type JSON = Media "application" "json" -docs :: ByteString ::: JSON -> Gundeck Response -docs (url ::: _) = +docsH :: ByteString ::: JSON -> Gundeck Response +docsH (url ::: _) = let doc = mkSwaggerApi (decodeLatin1 url) Model.gundeckModels sitemap in return $ json doc + +addTokenH :: UserId ::: ConnId ::: JsonRequest PushToken ::: JSON -> Gundeck Response +addTokenH (uid ::: cid ::: req ::: _) = do + newtok <- fromJsonBody req + handleAddTokenResponse <$> Push.addToken uid cid newtok + +handleAddTokenResponse :: Push.AddTokenResponse -> Response +handleAddTokenResponse = \case + Push.AddTokenSuccess newtok -> success newtok + Push.AddTokenNoBudget -> snsThreadBudgetReached + Push.AddTokenNotFound -> notFound + Push.AddTokenInvalid -> invalidToken + Push.AddTokenTooLong -> tokenTooLong + Push.AddTokenMetadataTooLong -> metadataTooLong + +success :: PushToken -> Response +success t = + let loc = Text.encodeUtf8 . tokenText $ t ^. token + in json t & setStatus status201 & addHeader hLocation loc + +invalidToken :: Response +invalidToken = + json (Error status400 "invalid-token" "Invalid push token") + & setStatus status404 + +snsThreadBudgetReached :: Response +snsThreadBudgetReached = + json (Error status400 "sns-thread-budget-reached" "Too many concurrent calls to SNS; is SNS down?") + & setStatus status413 + +tokenTooLong :: Response +tokenTooLong = + json (Error status400 "token-too-long" "Push token length must be < 8192 for GCM or 400 for APNS") + & setStatus status413 + +metadataTooLong :: Response +metadataTooLong = + json (Error status400 "metadata-too-long" "Tried to add token to endpoint resulting in metadata length > 2048") + & setStatus status413 + +notFound :: Response +notFound = empty & setStatus status404 + +deleteTokenH :: UserId ::: Token ::: JSON -> Gundeck Response +deleteTokenH (uid ::: tok ::: _) = setStatus status204 empty <$ Push.deleteToken uid tok + +listTokensH :: UserId ::: JSON -> Gundeck Response +listTokensH (uid ::: _) = setStatus status200 . json <$> Push.listTokens uid + +pushH :: Request ::: JSON -> Gundeck Response +pushH (req ::: _) = do + ps <- fromJsonBody (JsonRequest req) + empty <$ Push.push ps + +-- | Returns a list of notifications for given 'uid' +-- +-- +-- Takes an optional parameter 'since' which is a V1 UUID, (which includes a +-- timestamp). +-- +-- If the parameter 'since' is omitted, all notifications of the user are +-- returned. This is not recommended. (TODO: Ask client teams if they ever use +-- this) +-- +-- If the parameter 'since' fails to parse, all notifications of the user are +-- returned but the status code is set to 404. +-- FUTUREWORK: We should change this behaviour as it's extremely confusing. We +-- could kindly reject with a 400, and not event hit the database at all. +-- This was introduced in +-- https://github.com/zinfra/orlop/pull/30/commits/a358dfc1cb225c92066ea79db28c8824531ae231 +-- +-- If the 'since' parameter is present, and a notification 'since' is actually +-- found in the database, this returns all the notifications since 'since' +-- (exclusive of 'since' itself) and returns a status code 200. +-- +-- If the 'since' parameter is present, and a notification 'since' is not found +-- in the database, then due to the fact that 'since' is a V1 UUID (which +-- contains a timestamp) we can still return all the notifications that +-- happened after it eventhough it is not present in the database. This can +-- happen for example because a client hasn't been online for 30 days and we +-- have deleted the notification in the backend in the meantime. +-- We will return all the notifications that we have that happened after 'since' +-- but return status code 404 to signal that 'since' itself was missing. +-- +-- (arianvp): I am not sure why it is convenient for clients to distinct +-- between these two cases. +paginateH :: JSON ::: UserId ::: Maybe ByteString ::: Maybe ClientId ::: Range 100 10000 Int32 -> Gundeck Response +paginateH (_ ::: uid ::: sinceRaw ::: clt ::: size) = do + Notification.PaginateResult gap page <- Notification.paginate uid (join since) clt size + pure . updStatus gap . json $ page + where + since :: Maybe (Maybe NotificationId) + since = parseUUID <$> sinceRaw + parseUUID :: ByteString -> Maybe NotificationId + parseUUID = UUID.fromASCIIBytes >=> isV1UUID >=> return . Id + isV1UUID :: UUID -> Maybe UUID + isV1UUID u = if UUID.version u == 1 then Just u else Nothing + updStatus :: Bool -> Response -> Response + updStatus True = setStatus status404 + updStatus False = case since of + Just (Just _) -> id + Nothing -> id + Just Nothing -> setStatus status404 + +getByIdH :: JSON ::: UserId ::: NotificationId ::: Maybe ClientId -> Gundeck Response +getByIdH (_ ::: uid ::: nid ::: cid) = json <$> Notification.getById uid nid cid + +getLastH :: JSON ::: UserId ::: Maybe ClientId -> Gundeck Response +getLastH (_ ::: uid ::: cid) = json <$> Notification.getLast uid cid + +unregisterClientH :: UserId ::: ClientId -> Gundeck Response +unregisterClientH (uid ::: cid) = empty <$ Client.unregister uid cid + +removeUserH :: UserId -> Gundeck Response +removeUserH uid = empty <$ Client.removeUser uid diff --git a/services/gundeck/src/Gundeck/Client.hs b/services/gundeck/src/Gundeck/Client.hs index 390320eee23..cf3d672b5fe 100644 --- a/services/gundeck/src/Gundeck/Client.hs +++ b/services/gundeck/src/Gundeck/Client.hs @@ -6,27 +6,22 @@ where import Control.Lens (view) import Data.Id -import Data.Predicate import Gundeck.Monad import qualified Gundeck.Notification.Data as Notifications import qualified Gundeck.Push.Data as Push import Gundeck.Push.Native import Imports -import Network.Wai (Response) -import Network.Wai.Utilities -unregister :: UserId ::: ClientId -> Gundeck Response -unregister (uid ::: cid) = do +unregister :: UserId -> ClientId -> Gundeck () +unregister uid cid = do toks <- filter byClient <$> Push.lookup uid Push.Quorum deleteTokens toks Nothing - return empty where byClient = (cid ==) . view addrClient -removeUser :: UserId -> Gundeck Response +removeUser :: UserId -> Gundeck () removeUser user = do toks <- Push.lookup user Push.Quorum deleteTokens toks Nothing Push.erase user Notifications.deleteAll user - return empty diff --git a/services/gundeck/src/Gundeck/Notification.hs b/services/gundeck/src/Gundeck/Notification.hs index 4d030d322d5..18129cc046b 100644 --- a/services/gundeck/src/Gundeck/Notification.hs +++ b/services/gundeck/src/Gundeck/Notification.hs @@ -1,5 +1,6 @@ module Gundeck.Notification ( paginate, + PaginateResult (..), getById, getLast, ) @@ -8,57 +9,39 @@ where import Control.Monad.Catch (throwM) import Data.Id import Data.Misc (Milliseconds (..)) -import Data.Predicate import Data.Range import Data.Time.Clock.POSIX -import qualified Data.UUID as UUID -import qualified Data.UUID.Util as UUID import Gundeck.API.Error import Gundeck.Monad import qualified Gundeck.Notification.Data as Data import Gundeck.Types.Notification -import Gundeck.Util import Imports hiding (getLast) -import Network.HTTP.Types.Status -import Network.Wai (Response) -import Network.Wai.Utilities -paginate :: JSON ::: UserId ::: Maybe ByteString ::: Maybe ClientId ::: Range 100 10000 Int32 -> Gundeck Response -paginate (_ ::: uid ::: Nothing ::: clt ::: size) = do - t <- posixTime - pageResponse t <$> Data.fetch uid clt Nothing size -paginate (_ ::: uid ::: Just since ::: clt ::: size) = do - t <- posixTime - case parseUUID since of - Nothing -> - setStatus status404 . pageResponse t - <$> Data.fetch uid clt Nothing size - Just s -> do - pageResponse t <$> Data.fetch uid clt (Just s) size - where - parseUUID = UUID.fromASCIIBytes >=> isV1UUID >=> return . Id - isV1UUID u = if UUID.version u == 1 then Just u else Nothing - -getById :: JSON ::: UserId ::: NotificationId ::: Maybe ClientId -> Gundeck Response -getById (_ ::: uid ::: nid ::: clt) = do - mn <- Data.fetchId uid nid clt - case mn of - Nothing -> throwM notificationNotFound - Just n -> return $ json n - -getLast :: JSON ::: UserId ::: Maybe ClientId -> Gundeck Response -getLast (_ ::: uid ::: clt) = do - n <- Data.fetchLast uid clt - maybe (throwM notificationNotFound) (return . json) n +data PaginateResult + = PaginateResult + { paginateResultGap :: Bool, + paginateResultPage :: QueuedNotificationList + } -pageResponse :: Milliseconds -> Data.ResultPage -> Response -pageResponse t rs - | Data.resultGap rs = setStatus status404 (json resultList) - | otherwise = json resultList +paginate :: UserId -> Maybe NotificationId -> Maybe ClientId -> Range 100 10000 Int32 -> Gundeck PaginateResult +paginate uid since clt size = do + time <- posixTime + rs <- Data.fetch uid clt since size + pure $ PaginateResult (Data.resultGap rs) (resultList time rs) where - resultList = + resultList time rs = queuedNotificationList (toList (Data.resultSeq rs)) (Data.resultHasMore rs) - (Just (millisToUTC t)) + (Just (millisToUTC time)) millisToUTC = posixSecondsToUTCTime . fromIntegral . (`div` 1000) . ms + +getById :: UserId -> NotificationId -> Maybe ClientId -> Gundeck QueuedNotification +getById uid nid clt = do + mn <- Data.fetchId uid nid clt + maybe (throwM notificationNotFound) return mn + +getLast :: UserId -> Maybe ClientId -> Gundeck QueuedNotification +getLast uid clt = do + mn <- Data.fetchLast uid clt + maybe (throwM notificationNotFound) return mn diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index c5750c6fa35..a2677e40ba9 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -1,5 +1,6 @@ module Gundeck.Push ( push, + AddTokenResponse (..), addToken, listTokens, deleteToken, @@ -23,12 +24,10 @@ import Data.Id import qualified Data.List.Extra as List import Data.List1 (List1, list1) import qualified Data.Map as Map -import Data.Predicate ((:::) (..)) import Data.Range import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text import qualified Data.UUID as UUID import Gundeck.Aws (endpointUsers) import qualified Gundeck.Aws as Aws @@ -48,22 +47,20 @@ import qualified Gundeck.Types.Presence as Presence import Gundeck.Util import Imports import Network.HTTP.Types -import Network.Wai (Request, Response) import Network.Wai.Utilities import System.Logger.Class ((+++), (.=), msg, val, (~~)) import qualified System.Logger.Class as Log import UnliftIO.Concurrent (forkIO) -push :: Request ::: JSON -> Gundeck Response -push (req ::: _) = do - ps :: [Push] <- fromJsonBody (JsonRequest req) +push :: [Push] -> Gundeck () +push ps = do bulk :: Bool <- view (options . optSettings . setBulkPush) rs <- if bulk then (Right <$> pushAll ps) `catch` (pure . Left . Seq.singleton) else pushAny ps case rs of - Right () -> return empty + Right () -> return () Left exs -> do forM_ exs $ Log.err . msg . (val "Push failed: " +++) . show throwM (Error status500 "server-error" "Server Error") @@ -357,22 +354,34 @@ nativeTargets psh rcps' alreadySent = check (Left e) = mntgtLogErr e >> return [] check (Right r) = return r -addToken :: UserId ::: ConnId ::: JsonRequest PushToken ::: JSON -> Gundeck Response -addToken (uid ::: cid ::: req ::: _) = mpaRunWithBudget 1 snsThreadBudgetReached $ do - new <- fromJsonBody req - (cur, old) <- foldl' (matching new) (Nothing, []) <$> Data.lookup uid Data.Quorum +data AddTokenResponse + = AddTokenSuccess PushToken + | AddTokenNoBudget + | AddTokenNotFound + | AddTokenInvalid + | AddTokenTooLong + | AddTokenMetadataTooLong + +addToken :: UserId -> ConnId -> PushToken -> Gundeck AddTokenResponse +addToken uid cid newtok = mpaRunWithBudget 1 AddTokenNoBudget $ do + (cur, old) <- foldl' (matching newtok) (Nothing, []) <$> Data.lookup uid Data.Quorum Log.info $ "user" .= UUID.toASCIIBytes (toUUID uid) - ~~ "token" .= Text.take 16 (tokenText (new ^. token)) + ~~ "token" .= Text.take 16 (tokenText (newtok ^. token)) ~~ msg (val "Registering push token") - continue new cur + continue newtok cur >>= either return ( \a -> do Native.deleteTokens old (Just a) - return (success new) + return (AddTokenSuccess newtok) ) where + matching :: + PushToken -> + (Maybe Address, [Address]) -> + Address -> + (Maybe Address, [Address]) matching t (x, old) a | a ^. addrTransport == t ^. tokenTransport && a ^. addrApp == t ^. tokenApp @@ -381,9 +390,18 @@ addToken (uid ::: cid ::: req ::: _) = mpaRunWithBudget 1 snsThreadBudgetReached then (Just a, old) else (x, a : old) | otherwise = (x, old) + -- + continue :: + PushToken -> + Maybe Address -> + Gundeck (Either AddTokenResponse Address) continue t Nothing = create (0 :: Int) t continue t (Just a) = update (0 :: Int) t (a ^. addrEndpoint) - create :: Int -> PushToken -> Gundeck (Either Response Address) + -- + create :: + Int -> + PushToken -> + Gundeck (Either AddTokenResponse Address) create n t = do let trp = t ^. tokenTransport let app = t ^. tokenApp @@ -397,19 +415,24 @@ addToken (uid ::: cid ::: req ::: _) = mpaRunWithBudget 1 snsThreadBudgetReached update (n + 1) t arn Left (Aws.AppNotFound app') -> do Log.info $ msg ("Push token of unknown application: '" <> appNameText app' <> "'") - return (Left notFound) + return (Left AddTokenNotFound) Left (Aws.InvalidToken _) -> do Log.info $ "token" .= tokenText tok ~~ msg (val "Invalid push token.") - return (Left invalidToken) + return (Left AddTokenInvalid) Left (Aws.TokenTooLong l) -> do Log.info $ msg ("Push token is too long: token length = " ++ show l) - return (Left tokenTooLong) + return (Left AddTokenTooLong) Right arn -> do Data.insert uid trp app tok arn cid (t ^. tokenClient) return (Right (mkAddr t arn)) - update :: Int -> PushToken -> SnsArn EndpointTopic -> Gundeck (Either Response Address) + -- + update :: + Int -> + PushToken -> + SnsArn EndpointTopic -> + Gundeck (Either AddTokenResponse Address) update n t arn = do when (n >= 3) $ do Log.err $ msg (val "AWS SNS inconsistency w.r.t. " +++ toText arn) @@ -437,8 +460,13 @@ addToken (uid ::: cid ::: req ::: _) = mpaRunWithBudget 1 snsThreadBudgetReached -- possibly updates in general). We make another attempt to (re-)create -- the endpoint in these cases instead of failing immediately. Aws.EndpointNotFound {} -> create (n + 1) t - Aws.InvalidCustomData {} -> return (Left metadataTooLong) + Aws.InvalidCustomData {} -> return (Left AddTokenMetadataTooLong) ex -> throwM ex + -- + mkAddr :: + PushToken -> + EndpointArn -> + Address mkAddr t arn = Address uid @@ -465,42 +493,12 @@ updateEndpoint uid t arn e = do ~~ "arn" .= toText r ~~ msg (val m) -deleteToken :: UserId ::: Token ::: JSON -> Gundeck Response -deleteToken (uid ::: tok ::: _) = do +deleteToken :: UserId -> Token -> Gundeck () +deleteToken uid tok = do as <- filter (\x -> x ^. addrToken == tok) <$> Data.lookup uid Data.Quorum when (null as) $ throwM (Error status404 "not-found" "Push token not found") Native.deleteTokens as Nothing - return $ empty & setStatus status204 - -success :: PushToken -> Response -success t = - let loc = Text.encodeUtf8 . tokenText $ t ^. token - in json t & setStatus status201 & addHeader hLocation loc - -invalidToken :: Response -invalidToken = - json (Error status400 "invalid-token" "Invalid push token") - & setStatus status404 - -snsThreadBudgetReached :: Response -snsThreadBudgetReached = - json (Error status400 "sns-thread-budget-reached" "Too many concurrent calls to SNS; is SNS down?") - & setStatus status413 - -tokenTooLong :: Response -tokenTooLong = - json (Error status400 "token-too-long" "Push token length must be < 8192 for GCM or 400 for APNS") - & setStatus status413 - -metadataTooLong :: Response -metadataTooLong = - json (Error status400 "metadata-too-long" "Tried to add token to endpoint resulting in metadata length > 2048") - & setStatus status413 - -notFound :: Response -notFound = empty & setStatus status404 -listTokens :: UserId ::: JSON -> Gundeck Response -listTokens (uid ::: _) = - setStatus status200 . json . PushTokenList . map (^. addrPushToken) <$> Data.lookup uid Data.Quorum +listTokens :: UserId -> Gundeck PushTokenList +listTokens uid = PushTokenList . map (^. addrPushToken) <$> Data.lookup uid Data.Quorum diff --git a/services/integration.sh b/services/integration.sh index bae017d675d..7979bfe9d70 100755 --- a/services/integration.sh +++ b/services/integration.sh @@ -102,12 +102,23 @@ run cannon "" ${orange} run cannon "2" ${orange} run cargohold "" ${purpleish} run spar "" ${orange} +run federator "" ${blue} function run_nginz() { colour=$1 - prefix=$([ -w /usr/local ] && echo /usr/local || echo "${HOME}/.wire-dev") - (cd ${NGINZ_WORK_DIR} && LD_LIBRARY_PATH=$LD_LIBRARY_PATH:${prefix}/lib/ ${TOP_LEVEL}/dist/nginx -p ${NGINZ_WORK_DIR} -c ${NGINZ_WORK_DIR}/conf/nginz/nginx.conf -g 'daemon off;' || kill_all) \ - | sed -e "s/^/$(tput setaf ${colour})[nginz] /" -e "s/$/$(tput sgr0)/" & + + # For nix we dont need LD_LIBRARY_PATH; we link against libzauth directly. + # nix-build will put a symlink to ./result with the nginx artifact + if which nix-build; then + nginz=$(nix-build "${TOP_LEVEL}/nix" -A nginz --no-out-link ) + (cd ${NGINZ_WORK_DIR} && ${nginz}/bin/nginx -p ${NGINZ_WORK_DIR} -c ${NGINZ_WORK_DIR}/conf/nginz/nginx.conf -g 'daemon off;' || kill_all) \ + | sed -e "s/^/$(tput setaf ${colour})[nginz] /" -e "s/$/$(tput sgr0)/" & + else + prefix=$([ -w /usr/local ] && echo /usr/local || echo "${HOME}/.wire-dev") + + (cd ${NGINZ_WORK_DIR} && LD_LIBRARY_PATH=$LD_LIBRARY_PATH:${prefix}/lib/ ${TOP_LEVEL}/dist/nginx -p ${NGINZ_WORK_DIR} -c ${NGINZ_WORK_DIR}/conf/nginz/nginx.conf -g 'daemon off;' || kill_all) \ + | sed -e "s/^/$(tput setaf ${colour})[nginz] /" -e "s/$/$(tput sgr0)/" & + fi } NGINZ_PORT="" diff --git a/services/nginz/Dockerfile b/services/nginz/Dockerfile index 3bb219187a0..fe83c8e6473 100644 --- a/services/nginz/Dockerfile +++ b/services/nginz/Dockerfile @@ -1,5 +1,5 @@ # Requires docker >= 17.05 (requires support for multi-stage builds) -FROM alpine:3.8 as libzauth-builder +FROM alpine:3.11 as libzauth-builder # Compile libzauth COPY libs/libzauth /src/libzauth @@ -8,9 +8,7 @@ RUN cd /src/libzauth/libzauth-c \ && make install # Nginz container -FROM alpine:3.8 - -ENV NGINX_VERSION 1.14.2 +FROM alpine:3.11 # Install libzauth COPY --from=libzauth-builder /usr/local/include/zauth.h /usr/local/include/zauth.h @@ -19,12 +17,7 @@ COPY --from=libzauth-builder /usr/local/lib/pkgconfig/libzauth.pc /usr/local/lib COPY services/nginz/third_party /src/third_party -RUN apk add --no-cache inotify-tools dumb-init bash curl && \ - # Install nginz (nginx including the zauth module) - # (taken mostly from https://github.com/nginxinc/docker-nginx/blob/master/stable/alpine/Dockerfile) - export GPG_KEYS=B0F4253373F8F6F510D42178520A9993A1C052F8 \ - && CONFIG="\ - --prefix=/etc/nginx \ +ENV CONFIG --prefix=/etc/nginx \ --sbin-path=/usr/sbin/nginx \ --modules-path=/usr/lib/nginx/modules \ --conf-path=/etc/nginx/nginx.conf \ @@ -45,10 +38,24 @@ RUN apk add --no-cache inotify-tools dumb-init bash curl && \ --with-http_gunzip_module \ --add-module=/src/third_party/nginx-zauth-module \ --add-module=/src/third_party/headers-more-nginx-module \ - --add-module=/src/third_party/nginx-module-vts \ - " \ - && addgroup -g 666 -S nginx \ - && adduser -u 666 -D -S -h /var/cache/nginx -s /sbin/nologin -G nginx nginx \ + --add-module=/src/third_party/nginx-module-vts + +# extra build dependencies needed for libzauth/nginx-xauth-module +RUN apk add --no-cache --virtual .build-deps \ + libsodium-dev \ + llvm-libunwind-dev + +################# similar block as upstream ######################################## +# see https://github.com/nginxinc/docker-nginx/blob/master/stable/alpine/Dockerfile +# This uses dockerfile logic from before 1.16 +#################################################################################### + +ENV NGINX_VERSION 1.16.1 + +RUN set -x \ + && addgroup -g 101 -S nginx \ + && adduser -S -D -H -u 101 -h /var/cache/nginx -s /sbin/nologin -G nginx -g nginx nginx \ + && export GPG_KEYS=B0F4253373F8F6F510D42178520A9993A1C052F8 \ && apk add --no-cache --virtual .build-deps \ libsodium-dev \ llvm-libunwind-dev \ @@ -124,13 +131,18 @@ RUN apk add --no-cache inotify-tools dumb-init bash curl && \ # variables && apk add --no-cache tzdata \ \ - # add libzauth runtime dependencies back in - && apk add --no-cache libsodium llvm-libunwind \ - \ # forward request and error logs to docker log collector && ln -sf /dev/stdout /var/log/nginx/access.log \ - && ln -sf /dev/stderr /var/log/nginx/error.log \ - && apk add --no-cache libgcc + && ln -sf /dev/stderr /var/log/nginx/error.log + +################# wire/nginz specific ###################### + +# Fix file permissions +RUN mkdir -p /var/cache/nginx/client_temp && chown -R nginx:nginx /var/cache/nginx + +RUN apk add --no-cache inotify-tools dumb-init bash curl && \ + # add libzauth runtime dependencies back in + apk add --no-cache libsodium llvm-libunwind libgcc COPY services/nginz/nginz_reload.sh /usr/bin/nginz_reload.sh diff --git a/services/nginz/Makefile b/services/nginz/Makefile index 9291801950a..c5deef25590 100644 --- a/services/nginz/Makefile +++ b/services/nginz/Makefile @@ -1,7 +1,7 @@ LANG := en_US.UTF-8 SHELL := /usr/bin/env bash NAME := nginz -NGINX_VERSION = 1.14.2 +NGINX_VERSION = 1.16.1 NGINZ_VERSION ?= SWAGGER_VERSION:= 2.2.10 ARCH := $(shell if [ -f "`which dpkg-architecture`" ]; then dpkg-architecture -qDEB_HOST_ARCH; else [ -f "`which dpkg`" ] && dpkg --print-architecture; fi ) @@ -12,6 +12,7 @@ DEB := $(NAME)_$(NGINZ_VERSION)_$(ARCH).deb ifeq ($(DEBUG), 1) WITH_DEBUG = --with-debug endif +DOCKER_REGISTRY ?= quay.io DOCKER_USER ?= quay.io/wire DOCKER_TAG ?= local @@ -124,8 +125,15 @@ docker: git submodule update --init docker build -t $(DOCKER_USER)/nginz:$(DOCKER_TAG) -f Dockerfile ../.. docker tag $(DOCKER_USER)/nginz:$(DOCKER_TAG) $(DOCKER_USER)/nginz:latest - if test -n "$$DOCKER_PUSH"; then docker login -u $(DOCKER_USERNAME) -p $(DOCKER_PASSWORD); docker push $(DOCKER_USER)/nginz:$(DOCKER_TAG); docker push $(DOCKER_USER)/nginz:latest; fi; + if test -n "$$DOCKER_PUSH"; then docker login $(DOCKER_REGISTRY); docker push $(DOCKER_USER)/nginz:$(DOCKER_TAG); docker push $(DOCKER_USER)/nginz:latest; fi; .PHONY: libzauth libzauth: $(MAKE) -C ../../libs/libzauth install + +# a target to start the locally-compiled docker image (tagged 'local') +# using the configuration in wire-server/deploy/services-demo +# can aid when updating nginx versions and configuration +.PHONY: docker-run-demo-local +docker-run-demo: + docker run --network=host -it -v $$(pwd)/../../deploy/services-demo:/configs --entrypoint /usr/sbin/nginx quay.io/wire/nginz:local -p /configs -c /configs/conf/nginz/nginx-docker.conf diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index f023c821867..68463ea520a 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -38,6 +38,7 @@ import Control.Lens import Control.Monad.Except import Data.Aeson (FromJSON, eitherDecode') import Data.ByteString.Conversion +import Data.Handle (Handle (fromHandle)) import Data.Id (Id (Id), TeamId, UserId) import Data.Ix import Data.Misc (PlainTextPassword) @@ -223,14 +224,14 @@ setBrigUserName buid name = do -- | Set user's handle. Fails with status <500 if brig fails with <500, and with 500 if brig fails -- with >= 500. setBrigUserHandle :: (HasCallStack, MonadSparToBrig m) => UserId -> Handle -> m () -setBrigUserHandle buid (Handle handle) = do +setBrigUserHandle buid handle = do resp <- call $ method PUT . path "/self/handle" . header "Z-User" (toByteString' buid) . header "Z-Connection" "" - . json (HandleUpdate handle) + . json (HandleUpdate (fromHandle handle)) let sCode = statusCode resp if | sCode < 300 -> pure () diff --git a/services/spar/src/Spar/Scim/Types.hs b/services/spar/src/Spar/Scim/Types.hs index 95a972afa38..367e3e98215 100644 --- a/services/spar/src/Spar/Scim/Types.hs +++ b/services/spar/src/Spar/Scim/Types.hs @@ -27,6 +27,7 @@ import Brig.Types.User as Brig import Control.Lens hiding ((#), (.=), Strict) import Data.Aeson as Aeson import qualified Data.CaseInsensitive as CI +import Data.Handle (Handle) import Data.Id import Data.Json.Util ((#)) import qualified Data.Map as Map diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 67543738446..82c3e172fb2 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -31,6 +31,7 @@ import Control.Monad.Except import Control.Monad.Trans.Maybe import Crypto.Hash import Data.Aeson as Aeson +import Data.Handle (Handle (Handle), parseHandle) import Data.Id import Data.Range import Data.String.Conversions diff --git a/services/spar/test-integration/Spec.hs b/services/spar/test-integration/Spec.hs index 073353ee58e..5113b1c2032 100644 --- a/services/spar/test-integration/Spec.hs +++ b/services/spar/test-integration/Spec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- | It would be nice to use hspec-discover, which even has support for -- . -- @@ -10,8 +12,15 @@ -- the solution: https://github.com/hspec/hspec/pull/397. module Main where +import Control.Lens ((^.)) +import Data.String.Conversions +import Data.Text (pack) import Imports +import Servant.API (toHeader) +import Spar.Run (mkApp) +import Spar.Scim.Types import System.Environment (withArgs) +import System.Random (randomRIO) import Test.Hspec import qualified Test.LoggingSpec import qualified Test.MetricsSpec @@ -22,12 +31,15 @@ import qualified Test.Spar.Intra.BrigSpec import qualified Test.Spar.Scim.AuthSpec import qualified Test.Spar.Scim.UserSpec import Util +import Web.Scim.Test.Acceptance (AcceptanceConfig (..), AcceptanceQueryConfig (..), microsoftAzure) main :: IO () main = do (wireArgs, hspecArgs) <- partitionArgs <$> getArgs env <- withArgs wireArgs mkEnvFromOptions - withArgs hspecArgs . hspec . beforeAll (pure env) . afterAll destroyEnv $ mkspec + withArgs hspecArgs . hspec $ do + beforeAll (pure env) . afterAll destroyEnv $ mkspec + mkspec' env partitionArgs :: [String] -> ([String], [String]) partitionArgs = go [] [] @@ -47,3 +59,17 @@ mkspec = do describe "Spar.Intra.Brig" Test.Spar.Intra.BrigSpec.spec describe "Spar.Scim.Auth" Test.Spar.Scim.AuthSpec.spec describe "Spar.Scim.User" Test.Spar.Scim.UserSpec.spec + +mkspec' :: TestEnv -> Spec +mkspec' env = do + describe "hscim acceptance tests" $ + microsoftAzure @SparTag AcceptanceConfig {..} + where + scimAppAndConfig = do + (app, _) <- mkApp (env ^. teOpts) + scimAuthToken <- toHeader . fst <$> registerIdPAndScimToken `runReaderT` env + let queryConfig = AcceptanceQueryConfig {..} + scimPathPrefix = "/scim/v2" + pure (app, queryConfig) + genUserName = pack <$> replicateM 9 (randomRIO ('a', 'z')) + responsesFullyKnown = False diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 0b9094ee1d6..20496c1c7ac 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -16,6 +16,7 @@ import qualified Data.Aeson as Aeson import Data.Aeson.QQ (aesonQQ) import Data.Aeson.Types (fromJSON, toJSON) import Data.ByteString.Conversion +import Data.Handle (Handle (Handle)) import Data.Id (UserId, randomId) import Data.Ix (inRange) import qualified Data.Map as Map @@ -1034,13 +1035,12 @@ specDeleteUser = do deleteUser_ (Just tok) (Just $ scimUserId storedUser) (env ^. teSpar) !!! assertTrue_ (inRange (200, 499) . statusCode) --- TODO(arianvp): Move the acceptance tests from hscim to spar. We should've caught this mistake!!! +-- | Azure sends a request for an unknown user to test out whether your API is online However; +-- it sends a userName that is not a valid wire handle. So we should treat 'invalid' as 'not +-- found'. specAzureQuirks :: SpecWith TestEnv specAzureQuirks = do describe "Assert that we implement all azure quirks" $ do - -- Azure sends a request for an unknown user to test out whether your API is online - -- However; it sends a userName that is not a valid wire handle. So we should ignore - -- when wire handles are invalid :) it "GET /Users?filter=randomField eq should return empty list; not error out" $ do (tok, (_, _, _)) <- registerIdPAndScimToken users <- listUsers tok (Just (filterBy "userName" "f52dcb88-9fa1-4ec7-984f-7bc2d4046a9c")) diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 994899f4e89..ee385afe697 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -114,6 +114,7 @@ import Data.Aeson.Lens as Aeson import qualified Data.ByteString as SBS import qualified Data.ByteString.Base64.Lazy as EL import Data.ByteString.Conversion +import Data.Handle (Handle (Handle)) import Data.Id import Data.Misc (PlainTextPassword (..)) import Data.Proxy @@ -378,8 +379,8 @@ nextWireId = Id <$> liftIO UUID.nextRandom nextSAMLID :: MonadIO m => m (ID a) nextSAMLID = mkID . UUID.toText <$> liftIO UUID.nextRandom -nextHandle :: MonadIO m => m Brig.Handle -nextHandle = liftIO $ Brig.Handle . cs . show <$> randomRIO (0 :: Int, 13371137) +nextHandle :: MonadIO m => m Handle +nextHandle = liftIO $ Handle . cs . show <$> randomRIO (0 :: Int, 13371137) -- | Generate a 'SAML.UserRef' subject. nextSubject :: (HasCallStack, MonadIO m) => m NameID diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index 81b757de354..8c628e1b6c7 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -11,6 +11,7 @@ import Control.Monad.Random import qualified Data.Aeson as Aeson import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI +import Data.Handle (Handle (Handle)) import Data.Id import qualified Data.Map as Map import Data.String.Conversions (cs) diff --git a/shell.nix b/shell.nix index af3393d55a3..b16d1ad7d76 100644 --- a/shell.nix +++ b/shell.nix @@ -1,7 +1,7 @@ -{ pkgs ? import {}}: +{ pkgs ? import ./nix }: with pkgs; mkShell { name = "shell"; - buildInputs = [ + buildInputs = [ docker-compose gnumake stack diff --git a/snapshots/README.md b/snapshots/README.md index ff11c984d17..0a9f240cac0 100644 --- a/snapshots/README.md +++ b/snapshots/README.md @@ -3,7 +3,8 @@ This directory contains [custom Stack snapshots][custom] used for Wire code. [custom]: https://docs.haskellstack.org/en/stable/custom_snapshot/ Snapshot definitions should never be changed (once committed to `develop`), because in other -repositories we refer to snapshot definitions by URL. +repositories we refer to snapshot definitions by URL. This goes for *ANY* change! What +matters is that the sha256 hash of the file remains intact! (Rationale: Stack only downloads snapshot definitions once, and never checks whether they have changed. If a snapshot changes and you have a repo that depends on it, you will get diff --git a/snapshots/wire-3.0.yaml b/snapshots/wire-3.0.yaml new file mode 100644 index 00000000000..655d191c63e --- /dev/null +++ b/snapshots/wire-3.0.yaml @@ -0,0 +1,104 @@ +# DO NOT MODIFY THIS FILE. See README.md to learn why. + +resolver: lts-14.12 +name: wire-3.0 + +# compiler: ghc-8.6.5 + +packages: +- git: https://github.com/kim/hs-collectd + commit: 885da222be2375f78c7be36127620ed772b677c9 + +- git: https://github.com/kim/snappy-framing + commit: d99f702c0086729efd6848dea8a01e5266c3a61c + +- git: https://gitlab.com/twittner/wai-routing + commit: 7e996a93fec5901767f845a50316b3c18e51a61d + +# Includes the changes from +# - git: https://gitlab.com/twittner/cql-io.git +# commit: 8b91d053c469887a427e8c075cef43139fa189c4 + +# Our fork of multihash with relaxed upper bounds +- git: https://github.com/wireapp/haskell-multihash.git + commit: 300a6f46384bfca33e545c8bab52ef3717452d12 + +# Our fork of aws with minor fixes +- git: https://github.com/wireapp/aws + commit: 42695688fc20f80bf89cec845c57403954aab0a2 + +# https://github.com/hspec/hspec-wai/pull/49 +- git: https://github.com/wireapp/hspec-wai + commit: 0a5142cd3ba48116ff059c041348b817fb7bdb25 + +# amazonka-1.6.1 is buggy: https://github.com/brendanhay/amazonka/issues/466 +# Therefore we pin an unreleased commit directly. +# +# More precisely, we pull just some libraries out of it, +# the other packages weren't changed between 1.6.1 and this commit, +# so we can use Stackage-supplied versions for them. +# See https://github.com/brendanhay/amazonka/compare/1.6.1...9cf5b5777b69ac494d23d43a692294882927df34 +# +# Once there has been made a new hackage release, we can use that instead. +- archive: https://github.com/brendanhay/amazonka/archive/9cf5b5777b69ac494d23d43a692294882927df34.tar.gz + sha256: c3044f803a7652aee88fe600a97321175cdc1443d671246ba7ff78e14bf5b49f + size: 11137527 + subdirs: + - amazonka + - amazonka-elb + - amazonka-redshift + - amazonka-route53 + - core + +############################################################ +# Wire packages (only ones that change infrequently) +############################################################ + +- git: https://github.com/wireapp/cryptobox-haskell + commit: 7546a1a25635ef65183e3d44c1052285e8401608 # master (Jul 21, 2016) + +- git: https://github.com/wireapp/hsaml2 + commit: cc47da1d097b0b26595b8889e40c33c6c0c1c551 # master (Feb 27, 2020) + +- git: https://github.com/wireapp/http-client + commit: a160cef95d9daaff7d9cfe616d95754c2f8202bf # master (Feb 4, 2020) + subdirs: + - http-client + - http-client-openssl + - http-client-tls + - http-conduit + +# Dropped from upstream snapshot +- bloodhound-0.16.0.0 +- template-0.2.0.10 +- HaskellNet-0.5.1 +- HaskellNet-SSL-0.3.4.1 +- snappy-0.2.0.2 +- smtp-mail-0.2.0.0 +- stm-containers-1.1.0.4 +- redis-io-1.0.0 +- redis-resp-1.0.0 +- hedgehog-quickcheck-0.1.1 + +# Only in nightly +- stm-hamt-1.2.0.4 +- optics-th-0.2 +- primitive-unlifted-0.1.2.0 + +# Not on stackage +- currency-codes-3.0.0.1 +- mime-0.4.0.2 +- data-timeout-0.3.1 +- geoip2-0.4.0.1 +- stomp-queue-0.3.1 +- text-icu-translit-0.1.0.7 +- wai-middleware-gunzip-0.0.2 +- cql-io-tinylog-0.1.0 +- invertible-hxt-0.1 +- network-uri-static-0.1.2.1 +- base58-bytestring-0.1.0 +- stompl-0.5.0 +- pattern-trie-0.1.0 + +# Not latest as latst one breaks wai-routing +- wai-route-0.4.0 diff --git a/stack-deps.nix b/stack-deps.nix index c42f2573efb..1266f8f647e 100644 --- a/stack-deps.nix +++ b/stack-deps.nix @@ -1,56 +1,20 @@ let - # Pin nixpkgs for all dependencies. - # If you want to update. - # 1. go to https://nixos.org/channels/nixos-19.09 - # 2. copy the URL to nixexprs.tar.gz and the sha256 hash - # 3. Uncomment the sha256 = 00000 field - # 4. nix-build - # 5. Make nix complain to you what the correct hash is. - # 6. comment sha256 = 0000 and add sha256 = - # 7. nix-build - # 8. commit - # TODO(arianvp): There are tools that automate this; we should use them - pkgsTar = builtins.fetchTarball { - name = "nixos-1909"; - url = "https://releases.nixos.org/nixos/19.09/nixos-19.09.1019.c5aabb0d603/nixexprs.tar.xz"; - sha256 = "1hjw843g964aj9cd9p6x5473yy4sfmqnqlvavc5c1lbqa8v676zg"; - # sha256 = "0000000000000000000000000000000000000000000000000000"; - }; - pkgs = import pkgsTar {}; - cryptobox-c = pkgs.callPackage ({fetchFromGitHub, rustPlatform, pkgconfig, libsodium}: - rustPlatform.buildRustPackage rec { - name = "cryptobox-c-${version}"; - version = "2019-06-17"; - buildInputs = [ pkgconfig libsodium ]; - src = fetchFromGitHub { - owner = "wireapp"; - repo = "cryptobox-c"; - rev = "4067ad96b125942545dbdec8c1a89f1e1b65d013"; - sha256 = "1i9dlhw0xk1viglyhail9fb36v1awrypps8jmhrkz8k1bhx98ci3"; - }; - cargoSha256 = "0m85c49hvvxxv7jdipfcaydy4n8iw4h6myzv63v7qc0fxnp1vfm8"; - postInstall = '' - mkdir -p $out/include - cp src/cbox.h $out/include - ''; - }) {}; - hoogle = pkgs.haskellPackages.hoogle; + pkgs = import ./nix; in - pkgs.haskell.lib.buildStackProject { - name = "wire-server"; - buildInputs = with pkgs; [ - cryptobox-c - geoip - git - icu - libsodium - libxml2 - openssl - pkgconfig - protobuf - snappy - zlib - hoogle - ]; - ghc = pkgs.haskell.compiler.ghc865; - } +pkgs.haskell.lib.buildStackProject { + name = "wire-server"; + buildInputs = with pkgs; [ + cryptobox + geoip + git + icu + libsodium + libxml2 + openssl + pkgconfig + protobuf + snappy + zlib + ]; + ghc = pkgs.haskell.compiler.ghc865; +} diff --git a/stack.yaml b/stack.yaml index 29508b85331..b22c59283ee 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: snapshots/wire-2.2.yaml +resolver: snapshots/wire-3.0.yaml packages: - libs/api-bot @@ -26,6 +26,7 @@ packages: - services/brig - services/cannon - services/cargohold +- services/federator - services/galley - services/gundeck - services/proxy @@ -51,22 +52,10 @@ extra-deps: - git: https://github.com/wireapp/saml2-web-sso commit: 1a1b313092beb685a9bb15685c83a3162c1e220f # master (Feb 17, 2020) - git: https://github.com/wireapp/hscim - commit: af22d89e7723d0f1a264fb4dbd0b4bbb4097c7a1 # master (Feb 4, 2020) + commit: 20e2ce169d2c85a10c09b4dc564eacedf8acad68 # master (Mar 9, 2020) - ormolu-0.0.3.1 - ghc-lib-parser-8.8.2.20200205@sha256:343f889f7b29f5ec07cf0d18d2a53f250fa5c002b6468a6a05b385d0191b8d34,8408 # for ormolu-0.0.3.1 -flags: - types-common: - cql: true - protobuf: true - arbitrary: true - - galley-types: - cql: true - - brig-types: - cql: true - allow-newer: false nix: diff --git a/tools/api-simulations/lib/src/Network/Wire/Simulations.hs b/tools/api-simulations/lib/src/Network/Wire/Simulations.hs index ecbd8b540e0..7e5f3446783 100644 --- a/tools/api-simulations/lib/src/Network/Wire/Simulations.hs +++ b/tools/api-simulations/lib/src/Network/Wire/Simulations.hs @@ -30,7 +30,7 @@ import Control.Lens ((^.)) import Control.Monad.Catch import qualified Data.ByteString as BS import Data.ByteString.Conversion -import Data.Id (ConvId, UserId) +import Data.Id (ConvId, UserId, makeIdOpaque) import qualified Data.Map.Strict as Map import Data.Serialize import qualified Data.Set as Set @@ -199,6 +199,6 @@ assertClientMissing :: BotSession () assertClientMissing u d cm = assertEqual - (UserClients (Map.singleton u (Set.singleton $ botClientId d))) + (UserClients (Map.singleton (makeIdOpaque u) (Set.singleton $ botClientId d))) (missingClients cm) "Missing Clients" diff --git a/tools/ormolu.sh b/tools/ormolu.sh index 71c6b67e138..180b0822efe 100755 --- a/tools/ormolu.sh +++ b/tools/ormolu.sh @@ -1,10 +1,15 @@ #!/usr/bin/env bash -set -e cd "$( dirname "${BASH_SOURCE[0]}" )/.." -ORMOLU_VERSION=$(perl -ne '/^- ormolu-([^\s]+)(\s|$)/ && print $1' stack.yaml) +command -v grep >/dev/null 2>&1 || { echo >&2 "grep is not installed, aborting."; exit 1; } +command -v awk >/dev/null 2>&1 || { echo >&2 "awk is not installed, aborting."; exit 1; } +command -v sed >/dev/null 2>&1 || { echo >&2 "sed is not installed, aborting."; exit 1; } +command -v yq >/dev/null 2>&1 || { echo >&2 "yq is not installed, aborting. See https://github.com/mikefarah/yq"; exit 1; } + +ORMOLU_VERSION=$(yq read stack.yaml 'extra-deps[*]' | sed -n 's/ormolu-//p') ( ormolu -v 2>/dev/null | grep -q $ORMOLU_VERSION ) || ( echo "please install ormolu $ORMOLU_VERSION (eg., run 'stack install ormolu' and ensure ormolu is on your PATH.)"; exit 1 ) +echo "ormolu version: $ORMOLU_VERSION" ARG_ALLOW_DIRTY_WC="0" ARG_ORMOLU_MODE="inplace" @@ -59,8 +64,9 @@ if [ "$(git status -s | grep -v \?\?)" != "" ]; then fi fi -LANGUAGE_EXTS=$(perl -ne '$x=1 if /default-extensions:/?1:(/^[^-]/?0:$x); print "--ghc-opt -X$1 " if ($x && /^- (.+)/);' package-defaults.yaml) +LANGUAGE_EXTS=$(yq read package-defaults.yaml 'default-extensions[*]' | awk '{print "--ghc-opt -X" $0}' ORS=' ') echo "ormolu mode: $ARG_ORMOLU_MODE" +echo "language extensions: $LANGUAGE_EXTS" FAILURES=0 @@ -77,5 +83,8 @@ done if [ "$FAILURES" != 0 ]; then echo "ormolu failed on $FAILURES files." + if [ "$ARG_ORMOLU_MODE" == "check" ]; then + echo -en "\n\nyou can fix this by running 'make format' from the git repo root.\n\n" + fi exit 1 fi diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 513ddccc52d..524422708b4 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -22,6 +22,7 @@ import Data.Aeson.Types (emptyArray) import Data.ByteString (ByteString) import Data.ByteString.Conversion import Data.ByteString.Lazy (fromStrict) +import Data.Handle (Handle) import Data.Id import Data.Predicate import Data.Range diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index 38fce603d40..9d611b7bc04 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -54,6 +54,7 @@ import Data.Aeson.Types (emptyArray) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.ByteString.Conversion +import Data.Handle (Handle) import qualified Data.HashMap.Strict as M import Data.Id import Data.Int