From 153fc94b5ef94f6e07b2fceb942205113c510949 Mon Sep 17 00:00:00 2001 From: jschaul Date: Tue, 18 Feb 2020 19:44:11 +0100 Subject: [PATCH 01/25] Update nginx to latest stable (#725) * update nginx to latest stable 1.16.1 * alpine 3.11 --- .../conf/nginz/nginx-docker.conf | 4 +- services/nginz/Dockerfile | 47 +++++++++++-------- services/nginz/Makefile | 9 +++- 3 files changed, 38 insertions(+), 22 deletions(-) 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/services/nginz/Dockerfile b/services/nginz/Dockerfile index 3bb219187a0..e54b2041fb5 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,15 @@ 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 ###################### + +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..3ec57a335c1 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 ) @@ -129,3 +129,10 @@ docker: .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 From d48b6711a59afabe2d52894fae8569f8870c9373 Mon Sep 17 00:00:00 2001 From: fisx Date: Wed, 19 Feb 2020 14:03:09 +0100 Subject: [PATCH 02/25] Small PRs! :) (#983) --- build/alpine/Dockerfile.builder | 1 + 1 file changed, 1 insertion(+) 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 From 59feffd4def6546952ae2fac9954762dd4d8e82b Mon Sep 17 00:00:00 2001 From: jschaul Date: Wed, 19 Feb 2020 17:40:34 +0100 Subject: [PATCH 03/25] fix nginx permissions in docker image (#985) --- services/nginz/Dockerfile | 3 +++ services/nginz/Makefile | 3 ++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/services/nginz/Dockerfile b/services/nginz/Dockerfile index e54b2041fb5..fe83c8e6473 100644 --- a/services/nginz/Dockerfile +++ b/services/nginz/Dockerfile @@ -137,6 +137,9 @@ RUN set -x \ ################# 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 diff --git a/services/nginz/Makefile b/services/nginz/Makefile index 3ec57a335c1..c5deef25590 100644 --- a/services/nginz/Makefile +++ b/services/nginz/Makefile @@ -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,7 +125,7 @@ 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: From 42670272ab62a7cd849bec90491dd7798e8686d6 Mon Sep 17 00:00:00 2001 From: fisx Date: Thu, 20 Feb 2020 07:05:36 +0100 Subject: [PATCH 04/25] Cleanup compiler warnings (#984) * Cleanup formatting and syntax in package.yaml. * Remove illegal ghc options. Before this change: ``` [...] sodium-crypto-sign > Warning: 'ghc-options: -prof' is not necessary and will lead to problems when sodium-crypto-sign > used on a library. Use the configure flag --enable-library-profiling and/or sodium-crypto-sign > --enable-profiling. [...] ``` --- libs/sodium-crypto-sign/package.yaml | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) 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 From fbfb428baa3ccfbc52a245df9aec18d9462644c6 Mon Sep 17 00:00:00 2001 From: fisx Date: Fri, 21 Feb 2020 15:30:22 +0100 Subject: [PATCH 05/25] Eliminate more CPP (#987) * Make 'EmailDomain' effectively abstract. * Remove feature flags and CPP from core libs. This is a noisy commit since I ran ormolu right away, but you only need to know that the packages have more dependencies now even if the flags are turned off, and that CPP is not enabled any more in all modules that have been changed. this is the only change. This is a good change independently of ormolu, because turning off the flags wasn't tested anywhere and didn't quite work anyway. --- libs/brig-types/package.yaml | 30 +- libs/brig-types/src/Brig/Types/Common.hs | 1 + libs/brig-types/src/Brig/Types/Instances.hs | 119 +- .../brig-types/src/Brig/Types/Provider/Tag.hs | 327 +++-- .../src/Brig/Types/Test/Arbitrary.hs | 557 +++++---- libs/galley-types/package.yaml | 15 +- libs/galley-types/src/Galley/Types.hs | 9 +- .../src/Galley/Types/Bot/Service/Internal.hs | 82 +- .../src/Galley/Types/Conversations/Roles.hs | 191 +-- libs/galley-types/src/Galley/Types/Teams.hs | 1108 +++++++++-------- libs/types-common/package.yaml | 42 +- libs/types-common/src/Data/Code.hs | 62 +- libs/types-common/src/Data/Id.hs | 265 ++-- libs/types-common/src/Data/Json/Util.hs | 81 +- libs/types-common/src/Data/LegalHold.hs | 62 +- libs/types-common/src/Data/List1.hs | 68 +- libs/types-common/src/Data/Misc.hs | 294 ++--- libs/types-common/src/Data/Range.hs | 313 ++--- libs/types-common/src/Data/Text/Ascii.hs | 296 ++--- services/galley/src/Galley/API/Error.hs | 2 +- stack.yaml | 12 - 21 files changed, 1977 insertions(+), 1959 deletions(-) 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/Common.hs b/libs/brig-types/src/Brig/Types/Common.hs index 0d728f66f84..ffa86338303 100644 --- a/libs/brig-types/src/Brig/Types/Common.hs +++ b/libs/brig-types/src/Brig/Types/Common.hs @@ -87,6 +87,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/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/Test/Arbitrary.hs b/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs index a39b7132eb3..692c7cd423d 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,100 @@ 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 - + 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))) + let many n = replicateM n (elements $ ['a' .. 'z'] <> ['0' .. '9'] <> ['_'] <> ['-'] <> ['.']) + ((<>) <$> many 2 <*> (many =<< choose (0, 254))) 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 +150,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 +449,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/galley-types/package.yaml b/libs/galley-types/package.yaml index 00f2c88c474..bb15dd80cdc 100644 --- a/libs/galley-types/package.yaml +++ b/libs/galley-types/package.yaml @@ -19,14 +19,15 @@ 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 +39,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 +54,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..14f5d989451 100644 --- a/libs/galley-types/src/Galley/Types.hs +++ b/libs/galley-types/src/Galley/Types.hs @@ -45,7 +45,8 @@ module Galley.Types ConversationMessageTimerUpdate (..), ConvType (..), CustomBackend (..), - EmailDomain (emailDomainText), + EmailDomain, + emailDomainText, mkEmailDomain, Invite (..), NewConv (..), @@ -581,12 +582,16 @@ data CustomBackend } deriving (Eq, Show) +-- | FUTUREWORK: move this type upstream into the email-validate package. newtype EmailDomain = EmailDomain - { emailDomainText :: Text + { _emailDomainText :: Text } deriving (Eq, Generic, Show) +emailDomainText :: EmailDomain -> Text +emailDomainText = _emailDomainText + mkEmailDomain :: ByteString -> Either String EmailDomain mkEmailDomain = bimap show EmailDomain . T.decodeUtf8' <=< validateDomain where 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/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 1a1ffc29e70..ebda1afb52a 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,20 @@ 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) + 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 +496,54 @@ 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 RoleAdmin = + (roleHiddenPerms RoleMember <>) $ + Set.fromList + [ ChangeLegalHoldTeamSettings, + ChangeLegalHoldUserSettings + ] roleHiddenPerms RoleMember = roleHiddenPerms RoleExternalPartner 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 +552,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 +572,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 +618,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 +649,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/types-common/package.yaml b/libs/types-common/package.yaml index ebeecd958d5..c3d0ed5a813 100644 --- a/libs/types-common/package.yaml +++ b/libs/types-common/package.yaml @@ -15,13 +15,14 @@ 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 @@ -32,12 +33,15 @@ library: - 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 - singletons >=2.0 - string-conversions - swagger >=0.3 @@ -47,28 +51,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 +84,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/Id.hs b/libs/types-common/src/Data/Id.hs index ac0b61539f0..0478631f300 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -1,59 +1,67 @@ -{-# 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 +type AssetId = Id A + +type ConvId = Id C + type InvitationId = Id I -type UserId = Id U -type ProviderId = Id P -type ServiceId = Id S -type TeamId = Id T -type ScimTokenId = Id STo + +type UserId = Id U + +type ProviderId = Id P + +type ServiceId = Id S + +type TeamId = Id T + +type ScimTokenId = Id STo -- Id ------------------------------------------------------------------------- @@ -61,42 +69,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 +114,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 +143,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/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/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/services/galley/src/Galley/API/Error.hs b/services/galley/src/Galley/API/Error.hs index 31bf6663d4d..3e7352ae08c 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -2,7 +2,7 @@ module Galley.API.Error where import Data.String.Conversions (cs) import Data.Text.Lazy as LT (pack) -import Galley.Types (EmailDomain (..)) +import Galley.Types (EmailDomain, emailDomainText) import Galley.Types.Conversations.Roles (Action) import Galley.Types.Teams (IsPerm) import Imports diff --git a/stack.yaml b/stack.yaml index d4c423ce0ea..a6b321a31bc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -55,18 +55,6 @@ extra-deps: - 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: From 47684fec021bfbd78f89e0ac8f70223929f40181 Mon Sep 17 00:00:00 2001 From: fisx Date: Mon, 24 Feb 2020 15:18:07 +0100 Subject: [PATCH 06/25] Mock federator (#986) * Create schaffolding for new service for federation. * Minimum federation API and instances. * Fixup --- services/federator/Makefile | 24 ++++ services/federator/README.md | 3 + services/federator/dist | 1 + services/federator/exec/Main.hs | 12 ++ services/federator/federator.integration.yaml | 6 + services/federator/package.yaml | 53 ++++++++ services/federator/src/Federator/API.hs | 115 ++++++++++++++++++ services/federator/src/Federator/App.hs | 20 +++ services/federator/src/Federator/Options.hs | 24 ++++ services/federator/src/Federator/Run.hs | 115 ++++++++++++++++++ services/federator/src/Federator/Types.hs | 18 +++ services/federator/src/Federator/Util.hs | 22 ++++ services/integration.sh | 1 + stack.yaml | 1 + 14 files changed, 415 insertions(+) create mode 100644 services/federator/Makefile create mode 100644 services/federator/README.md create mode 120000 services/federator/dist create mode 100644 services/federator/exec/Main.hs create mode 100644 services/federator/federator.integration.yaml create mode 100644 services/federator/package.yaml create mode 100644 services/federator/src/Federator/API.hs create mode 100644 services/federator/src/Federator/App.hs create mode 100644 services/federator/src/Federator/Options.hs create mode 100644 services/federator/src/Federator/Run.hs create mode 100644 services/federator/src/Federator/Types.hs create mode 100644 services/federator/src/Federator/Util.hs 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..82420f99171 --- /dev/null +++ b/services/federator/package.yaml @@ -0,0 +1,53 @@ +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 +- 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..3abd8212b23 --- /dev/null +++ b/services/federator/src/Federator/API.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Federator.API where + +import Brig.Types.Client.Prekey +import Brig.Types.Test.Arbitrary () +import Control.Lens ((%~), _Left) +import Data.Aeson as Aeson +import Data.Aeson.TH (deriveJSON) +import Data.String.Conversions (cs) +import Data.UUID +import Federator.Util +import Galley.Types (EmailDomain, emailDomainText, mkEmailDomain) +import Imports +import Servant.API +import Servant.API.Generic +import Test.QuickCheck +import Text.Email.Validate (EmailAddress) +import qualified Text.Email.Validate as Email + +data API route + = API + { _gapiSearch :: + route + :- "i" :> "search" :> QueryParam' [Required, Strict] "q" EmailAddress :> Get '[JSON] FUser, + _gapiPrekeys :: + route + :- "i" :> "users" :> Capture "fqu" FQU :> "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: all names subject to debate. they will go to other modules, too, but for now we'll +-- keep them all in one place here. +-- +-- 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 + { _fuEmail :: EmailAddress, + _fuFQU :: FQU + } + deriving (Eq, Show, Generic) + +data FQU + = FQU + { _fquUUID :: UUID, + _fquDomain :: EmailDomain + } + deriving (Eq, Show, Generic) + +-- instances + +instance FromHttpApiData EmailAddress where + parseUrlPiece = (_Left %~ cs) . Email.validate . cs + +instance Arbitrary EmailAddress where + arbitrary = do + localp <- listOf1 $ elements (['a' .. 'z'] <> ['0' .. '9'] <> ['_', '-', '+']) + domainp <- emailDomainText <$> arbitrary + let errmsg = error . ("arbitrary @EmailAddress: " <>) + either errmsg pure . Email.validate $ cs localp <> "@" <> cs domainp + +instance Arbitrary EmailDomain where + arbitrary = + either (error "arbitrary @EmailDomain") id . mkEmailDomain + <$> elements + [ "example.com", + "beispiel.com" + -- unicode domains are not supported, sadly: + -- "例.com", + -- "مثال.com", + -- "dæmi.com" + ] + +instance Arbitrary FUser where + arbitrary = FUser <$> arbitrary <*> arbitrary + +instance Arbitrary FQU where + arbitrary = FQU <$> arbitrary <*> arbitrary + +deriveJSON (wireJsonOptions "_fu") ''FUser + +deriveJSON (wireJsonOptions "_fqu") ''FQU + +instance ToJSON EmailDomain where + toJSON = Aeson.String . emailDomainText + +instance FromJSON EmailDomain where + parseJSON = withText "EmailDomain" $ either fail pure . mkEmailDomain . cs + +instance ToJSON EmailAddress where + toJSON = Aeson.String . cs . Email.toByteString + +instance FromJSON EmailAddress where + parseJSON = withText "EmailAddress" $ either fail pure . Email.validate . cs + +instance FromHttpApiData FQU where + parseUrlPiece raw = do + email <- parseUrlPiece raw + _fquDomain <- (_Left %~ cs) . mkEmailDomain . cs . Email.domainPart $ email + _fquUUID <- maybe (Left "FQU: local part not a UUID") pure . fromText . cs . Email.localPart $ email + pure FQU {..} + +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/integration.sh b/services/integration.sh index bae017d675d..e3fa71b019b 100755 --- a/services/integration.sh +++ b/services/integration.sh @@ -102,6 +102,7 @@ run cannon "" ${orange} run cannon "2" ${orange} run cargohold "" ${purpleish} run spar "" ${orange} +run federator "" ${blue} function run_nginz() { colour=$1 diff --git a/stack.yaml b/stack.yaml index a6b321a31bc..77767940ba6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -26,6 +26,7 @@ packages: - services/brig - services/cannon - services/cargohold +- services/federator - services/galley - services/gundeck - services/proxy From 3afdae15464f415f3fcebe01a5e354a3f8838290 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Tue, 25 Feb 2020 14:34:22 +0100 Subject: [PATCH 07/25] Refactor: separate HTTP handlers from app logic (galley) (#989) Co-authored-by: fisx --- .../src/Network/Wai/Utilities/Request.hs | 23 + services/galley/src/Galley/API.hs | 178 +++--- services/galley/src/Galley/API/Clients.hs | 22 +- services/galley/src/Galley/API/Create.hs | 107 ++-- .../galley/src/Galley/API/CustomBackend.hs | 25 +- services/galley/src/Galley/API/Internal.hs | 11 +- services/galley/src/Galley/API/LegalHold.hs | 118 ++-- services/galley/src/Galley/API/Query.hs | 118 ++-- services/galley/src/Galley/API/Teams.hs | 420 ++++++++++----- services/galley/src/Galley/API/Update.hs | 510 +++++++++++------- services/galley/src/Galley/App.hs | 5 + 11 files changed, 966 insertions(+), 571 deletions(-) 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/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index 1b5770ab50b..a7b8c0ed3f7 100644 --- a/services/galley/src/Galley/API.hs +++ b/services/galley/src/Galley/API.hs @@ -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" diff --git a/services/galley/src/Galley/API/Clients.hs b/services/galley/src/Galley/API/Clients.hs index f4c9f0a7df3..84cbbcfc622 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 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..c437858f4ed 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -1,9 +1,9 @@ module Galley.API.Create - ( createGroupConversation, - internalCreateManagedConversation, - createSelfConversation, - createOne2OneConversation, - createConnectConversation, + ( createGroupConversationH, + internalCreateManagedConversationH, + createSelfConversationH, + createOne2OneConversationH, + createConnectConversationH, ) where @@ -36,36 +36,43 @@ 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) 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 name <- rangeCheckedMaybe (newConvName body) teamMems <- Data.teamMembers (cnvTeamId tinfo) @@ -98,23 +105,31 @@ createTeamGroupConv zusr zcon tinfo body = do 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 +createOne2OneConversation :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse +createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do other <- head . fromRange <$> (rangeChecked (newConvUsers j) :: Galley (Range 1 1 [UserId])) (x, y) <- toUUIDs zusr other when (x == y) @@ -127,7 +142,7 @@ 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 mems <- bindingTeamMembers tid @@ -137,17 +152,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 + handleConversationResponse <$> createConnectConversation usr conn j + +createConnectConversation :: UserId -> Maybe ConnId -> Connect -> Galley ConversationResponse +createConnectConversation usr conn j = do (x, y) <- toUUIDs usr (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 +174,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 | usr `isMember` mems -> connect n conv | otherwise -> do now <- liftIO getCurrentTime mm <- snd <$> Data.addMember now (Data.convId conv) usr @@ -168,13 +187,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 +213,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 diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index 4cbf5f5af18..ebad9a7fd6d 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -1,7 +1,7 @@ module Galley.API.CustomBackend - ( getCustomBackendByDomain, - internalPutCustomBackendByDomain, - internalDeleteCustomBackendByDomain, + ( getCustomBackendByDomainH, + internalPutCustomBackendByDomainH, + internalDeleteCustomBackendByDomainH, ) where @@ -19,21 +19,26 @@ import Network.Wai.Utilities -- PUBLIC --------------------------------------------------------------------- -getCustomBackendByDomain :: EmailDomain ::: JSON -> Galley Response -getCustomBackendByDomain (domain ::: _) = +getCustomBackendByDomainH :: EmailDomain ::: JSON -> Galley Response +getCustomBackendByDomainH (domain ::: _) = + json <$> getCustomBackendByDomain domain + +getCustomBackendByDomain :: EmailDomain -> 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 :: EmailDomain ::: 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 :: EmailDomain ::: JSON -> Galley Response +internalDeleteCustomBackendByDomainH (domain ::: _) = do Data.deleteCustomBackend domain pure (empty & setStatus status200) diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 2102801404e..6f4c34a0d92 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, ) @@ -29,8 +29,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,7 +42,6 @@ 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 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..40a152ebf38 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,101 @@ import Network.Wai import Network.Wai.Predicate hiding (result, setStatus) import Network.Wai.Utilities -getBotConversation :: BotId ::: ConvId ::: JSON -> Galley Response -getBotConversation (zbot ::: zcnv ::: _) = do +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) 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 ::: ConvId ::: JSON -> Galley Response +getConversationH (zusr ::: cnv ::: _) = do + json <$> getConversation zusr cnv + +getConversation :: UserId -> ConvId -> Galley Conversation +getConversation zusr cnv = do c <- getConversationAndCheckMembership zusr cnv - a <- conversationView zusr c - return $ json a + conversationView zusr c + +getConversationRolesH :: UserId ::: ConvId ::: JSON -> Galley Response +getConversationRolesH (zusr ::: cnv ::: _) = do + json <$> getConversationRoles zusr cnv -getConversationRoles :: UserId ::: ConvId ::: JSON -> Galley Response -getConversationRoles (zusr ::: cnv ::: _) = do +getConversationRoles :: UserId -> ConvId -> 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 ConvId ::: 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 ConvId -> Range 1 1000 Int32 -> Galley (ConversationList ConvId) +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 ConvId)) ConvId) ::: Range 1 500 Int32 ::: JSON -> Galley Response +getConversationsH (zusr ::: range ::: size ::: _) = + json <$> getConversations zusr range size + +getConversations :: UserId -> Maybe (Either (Range 1 32 (List ConvId)) ConvId) -> Range 1 500 Int32 -> Galley (ConversationList Conversation) +getConversations zusr range size = withConvIds zusr range size $ \more ids -> do cs <- Data.conversations ids >>= filterM removeDeleted >>= filterM (pure . isMember zusr . Data.convMembers) - json . flip ConversationList more <$> mapM (conversationView zusr) cs + 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 @@ -106,14 +142,14 @@ withConvIds :: UserId -> Maybe (Either (Range 1 32 (List ConvId)) ConvId) -> Range 1 500 Int32 -> - (Bool -> [ConvId] -> Galley Response) -> - Galley Response + (Bool -> [ConvId] -> 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..f8f67a52053 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) @@ -122,22 +137,31 @@ createNonBindingTeam (zusr ::: zcon ::: req ::: _) = do 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) @@ -303,20 +366,27 @@ addTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do 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 () @@ -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..7de771158ab 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 @@ -55,14 +55,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 +76,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 (usr ::: cnv) = do + empty <$ blockConv usr cnv -blockConv :: UserId ::: ConvId -> Galley Response -blockConv (usr ::: cnv) = do +blockConv :: UserId -> ConvId -> Galley () +blockConv usr 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 -unblockConv :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response -unblockConv (usr ::: conn ::: cnv) = do +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 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 -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 +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 -> 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 +155,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 +186,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 @@ -199,50 +226,59 @@ uncheckedUpdateConversationAccess body usr zcon conv (currentAccess, targetAcces 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 +286,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 +306,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 -rmCode :: UserId ::: ConnId ::: ConvId -> Galley Response -rmCode (usr ::: zcon ::: cnv) = do +rmCodeH :: UserId ::: ConnId ::: ConvId -> Galley Response +rmCodeH (usr ::: zcon ::: cnv) = do + setStatus status200 . json <$> rmCode usr zcon cnv + +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 +335,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 + +getCodeH :: UserId ::: ConvId -> Galley Response +getCodeH (usr ::: cnv) = do + setStatus status200 . json <$> getCode usr cnv -getCode :: UserId ::: ConvId -> Galley Response -getCode (usr ::: cnv) = do +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 +352,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,10 +374,25 @@ 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 -joinConversation :: UserId -> ConnId -> ConvId -> Access -> Galley Response +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 + +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 @@ -339,24 +405,28 @@ joinConversation zusr zcon cnv access = do -- 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 +addMembersH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Invite -> Galley Response +addMembersH (zusr ::: zcon ::: cid ::: req) = do + invite <- fromJsonBody req + handleUpdateResult <$> addMembers zusr zcon cid invite + +addMembers :: UserId -> ConnId -> ConvId -> Invite -> Galley UpdateResult +addMembers zusr zcon cid invite = do 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) + toAdd <- fromMemberSize <$> checkedMemberAddSize (toList $ invUsers invite) let newUsers = filter (notIsMember conv) (toList toAdd) ensureMemberLimit (toList $ Data.convMembers conv) newUsers ensureAccess conv InviteAccess - ensureConvRoleNotElevated self (invRoleName body) + 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 conv - addToConversation mems (zusr, memConvRoleName self) zcon ((,invRoleName body) <$> newUsers) conv + addToConversation mems (zusr, memConvRoleName self) zcon ((,invRoleName invite) <$> newUsers) conv where teamConvChecks tid newUsers conv = do tms <- Data.teamMembersLimited tid newUsers @@ -366,31 +436,43 @@ addMembers (zusr ::: zcon ::: cid ::: req) = do throwM noAddToManaged ensureConnectedOrSameTeam zusr newUsers -updateSelfMember :: UserId ::: ConnId ::: ConvId ::: JsonRequest MemberUpdate -> Galley Response -updateSelfMember (zusr ::: zcon ::: cid ::: req) = do +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 cid - body <- fromJsonBody req 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 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 +removeMemberH :: UserId ::: ConnId ::: ConvId ::: UserId -> Galley Response +removeMemberH (zusr ::: zcon ::: cid ::: victim) = do + handleUpdateResult <$> removeMember zusr zcon cid victim + +removeMember :: UserId -> ConnId -> ConvId -> UserId -> Galley UpdateResult +removeMember zusr zcon cid victim = do conv <- Data.conversation cid >>= ifNothing convNotFound let (bots, users) = botsAndUsers (Data.convMembers conv) genConvChecks conv users @@ -399,12 +481,12 @@ removeMember (zusr ::: zcon ::: cid ::: victim) = do 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 -> + event <- Data.removeMembers conv zusr (singleton victim) + for_ (newPush (evtFrom event) (ConvEvent event) (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 + void . forkIO $ void $ External.deliver (bots `zip` repeat event) + pure $ Updated event + else pure Unchanged where genConvChecks conv usrs = do ensureGroupConv conv @@ -416,30 +498,58 @@ removeMember (zusr ::: zcon ::: cid ::: victim) = do 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 -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 +postBotMessageH :: BotId ::: ConvId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage ::: JSON -> Galley Response +postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do + message <- fromJsonBody req + handleOtrResult <$> postBotMessage zbot zcnv 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 +postBotMessage :: BotId -> ConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postBotMessage zbot zcnv val message = do + postNewOtrMessage (botUserId zbot) Nothing zcnv val message -postOtrBroadcast :: UserId ::: ConnId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage -> Galley Response -postOtrBroadcast (zusr ::: zcon ::: val ::: req) = - postNewOtrBroadcast zusr (Just zcon) val =<< fromJsonBody req +postProtoOtrMessageH :: UserId ::: ConnId ::: ConvId ::: 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 -postProtoOtrBroadcast :: UserId ::: ConnId ::: OtrFilterMissing ::: Request ::: JSON -> Galley Response -postProtoOtrBroadcast (zusr ::: zcon ::: val ::: req ::: _) = - Proto.toNewOtrMessage <$> fromProtoBody req - >>= postNewOtrBroadcast zusr (Just zcon) val +postOtrMessageH :: UserId ::: ConnId ::: ConvId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage -> Galley Response +postOtrMessageH (zusr ::: zcon ::: cnv ::: val ::: req) = do + message <- fromJsonBody req + handleOtrResult <$> postOtrMessage zusr zcon cnv val message -postNewOtrBroadcast :: UserId -> Maybe ConnId -> OtrFilterMissing -> NewOtrMessage -> Galley Response +postOtrMessage :: UserId -> ConnId -> ConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postOtrMessage zusr zcon cnv val message = + postNewOtrMessage zusr (Just zcon) cnv val message + +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 + +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,9 +558,7 @@ 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 -> ConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult postNewOtrMessage usr con cnv val msg = do let sender = newOtrSender msg let recvrs = newOtrRecipients msg @@ -494,12 +602,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,56 +621,64 @@ 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 + +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 ::: JsonRequest TypingData -> Galley Response -isTyping (zusr ::: zcon ::: cnv ::: req) = do - body <- fromJsonBody req +isTyping :: UserId -> ConnId -> ConvId -> TypingData -> Galley () +isTyping zusr zcon cnv typingData = do mm <- Data.members cnv unless (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) $ throwM convNotFound @@ -570,15 +692,19 @@ addBot (zusr ::: zcon ::: req) = do 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) $ 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 +714,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 +729,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 @@ -691,7 +817,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 +838,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 +870,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 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 From fca34f8a01a1ed46e61c464ce4f49c1c543a6ebc Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Wed, 26 Feb 2020 14:19:24 +0100 Subject: [PATCH 08/25] Ignore dist-newstyle (#991) --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 50a4d5aff20..e1c91d94076 100644 --- a/.gitignore +++ b/.gitignore @@ -24,6 +24,7 @@ ID Setup.hs cabal.sandbox.config dist +dist-newstyle gen-hs log tags From 94d3766c3ea98b5469518c953b1c7376b863120e Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 26 Feb 2020 19:13:28 +0100 Subject: [PATCH 09/25] Rename cassandra-schema.txt to cassandra-schema.cql (#992) * Rename cassandra-schema.txt to cassandra-schema.cql This will ensure github highlights the code. --- Makefile | 4 ++-- ...sandra-schema.txt => cassandra-schema.cql} | 22 ++++++++++++++++++- 2 files changed, 23 insertions(+), 3 deletions(-) rename docs/reference/{cassandra-schema.txt => cassandra-schema.cql} (98%) 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/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, From edd2361634ac5e80528e395f118f7252c2d0ba13 Mon Sep 17 00:00:00 2001 From: fisx Date: Wed, 26 Feb 2020 20:26:03 +0100 Subject: [PATCH 10/25] Give handlers in gundeck, cannon stronger types (#990) Co-authored-by: Arian van Putten --- services/cannon/src/Cannon/API.hs | 34 ++--- services/gundeck/src/Gundeck/API.hs | 149 +++++++++++++++++-- services/gundeck/src/Gundeck/Client.hs | 11 +- services/gundeck/src/Gundeck/Notification.hs | 63 +++----- services/gundeck/src/Gundeck/Push.hs | 106 +++++++------ 5 files changed, 230 insertions(+), 133 deletions(-) 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/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 From 8697b57609b523905641f943d68bbbe18de110e8 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 26 Feb 2020 20:28:12 +0100 Subject: [PATCH 11/25] Typos in yaml-comments in stack snapshot. (It's safe to change these, since the machine-readable meaning doesn't change.) --- snapshots/wire-2.0.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/snapshots/wire-2.0.yaml b/snapshots/wire-2.0.yaml index 7a657dac3d5..4c98e7bb3a4 100644 --- a/snapshots/wire-2.0.yaml +++ b/snapshots/wire-2.0.yaml @@ -59,7 +59,7 @@ packages: commit: 7546a1a25635ef65183e3d44c1052285e8401608 # master (Jul 21, 2016) - git: https://github.com/wireapp/hsaml2 - commit: 2d56f432464e9bf6be8ee214d7f5bb28639457ac # master (Feb 4, 20202) + commit: 2d56f432464e9bf6be8ee214d7f5bb28639457ac # master (Feb 4, 2020) - git: https://github.com/wireapp/http-client commit: a160cef95d9daaff7d9cfe616d95754c2f8202bf # master (Feb 4, 2020) @@ -102,4 +102,4 @@ packages: - pattern-trie-0.1.0 # Not latest as latst one breaks wai-routing -- wai-route-0.4.0 +- wai-route-0.4.0 From c4e1780644b7e3a1bc8c54faa0955e1394e756ee Mon Sep 17 00:00:00 2001 From: fisx Date: Thu, 27 Feb 2020 10:13:18 +0100 Subject: [PATCH 12/25] Upgrade hsaml2 (fixes utf8 handling in bytestrings). (#995) --- snapshots/wire-2.2.yaml | 8 ++++++++ stack.yaml | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) create mode 100644 snapshots/wire-2.2.yaml diff --git a/snapshots/wire-2.2.yaml b/snapshots/wire-2.2.yaml new file mode 100644 index 00000000000..26b49c246a1 --- /dev/null +++ b/snapshots/wire-2.2.yaml @@ -0,0 +1,8 @@ +# DO NOT MODIFY THIS FILE. See README.md to learn why. + +resolver: https://raw.githubusercontent.com/wireapp/wire-server/develop/snapshots/wire-2.1.yaml +name: wire-2.2 + +packages: +- git: https://github.com/wireapp/hsaml2 + commit: cc47da1d097b0b26595b8889e40c33c6c0c1c551 # master (Feb 27, 2020) diff --git a/stack.yaml b/stack.yaml index 77767940ba6..daeec4373f3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: snapshots/wire-2.1.yaml +resolver: snapshots/wire-2.2.yaml packages: - libs/api-bot From b19ee990b2b05da183ee71b3014cc2d465555b9b Mon Sep 17 00:00:00 2001 From: fisx Date: Mon, 2 Mar 2020 13:18:26 +0100 Subject: [PATCH 13/25] Tweak ormolu script. (#998) - don't choke in check mode, but report all errors. - in check mode in case of error, give hints on how to fix this. --- tools/ormolu.sh | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tools/ormolu.sh b/tools/ormolu.sh index 71c6b67e138..28aca0816f2 100755 --- a/tools/ormolu.sh +++ b/tools/ormolu.sh @@ -1,6 +1,5 @@ #!/usr/bin/env bash -set -e cd "$( dirname "${BASH_SOURCE[0]}" )/.." ORMOLU_VERSION=$(perl -ne '/^- ormolu-([^\s]+)(\s|$)/ && print $1' stack.yaml) @@ -77,5 +76,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 From 4913e17fc6f4c90282b14bdf469b7acb518d695c Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Tue, 3 Mar 2020 17:18:49 +0100 Subject: [PATCH 14/25] Move and create federation-related types (#997) * federator: some churn * move Handle to common-types * introduce Qualified to types-common * move EmailDomain to Data.Domain * define opaque user and conversation IDs * clarify terminology inside/outside the codebase * Add Data.IdMapping --- libs/brig-types/src/Brig/Types/Common.hs | 41 +-------- .../src/Brig/Types/Provider/External.hs | 1 + .../src/Brig/Types/Test/Arbitrary.hs | 5 -- libs/brig-types/src/Brig/Types/User.hs | 1 + libs/brig-types/src/Brig/Types/User/Auth.hs | 1 + .../test/unit/Test/Brig/Types/Common.hs | 3 +- libs/galley-types/package.yaml | 1 - libs/galley-types/src/Galley/Types.hs | 30 ------- libs/types-common/package.yaml | 2 + libs/types-common/src/Data/Domain.hs | 54 ++++++++++++ libs/types-common/src/Data/Handle.hs | 59 +++++++++++++ libs/types-common/src/Data/Id.hs | 36 +++++++- libs/types-common/src/Data/IdMapping.hs | 34 ++++++++ libs/types-common/src/Data/Qualified.hs | 74 ++++++++++++++++ libs/types-common/test/Test/Properties.hs | 21 ++++- services/brig/src/Brig/API.hs | 1 + services/brig/src/Brig/API/User.hs | 1 + services/brig/src/Brig/Data/Instances.hs | 1 + services/brig/src/Brig/Data/User.hs | 1 + services/brig/src/Brig/User/Auth.hs | 1 + services/brig/src/Brig/User/Event.hs | 1 + services/brig/src/Brig/User/Handle.hs | 2 +- .../brig/src/Brig/User/Handle/Blacklist.hs | 2 +- services/brig/src/Brig/User/Search/Index.hs | 1 + .../brig/src/Brig/User/Search/Index/Types.hs | 1 + .../brig/test/integration/API/Provider.hs | 1 + services/brig/test/integration/API/Search.hs | 1 + .../brig/test/integration/API/Search/Util.hs | 1 + services/brig/test/integration/API/Team.hs | 1 + .../brig/test/integration/API/User/Auth.hs | 1 + .../brig/test/integration/API/User/Handles.hs | 1 + services/federator/package.yaml | 1 + services/federator/src/Federator/API.hs | 87 ++++--------------- .../galley/src/Galley/API/CustomBackend.hs | 9 +- services/galley/src/Galley/API/Error.hs | 6 +- .../galley/src/Galley/Data/CustomBackend.hs | 7 +- services/galley/src/Galley/Data/Instances.hs | 10 +-- services/galley/src/Galley/Data/Queries.hs | 7 +- services/spar/src/Spar/Intra/Brig.hs | 5 +- services/spar/src/Spar/Scim/Types.hs | 1 + services/spar/src/Spar/Scim/User.hs | 1 + .../Test/Spar/Scim/UserSpec.hs | 1 + services/spar/test-integration/Util/Core.hs | 5 +- services/spar/test-integration/Util/Scim.hs | 1 + tools/stern/src/Stern/API.hs | 1 + tools/stern/src/Stern/Intra.hs | 1 + 46 files changed, 351 insertions(+), 173 deletions(-) create mode 100644 libs/types-common/src/Data/Domain.hs create mode 100644 libs/types-common/src/Data/Handle.hs create mode 100644 libs/types-common/src/Data/IdMapping.hs create mode 100644 libs/types-common/src/Data/Qualified.hs diff --git a/libs/brig-types/src/Brig/Types/Common.hs b/libs/brig-types/src/Brig/Types/Common.hs index ffa86338303..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} 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/Test/Arbitrary.hs b/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs index 692c7cd423d..748286b7ed0 100644 --- a/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs +++ b/libs/brig-types/src/Brig/Types/Test/Arbitrary.hs @@ -96,11 +96,6 @@ instance Arbitrary TurnURI where <*> 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))) - instance Arbitrary Name where arbitrary = Name . ST.pack 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 bb15dd80cdc..8c24178b295 100644 --- a/libs/galley-types/package.yaml +++ b/libs/galley-types/package.yaml @@ -23,7 +23,6 @@ library: - containers >=0.5 - currency-codes >=2.0 - data-default >=0.5 - - email-validate >=2.0 - errors - exceptions >=0.10.0 - gundeck-types >=1.15.13 diff --git a/libs/galley-types/src/Galley/Types.hs b/libs/galley-types/src/Galley/Types.hs index 14f5d989451..2bdd4665c47 100644 --- a/libs/galley-types/src/Galley/Types.hs +++ b/libs/galley-types/src/Galley/Types.hs @@ -45,9 +45,6 @@ module Galley.Types ConversationMessageTimerUpdate (..), ConvType (..), CustomBackend (..), - EmailDomain, - emailDomainText, - mkEmailDomain, Invite (..), NewConv (..), NewConvManaged (..), @@ -68,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 @@ -85,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 ------------------------------------------------------------ @@ -582,30 +576,6 @@ data CustomBackend } deriving (Eq, Show) --- | FUTUREWORK: move this type upstream into the email-validate package. -newtype EmailDomain - = EmailDomain - { _emailDomainText :: Text - } - deriving (Eq, Generic, Show) - -emailDomainText :: EmailDomain -> Text -emailDomainText = _emailDomainText - -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/types-common/package.yaml b/libs/types-common/package.yaml index c3d0ed5a813..e216d1511dd 100644 --- a/libs/types-common/package.yaml +++ b/libs/types-common/package.yaml @@ -29,6 +29,7 @@ library: - data-default >=0.5 - deepseq >=1.4 - directory >=1.2 + - email-validate >=2.3 - errors >=2.0 - ghc-prim - hashable >=1.2 @@ -42,6 +43,7 @@ library: - safe >=0.3 - scientific >=0.3.4 - semigroups >=0.12 + - servant >=0.16 - singletons >=2.0 - string-conversions - swagger >=0.3 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 0478631f300..3eb66ec1261 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -47,14 +47,48 @@ data T data STo +data Mapped a + +data Opaque a + type AssetId = Id A +type InvitationId = Id I + +-- | A local conversation ID type ConvId = Id C -type InvitationId = Id I +-- | 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 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/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/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/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs index 1a70bca76e9..938facd78cc 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 diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index b3fea3c95dd..eda4cf4a747 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -103,6 +103,7 @@ 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) 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/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..66d234a9b6f 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) 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/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/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/federator/package.yaml b/services/federator/package.yaml index 82420f99171..892fe7194c8 100644 --- a/services/federator/package.yaml +++ b/services/federator/package.yaml @@ -13,6 +13,7 @@ dependencies: - base - bilge - brig-types +- bytestring-conversion - data-default - email-validate - errors diff --git a/services/federator/src/Federator/API.hs b/services/federator/src/Federator/API.hs index 3abd8212b23..a7e7a077829 100644 --- a/services/federator/src/Federator/API.hs +++ b/services/federator/src/Federator/API.hs @@ -5,37 +5,38 @@ module Federator.API where import Brig.Types.Client.Prekey import Brig.Types.Test.Arbitrary () -import Control.Lens ((%~), _Left) -import Data.Aeson as Aeson import Data.Aeson.TH (deriveJSON) -import Data.String.Conversions (cs) -import Data.UUID +import Data.Handle (Handle (..)) +import Data.Id (UserId) +import Data.Qualified import Federator.Util -import Galley.Types (EmailDomain, emailDomainText, mkEmailDomain) import Imports import Servant.API import Servant.API.Generic import Test.QuickCheck -import Text.Email.Validate (EmailAddress) -import qualified Text.Email.Validate as Email data API route = API { _gapiSearch :: route - :- "i" :> "search" :> QueryParam' [Required, Strict] "q" EmailAddress :> Get '[JSON] FUser, + :- "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" FQU :> "prekeys" :> Get '[JSON] PrekeyBundle + :- "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: all names subject to debate. they will go to other modules, too, but for now we'll --- keep them all in one place here. --- -- 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 @@ -43,70 +44,18 @@ data API route data FUser = FUser - { _fuEmail :: EmailAddress, - _fuFQU :: FQU + { _fuGlobalHandle :: !(Qualified Handle), + _fuFQU :: !(Qualified UserId) } deriving (Eq, Show, Generic) -data FQU - = FQU - { _fquUUID :: UUID, - _fquDomain :: EmailDomain - } - deriving (Eq, Show, Generic) - --- instances - -instance FromHttpApiData EmailAddress where - parseUrlPiece = (_Left %~ cs) . Email.validate . cs - -instance Arbitrary EmailAddress where - arbitrary = do - localp <- listOf1 $ elements (['a' .. 'z'] <> ['0' .. '9'] <> ['_', '-', '+']) - domainp <- emailDomainText <$> arbitrary - let errmsg = error . ("arbitrary @EmailAddress: " <>) - either errmsg pure . Email.validate $ cs localp <> "@" <> cs domainp - -instance Arbitrary EmailDomain where - arbitrary = - either (error "arbitrary @EmailDomain") id . mkEmailDomain - <$> elements - [ "example.com", - "beispiel.com" - -- unicode domains are not supported, sadly: - -- "例.com", - -- "مثال.com", - -- "dæmi.com" - ] +deriveJSON (wireJsonOptions "_fu") ''FUser instance Arbitrary FUser where arbitrary = FUser <$> arbitrary <*> arbitrary -instance Arbitrary FQU where - arbitrary = FQU <$> arbitrary <*> arbitrary - -deriveJSON (wireJsonOptions "_fu") ''FUser - -deriveJSON (wireJsonOptions "_fqu") ''FQU - -instance ToJSON EmailDomain where - toJSON = Aeson.String . emailDomainText - -instance FromJSON EmailDomain where - parseJSON = withText "EmailDomain" $ either fail pure . mkEmailDomain . cs - -instance ToJSON EmailAddress where - toJSON = Aeson.String . cs . Email.toByteString - -instance FromJSON EmailAddress where - parseJSON = withText "EmailAddress" $ either fail pure . Email.validate . cs - -instance FromHttpApiData FQU where - parseUrlPiece raw = do - email <- parseUrlPiece raw - _fquDomain <- (_Left %~ cs) . mkEmailDomain . cs . Email.domainPart $ email - _fquUUID <- maybe (Left "FQU: local part not a UUID") pure . fromText . cs . Email.localPart $ email - pure FQU {..} +---------------------------------------------------------------------- +-- ORPHANS instance Arbitrary PrekeyBundle where arbitrary = PrekeyBundle <$> arbitrary <*> arbitrary diff --git a/services/galley/src/Galley/API/CustomBackend.hs b/services/galley/src/Galley/API/CustomBackend.hs index ebad9a7fd6d..a52bf460d4d 100644 --- a/services/galley/src/Galley/API/CustomBackend.hs +++ b/services/galley/src/Galley/API/CustomBackend.hs @@ -6,6 +6,7 @@ module Galley.API.CustomBackend where import Control.Monad.Catch +import Data.Domain (Domain) import Galley.API.Error import Galley.API.Util import Galley.App @@ -19,11 +20,11 @@ import Network.Wai.Utilities -- PUBLIC --------------------------------------------------------------------- -getCustomBackendByDomainH :: EmailDomain ::: JSON -> Galley Response +getCustomBackendByDomainH :: Domain ::: JSON -> Galley Response getCustomBackendByDomainH (domain ::: _) = json <$> getCustomBackendByDomain domain -getCustomBackendByDomain :: EmailDomain -> Galley CustomBackend +getCustomBackendByDomain :: Domain -> Galley CustomBackend getCustomBackendByDomain domain = Data.getCustomBackend domain >>= \case Nothing -> throwM (customBackendNotFound domain) @@ -31,14 +32,14 @@ getCustomBackendByDomain domain = -- INTERNAL ------------------------------------------------------------------- -internalPutCustomBackendByDomainH :: EmailDomain ::: JsonRequest CustomBackend -> Galley Response +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) -internalDeleteCustomBackendByDomainH :: EmailDomain ::: JSON -> Galley Response +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 3e7352ae08c..b5991669875 100644 --- a/services/galley/src/Galley/API/Error.hs +++ b/services/galley/src/Galley/API/Error.hs @@ -1,8 +1,8 @@ module Galley.API.Error where +import Data.Domain (Domain, domainText) import Data.String.Conversions (cs) import Data.Text.Lazy as LT (pack) -import Galley.Types (EmailDomain, emailDomainText) import Galley.Types.Conversations.Roles (Action) import Galley.Types.Teams (IsPerm) import Imports @@ -182,9 +182,9 @@ 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)) 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..a6d0f7e2341 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 @@ -332,14 +333,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/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/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 0b9094ee1d6..f8cdc31d912 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 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/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 From a8a1ae96d31a46836b3b3809e129613377c83ea0 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Wed, 4 Mar 2020 08:28:28 +0100 Subject: [PATCH 15/25] Compile nginx with libzauth using nix (#988) * Compile nginx with libzauth using nix/niv Noteworthy: both vts and moreheaders are packaged in nixpkgs, so no need to fetch those git submodules... but perhaps there are version conflicts. we should check! :) I also use niv for version management of nixpkgs. instead of hacky own thing. * Git ignore rust build artifacts * Actually add rust build artifacts to gitignore. It's in the top-level gitignore of wire-server, but not in the one in libzauth This is all a bit confusing. We should unify everything in one top-level gitignore. That makes things a lot less complicated. However, this is an impurity to tackle in another commit --- libs/libzauth/.gitignore | 1 + nix/default.nix | 14 ++++ nix/overlays/wire-server.nix | 60 ++++++++++++++++ nix/sources.json | 26 +++++++ nix/sources.nix | 128 +++++++++++++++++++++++++++++++++++ services/integration.sh | 16 ++++- shell.nix | 4 +- stack-deps.nix | 72 +++++--------------- 8 files changed, 262 insertions(+), 59 deletions(-) create mode 100644 nix/default.nix create mode 100644 nix/overlays/wire-server.nix create mode 100644 nix/sources.json create mode 100644 nix/sources.nix diff --git a/libs/libzauth/.gitignore b/libs/libzauth/.gitignore index 9db9d280889..1f8fa7eb156 100644 --- a/libs/libzauth/.gitignore +++ b/libs/libzauth/.gitignore @@ -1 +1,2 @@ libzauth-c/deb/usr +target 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..5722a12a304 --- /dev/null +++ b/nix/overlays/wire-server.nix @@ -0,0 +1,60 @@ +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.gitignoreSource [] ../../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/integration.sh b/services/integration.sh index e3fa71b019b..7979bfe9d70 100755 --- a/services/integration.sh +++ b/services/integration.sh @@ -106,9 +106,19 @@ 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/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/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; +} From 907837db61ee80c3faaad38eb891370a66032881 Mon Sep 17 00:00:00 2001 From: fisx Date: Wed, 4 Mar 2020 13:34:34 +0100 Subject: [PATCH 16/25] Cleanup (#1000) * Make nginz switch for integration tests reachable from outside the Makefile. * Cleanup gitignore files a little. --- .gitignore | 10 +++++ .../services-demo/resources/turn/.gitignore | 2 - .../services-demo/resources/zauth/.gitignore | 3 -- libs/libzauth/.gitignore | 2 - libs/types-common-journal/src/.gitignore | 0 services/brig/.gitignore | 43 ------------------- services/brig/Makefile | 7 +-- 7 files changed, 14 insertions(+), 53 deletions(-) delete mode 100644 deploy/services-demo/resources/turn/.gitignore delete mode 100644 deploy/services-demo/resources/zauth/.gitignore delete mode 100644 libs/libzauth/.gitignore delete mode 100644 libs/types-common-journal/src/.gitignore delete mode 100644 services/brig/.gitignore diff --git a/.gitignore b/.gitignore index e1c91d94076..aa84ef0c260 100644 --- a/.gitignore +++ b/.gitignore @@ -75,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/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/libs/libzauth/.gitignore b/libs/libzauth/.gitignore deleted file mode 100644 index 1f8fa7eb156..00000000000 --- a/libs/libzauth/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -libzauth-c/deb/usr -target 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/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 From d62e1f8960b21e3dc7c939a704df9733e543cf0c Mon Sep 17 00:00:00 2001 From: fisx Date: Thu, 5 Mar 2020 16:49:01 +0100 Subject: [PATCH 17/25] Email visible to all users in same team (#999) * Test different viewing users (not just viewed). * Permission check for email visibility in same team. * Change visible_if_on_team behavior back to "no perms check". * Cleanup. --- libs/galley-types/src/Galley/Types/Teams.hs | 5 +- services/brig/src/Brig/API/User.hs | 58 ++++++--- services/brig/src/Brig/Options.hs | 10 +- .../brig/test/integration/API/Settings.hs | 112 +++++++++++------- .../brig/test/integration/API/User/Account.hs | 7 +- 5 files changed, 128 insertions(+), 64 deletions(-) diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index ebda1afb52a..111c3051531 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -480,6 +480,7 @@ data HiddenPerm | ChangeLegalHoldUserSettings | ViewLegalHoldUserSettings | ViewSSOTeamSettings -- (change is only allowed via customer support backoffice) + | ViewSameTeamEmails deriving (Eq, Ord, Show, Enum, Bounded) -- | See Note [hidden team roles] @@ -518,7 +519,9 @@ hiddenPermissionsFromPermissions = [ ChangeLegalHoldTeamSettings, ChangeLegalHoldUserSettings ] - roleHiddenPerms RoleMember = roleHiddenPerms RoleExternalPartner + roleHiddenPerms RoleMember = + (roleHiddenPerms RoleExternalPartner <>) $ + Set.fromList [ViewSameTeamEmails] roleHiddenPerms RoleExternalPartner = Set.fromList [ ViewLegalHoldTeamSettings, diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index eda4cf4a747..5407d95678b 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -108,6 +108,7 @@ 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) @@ -876,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/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/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/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 () From 5840348ae56b066248936f4f1f2d8578f9a7a1b8 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Thu, 5 Mar 2020 17:00:32 +0100 Subject: [PATCH 18/25] Update types of some galley endpoints to be federation-aware (#1001) * galley: change input API types of minimal endpoints * make everything compile again * add FUTUREWORK notes --- libs/api-bot/src/Network/Wire/Bot/Crypto.hs | 3 +- .../Network/Wire/Client/API/Conversation.hs | 4 +- .../src/Network/Wire/Client/API/Push.hs | 4 + libs/galley-types/src/Galley/Types.hs | 16 +- libs/galley-types/src/Galley/Types/Proto.hs | 7 +- services/brig/src/Brig/API.hs | 5 +- services/brig/src/Brig/API/Client.hs | 48 +++-- services/brig/src/Brig/API/Error.hs | 19 ++ services/brig/src/Brig/API/Util.hs | 9 +- services/brig/src/Brig/App.hs | 8 +- services/brig/src/Brig/Provider/API.hs | 2 +- .../brig/test/integration/API/Provider.hs | 2 +- .../brig/test/integration/API/Team/Util.hs | 4 +- services/galley/src/Galley/API.hs | 4 +- services/galley/src/Galley/API/Clients.hs | 2 +- services/galley/src/Galley/API/Create.hs | 46 +++-- services/galley/src/Galley/API/Error.hs | 18 ++ services/galley/src/Galley/API/Internal.hs | 19 +- services/galley/src/Galley/API/Query.hs | 29 +-- services/galley/src/Galley/API/Teams.hs | 6 +- services/galley/src/Galley/API/Update.hs | 167 ++++++++++-------- services/galley/src/Galley/API/Util.hs | 76 +++++--- services/galley/src/Galley/Data.hs | 38 ++-- services/galley/src/Galley/Data/Queries.hs | 9 +- services/galley/src/Galley/Types/Clients.hs | 22 +-- services/galley/test/integration/API.hs | 10 +- services/galley/test/integration/API/Teams.hs | 2 +- .../test/integration/API/Teams/LegalHold.hs | 2 +- services/galley/test/integration/API/Util.hs | 29 +-- .../lib/src/Network/Wire/Simulations.hs | 4 +- 30 files changed, 404 insertions(+), 210 deletions(-) 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/api-client/src/Network/Wire/Client/API/Push.hs b/libs/api-client/src/Network/Wire/Client/API/Push.hs index 047ef19c2dd..ff55798e76e 100644 --- a/libs/api-client/src/Network/Wire/Client/API/Push.hs +++ b/libs/api-client/src/Network/Wire/Client/API/Push.hs @@ -147,6 +147,10 @@ lastNotification = do -- * Event Data +-- FUTUREWORK(federation): +-- A lot of information in the events can contain remote IDs (UserConnection, +-- User, ConvEvent, Conversation, SimpleMembers, UserIdList, Connect), but the +-- receiver might be on another backend, so mapped IDs don't work for them. data Event = -- User events EConnection UserConnection (Maybe UserInfo) diff --git a/libs/galley-types/src/Galley/Types.hs b/libs/galley-types/src/Galley/Types.hs index 2bdd4665c47..fe16e98ce64 100644 --- a/libs/galley-types/src/Galley/Types.hs +++ b/libs/galley-types/src/Galley/Types.hs @@ -215,7 +215,7 @@ data ConvTeamInfo data NewConv = NewConv - { newConvUsers :: ![UserId], + { newConvUsers :: ![OpaqueUserId], newConvName :: !(Maybe Text), newConvAccess :: !(Set Access), newConvAccessRole :: !(Maybe AccessRole), @@ -271,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, @@ -296,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 @@ -313,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 @@ -330,7 +330,7 @@ data NewOtrMessage newtype UserClients = UserClients - { userClients :: Map UserId (Set ClientId) + { userClients :: Map OpaqueUserId (Set ClientId) } deriving (Eq, Show, Semigroup, Monoid, Generic) @@ -430,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 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/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs index 938facd78cc..152bba54417 100644 --- a/services/brig/src/Brig/API.hs +++ b/services/brig/src/Brig/API.hs @@ -896,7 +896,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 @@ -960,7 +960,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 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/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/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/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/test/integration/API/Provider.hs b/services/brig/test/integration/API/Provider.hs index 66d234a9b6f..ddc2421065c 100644 --- a/services/brig/test/integration/API/Provider.hs +++ b/services/brig/test/integration/API/Provider.hs @@ -1255,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/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/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index a7b8c0ed3f7..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 @@ -968,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 84cbbcfc622..d24099c3f93 100644 --- a/services/galley/src/Galley/API/Clients.hs +++ b/services/galley/src/Galley/API/Clients.hs @@ -28,7 +28,7 @@ getClients usr = do if isInternal then fromUserClients <$> Intra.lookupClients [usr] else Data.lookupClients [usr] - return $ clientIds usr clts + return $ clientIds (makeIdOpaque usr) clts addClientH :: UserId ::: ClientId -> Galley Response addClientH (usr ::: clt) = do diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index c437858f4ed..dbec4763053 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -10,6 +10,8 @@ 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 @@ -66,7 +68,23 @@ 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 conversationCreated zusr c @@ -74,9 +92,14 @@ createRegularGroupConv zusr zcon (NewConvUnmanaged body) = do -- handlers above. Allows both unmanaged and managed conversations. 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 @@ -84,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 @@ -99,7 +122,7 @@ 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 @@ -130,8 +153,8 @@ createOne2OneConversationH (zusr ::: zcon ::: req) = do createOne2OneConversation :: UserId -> ConnId -> NewConvUnmanaged -> Galley ConversationResponse createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do - other <- head . fromRange <$> (rangeChecked (newConvUsers j) :: Galley (Range 1 1 [UserId])) - (x, y) <- toUUIDs zusr other + 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" @@ -144,7 +167,10 @@ createOne2OneConversation zusr zcon (NewConvUnmanaged j) = do c <- Data.conversation (Data.one2OneConvId x y) 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]) $ @@ -161,7 +187,7 @@ createConnectConversationH (usr ::: conn ::: req) = do createConnectConversation :: UserId -> Maybe ConnId -> Connect -> Galley ConversationResponse createConnectConversation usr conn j = do - (x, y) <- toUUIDs usr (cRecipient j) + (x, y) <- toUUIDs (makeIdOpaque usr) (makeIdOpaque (cRecipient j)) n <- rangeCheckedMaybe (cName j) conv <- Data.conversation (Data.one2OneConvId x y) maybe (create x y n) (update n) conv @@ -178,7 +204,7 @@ createConnectConversation usr conn j = do update n conv = let mems = Data.convMembers conv in conversationExisted usr - =<< if | usr `isMember` mems -> connect n conv + =<< if | makeIdOpaque usr `isMember` mems -> connect n conv | otherwise -> do now <- liftIO getCurrentTime mm <- snd <$> Data.addMember now (Data.convId conv) usr @@ -244,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/Error.hs b/services/galley/src/Galley/API/Error.hs index b5991669875..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 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" @@ -188,3 +194,15 @@ customBackendNotFound domain = status404 "custom-backend-not-found" ("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 6f4c34a0d92..ab8239545ca 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -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 @@ -47,15 +49,22 @@ rmUser user conn = 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/Query.hs b/services/galley/src/Galley/API/Query.hs index 40a152ebf38..af365c76fb6 100644 --- a/services/galley/src/Galley/API/Query.hs +++ b/services/galley/src/Galley/API/Query.hs @@ -35,7 +35,7 @@ getBotConversationH (zbot ::: zcnv ::: _) = do getBotConversation :: BotId -> ConvId -> Galley BotConvView getBotConversation zbot zcnv = do - c <- getConversationAndCheckMembershipWithError convNotFound (botUserId zbot) zcnv + c <- getConversationAndCheckMembershipWithError convNotFound (botUserId zbot) (makeIdOpaque zcnv) let cmems = mapMaybe mkMember (toList (Data.convMembers c)) pure $ botConvView zcnv (Data.convName c) cmems where @@ -43,46 +43,49 @@ getBotConversation zbot zcnv = do | memId m /= botUserId zbot = Just (OtherMember (memId m) (memService m) (memConvRoleName m)) | otherwise = Nothing -getConversationH :: UserId ::: ConvId ::: JSON -> Galley Response +getConversationH :: UserId ::: OpaqueConvId ::: JSON -> Galley Response getConversationH (zusr ::: cnv ::: _) = do json <$> getConversation zusr cnv -getConversation :: UserId -> ConvId -> Galley Conversation +getConversation :: UserId -> OpaqueConvId -> Galley Conversation getConversation zusr cnv = do c <- getConversationAndCheckMembership zusr cnv conversationView zusr c -getConversationRolesH :: UserId ::: ConvId ::: JSON -> Galley Response +getConversationRolesH :: UserId ::: OpaqueConvId ::: JSON -> Galley Response getConversationRolesH (zusr ::: cnv ::: _) = do json <$> getConversationRoles zusr cnv -getConversationRoles :: UserId -> ConvId -> Galley ConversationRolesList +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) pure $ ConversationRolesList wireConvRoles -getConversationIdsH :: UserId ::: Maybe ConvId ::: Range 1 1000 Int32 ::: JSON -> Galley Response +getConversationIdsH :: UserId ::: Maybe OpaqueConvId ::: Range 1 1000 Int32 ::: JSON -> Galley Response getConversationIdsH (zusr ::: start ::: size ::: _) = do json <$> getConversationIds zusr start size -getConversationIds :: UserId -> Maybe ConvId -> Range 1 1000 Int32 -> Galley (ConversationList ConvId) +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 ConvId)) ConvId) ::: Range 1 500 Int32 ::: JSON -> Galley Response +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 ConvId)) ConvId) -> Range 1 500 Int32 -> Galley (ConversationList Conversation) +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) + >>= filterM (pure . isMember (makeIdOpaque zusr) . Data.convMembers) flip ConversationList more <$> mapM (conversationView zusr) cs where removeDeleted c @@ -140,9 +143,9 @@ 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 a) -> + (Bool -> [OpaqueConvId] -> Galley a) -> Galley a withConvIds usr range size k = case range of Nothing -> do diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index f8f67a52053..94a1c52b06f 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -130,7 +130,7 @@ createNonBindingTeam zusr zcon (NonBindingNewTeam body) = 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") @@ -362,7 +362,7 @@ addTeamMember zusr zcon tid nmem = 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). @@ -468,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 diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 7de771158ab..bf4e880e6cb 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -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 @@ -87,17 +89,17 @@ acceptConv usr conn cnv = do conversationView usr conv' blockConvH :: UserId ::: ConvId -> Galley Response -blockConvH (usr ::: cnv) = do - empty <$ blockConv usr cnv +blockConvH (zusr ::: cnv) = do + empty <$ blockConv zusr cnv blockConv :: UserId -> ConvId -> Galley () -blockConv usr cnv = do +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 + when (makeIdOpaque zusr `isMember` mems) $ Data.removeMember zusr cnv unblockConvH :: UserId ::: Maybe ConnId ::: ConvId -> Galley Response unblockConvH (usr ::: conn ::: cnv) = do @@ -220,7 +222,7 @@ 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 @@ -398,40 +400,50 @@ joinConversation zusr zcon cnv access = do 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 -addMembersH :: UserId ::: ConnId ::: ConvId ::: JsonRequest Invite -> Galley Response +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 -> ConvId -> Invite -> Galley UpdateResult +addMembers :: UserId -> ConnId -> OpaqueConvId -> Invite -> Galley UpdateResult addMembers zusr zcon cid invite = do - 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 invite) - let newUsers = filter (notIsMember conv) (toList toAdd) - ensureMemberLimit (toList $ Data.convMembers conv) newUsers - 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 conv - addToConversation mems (zusr, memConvRoleName self) zcon ((,invRoleName invite) <$> newUsers) conv + 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 @@ -444,7 +456,7 @@ updateSelfMemberH (zusr ::: zcon ::: cid ::: req) = do updateSelfMember :: UserId -> ConnId -> ConvId -> MemberUpdate -> Galley () updateSelfMember zusr zcon cid update = do - conv <- getConversationAndCheckMembership zusr cid + conv <- getConversationAndCheckMembership zusr (makeIdOpaque cid) m <- getSelfMember zusr (Data.convMembers conv) -- Ensure no self role upgrades for_ (mupConvRoleName update) $ ensureConvRoleNotElevated m @@ -460,41 +472,50 @@ updateOtherMember :: UserId -> ConnId -> ConvId -> UserId -> OtherMemberUpdate - 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) ensureActionAllowed ModifyOtherConversationMember =<< getSelfMember zusr users memTarget <- getOtherMember victim users e <- processUpdateMemberEvent zusr zcon cid users memTarget (memberUpdate {mupConvRoleName = omuConvRoleName update}) void . forkIO $ void $ External.deliver (bots `zip` repeat e) -removeMemberH :: UserId ::: ConnId ::: ConvId ::: UserId -> Galley Response +removeMemberH :: UserId ::: ConnId ::: OpaqueConvId ::: OpaqueUserId -> Galley Response removeMemberH (zusr ::: zcon ::: cid ::: victim) = do handleUpdateResult <$> removeMember zusr zcon cid victim -removeMember :: UserId -> ConnId -> ConvId -> UserId -> Galley UpdateResult +removeMember :: UserId -> ConnId -> OpaqueConvId -> OpaqueUserId -> Galley UpdateResult 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 - event <- Data.removeMembers conv zusr (singleton victim) - 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 + 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.") @@ -516,19 +537,19 @@ postBotMessageH (zbot ::: zcnv ::: val ::: req ::: _) = do postBotMessage :: BotId -> ConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult postBotMessage zbot zcnv val message = do - postNewOtrMessage (botUserId zbot) Nothing zcnv val message + postNewOtrMessage (botUserId zbot) Nothing (makeIdOpaque zcnv) val message -postProtoOtrMessageH :: UserId ::: ConnId ::: ConvId ::: OtrFilterMissing ::: Request ::: Media "application" "x-protobuf" -> Galley Response +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 -postOtrMessageH :: UserId ::: ConnId ::: ConvId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage -> Galley Response +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 -postOtrMessage :: UserId -> ConnId -> ConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +postOtrMessage :: UserId -> ConnId -> OpaqueConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult postOtrMessage zusr zcon cnv val message = postNewOtrMessage zusr (Just zcon) cnv val message @@ -558,17 +579,22 @@ postNewOtrBroadcast usr con val msg = do let (_, toUsers) = foldr (newMessage usr con Nothing msg now) ([], []) rs pushSome (catMaybes toUsers) -postNewOtrMessage :: UserId -> Maybe ConnId -> ConvId -> OtrFilterMissing -> NewOtrMessage -> Galley OtrResult +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 -> @@ -638,7 +664,7 @@ isTypingH (zusr ::: zcon ::: cnv ::: req) = do 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 typingData) @@ -680,12 +706,12 @@ addBot zusr zcon b = do where 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 @@ -700,7 +726,7 @@ rmBotH (zusr ::: zcon ::: req) = do 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) @@ -744,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 () @@ -897,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 @@ -907,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/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/Queries.hs b/services/galley/src/Galley/Data/Queries.hs index a6d0f7e2341..b8c12e956b9 100644 --- a/services/galley/src/Galley/Data/Queries.hs +++ b/services/galley/src/Galley/Data/Queries.hs @@ -185,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 (?, ?)" @@ -213,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) () 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/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" From affbababfdfba90e2b846d22fe832b718024f281 Mon Sep 17 00:00:00 2001 From: Arian van Putten Date: Thu, 5 Mar 2020 18:14:27 +0100 Subject: [PATCH 19/25] Fix .gitignore shenanigans in Nix (#1002) Before, for building libzauth we were only considering the .gitignore in the ./lib/libzauth directory, (ignoring the toplevel one) which didn't contain a Cargo.lock ignore (and shouldn't! lockfiles should be comitted so builds are reproducible!). Then we deleted the local gitignore which tripped up the nix build as the gitignore didn't exist anymore. We now use the toplevel .gitignore, but remove the global Cargo.lock ignore as Cargo.lock's are important to be comitted (and were already!). For some reason we do not have a Cargo.lock for ./libs/libzauth/libzauth but only ./libs/libzauth/libzauth-c so I kept it like that. libzauth-c is the thing we directly build, and then pulls in libzauth as a dependency, so locking at just libzauth-c is sufficient and is also the lockfile we had in source control already anyway. --- .gitignore | 2 +- nix/overlays/wire-server.nix | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/.gitignore b/.gitignore index aa84ef0c260..0b41c5aba60 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,5 @@ target -Cargo.lock +./libs/libzauth/libzauth/Cargo.lock *.aux* *.chi *.chs.h diff --git a/nix/overlays/wire-server.nix b/nix/overlays/wire-server.nix index 5722a12a304..9b1a1e5a983 100644 --- a/nix/overlays/wire-server.nix +++ b/nix/overlays/wire-server.nix @@ -26,8 +26,7 @@ self: super: { name = "libzauth-${version}"; version = "3.0.0"; buildInputs = [ libsodium pkgconfig ]; - src = self.nix-gitignore.gitignoreSource [] ../../libs/libzauth; - + src = self.nix-gitignore.gitignoreSourcePure [ ../../.gitignore ] ../../libs/libzauth; sourceRoot = "libzauth/libzauth-c"; cargoSha256 = "01yj1rchqmjnpj5cb9wl7vdzrycjwjhm60xh1jghw02n8jhl51p2"; # self.lib.fakeSha256; From c5684606ee069c12f55b9e953fa4c880b3033a7e Mon Sep 17 00:00:00 2001 From: fisx Date: Fri, 6 Mar 2020 12:06:43 +0100 Subject: [PATCH 20/25] stack snapshot 3.0. (#1004) This does not change any dependencies from 2.2. I broke 2.* a while ago by editing the files, and thus learned that even editing typos in comments is a bad idea. the easiest way out is to abandon the old snapshot and clone it into a new one with the same content. --- snapshots/README.md | 3 +- snapshots/wire-3.0.yaml | 104 ++++++++++++++++++++++++++++++++++++++++ stack.yaml | 2 +- 3 files changed, 107 insertions(+), 2 deletions(-) create mode 100644 snapshots/wire-3.0.yaml 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.yaml b/stack.yaml index daeec4373f3..348112297b6 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 From e784beef004c57f51fae969334b715d9ecb69644 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Fri, 6 Mar 2020 15:37:44 +0100 Subject: [PATCH 21/25] move FUTUREWORK(federation) comment to right place --- libs/api-client/src/Network/Wire/Client/API/Push.hs | 4 ---- libs/galley-types/src/Galley/Types.hs | 3 +++ 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/libs/api-client/src/Network/Wire/Client/API/Push.hs b/libs/api-client/src/Network/Wire/Client/API/Push.hs index ff55798e76e..047ef19c2dd 100644 --- a/libs/api-client/src/Network/Wire/Client/API/Push.hs +++ b/libs/api-client/src/Network/Wire/Client/API/Push.hs @@ -147,10 +147,6 @@ lastNotification = do -- * Event Data --- FUTUREWORK(federation): --- A lot of information in the events can contain remote IDs (UserConnection, --- User, ConvEvent, Conversation, SimpleMembers, UserIdList, Connect), but the --- receiver might be on another backend, so mapped IDs don't work for them. data Event = -- User events EConnection UserConnection (Maybe UserInfo) diff --git a/libs/galley-types/src/Galley/Types.hs b/libs/galley-types/src/Galley/Types.hs index fe16e98ce64..59440f0b874 100644 --- a/libs/galley-types/src/Galley/Types.hs +++ b/libs/galley-types/src/Galley/Types.hs @@ -470,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 From b5ffbc09b8bb5c2e7ed41e11d6a8398f373a4db8 Mon Sep 17 00:00:00 2001 From: fisx Date: Mon, 9 Mar 2020 15:31:55 +0100 Subject: [PATCH 22/25] Run hscim azure tests (#941) --- services/spar/test-integration/Spec.hs | 28 ++++++++++++++++++- .../Test/Spar/Scim/UserSpec.hs | 7 ++--- stack.yaml | 2 +- 3 files changed, 31 insertions(+), 6 deletions(-) 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 f8cdc31d912..20496c1c7ac 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -1035,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/stack.yaml b/stack.yaml index 348112297b6..b22c59283ee 100644 --- a/stack.yaml +++ b/stack.yaml @@ -52,7 +52,7 @@ 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 From ce6994bebc09e45a97587264b92e5272f07b0d39 Mon Sep 17 00:00:00 2001 From: fisx Date: Tue, 10 Mar 2020 10:16:32 +0100 Subject: [PATCH 23/25] Remove autoconnect functionality; deprecate end-point. (#1005) --- docs/reference/user/connection.md | 2 - libs/brig-types/src/Brig/Types.hs | 1 - libs/brig-types/src/Brig/Types/AddressBook.hs | 109 ------------------ libs/brig-types/src/Brig/Types/Swagger.hs | 11 -- services/brig/src/Brig/API.hs | 52 +++++---- services/brig/src/Brig/API/Connection.hs | 41 ------- services/brig/test/integration/API/User.hs | 2 - .../test/integration/API/User/Onboarding.hs | 67 ----------- .../brig/test/integration/API/User/Util.hs | 36 ------ 9 files changed, 30 insertions(+), 291 deletions(-) delete mode 100644 libs/brig-types/src/Brig/Types/AddressBook.hs delete mode 100644 services/brig/test/integration/API/User/Onboarding.hs 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/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/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/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs index 152bba54417..f1a5ef32c3b 100644 --- a/services/brig/src/Brig/API.hs +++ b/services/brig/src/Brig/API.hs @@ -810,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 @@ -1347,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 @@ -1511,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 @@ -1559,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/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/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/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 $ From 07eaf103f1b95f748e5508b10719911b804cbc65 Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Tue, 10 Mar 2020 13:16:01 +0100 Subject: [PATCH 24/25] ormolu.sh: make queries for options more robust (#1009) Still not pretty, we should try to find a better solution. * ormolu.sh: more robust queries * ormolu.sh: print version and enabled language extensions * check that tools are installed --- tools/ormolu.sh | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/tools/ormolu.sh b/tools/ormolu.sh index 28aca0816f2..180b0822efe 100755 --- a/tools/ormolu.sh +++ b/tools/ormolu.sh @@ -2,8 +2,14 @@ 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" @@ -58,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 From 388284fe2b8296d85d163490febea8d9e217ab96 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Tue, 10 Mar 2020 16:52:14 +0100 Subject: [PATCH 25/25] CHANGELOG.md --- CHANGELOG.md | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) 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