diff --git a/CHANGELOG.md b/CHANGELOG.md index 593eca13dbf..171867e5223 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,37 @@ - +# [2022-02-02] + +## Release notes + + +* Upgrade webapp version to 2022-01-27-production.0-v0.28.29-0-42c9a1e (#2078) + + +## Features + + +* Allow brig's additionalWriteIndex to be on a different ElasticSearch cluster. + This allows migrating to a new ElasticSearch cluster. (#2063) + +* The file sharing team feature now has a server wide configurable lock status. For more information please refer to [/docs/reference/config-options.md#file-sharing](https://github.com/wireapp/wire-server/blob/develop/docs/reference/config-options.md#file-sharing). (#2059) + + +## Internal changes + + +* Remove non-existing functions from module export lists (#2095) + +* Rename Spar.Sem.IdP to Spar.Sem.IdPConfigStore (#2067) + +* Endpoints based on `MultiVerb` can now be made to return content types not listed in the `Accept` header (#2074) + +* The lock status of the file sharing team feature can be updated via the internal API (`PUT /i/teams/:tid/features/fileSharing/(un)?locked`). (#2059) + +* Servantify Galley Teams API (`GET /teams/:tid` and `DELETE /teams/:tid`). (#2092) + +* Add explicit export lists to all Spar.Sem modules (#2070) + +* Separate some Spar.Sem utility functions into their own module (#2069) + # [2022-01-28] diff --git a/charts/cassandra-migrations/templates/_helpers.tpl b/charts/cassandra-migrations/templates/_helpers.tpl new file mode 100644 index 00000000000..71a57640c47 --- /dev/null +++ b/charts/cassandra-migrations/templates/_helpers.tpl @@ -0,0 +1,108 @@ +{{- define "cassandraGalleyHost" -}} +{{ $cassandraGalley := default dict .Values.cassandraGalley }} +{{- default (.Values.cassandra.host) $cassandraGalley.host }} +{{- end -}} + +{{- define "cassandraBrigHost" -}} +{{ $cassandraBrig := default dict .Values.cassandraBrig }} +{{- default (.Values.cassandra.host) $cassandraBrig.host }} +{{- end -}} + +{{- define "cassandraGundeckHost" -}} +{{ $cassandraGundeck := default dict .Values.cassandraGundeck }} +{{- default (.Values.cassandra.host) $cassandraGundeck.host }} +{{- end -}} + +{{- define "cassandraSparHost" -}} +{{ $cassandraSpar := default dict .Values.cassandraSpar }} +{{- default (.Values.cassandra.host) $cassandraSpar.host }} +{{- end -}} + +{{/* +Note: in the past, 'replicaCount' was used, this fallback is only used +for backwards-compatibility with already-installed charts to not break existing installations. + +Thus the order of priority is: + +1. cassandraGalley.replicationMap +2. cassandra.replicationMap +3. cassandraGalley.replicationFactor +4. cassandra.replicationFactor +5. cassandra.replicaCount + +*/}} + +{{- define "cassandraGalleyReplicationArg" -}} +{{ $cassandraGalley := default dict .Values.cassandraGalley }} +{{- if (or .Values.cassandra.replicationMap $cassandraGalley.replicationMap) -}} +{{- default (.Values.cassandra.replicationMap) $cassandraGalley.replicationMap -}} +{{- else -}} +{{- default (default (.Values.cassandra.replicaCount) .Values.cassandra.replicationFactor) $cassandraGalley.replicationFactor -}} +{{- end -}} +{{- end -}} + +{{- define "cassandraGalleyReplicationType" -}} +{{ $cassandraGalley := default dict .Values.cassandraGalley }} +{{- if (or .Values.cassandra.replicationMap $cassandraGalley.replicationMap) -}} +{{- printf "--replication-map" -}} +{{- else -}} +{{- printf "--replication-factor" -}} +{{- end -}} +{{- end -}} + + +{{- define "cassandraGundeckReplicationArg" -}} +{{ $cassandraGundeck := default dict .Values.cassandraGundeck }} +{{- if (or .Values.cassandra.replicationMap $cassandraGundeck.replicationMap) -}} +{{- default (.Values.cassandra.replicationMap) $cassandraGundeck.replicationMap -}} +{{- else -}} +{{- default (default (.Values.cassandra.replicaCount) .Values.cassandra.replicationFactor) $cassandraGundeck.replicationFactor -}} +{{- end -}} +{{- end -}} + +{{- define "cassandraGundeckReplicationType" -}} +{{ $cassandraGundeck := default dict .Values.cassandraGundeck }} +{{- if (or .Values.cassandra.replicationMap $cassandraGundeck.replicationMap) -}} +{{- printf "--replication-map" -}} +{{- else -}} +{{- printf "--replication-factor" -}} +{{- end -}} +{{- end -}} + + +{{- define "cassandraBrigReplicationArg" -}} +{{ $cassandraBrig := default dict .Values.cassandraBrig }} +{{- if (or .Values.cassandra.replicationMap $cassandraBrig.replicationMap) -}} +{{- default (.Values.cassandra.replicationMap) $cassandraBrig.replicationMap -}} +{{- else -}} +{{- default (default (.Values.cassandra.replicaCount) .Values.cassandra.replicationFactor) $cassandraBrig.replicationFactor -}} +{{- end -}} +{{- end -}} + +{{- define "cassandraBrigReplicationType" -}} +{{ $cassandraBrig := default dict .Values.cassandraBrig }} +{{- if (or .Values.cassandra.replicationMap $cassandraBrig.replicationMap) -}} +{{- printf "--replication-map" -}} +{{- else -}} +{{- printf "--replication-factor" -}} +{{- end -}} +{{- end -}} + + +{{- define "cassandraSparReplicationArg" -}} +{{ $cassandraSpar := default dict .Values.cassandraSpar }} +{{- if (or .Values.cassandra.replicationMap $cassandraSpar.replicationMap) -}} +{{- default (.Values.cassandra.replicationMap) $cassandraSpar.replicationMap -}} +{{- else -}} +{{- default (default (.Values.cassandra.replicaCount) .Values.cassandra.replicationFactor) $cassandraSpar.replicationFactor -}} +{{- end -}} +{{- end -}} + +{{- define "cassandraSparReplicationType" -}} +{{ $cassandraSpar := default dict .Values.cassandraSpar }} +{{- if (or .Values.cassandra.replicationMap $cassandraSpar.replicationMap) -}} +{{- printf "--replication-map" -}} +{{- else -}} +{{- printf "--replication-factor" -}} +{{- end -}} +{{- end -}} diff --git a/charts/cassandra-migrations/templates/galley-migrate-data.yaml b/charts/cassandra-migrations/templates/galley-migrate-data.yaml index 90e7f4a58b0..3800615d2b9 100644 --- a/charts/cassandra-migrations/templates/galley-migrate-data.yaml +++ b/charts/cassandra-migrations/templates/galley-migrate-data.yaml @@ -1,6 +1,7 @@ # This jobs runs migrations on the galley DB using the galley-migrate-data tool. # The source for the tool can be found at services/galley in the wire-server # repository. +{{- if .Values.enableGalleyMigrations }} apiVersion: batch/v1 kind: Job metadata: @@ -32,8 +33,9 @@ spec: imagePullPolicy: {{ default "" .Values.imagePullPolicy | quote }} args: - --cassandra-host - - "{{ .Values.cassandra.host }}" + - "{{ template "cassandraGalleyHost" . }}" - --cassandra-port - "9042" - --cassandra-keyspace - galley +{{- end }} diff --git a/charts/cassandra-migrations/templates/migrate-schema.yaml b/charts/cassandra-migrations/templates/migrate-schema.yaml index 1934d510665..b64815b6553 100644 --- a/charts/cassandra-migrations/templates/migrate-schema.yaml +++ b/charts/cassandra-migrations/templates/migrate-schema.yaml @@ -23,61 +23,70 @@ spec: # to avoid 'Column family ID mismatch' / schema disagreements # see https://stackoverflow.com/questions/29030661/creating-new-table-with-cqlsh-on-existing-keyspace-column-family-id-mismatch#40325651 for details. initContainers: + {{- if .Values.enableGundeckMigrations }} - name: gundeck-schema image: "{{ .Values.images.gundeck }}:{{ .Values.images.tag }}" imagePullPolicy: {{ default "" .Values.imagePullPolicy | quote }} command: - gundeck-schema - --host - - "{{ .Values.cassandra.host }}" + - "{{ template "cassandraGundeckHost" . }}" - --port - "9042" - --keyspace - gundeck - - --replication-factor - - "{{ .Values.cassandra.replicaCount }}" + - {{ template "cassandraGundeckReplicationType" . }} + - "{{ template "cassandraGundeckReplicationArg" . }}" + {{- end }} + {{- if .Values.enableBrigMigrations }} - name: brig-schema image: "{{ .Values.images.brig }}:{{ .Values.images.tag }}" imagePullPolicy: {{ default "" .Values.imagePullPolicy | quote }} command: - brig-schema - --host - - "{{ .Values.cassandra.host }}" + - "{{ template "cassandraBrigHost" . }}" - --port - "9042" - --keyspace - brig - - --replication-factor - - "{{ .Values.cassandra.replicaCount }}" + - {{ template "cassandraBrigReplicationType" . }} + - "{{ template "cassandraBrigReplicationArg" . }}" + {{- end }} + {{- if .Values.enableGalleyMigrations }} - name: galley-schema image: "{{ .Values.images.galley }}:{{ .Values.images.tag }}" imagePullPolicy: {{ default "" .Values.imagePullPolicy | quote }} command: - galley-schema - --host - - "{{ .Values.cassandra.host }}" + - "{{ template "cassandraGalleyHost" . }}" - --port - "9042" - --keyspace - galley - - --replication-factor - - "{{ .Values.cassandra.replicaCount }}" + - {{ template "cassandraGalleyReplicationType" . }} + - "{{ template "cassandraGalleyReplicationArg" . }}" + {{- end }} + {{- if .Values.enableSparMigrations }} - name: spar-schema image: "{{ .Values.images.spar }}:{{ .Values.images.tag }}" imagePullPolicy: {{ default "" .Values.imagePullPolicy | quote }} command: - spar-schema - --host - - "{{ .Values.cassandra.host }}" + - "{{ template "cassandraSparHost" . }}" - --port - "9042" - --keyspace - spar - - --replication-factor - - "{{ .Values.cassandra.replicaCount }}" + - {{ template "cassandraSparReplicationType" . }} + - "{{ template "cassandraSparReplicationArg" . }}" + {{- end }} + containers: - name: job-done image: busybox:1.32.0 diff --git a/charts/cassandra-migrations/templates/spar-migrate-data.yaml b/charts/cassandra-migrations/templates/spar-migrate-data.yaml index 78c3ce3de78..26710c73697 100644 --- a/charts/cassandra-migrations/templates/spar-migrate-data.yaml +++ b/charts/cassandra-migrations/templates/spar-migrate-data.yaml @@ -1,6 +1,7 @@ # This jobs runs data migrations for the spar DB using the spar-migrate-data tool. # The source for the tool can be found at services/spar/migrate-data # +{{- if (and .Values.enableSparMigrations .Values.enableBrigMigrations) }} apiVersion: batch/v1 kind: Job metadata: @@ -32,14 +33,15 @@ spec: imagePullPolicy: {{ default "" .Values.imagePullPolicy | quote }} args: - --cassandra-host-spar - - "{{ .Values.cassandra.host }}" + - "{{ template "cassandraSparHost" . }}" - --cassandra-port-spar - "9042" - --cassandra-keyspace-spar - spar - --cassandra-host-brig - - "{{ .Values.cassandra.host }}" + - "{{ template "cassandraBrigHost" . }}" - --cassandra-port-brig - "9042" - --cassandra-keyspace-brig - brig +{{- end }} diff --git a/charts/cassandra-migrations/values.yaml b/charts/cassandra-migrations/values.yaml index 0347fac256d..6aff2da2685 100644 --- a/charts/cassandra-migrations/values.yaml +++ b/charts/cassandra-migrations/values.yaml @@ -6,3 +6,52 @@ images: spar: quay.io/wire/spar-schema galleyMigrateData: quay.io/wire/galley-migrate-data sparMigrateData: quay.io/wire/spar-migrate-data + +# Setting cassandra host name and replication is mandatory to specify. +# +# Example production case: +# +# cassandra: +# host: cassandra-external +# replicationFactor: 3 +# +# Example demo case (single cassandra machine, test deployment): +# +# cassandra: +# host: cassandra-ephemeral +# replicationFactor: 1 +# +# The following is optional and useful only in a multi-datacenter setup. +# if 'replicationMap' is set, it's used; otherwise replicationFactor is used. +# +# cassandra: +# replicationMap: DC1:3,DC2:5 +# +# The following is optional. If set, it overrides the otherwise-used +# cassandra.host and cassandra.replicationFactor / replicationMap for +# the specific haskell service in case you have separate +# cassandra clusters for each service. +# +# cassandraGalley: +# host: cassandra-ephemeral-galley +# replicationMap: eu-west-1:3 +# +# cassandraBrig: +# host: cassandra-ephemeral-galley +# replicationMap: eu-central-1:3 +# +# cassandraSpar: +# host: cassandra-ephemeral-galley +# replicationMap: us-east-1:3 +# +# cassandraGundeck: +# host: cassandra-ephemeral-galley +# replicationMap: eu-west-1:3 + + +# Overriding the following is only useful during datacenter migration time periods, +# where some other job already migrates schemas. +enableGalleyMigrations: true +enableBrigMigrations: true +enableGundeckMigrations: true +enableSparMigrations: true diff --git a/charts/galley/templates/configmap.yaml b/charts/galley/templates/configmap.yaml index 3200588cd52..548db7f85e9 100644 --- a/charts/galley/templates/configmap.yaml +++ b/charts/galley/templates/configmap.yaml @@ -64,5 +64,9 @@ data: teamSearchVisibility: {{ .settings.featureFlags.teamSearchVisibility }} classifiedDomains: {{- toYaml .settings.featureFlags.classifiedDomains | nindent 10 }} + {{- if .settings.featureFlags.fileSharing }} + fileSharing: + {{- toYaml .settings.featureFlags.fileSharing | nindent 10 }} + {{- end }} {{- end }} {{- end }} diff --git a/charts/galley/values.yaml b/charts/galley/values.yaml index 59b458237fb..45e9c0ca77e 100644 --- a/charts/galley/values.yaml +++ b/charts/galley/values.yaml @@ -34,6 +34,12 @@ config: status: disabled config: domains: [] + # fileSharing setting is optional + # if not set the default feature status is enabled and the default lock status is unlocked + # fileSharing: + # defaults: + # status: enabled + # lockStatus: unlocked aws: region: "eu-west-1" proxy: {} diff --git a/docs/reference/cassandra-schema.cql b/docs/reference/cassandra-schema.cql index 914a8236f9b..5aee8661a51 100644 --- a/docs/reference/cassandra-schema.cql +++ b/docs/reference/cassandra-schema.cql @@ -421,6 +421,7 @@ CREATE TABLE galley_test.team_features ( conference_calling int, digital_signatures int, file_sharing int, + file_sharing_lock_status int, guest_links_lock_status int, guest_links_status int, legalhold_status int, diff --git a/docs/reference/config-options.md b/docs/reference/config-options.md index c5143212ac4..85592137db8 100644 --- a/docs/reference/config-options.md +++ b/docs/reference/config-options.md @@ -145,14 +145,28 @@ See also: conference falling for personal accounts (below). ### File Sharing -File sharing is enabled by default. If you want to disable it for all teams, add this to your feature config settings: +File sharing is enabled and unlocked by default. If you want a different configuration, use the following syntax: -``` +```yaml fileSharing: defaults: - status: enabled + status: disabled|enabled + lockStatus: locked|unlocked ``` +These are all the possible combinations of `status` and `lockStatus`: + +| `status` | `lockStatus` | | +| ---------- | ------------ | ------------------------------------------------- | +| `enabled` | `locked` | Feature enabled, cannot be disabled by team admin | +| `enabled` | `unlocked` | Feature enabled, can be disabled by team admin | +| `disabled` | `locked` | Feature disabled, cannot be enabled by team admin | +| `disabled` | `unlocked` | Feature disabled, can be enabled by team admin | + +The lock status for individual teams can be changed via the internal API (`PUT /i/teams/:tid/features/fileSharing/(un)?locked`). + +The feature status for individual teams can be changed via the public API (if the feature is unlocked). + ### Federation Domain Regardless of whether a backend wants to enable federation or not, the operator @@ -284,7 +298,7 @@ federator: Some features (as of the time of writing this: only `conferenceCalling`) allow to set defaults for personal accounts in -brig. Those are taken into account in galley's end-points `GET +brig. Those are taken into account in galley's end-points `GET /feature-configs*`. To be specific: diff --git a/docs/reference/elastic-search.md b/docs/reference/elastic-search.md index c9f42195592..3316d32f19e 100644 --- a/docs/reference/elastic-search.md +++ b/docs/reference/elastic-search.md @@ -90,7 +90,7 @@ REPLICAS= REFRESH_INTERVAL= ``` -1. Create the new index (please fill out values in `<>` as required) +1. Create the new index ```bash docker run "quay.io/wire/brig-index:$WIRE_VERSION" create \ --elasticsearch-server "http://$ES_HOST:$ES_PORT" \ @@ -119,6 +119,61 @@ environment have failed. As a workaround, there is a tool in undead users right after the migration. If they exist, please run refill the ES documents from cassandra as described [above](#refill-es-documents-from-cassandra) +## Migrate to a new cluster + +If the ES cluster used by brig needs to be shutdown and data must be moved to a +new cluser, these steps can be taken to ensure minimal disruption to the +service. + +Before starting, please set these environment variables: + +```bash +ES_OLD_HOST= +ES_OLD_PORT= # usually 9200 +ES_OLD_INDEX= +ES_NEW_HOST= +ES_NEW_PORT= # usually 9200 +ES_NEW_INDEX= +WIRE_VERSION= + +# Use curl http://$ES_OLD_HOST:$ES_OLD_PORT/$ES_OLD_INDEX/_settings +# to know previous values of SHARDS, REPLICAS and REFRESH_INTERVAL +SHARDS= +REPLICAS= +REFRESH_INTERVAL= + +BRIG_CASSANDRA_HOST= +BRIG_CASSANDRA_PORT= +BRIG_CASSANDRA_KEYSPACE= +``` + +1. Create the new index + ```bash + docker run "quay.io/wire/brig-index:$WIRE_VERSION" create \ + --elasticsearch-server "http://$ES_NEW_HOST:$ES_NEW_PORT" \ + --elasticsearch-index "$ES_NEW_INDEX" \ + --elasticsearch-shards "$SHARDS" \ + --elasticsearch-replicas "$REPLICAS" \ + --elasticsearch-refresh-interval "$REFRESH_INTERVAL" + ``` +1. Redeploy brig with `elasticsearch.additionalWriteIndexUrl` set to the URL of + the new cluster and `elasticsearch.additionalWriteIndex` set to + `$ES_NEW_INDEX`. +1. Make sure no old instances of brig are running. +1. Reindex data to the new index + ```bash + docker run "quay.io/wire/brig-index:$WIRE_VERSION" migrate-data \ + --elasticsearch-server "http://$ES_NEW_HOST:$ES_NEW_PORT" \ + --elasticsearch-index "$ES_NEW_INDEX" \ + --cassandra-host "$BRIG_CASSANDRA_HOST" \ + --cassandra-port "$BRIG_CASSANDRA_PORT" \ + --cassandra-keyspace "$BRIG_CASSANDRA_KEYSPACE" + ``` +1. Remove `elasticsearch.additionalWriteIndex` and + `elasticsearch.additionalWriteIndexUrl` from brig config. Set + `elasticsearch.url` to the URL of the new cluster and `elasticsearch.index` + to the name of new index. Deploy brig with these settings. + ## Recreate an index (Requires downtime) When analysis settings of an index need to be changed, e.g. for changes diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index b13fcc67b11..d4f7b0b984b 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -214,7 +214,7 @@ data FeatureFlags = FeatureFlags _flagTeamSearchVisibility :: !FeatureTeamSearchVisibility, _flagAppLockDefaults :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureAppLock)), _flagClassifiedDomains :: !(TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureClassifiedDomains), - _flagFileSharing :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureFileSharing)), + _flagFileSharing :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureFileSharing)), _flagConferenceCalling :: !(Defaults (TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureConferenceCalling)), _flagSelfDeletingMessages :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureSelfDeletingMessages)), _flagConversationGuestLinks :: !(Defaults (TeamFeatureStatus 'WithLockStatus 'TeamFeatureGuestLinks)) @@ -261,7 +261,7 @@ instance FromJSON FeatureFlags where <*> obj .: "teamSearchVisibility" <*> (fromMaybe (Defaults defaultAppLockStatus) <$> (obj .:? "appLock")) <*> (fromMaybe defaultClassifiedDomains <$> (obj .:? "classifiedDomains")) - <*> (fromMaybe (Defaults (TeamFeatureStatusNoConfig TeamFeatureEnabled)) <$> (obj .:? "fileSharing")) + <*> (fromMaybe (Defaults defaultTeamFeatureFileSharing) <$> (obj .:? "fileSharing")) <*> (fromMaybe (Defaults (TeamFeatureStatusNoConfig TeamFeatureEnabled)) <$> (obj .:? "conferenceCalling")) <*> (fromMaybe (Defaults defaultSelfDeletingMessagesStatus) <$> (obj .:? "selfDeletingMessages")) <*> (fromMaybe (Defaults defaultGuestLinksStatus) <$> (obj .:? "conversationGuestLinks")) diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 51825b23589..4cd0b9be10e 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -30,10 +30,8 @@ import GHC.TypeLits (KnownSymbol, Symbol, natVal, symbolVal) import GHC.TypeNats (Nat) import Imports hiding (head) import Network.HTTP.Types as HTTP -import Servant hiding (Handler, addHeader, contentType, respond) -import Servant.API (contentType) -import Servant.API.ContentTypes (AllMimeRender, AllMimeUnrender) -import Servant.API.Status (KnownStatus, statusVal) +import Servant +import Servant.API.Status import Servant.Client.Core import Servant.Swagger.Internal import Wire.API.Routes.MultiVerb @@ -118,14 +116,12 @@ instance KnownStatus status => HasStatus (ErrorDescription status label desc) wh -- * MultiVerb errors type RespondWithErrorDescription s label desc = - Respond s desc (ErrorDescription s label desc) + RespondAs JSON s desc (ErrorDescription s label desc) type instance ResponseType (ErrorDescription s label desc) = ErrorDescription s label desc instance - ( AllMimeRender cs (ErrorDescription s label desc), - AllMimeUnrender cs (ErrorDescription s label desc), - KnownStatus s, + ( KnownStatus s, KnownSymbol label, KnownSymbol desc ) => @@ -184,8 +180,7 @@ instance responseRender _ () = pure $ - addContentType - (contentType (Proxy @PlainText)) + addContentType @PlainText Response { responseStatusCode = statusVal (Proxy @s), responseHeaders = mempty, @@ -207,21 +202,6 @@ instance <> "(**Note**: This error has an empty body for legacy reasons)" ) -instance - ( ResponseType r ~ a, - KnownStatus s, - KnownSymbol desc - ) => - AsUnion - '[EmptyErrorForLegacyReasons s desc, r] - (Maybe a) - where - toUnion Nothing = Z (I ()) - toUnion (Just x) = S (Z (I x)) - fromUnion (Z (I ())) = Nothing - fromUnion (S (Z (I x))) = Just x - fromUnion (S (S x)) = case x of - -- * Errors mkErrorDescription :: forall code label desc. KnownSymbol desc => ErrorDescription code label desc @@ -235,6 +215,8 @@ type UnknownClient = ErrorDescription 403 "unknown-client" "Unknown Client" type ClientNotFound = ErrorDescription 404 "client-not-found" "Client not found" +type TeamNotFound = ErrorDescription 404 "no-team" "team not found" + type NotConnected = ErrorDescription 403 "not-connected" "Users are not connected" type ConnectionLimitReached = ErrorDescription 403 "connection-limit" "Too many sent/accepted connections." @@ -256,6 +238,7 @@ type OperationDenied = ErrorDescription 403 "operation-denied" "Insufficient per -- Be aware that this is redundant and should be replaced by a more type safe solution in the future. type family OperationDeniedError (a :: Perm) :: * where OperationDeniedError 'SetTeamData = ErrorDescription 403 "operation-denied" "Insufficient permissions (missing SetTeamData)" + OperationDeniedError 'DeleteTeam = ErrorDescription 403 "operation-denied" "Insufficient permissions (missing DeleteTeam)" operationDeniedSpecialized :: String -> OperationDenied operationDeniedSpecialized p = @@ -269,6 +252,8 @@ type NotATeamMember = ErrorDescription 403 "no-team-member" "Requesting user is type Unauthorised = ErrorDescription 403 "unauthorised" "Unauthorised operation" +type ReAuthFailed = ErrorDescription 403 "access-denied" "This operation requires reauthentication" + type ActionDenied = ErrorDescription 403 "action-denied" "Insufficient authorization" actionDenied :: Show a => a -> ActionDenied @@ -331,6 +316,8 @@ type InvalidOp desc = "invalid-op" desc +type DeleteQueueFull = ErrorDescription 503 "queue-full" "The delete queue is full. No further delete requests can be processed at the moment." + invalidOpErrorDesc :: KnownSymbol desc => proxy desc -> InvalidOp desc invalidOpErrorDesc = ErrorDescription . Text.pack . symbolVal diff --git a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs index 39c82fe3112..f9bfca464f3 100644 --- a/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs +++ b/libs/wire-api/src/Wire/API/Event/FeatureConfig.hs @@ -72,7 +72,7 @@ taggedEventDataSchema = TeamFeatureValidateSAMLEmails -> tag _EdFeatureWithoutConfigChanged (unnamed schema) TeamFeatureDigitalSignatures -> tag _EdFeatureWithoutConfigChanged (unnamed schema) TeamFeatureAppLock -> tag _EdFeatureApplockChanged (unnamed schema) - TeamFeatureFileSharing -> tag _EdFeatureWithoutConfigChanged (unnamed schema) + TeamFeatureFileSharing -> tag _EdFeatureWithoutConfigAndLockStatusChanged (unnamed schema) TeamFeatureClassifiedDomains -> tag _EdFeatureClassifiedDomainsChanged (unnamed schema) TeamFeatureConferenceCalling -> tag _EdFeatureWithoutConfigChanged (unnamed schema) TeamFeatureSelfDeletingMessages -> tag _EdFeatureSelfDeletingMessagesChanged (unnamed schema) diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index 5f0f7eaa328..590c583e32c 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -22,6 +22,7 @@ module Wire.API.Routes.MultiVerb ( -- * MultiVerb types MultiVerb, Respond, + RespondAs, RespondEmpty, RespondStreaming, WithHeaders, @@ -84,13 +85,21 @@ type Declare = S.Declare (S.Definitions S.Schema) -- | A type to describe a 'MultiVerb' response. -- --- Includes status code, description, and return type. +-- Includes status code, description, and return type. The content type of the +-- response is determined dynamically using the accept header and the list of +-- supported content types specified in the containing 'MultiVerb' type. data Respond (s :: Nat) (desc :: Symbol) (a :: *) +-- | A type to describe a 'MultiVerb' response with a fixed content type. +-- +-- Similar to 'Respond', but hardcodes the content type to be used for +-- generating the response. +data RespondAs ct (s :: Nat) (desc :: Symbol) (a :: *) + -- | A type to describe a 'MultiVerb' response with an empty body. -- -- Includes status code and description. -data RespondEmpty (s :: Nat) (desc :: Symbol) +type RespondEmpty s desc = RespondAs '() s desc () -- | A type to describe a streaming 'MultiVerb' response. -- @@ -160,7 +169,7 @@ instance (AllMimeRender cs a, AllMimeUnrender cs a, KnownStatus s) => IsResponse where mkRenderOutput :: M.MediaType -> LByteString -> (M.MediaType, Response) mkRenderOutput c body = - (c,) . addContentType c $ + (c,) . addContentType' c $ Response { responseStatusCode = statusVal (Proxy @s), responseBody = body, @@ -175,25 +184,52 @@ instance (AllMimeRender cs a, AllMimeUnrender cs a, KnownStatus s) => IsResponse Nothing -> empty Just f -> either UnrenderError UnrenderSuccess (f (responseBody output)) +simpleResponseSwagger :: forall a desc. (S.ToSchema a, KnownSymbol desc) => Declare S.Response +simpleResponseSwagger = do + ref <- S.declareSchemaRef (Proxy @a) + pure $ + mempty + & S.description .~ Text.pack (symbolVal (Proxy @desc)) + & S.schema ?~ ref + instance (KnownStatus s, KnownSymbol desc, S.ToSchema a) => IsSwaggerResponse (Respond s desc a) where - responseSwagger = do - ref <- S.declareSchemaRef (Proxy @a) - pure $ - mempty - & S.description .~ Text.pack (symbolVal (Proxy @desc)) - & S.schema ?~ ref + responseSwagger = simpleResponseSwagger @a @desc -type instance ResponseType (RespondEmpty s desc) = () +type instance ResponseType (RespondAs ct s desc a) = a -instance KnownStatus s => IsResponse cs (RespondEmpty s desc) where - type ResponseStatus (RespondEmpty s desc) = s - type ResponseBody (RespondEmpty s desc) = () +instance + ( KnownStatus s, + MimeRender ct a, + MimeUnrender ct a + ) => + IsResponse cs (RespondAs (ct :: *) s desc a) + where + type ResponseStatus (RespondAs ct s desc a) = s + type ResponseBody (RespondAs ct s desc a) = LByteString + + responseRender _ x = + pure . addContentType @ct $ + Response + { responseStatusCode = statusVal (Proxy @s), + responseBody = mimeRender (Proxy @ct) x, + responseHeaders = mempty, + responseHttpVersion = HTTP.http11 + } + + responseUnrender _ output = do + guard (responseStatusCode output == statusVal (Proxy @s)) + either UnrenderError UnrenderSuccess $ + mimeUnrender (Proxy @ct) (responseBody output) + +instance KnownStatus s => IsResponse cs (RespondAs '() s desc ()) where + type ResponseStatus (RespondAs '() s desc ()) = s + type ResponseBody (RespondAs '() s desc ()) = () responseRender _ _ = - Just $ + pure $ Response { responseStatusCode = statusVal (Proxy @s), responseBody = (), @@ -204,11 +240,11 @@ instance KnownStatus s => IsResponse cs (RespondEmpty s desc) where responseUnrender _ output = guard (responseStatusCode output == statusVal (Proxy @s)) -instance (KnownStatus s, KnownSymbol desc) => IsSwaggerResponse (RespondEmpty s desc) where - responseSwagger = - pure $ - mempty - & S.description .~ Text.pack (symbolVal (Proxy @desc)) +instance + (KnownStatus s, KnownSymbol desc, S.ToSchema a) => + IsSwaggerResponse (RespondAs ct s desc a) + where + responseSwagger = simpleResponseSwagger @a @desc type instance ResponseType (RespondStreaming s desc framing ct) = SourceIO ByteString @@ -219,7 +255,7 @@ instance type ResponseStatus (RespondStreaming s desc framing ct) = s type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString responseRender _ x = - pure . addContentType (contentType (Proxy @ct)) $ + pure . addContentType @ct $ Response { responseStatusCode = statusVal (Proxy @s), responseBody = x, @@ -426,7 +462,7 @@ combineSwaggerSchema s1 s2 -- instance. -- * Headers can be attached to individual responses, also without affecting -- the handler return type. -data MultiVerb (method :: StdMethod) (cs :: [*]) (as :: [*]) (r :: *) +data MultiVerb (method :: StdMethod) cs (as :: [*]) (r :: *) -- | This class is used to convert a handler return type to a union type -- including all possible responses of a 'MultiVerb' endpoint. @@ -529,6 +565,10 @@ instance AsConstructor '[a] (Respond code desc a) where toConstructor x = I x :* Nil fromConstructor = unI . hd +instance AsConstructor '[a] (RespondAs (ct :: *) code desc a) where + toConstructor x = I x :* Nil + fromConstructor = unI . hd + instance AsConstructor '[] (RespondEmpty code desc) where toConstructor _ = Nil fromConstructor _ = () @@ -567,31 +607,14 @@ instance toUnion (GenericAsUnion x) = fromSOP @xss @rs (GSOP.from x) fromUnion = GenericAsUnion . GSOP.to . toSOP @xss @rs --- | A handler for a pair of empty responses can be implemented simply by --- returning a boolean value. The convention is that the "failure" case, normally --- represented by 'False', corresponds to the /first/ response. -instance - AsUnion - '[ RespondEmpty s1 desc1, - RespondEmpty s2 desc2 - ] - Bool - where - toUnion False = Z (I ()) - toUnion True = S (Z (I ())) - - fromUnion (Z (I ())) = False - fromUnion (S (Z (I ()))) = True - fromUnion (S (S x)) = case x of - -- | A handler for a pair of responses where the first is empty can be -- implemented simply by returning a 'Maybe' value. The convention is that the -- "failure" case, normally represented by 'Nothing', corresponds to the /first/ -- response. instance - AsUnion - '[RespondEmpty s1 desc1, Respond s2 desc2 a] - (Maybe a) + {-# OVERLAPPABLE #-} + (ResponseType r1 ~ (), ResponseType r2 ~ a) => + AsUnion '[r1, r2] (Maybe a) where toUnion Nothing = Z (I ()) toUnion (Just x) = S (Z (I x)) @@ -600,9 +623,28 @@ instance fromUnion (S (Z (I x))) = Just x fromUnion (S (S x)) = case x of +instance + (SwaggerMethod method, IsSwaggerResponseList as) => + S.HasSwagger (MultiVerb method '() as r) + where + toSwagger _ = + mempty + & S.definitions <>~ defs + & S.paths + . at "/" + ?~ ( mempty + & method + ?~ ( mempty + & S.responses . S.responses .~ fmap S.Inline responses + ) + ) + where + method = S.swaggerMethod (Proxy @method) + (defs, responses) = S.runDeclare (responseListSwagger @as) mempty + instance (SwaggerMethod method, IsSwaggerResponseList as, AllMime cs) => - S.HasSwagger (MultiVerb method cs as r) + S.HasSwagger (MultiVerb method (cs :: [*]) as r) where toSwagger _ = mempty @@ -651,8 +693,11 @@ instance IsWaiBody (SourceIO ByteString) where data SomeResponse = forall a. IsWaiBody a => SomeResponse (ResponseF a) -addContentType :: M.MediaType -> ResponseF a -> ResponseF a -addContentType c r = r {responseHeaders = (hContentType, M.renderHeader c) <| responseHeaders r} +addContentType :: forall ct a. Accept ct => ResponseF a -> ResponseF a +addContentType = addContentType' (contentType (Proxy @ct)) + +addContentType' :: M.MediaType -> ResponseF a -> ResponseF a +addContentType' c r = r {responseHeaders = (hContentType, M.renderHeader c) <| responseHeaders r} setEmptyBody :: SomeResponse -> SomeResponse setEmptyBody (SomeResponse r) = SomeResponse (go r) @@ -672,8 +717,21 @@ fromSomeResponse (SomeResponse Response {..}) = do .. } +class HasAcceptCheck cs where + acceptCheck' :: Proxy cs -> AcceptHeader -> DelayedIO () + +instance AllMime cs => HasAcceptCheck cs where + acceptCheck' = acceptCheck + +instance HasAcceptCheck '() where + acceptCheck' _ _ = pure () + instance - (AllMime cs, IsResponseList cs as, AsUnion as r, ReflectMethod method) => + ( HasAcceptCheck cs, + IsResponseList cs as, + AsUnion as r, + ReflectMethod method + ) => HasServer (MultiVerb method cs as r) ctx where type ServerT (MultiVerb method cs as r) m = m r @@ -690,7 +748,7 @@ instance let acc = getAcceptHeader req action' = action `addMethodCheck` methodCheck method req - `addAcceptCheck` acceptCheck (Proxy @cs) acc + `addAcceptCheck` acceptCheck' (Proxy @cs) acc runAction action' env req k $ \output -> do let mresp = responseListRender @cs @as acc (toUnion @as output) someResponseToWai <$> case mresp of diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs b/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs index 37be37c15ed..4cadbd0661b 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs @@ -163,7 +163,7 @@ type QualifiedAPI = :> QueryParam "asset_token" AssetToken :> MultiVerb 'GET - '[JSON] + '() '[ AssetNotFound, AssetRedirect, AssetStreaming @@ -209,7 +209,7 @@ type LegacyAPI = ) type InternalAPI = - "i" :> "status" :> MultiVerb 'GET '[PlainText] '[RespondEmpty 200 "OK"] () + "i" :> "status" :> MultiVerb 'GET '() '[RespondEmpty 200 "OK"] () swaggerDoc :: Swagger.Swagger swaggerDoc = toSwagger (Proxy @ServantAPI) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs index ad0e261002e..853f58e588b 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Galley.hs @@ -657,6 +657,30 @@ type TeamAPI = :> "teams" :> Get '[JSON] TeamList ) + :<|> Named + "get-team" + ( Summary "Get a team by ID" + :> ZUser + :> CanThrow TeamNotFound + :> "teams" + :> Capture "tid" TeamId + :> Get '[JSON] Team + ) + :<|> Named + "delete-team" + ( Summary "Delete a team" + :> ZUser + :> ZConn + :> CanThrow TeamNotFound + :> CanThrow (OperationDeniedError 'DeleteTeam) + :> CanThrow NotATeamMember + :> CanThrow DeleteQueueFull + :> CanThrow ReAuthFailed + :> "teams" + :> Capture "tid" TeamId + :> ReqBody '[Servant.JSON] TeamDeleteData + :> MultiVerb 'DELETE '[JSON] '[RespondEmpty 202 "Team is scheduled for removal"] () + ) type MessagingAPI = Named @@ -725,7 +749,7 @@ type FeatureAPI = :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureValidateSAMLEmails :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureDigitalSignatures :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureAppLock - :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureFileSharing + :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureFileSharing :<|> FeatureConfigGet 'WithoutLockStatus 'TeamFeatureClassifiedDomains :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureConferenceCalling :<|> FeatureConfigGet 'WithLockStatus 'TeamFeatureSelfDeletingMessages diff --git a/libs/wire-api/src/Wire/API/Team/Feature.hs b/libs/wire-api/src/Wire/API/Team/Feature.hs index fb64150eeec..e3127733d82 100644 --- a/libs/wire-api/src/Wire/API/Team/Feature.hs +++ b/libs/wire-api/src/Wire/API/Team/Feature.hs @@ -41,6 +41,7 @@ module Wire.API.Team.Feature defaultClassifiedDomains, defaultSelfDeletingMessagesStatus, defaultGuestLinksStatus, + defaultTeamFeatureFileSharing, -- * Swagger typeTeamFeatureName, @@ -310,7 +311,8 @@ type family TeamFeatureStatus (ps :: IncludeLockStatus) (a :: TeamFeatureName) : TeamFeatureStatus _ 'TeamFeatureValidateSAMLEmails = TeamFeatureStatusNoConfig TeamFeatureStatus _ 'TeamFeatureDigitalSignatures = TeamFeatureStatusNoConfig TeamFeatureStatus _ 'TeamFeatureAppLock = TeamFeatureStatusWithConfig TeamFeatureAppLockConfig - TeamFeatureStatus _ 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig + TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureFileSharing = TeamFeatureStatusNoConfig + TeamFeatureStatus 'WithLockStatus 'TeamFeatureFileSharing = TeamFeatureStatusNoConfigAndLockStatus TeamFeatureStatus _ 'TeamFeatureClassifiedDomains = TeamFeatureStatusWithConfig TeamFeatureClassifiedDomainsConfig TeamFeatureStatus _ 'TeamFeatureConferenceCalling = TeamFeatureStatusNoConfig TeamFeatureStatus 'WithoutLockStatus 'TeamFeatureSelfDeletingMessages = TeamFeatureStatusWithConfig TeamFeatureSelfDeletingMessagesConfig @@ -435,6 +437,13 @@ instance ToSchema cfg => ToSchema (TeamFeatureStatusWithConfigAndLockStatus cfg) <*> tfwcapsConfig .= field "config" schema <*> tfwcapsLockStatus .= field "lockStatus" schema +---------------------------------------------------------------------- +-- TeamFeatureFileSharing + +defaultTeamFeatureFileSharing :: TeamFeatureStatusNoConfigAndLockStatus +defaultTeamFeatureFileSharing = + TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Unlocked + ---------------------------------------------------------------------- -- TeamFeatureClassifiedDomainsConfig diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/FeatureConfigEvent.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/FeatureConfigEvent.hs index 8f4ef349dd6..770c425e624 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/FeatureConfigEvent.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/FeatureConfigEvent.hs @@ -22,7 +22,7 @@ import Wire.API.Event.FeatureConfig import Wire.API.Team.Feature testObject_FeatureConfigEvent_1 :: Event -testObject_FeatureConfigEvent_1 = Event Update TeamFeatureFileSharing (EdFeatureWithoutConfigChanged (TeamFeatureStatusNoConfig TeamFeatureEnabled)) +testObject_FeatureConfigEvent_1 = Event Update TeamFeatureFileSharing (EdFeatureWithoutConfigAndLockStatusChanged (TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Unlocked)) testObject_FeatureConfigEvent_2 :: Event testObject_FeatureConfigEvent_2 = Event Update TeamFeatureSSO (EdFeatureWithoutConfigChanged (TeamFeatureStatusNoConfig TeamFeatureDisabled)) diff --git a/libs/wire-api/test/golden/testObject_FeatureConfigEvent_1.json b/libs/wire-api/test/golden/testObject_FeatureConfigEvent_1.json index ab643fe798e..88884687d2b 100644 --- a/libs/wire-api/test/golden/testObject_FeatureConfigEvent_1.json +++ b/libs/wire-api/test/golden/testObject_FeatureConfigEvent_1.json @@ -1,5 +1,6 @@ { "data": { + "lockStatus": "unlocked", "status": "enabled" }, "name": "fileSharing", diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 005df78d29a..48fcbc3f34e 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -505,6 +505,7 @@ executable brig-integration , http-client , http-client-tls >=0.2 , http-media + , http-reverse-proxy , http-types , imports , lens >=3.9 diff --git a/services/brig/package.yaml b/services/brig/package.yaml index 56bce3568b8..ed882bff0f8 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -228,6 +228,7 @@ executables: - http-client - http-client-tls >=0.2 - http-media + - http-reverse-proxy - http-types - imports - lens >=3.9 diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 47637c7d6f0..dc4c9ecc3e2 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -274,7 +274,8 @@ mkIndexEnv o lgr mgr mtr = lgr' = Log.clone (Just "index.brig") lgr mainIndex = ES.IndexName $ Opt.index (Opt.elasticsearch o) additionalIndex = ES.IndexName <$> Opt.additionalWriteIndex (Opt.elasticsearch o) - in IndexEnv mtr lgr' bhe Nothing mainIndex additionalIndex + additionalBhe = flip ES.mkBHEnv mgr . ES.Server <$> Opt.additionalWriteIndexUrl (Opt.elasticsearch o) + in IndexEnv mtr lgr' bhe Nothing mainIndex additionalIndex additionalBhe geoSetup :: Logger -> FS.WatchManager -> Maybe FilePath -> IO (Maybe (IORef GeoIp.GeoDB)) geoSetup _ _ Nothing = return Nothing diff --git a/services/brig/src/Brig/Index/Eval.hs b/services/brig/src/Brig/Index/Eval.hs index 869ac464756..11f9bc61ac1 100644 --- a/services/brig/src/Brig/Index/Eval.hs +++ b/services/brig/src/Brig/Index/Eval.hs @@ -95,6 +95,7 @@ runCommand l = \case <*> pure Nothing <*> pure indexName <*> pure Nothing + <*> pure Nothing initES esURI = ES.mkBHEnv (toESServer esURI) <$> newManager defaultManagerSettings diff --git a/services/brig/src/Brig/Index/Migrations/Types.hs b/services/brig/src/Brig/Index/Migrations/Types.hs index 6672e0785b9..c3757ebf103 100644 --- a/services/brig/src/Brig/Index/Migrations/Types.hs +++ b/services/brig/src/Brig/Index/Migrations/Types.hs @@ -65,7 +65,7 @@ instance MonadIO m => MonadLogger (MigrationActionT m) where instance MonadIO m => Search.MonadIndexIO (MigrationActionT m) where liftIndexIO m = do Env {..} <- ask - let indexEnv = Search.IndexEnv metrics logger bhEnv Nothing searchIndex Nothing + let indexEnv = Search.IndexEnv metrics logger bhEnv Nothing searchIndex Nothing Nothing Search.runIndexIO indexEnv m instance MonadIO m => ES.MonadBH (MigrationActionT m) where diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index 29b90c6dfe7..17244eeec3b 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -74,7 +74,12 @@ data ElasticSearchOpts = ElasticSearchOpts -- tools/db/find-undead which can be used to find the undead users right -- after the migration, if they exist, we can run the reindexing to get data -- in elasticsearch in a consistent state. - additionalWriteIndex :: !(Maybe Text) + additionalWriteIndex :: !(Maybe Text), + -- | An additional ES URL to write user data, useful while migrating to a + -- new instace of ES. It is necessary to provide 'additionalWriteIndex' for + -- this to be used. If this is 'Nothing' and 'additionalWriteIndex' is + -- configured, the 'url' field will be used. + additionalWriteIndexUrl :: !(Maybe Text) } deriving (Show, Generic) @@ -717,7 +722,8 @@ Lens.makeLensesFor Lens.makeLensesFor [ ("url", "urlL"), ("index", "indexL"), - ("additionalWriteIndex", "additionalWriteIndexL") + ("additionalWriteIndex", "additionalWriteIndexL"), + ("additionalWriteIndexUrl", "additionalWriteIndexUrlL") ] ''ElasticSearchOpts diff --git a/services/brig/src/Brig/User/Search/Index.hs b/services/brig/src/Brig/User/Search/Index.hs index 85cc8fcf364..ac53649f53d 100644 --- a/services/brig/src/Brig/User/Search/Index.hs +++ b/services/brig/src/Brig/User/Search/Index.hs @@ -101,7 +101,8 @@ data IndexEnv = IndexEnv idxElastic :: ES.BHEnv, idxRequest :: Maybe RequestId, idxName :: ES.IndexName, - idxAdditional :: Maybe ES.IndexName + idxAdditionalName :: Maybe ES.IndexName, + idxAdditionalElastic :: Maybe ES.BHEnv } newtype IndexIO a = IndexIO (ReaderT IndexEnv IO a) @@ -137,6 +138,18 @@ instance MonadLogger (ExceptT e IndexIO) where instance ES.MonadBH IndexIO where getBHEnv = asks idxElastic +withDefaultESUrl :: (MonadIndexIO m) => ES.BH m a -> m a +withDefaultESUrl action = do + bhEnv <- liftIndexIO $ asks idxElastic + ES.runBH bhEnv action + +-- | When the additional URL is not provided, uses the default url. +withAdditionalESUrl :: (MonadIndexIO m) => ES.BH m a -> m a +withAdditionalESUrl action = do + mAdditionalBHEnv <- liftIndexIO $ asks idxAdditionalElastic + defaultBHEnv <- liftIndexIO $ asks idxElastic + ES.runBH (fromMaybe defaultBHEnv mAdditionalBHEnv) action + -------------------------------------------------------------------------------- -- Updates @@ -153,12 +166,12 @@ updateIndex (IndexUpdateUser updateType iu) = liftIndexIO $ do field "user" (Bytes.toByteString (view iuUserId iu)) . msg (val "Indexing user") idx <- asks idxName - indexDoc idx - traverse_ indexDoc =<< asks idxAdditional + withDefaultESUrl $ indexDoc idx + withAdditionalESUrl $ traverse_ indexDoc =<< asks idxAdditionalName where - indexDoc :: MonadIndexIO m => ES.IndexName -> m () - indexDoc idx = liftIndexIO $ do - m <- asks idxMetrics + indexDoc :: (MonadIndexIO m, MonadThrow m) => ES.IndexName -> ES.BH m () + indexDoc idx = do + m <- lift . liftIndexIO $ asks idxMetrics r <- ES.indexDocument idx mappingName versioning (indexToDoc iu) docId unless (ES.isSuccess r || ES.isVersionConflict r) $ do counterIncr (path "user.index.update.err") m diff --git a/services/brig/test/integration/API/Search.hs b/services/brig/test/integration/API/Search.hs index 7e4796b0c1e..b38852c422d 100644 --- a/services/brig/test/integration/API/Search.hs +++ b/services/brig/test/integration/API/Search.hs @@ -31,6 +31,7 @@ import API.Team.Util import API.User.Util import Bilge import qualified Brig.Options as Opt +import qualified Brig.Options as Opts import Brig.Types import Control.Lens ((.~), (?~), (^.)) import Control.Monad.Catch (MonadCatch, MonadThrow) @@ -44,17 +45,25 @@ import qualified Data.Map.Strict as Map import Data.Qualified (Qualified (qDomain, qUnqualified)) import Data.String.Conversions (cs) import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import qualified Database.Bloodhound as ES import Federation.Util import qualified Galley.Types.Teams.SearchVisibility as Team import Imports import qualified Network.HTTP.Client as HTTP +import Network.HTTP.ReverseProxy (waiProxyTo) +import qualified Network.HTTP.ReverseProxy as Wai +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Test as WaiTest +import Safe (headMay) import Test.QuickCheck (Arbitrary (arbitrary), generate) import Test.Tasty import Test.Tasty.HUnit import Text.RawString.QQ (r) -import UnliftIO (Concurrently (..), runConcurrently) +import qualified URI.ByteString as URI +import UnliftIO (Concurrently (..), async, bracket, cancel, runConcurrently) import Util import Wire.API.Team.Feature (TeamFeatureStatusValue (..)) @@ -74,7 +83,7 @@ tests opts mgr galley brig = do testWithBothIndices opts mgr "order-handle (prefix match)" $ testOrderHandle brig, testWithBothIndices opts mgr "by-first/middle/last name" $ testSearchByLastOrMiddleName brig, testWithBothIndices opts mgr "Non ascii names" $ testSearchNonAsciiNames brig, - test mgr "migration to new index" $ testMigrationToNewIndex opts brig, + test mgr "migration to new index" $ testMigrationToNewIndex mgr opts brig, testGroup "team-search-visibility disabled OR SearchVisibilityStandard" $ [ testWithBothIndices opts mgr "team member cannot be found by non-team user with display name" $ testSearchTeamMemberAsNonMemberDisplayName brig, testWithBothIndices opts mgr "team member can be found by non-team user with exact handle" $ testSearchTeamMemeberAsNonMemberExactHandle brig, @@ -471,76 +480,111 @@ testSearchOtherDomain opts brig = do -- 2. When brig is writing to both indices -- 3. While/After reindexing is done form old index to new index -- 4. After brig is writing to only the new index -testMigrationToNewIndex :: TestConstraints m => Opt.Opts -> Brig -> m () -testMigrationToNewIndex opts brig = do - (optsOldIndex, ES.IndexName -> oldIndexName) <- optsForOldIndex opts - -- Phase 1: Using old index only - (phase1NonTeamUser, teamOwner, phase1TeamUser1, phase1TeamUser2, tid) <- withSettingsOverrides optsOldIndex $ do - nonTeamUser <- randomUser brig - (tid, teamOwner, [teamUser1, teamUser2]) <- createPopulatedBindingTeam brig 2 - pure (nonTeamUser, teamOwner, teamUser1, teamUser2, tid) - - -- Phase 2: Using old index for search, writing to both indices, migrations have not run - let phase2OptsWhile = optsOldIndex & Opt.elasticsearchL . Opt.additionalWriteIndexL ?~ (opts ^. Opt.elasticsearchL . Opt.indexL) - (phase2NonTeamUser, phase2TeamUser) <- withSettingsOverrides phase2OptsWhile $ do - phase2NonTeamUser <- randomUser brig - phase2TeamUser <- inviteAndRegisterUser teamOwner tid brig - refreshIndex brig +-- +-- Note: The new index can be on another cluster of ES, but we have only one ES +-- cluster. This test spins up a proxy server to pass requests to our only ES +-- server. The proxy server ensures that only requests to the 'old' index go +-- through. +testMigrationToNewIndex :: (TestConstraints m, MonadUnliftIO m) => Manager -> Opt.Opts -> Brig -> m () +testMigrationToNewIndex mgr opts brig = do + -- (optsOldIndex, ES.IndexName -> oldIndexName) <- optsForOldIndex opts + withOldESProxy opts mgr $ \oldESUrl oldESIndex -> do + let optsOldIndex = + opts + & Opt.elasticsearchL . Opt.indexL .~ oldESIndex + & Opt.elasticsearchL . Opt.urlL .~ oldESUrl + -- Phase 1: Using old index only + (phase1NonTeamUser, teamOwner, phase1TeamUser1, phase1TeamUser2, tid) <- withSettingsOverrides optsOldIndex $ do + nonTeamUser <- randomUser brig + (tid, teamOwner, [teamUser1, teamUser2]) <- createPopulatedBindingTeam brig 2 + pure (nonTeamUser, teamOwner, teamUser1, teamUser2, tid) + + -- Phase 2: Using old index for search, writing to both indices, migrations have not run + let phase2OptsWhile = + optsOldIndex + & Opt.elasticsearchL . Opt.additionalWriteIndexL ?~ (opts ^. Opt.elasticsearchL . Opt.indexL) + & Opt.elasticsearchL . Opt.additionalWriteIndexUrlL ?~ (opts ^. Opt.elasticsearchL . Opt.urlL) + (phase2NonTeamUser, phase2TeamUser) <- withSettingsOverrides phase2OptsWhile $ do + phase2NonTeamUser <- randomUser brig + phase2TeamUser <- inviteAndRegisterUser teamOwner tid brig + refreshIndex brig - -- searching phase1 users should work - assertCanFindByName brig phase1TeamUser1 phase1TeamUser2 - assertCanFindByName brig phase1TeamUser1 phase1NonTeamUser + -- searching phase1 users should work + assertCanFindByName brig phase1TeamUser1 phase1TeamUser2 + assertCanFindByName brig phase1TeamUser1 phase1NonTeamUser - -- searching phase2 users should work + -- searching phase2 users should work + assertCanFindByName brig phase1TeamUser1 phase2NonTeamUser + assertCanFindByName brig phase1TeamUser1 phase2TeamUser + pure (phase2NonTeamUser, phase2TeamUser) + + refreshIndex brig + -- Before migration the phase1 users shouldn't be found in the new index + assertCan'tFindByName brig phase1TeamUser1 phase1TeamUser2 + assertCan'tFindByName brig phase1TeamUser1 phase1NonTeamUser + + -- Before migration the phase2 users should be found in the new index assertCanFindByName brig phase1TeamUser1 phase2NonTeamUser assertCanFindByName brig phase1TeamUser1 phase2TeamUser - pure (phase2NonTeamUser, phase2TeamUser) - refreshIndex brig - -- Before migration the phase1 users shouldn't be found in the new index - assertCan'tFindByName brig phase1TeamUser1 phase1TeamUser2 - assertCan'tFindByName brig phase1TeamUser1 phase1NonTeamUser + -- Run Migrations + let newIndexName = ES.IndexName $ opts ^. Opt.elasticsearchL . Opt.indexL + taskNodeId <- assertRight =<< (runBH opts $ ES.reindexAsync $ ES.mkReindexRequest (ES.IndexName oldESIndex) newIndexName) + runBH opts $ waitForTaskToComplete @ES.ReindexResponse taskNodeId + + -- Phase 3: Using old index for search, writing to both indices, migrations have run + refreshIndex brig + (phase3NonTeamUser, phase3TeamUser) <- withSettingsOverrides phase2OptsWhile $ do + phase3NonTeamUser <- randomUser brig + phase3TeamUser <- inviteAndRegisterUser teamOwner tid brig + refreshIndex brig - -- Before migration the phase2 users should be found in the new index - assertCanFindByName brig phase1TeamUser1 phase2NonTeamUser - assertCanFindByName brig phase1TeamUser1 phase2TeamUser + -- searching phase1/2 users should work + assertCanFindByName brig phase1TeamUser1 phase1TeamUser2 + assertCanFindByName brig phase1TeamUser1 phase1NonTeamUser + assertCanFindByName brig phase1TeamUser1 phase2TeamUser + assertCanFindByName brig phase1TeamUser1 phase2NonTeamUser - -- Run Migrations - let newIndexName = ES.IndexName $ opts ^. Opt.elasticsearchL . Opt.indexL - taskNodeId <- assertRight =<< (runBH opts $ ES.reindexAsync $ ES.mkReindexRequest oldIndexName newIndexName) - runBH opts $ waitForTaskToComplete @ES.ReindexResponse taskNodeId + -- searching new phase3 should also work + assertCanFindByName brig phase1TeamUser1 phase3NonTeamUser + assertCanFindByName brig phase1TeamUser1 phase3TeamUser + pure (phase3NonTeamUser, phase3TeamUser) - -- Phase 3: Using old index for search, writing to both indices, migrations have run - refreshIndex brig - (phase3NonTeamUser, phase3TeamUser) <- withSettingsOverrides phase2OptsWhile $ do - phase3NonTeamUser <- randomUser brig - phase3TeamUser <- inviteAndRegisterUser teamOwner tid brig + -- Phase 4: Using only new index refreshIndex brig - - -- searching phase1/2 users should work + -- Searching should work for phase1 users assertCanFindByName brig phase1TeamUser1 phase1TeamUser2 assertCanFindByName brig phase1TeamUser1 phase1NonTeamUser + + -- Searching should work for phase2 users assertCanFindByName brig phase1TeamUser1 phase2TeamUser assertCanFindByName brig phase1TeamUser1 phase2NonTeamUser - -- searching new phase3 should also work + -- Searching should work for phase3 users assertCanFindByName brig phase1TeamUser1 phase3NonTeamUser assertCanFindByName brig phase1TeamUser1 phase3TeamUser - pure (phase3NonTeamUser, phase3TeamUser) - -- Phase 4: Using only new index - refreshIndex brig - -- Searching should work for phase1 users - assertCanFindByName brig phase1TeamUser1 phase1TeamUser2 - assertCanFindByName brig phase1TeamUser1 phase1NonTeamUser - - -- Searching should work for phase2 users - assertCanFindByName brig phase1TeamUser1 phase2TeamUser - assertCanFindByName brig phase1TeamUser1 phase2NonTeamUser - - -- Searching should work for phase3 users - assertCanFindByName brig phase1TeamUser1 phase3NonTeamUser - assertCanFindByName brig phase1TeamUser1 phase3TeamUser +withOldESProxy :: (TestConstraints m, MonadUnliftIO m) => Opt.Opts -> Manager -> (Text -> Text -> m a) -> m a +withOldESProxy opts mgr f = do + indexName <- randomHandle + createIndexWithMapping opts indexName oldMapping + (proxyPort, sock) <- liftIO Warp.openFreePort + bracket + (async $ liftIO $ Warp.runSettingsSocket Warp.defaultSettings sock $ indexProxyServer indexName opts mgr) + cancel + (\_ -> f ("http://localhost:" <> Text.pack (show proxyPort)) indexName) -- f undefined indexName + +indexProxyServer :: Text -> Opt.Opts -> Manager -> Wai.Application +indexProxyServer idx opts mgr = + let proxyURI = either (error . show) id $ URI.parseURI URI.strictURIParserOptions (Text.encodeUtf8 (Opts.url (Opts.elasticsearch opts))) + proxyToHost = URI.hostBS . URI.authorityHost . fromMaybe (error "No Host") . URI.uriAuthority $ proxyURI + proxyToPort = URI.portNumber . fromMaybe (URI.Port 9200) . URI.authorityPort . fromMaybe (error "No Host") . URI.uriAuthority $ proxyURI + proxyApp req = + pure $ + if headMay (Wai.pathInfo req) == Just idx + then Wai.WPRProxyDest (Wai.ProxyDest proxyToHost proxyToPort) + else Wai.WPRResponse (Wai.responseLBS HTTP.status400 [] $ "Refusing to proxy to path=" <> cs (Wai.rawPathInfo req)) + in waiProxyTo proxyApp Wai.defaultOnExc mgr waitForTaskToComplete :: forall a m. (ES.MonadBH m, MonadIO m, MonadThrow m, FromJSON a) => ES.TaskNodeId -> m () waitForTaskToComplete taskNodeId = do diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index d655f8c82c4..34700b3a301 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -28,7 +28,7 @@ import Brig.Types.Team.Invitation import Brig.Types.User import Control.Lens ((^?)) import Control.Monad.Catch (MonadCatch, MonadThrow) -import Data.Aeson +import Data.Aeson hiding (json) import Data.Aeson.Lens import Data.ByteString.Conversion import Data.Id hiding (client) @@ -268,7 +268,7 @@ deleteTeam g tid u = do . paths ["teams", toByteString' tid] . zUser u . zConn "conn" - . lbytes (encode $ Team.newTeamDeleteData $ Just Util.defPassword) + . json (Team.newTeamDeleteData $ Just Util.defPassword) ) !!! const 202 === statusCode diff --git a/services/cargohold/test/integration/API.hs b/services/cargohold/test/integration/API.hs index 85fbb126db5..f5f840ddb13 100644 --- a/services/cargohold/test/integration/API.hs +++ b/services/cargohold/test/integration/API.hs @@ -60,6 +60,7 @@ tests s = [ testGroup "simple" [ test s "roundtrip" testSimpleRoundtrip, + test s "download with accept header" testDownloadWithAcceptHeader, test s "tokens" testSimpleTokens, test s "s3-upstream-closed" testSimpleS3ClosedConnectionReuse, test s "client-compatibility" testUploadCompatibility @@ -126,6 +127,16 @@ testSimpleRoundtrip = do let utc' = parseTimeOrError False defaultTimeLocale rfc822DateFormat date' :: UTCTime liftIO $ assertBool "bad date" (utc' >= utc) +testDownloadWithAcceptHeader :: TestM () +testDownloadWithAcceptHeader = do + assetId <- liftIO $ Id <$> nextRandom + uid <- liftIO $ Id <$> nextRandom + domain <- viewFederationDomain + let key = AssetKeyV3 assetId AssetPersistent + qkey = Qualified key domain + downloadAssetWith (header "Accept" "image/jpeg") uid qkey () + !!! const 404 === statusCode + testSimpleTokens :: TestM () testSimpleTokens = do uid <- liftIO $ Id <$> nextRandom diff --git a/services/cargohold/test/integration/API/Util.hs b/services/cargohold/test/integration/API/Util.hs index 00eb0b7892c..9d00761fd5e 100644 --- a/services/cargohold/test/integration/API/Util.hs +++ b/services/cargohold/test/integration/API/Util.hs @@ -130,20 +130,30 @@ instance IsAssetToken (Maybe AssetToken) where instance IsAssetToken (Request -> Request) where tokenParam = id -downloadAsset :: +downloadAssetWith :: (IsAssetLocation loc, IsAssetToken tok) => + (Request -> Request) -> UserId -> loc -> tok -> TestM (Response (Maybe LByteString)) -downloadAsset uid loc tok = do +downloadAssetWith r uid loc tok = do c <- viewCargohold get $ - c . zUser uid + c . r + . zUser uid . locationPath loc . tokenParam tok . noRedirect +downloadAsset :: + (IsAssetLocation loc, IsAssetToken tok) => + UserId -> + loc -> + tok -> + TestM (Response (Maybe LByteString)) +downloadAsset = downloadAssetWith id + postToken :: UserId -> AssetKey -> TestM (Response (Maybe LByteString)) postToken uid key = do c <- viewCargohold diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index ee43a8f5a19..35ef91c0317 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -597,6 +597,7 @@ executable galley-schema V56_GuestLinksTeamFeatureStatus V57_GuestLinksLockStatus V58_ConversationAccessRoleV2 + V59_FileSharingLockStatus Paths_galley hs-source-dirs: schema/src diff --git a/services/galley/galley.integration.yaml b/services/galley/galley.integration.yaml index 16ab778ef1f..c5068b63784 100644 --- a/services/galley/galley.integration.yaml +++ b/services/galley/galley.integration.yaml @@ -60,6 +60,7 @@ settings: fileSharing: defaults: status: enabled + lockStatus: unlocked conferenceCalling: defaults: status: enabled diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index 4527efba15f..450b1342320 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -61,6 +61,7 @@ import qualified V55_SelfDeletingMessagesLockStatus import qualified V56_GuestLinksTeamFeatureStatus import qualified V57_GuestLinksLockStatus import qualified V58_ConversationAccessRoleV2 +import qualified V59_FileSharingLockStatus main :: IO () main = do @@ -107,7 +108,8 @@ main = do V55_SelfDeletingMessagesLockStatus.migration, V56_GuestLinksTeamFeatureStatus.migration, V57_GuestLinksLockStatus.migration, - V58_ConversationAccessRoleV2.migration + V58_ConversationAccessRoleV2.migration, + V59_FileSharingLockStatus.migration -- When adding migrations here, don't forget to update -- 'schemaVersion' in Galley.Cassandra -- (see also docs/developer/cassandra-interaction.md) diff --git a/services/galley/schema/src/V59_FileSharingLockStatus.hs b/services/galley/schema/src/V59_FileSharingLockStatus.hs new file mode 100644 index 00000000000..8195f186b39 --- /dev/null +++ b/services/galley/schema/src/V59_FileSharingLockStatus.hs @@ -0,0 +1,33 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2020 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module V59_FileSharingLockStatus + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 59 "Add lock status for file sharing team feature" $ do + schema' + [r| ALTER TABLE team_features ADD ( + file_sharing_lock_status int + ) + |] diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index 657d8c153cc..59f8d668d79 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -176,10 +176,13 @@ data InternalApi routes = InternalApi :- IFeatureStatusPut 'Public.TeamFeatureAppLock, iTeamFeatureStatusFileSharingGet :: routes - :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing, + :- IFeatureStatusGet 'Public.WithLockStatus 'Public.TeamFeatureFileSharing, iTeamFeatureStatusFileSharingPut :: routes :- IFeatureStatusPut 'Public.TeamFeatureFileSharing, + iTeamFeatureLockStatusFileSharingPut :: + routes + :- IFeatureStatusLockStatusPut 'Public.TeamFeatureFileSharing, iTeamFeatureStatusClassifiedDomainsGet :: routes :- IFeatureStatusGet 'Public.WithoutLockStatus 'Public.TeamFeatureClassifiedDomains, @@ -319,8 +322,9 @@ servantSitemap = iTeamFeatureStatusDigitalSignaturesDeprecatedPut = iPutTeamFeature @'Public.TeamFeatureDigitalSignatures Features.setDigitalSignaturesInternal, iTeamFeatureStatusAppLockGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock Features.getAppLockInternal, iTeamFeatureStatusAppLockPut = iPutTeamFeature @'Public.TeamFeatureAppLock Features.setAppLockInternal, - iTeamFeatureStatusFileSharingGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, + iTeamFeatureStatusFileSharingGet = iGetTeamFeature @'Public.WithLockStatus @'Public.TeamFeatureFileSharing Features.getFileSharingInternal, iTeamFeatureStatusFileSharingPut = iPutTeamFeature @'Public.TeamFeatureFileSharing Features.setFileSharingInternal, + iTeamFeatureLockStatusFileSharingPut = Features.setLockStatus @'Public.TeamFeatureFileSharing, iTeamFeatureStatusClassifiedDomainsGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains Features.getClassifiedDomainsInternal, iTeamFeatureStatusConferenceCallingPut = iPutTeamFeature @'Public.TeamFeatureConferenceCalling Features.setConferenceCallingInternal, iTeamFeatureStatusConferenceCallingGet = iGetTeamFeature @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling Features.getConferenceCallingInternal, diff --git a/services/galley/src/Galley/API/Public.hs b/services/galley/src/Galley/API/Public.hs index 6b6a4c84be9..3112574d1ec 100644 --- a/services/galley/src/Galley/API/Public.hs +++ b/services/galley/src/Galley/API/Public.hs @@ -58,7 +58,6 @@ import qualified Wire.API.Event.Team as Public () import qualified Wire.API.Message as Public import qualified Wire.API.Notification as Public import qualified Wire.API.Swagger as Public.Swagger (models) -import qualified Wire.API.Team as Public import qualified Wire.API.Team.LegalHold as Public import qualified Wire.API.Team.Member as Public import qualified Wire.API.Team.Permission as Public @@ -68,40 +67,6 @@ import Wire.Swagger (int32Between) sitemap :: Routes ApiBuilder (Sem GalleyEffects) () sitemap = do - -- Team API ----------------------------------------------------------- - - get "/teams/:tid" (continue Teams.getTeamH) $ - zauthUserId - .&. capture "tid" - .&. accept "application" "json" - document "GET" "getTeam" $ do - summary "Get a team by ID" - parameter Path "tid" bytes' $ - description "Team ID" - returns (ref Public.modelTeam) - response 200 "Team data" end - errorResponse Error.teamNotFound - - delete "/teams/:tid" (continue Teams.deleteTeamH) $ - zauthUserId - .&. zauthConnId - .&. capture "tid" - .&. optionalJsonRequest @Public.TeamDeleteData - .&. accept "application" "json" - document "DELETE" "deleteTeam" $ do - summary "Delete a team" - parameter Path "tid" bytes' $ - description "Team ID" - body (ref Public.modelTeamDelete) $ do - optional - description "JSON body, required only for binding teams." - response 202 "Team is scheduled for removal" end - errorResponse (Error.errorDescriptionTypeToWai @Error.NotATeamMember) - errorResponse (Error.errorDescriptionToWai (Error.operationDenied Public.DeleteTeam)) - errorResponse Error.deleteQueueFull - errorResponse Error.reAuthFailed - errorResponse Error.teamNotFound - -- Team Member API ----------------------------------------------------- get "/teams/:tid/members" (continue Teams.getTeamMembersH) $ diff --git a/services/galley/src/Galley/API/Public/Servant.hs b/services/galley/src/Galley/API/Public/Servant.hs index 90ce6ca3a39..8f55c10c9c6 100644 --- a/services/galley/src/Galley/API/Public/Servant.hs +++ b/services/galley/src/Galley/API/Public/Servant.hs @@ -80,6 +80,8 @@ servantSitemap = conversations :<|> teamConversations :<|> messaging :<|> team : Named @"create-non-binding-team" createNonBindingTeamH :<|> Named @"update-team" updateTeamH :<|> Named @"get-teams" getManyTeams + :<|> Named @"get-team" getTeamH + :<|> Named @"delete-team" deleteTeam features = Named @'("get", 'TeamFeatureSSO) @@ -148,7 +150,7 @@ servantSitemap = conversations :<|> teamConversations :<|> messaging :<|> team : . DoAuth ) :<|> Named @'("get", 'TeamFeatureFileSharing) - ( getFeatureStatus @'WithoutLockStatus @'TeamFeatureFileSharing + ( getFeatureStatus @'WithLockStatus @'TeamFeatureFileSharing getFileSharingInternal . DoAuth ) @@ -213,7 +215,7 @@ servantSitemap = conversations :<|> teamConversations :<|> messaging :<|> team : getAppLockInternal ) :<|> Named @'("get-config", 'TeamFeatureFileSharing) - ( getFeatureConfig @'WithoutLockStatus @'TeamFeatureFileSharing + ( getFeatureConfig @'WithLockStatus @'TeamFeatureFileSharing getFileSharingInternal ) :<|> Named @'("get-config", 'TeamFeatureClassifiedDomains) diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 4cffae12827..ae1ffb0e88b 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -26,7 +26,7 @@ module Galley.API.Teams getBindingTeamIdH, getBindingTeamMembersH, getManyTeams, - deleteTeamH, + deleteTeam, uncheckedDeleteTeam, addTeamMemberH, getTeamNotificationsH, @@ -146,11 +146,13 @@ import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) getTeamH :: - Members '[Error TeamError, Queue DeleteItem, TeamStore] r => - UserId ::: TeamId ::: JSON -> - Sem r Response -getTeamH (zusr ::: tid ::: _) = - maybe (throw TeamNotFound) (pure . json) =<< lookupTeam zusr tid + forall r. + (Member (Error TeamError) r, Member (Queue DeleteItem) r, Member TeamStore r) => + UserId -> + TeamId -> + Sem r Public.Team +getTeamH zusr tid = + maybe (throw TeamNotFound) pure =<< lookupTeam zusr tid getTeamInternalH :: Members '[Error TeamError, TeamStore] r => @@ -358,47 +360,24 @@ updateTeamH zusr zcon tid updateData = do let r = list1 (userRecipient zusr) (membersToRecipients (Just zusr) (memList ^. teamMembers)) E.push1 $ newPushLocal1 (memList ^. teamMemberListType) zusr (TeamEvent e) r & pushConn .~ Just zcon -deleteTeamH :: - Members - '[ BrigAccess, - Error ActionError, - Error AuthenticationError, - Error InternalError, - Error InvalidInput, - Error TeamError, - Error NotATeamMember, - Queue DeleteItem, - TeamStore, - WaiRoutes - ] - r => - UserId ::: ConnId ::: TeamId ::: OptionalJsonRequest Public.TeamDeleteData ::: JSON -> - Sem r 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 :: - Members - '[ BrigAccess, - Error ActionError, - Error AuthenticationError, - Error InternalError, - Error InvalidInput, - Error TeamError, - Error NotATeamMember, - Queue DeleteItem, - TeamStore - ] - r => + forall r. + ( Member BrigAccess r, + Member (Error ActionError) r, + Member (Error AuthenticationError) r, + Member (Error InternalError) r, + Member (Error InvalidInput) r, + Member (Error TeamError) r, + Member (Error NotATeamMember) r, + Member (Queue DeleteItem) r, + Member TeamStore r + ) => UserId -> ConnId -> TeamId -> - Maybe Public.TeamDeleteData -> + Public.TeamDeleteData -> Sem r () -deleteTeam zusr zcon tid mBody = do +deleteTeam zusr zcon tid body = do team <- E.getTeam tid >>= note TeamNotFound case tdStatus team of Deleted -> throw TeamNotFound @@ -411,7 +390,6 @@ deleteTeam zusr zcon tid mBody = do checkPermissions team = do void $ permissionCheck DeleteTeam =<< E.getTeamMember tid zusr when ((tdTeam team) ^. teamBinding == Binding) $ do - body <- mBody & note (InvalidPayload "missing request body") ensureReAuthorised zusr (body ^. tdAuthPassword) -- This can be called by stern diff --git a/services/galley/src/Galley/API/Teams/Features.hs b/services/galley/src/Galley/API/Teams/Features.hs index 8bfc7574218..20582c84846 100644 --- a/services/galley/src/Galley/API/Teams/Features.hs +++ b/services/galley/src/Galley/API/Teams/Features.hs @@ -231,7 +231,7 @@ getAllFeatureConfigs zusr = do getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock getAppLockInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, + getStatus @'Public.WithLockStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, getStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal, @@ -280,7 +280,7 @@ getAllFeatures uid tid = do getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureValidateSAMLEmails getValidateSAMLEmailsInternal, getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureDigitalSignatures getDigitalSignaturesInternal, getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureAppLock getAppLockInternal, - getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, + getStatus @'Public.WithLockStatus @'Public.TeamFeatureFileSharing getFileSharingInternal, getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureClassifiedDomains getClassifiedDomainsInternal, getStatus @'Public.WithoutLockStatus @'Public.TeamFeatureConferenceCalling getConferenceCallingInternal, getStatus @'Public.WithLockStatus @'Public.TeamFeatureSelfDeletingMessages getSelfDeletingMessagesInternal, @@ -493,11 +493,34 @@ setLegalholdStatusInternal tid status@(Public.tfwoStatus -> statusValue) = do TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureLegalHold tid status getFileSharingInternal :: - Members '[Input Opts, TeamFeatureStore] r => + forall r. + ( Member (Input Opts) r, + Member TeamFeatureStore r + ) => GetFeatureInternalParam -> - Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing) -getFileSharingInternal = - getFeatureStatusWithDefaultConfig @'Public.TeamFeatureFileSharing flagFileSharing . either (const Nothing) Just + Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureFileSharing) +getFileSharingInternal = \case + Left _ -> getCfgDefault + Right tid -> do + cfgDefault <- getCfgDefault + (mbFeatureStatus, fromMaybe (Public.tfwoapsLockStatus cfgDefault) -> lockStatus) <- TeamFeatures.getFeatureStatusNoConfigAndLockStatus @'Public.TeamFeatureFileSharing tid + pure $ determineFeatureStatus cfgDefault lockStatus mbFeatureStatus + where + getCfgDefault :: Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureFileSharing) + getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagFileSharing . unDefaults) + +determineFeatureStatus :: + Public.TeamFeatureStatusNoConfigAndLockStatus -> + Public.LockStatusValue -> + Maybe Public.TeamFeatureStatusNoConfig -> + Public.TeamFeatureStatusNoConfigAndLockStatus +determineFeatureStatus cfgDefault lockStatus mbFeatureStatus = case (lockStatus, mbFeatureStatus) of + (Public.Unlocked, Just featureStatus) -> + Public.TeamFeatureStatusNoConfigAndLockStatus + (Public.tfwoStatus featureStatus) + lockStatus + (Public.Unlocked, Nothing) -> cfgDefault {Public.tfwoapsLockStatus = lockStatus} + (Public.Locked, _) -> cfgDefault {Public.tfwoapsLockStatus = lockStatus} getFeatureStatusWithDefaultConfig :: forall (a :: TeamFeatureName) r. @@ -520,11 +543,31 @@ getFeatureStatusWithDefaultConfig lens' = <&> Public.tfwoStatus . view unDefaults setFileSharingInternal :: - Members '[GundeckAccess, TeamFeatureStore, TeamStore, P.TinyLog] r => + forall r. + ( Member GundeckAccess r, + Member TeamFeatureStore r, + Member TeamStore r, + Member P.TinyLog r, + Member (Error TeamFeatureError) r, + Member (Input Opts) r + ) => TeamId -> Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing -> Sem r (Public.TeamFeatureStatus 'Public.WithoutLockStatus 'Public.TeamFeatureFileSharing) -setFileSharingInternal = setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing $ \_status _tid -> pure () +setFileSharingInternal tid status = do + getDftLockStatus >>= guardLockStatus @'Public.TeamFeatureFileSharing tid + let pushEvent = + pushFeatureConfigEvent tid $ + Event.Event + Event.Update + Public.TeamFeatureFileSharing + ( EdFeatureWithoutConfigAndLockStatusChanged + (Public.TeamFeatureStatusNoConfigAndLockStatus (Public.tfwoStatus status) Public.Unlocked) + ) + TeamFeatures.setFeatureStatusNoConfig @'Public.TeamFeatureFileSharing tid status <* pushEvent + where + getDftLockStatus :: Sem r Public.LockStatusValue + getDftLockStatus = input <&> view (optSettings . setFeatureFlags . flagFileSharing . unDefaults . to Public.tfwoapsLockStatus) getAppLockInternal :: Members '[Input Opts, TeamFeatureStore] r => @@ -636,13 +679,7 @@ getGuestLinkInternal = \case Right tid -> do cfgDefault <- getCfgDefault (mbFeatureStatus, fromMaybe (Public.tfwoapsLockStatus cfgDefault) -> lockStatus) <- TeamFeatures.getFeatureStatusNoConfigAndLockStatus @'Public.TeamFeatureGuestLinks tid - pure $ case (lockStatus, mbFeatureStatus) of - (Public.Unlocked, Just featureStatus) -> - Public.TeamFeatureStatusNoConfigAndLockStatus - (Public.tfwoStatus featureStatus) - lockStatus - (Public.Unlocked, Nothing) -> cfgDefault {Public.tfwoapsLockStatus = lockStatus} - (Public.Locked, _) -> cfgDefault {Public.tfwoapsLockStatus = lockStatus} + pure $ determineFeatureStatus cfgDefault lockStatus mbFeatureStatus where getCfgDefault :: Sem r (Public.TeamFeatureStatus 'Public.WithLockStatus 'Public.TeamFeatureGuestLinks) getCfgDefault = input <&> view (optSettings . setFeatureFlags . flagConversationGuestLinks . unDefaults) diff --git a/services/galley/src/Galley/Cassandra.hs b/services/galley/src/Galley/Cassandra.hs index 3900d25ed94..f0b39e870fd 100644 --- a/services/galley/src/Galley/Cassandra.hs +++ b/services/galley/src/Galley/Cassandra.hs @@ -20,4 +20,4 @@ module Galley.Cassandra (schemaVersion) where import Imports schemaVersion :: Int32 -schemaVersion = 58 +schemaVersion = 59 diff --git a/services/galley/src/Galley/Data/TeamFeatures.hs b/services/galley/src/Galley/Data/TeamFeatures.hs index 6fd0c910c56..99f100215a9 100644 --- a/services/galley/src/Galley/Data/TeamFeatures.hs +++ b/services/galley/src/Galley/Data/TeamFeatures.hs @@ -68,6 +68,9 @@ instance HasLockStatusCol 'TeamFeatureSelfDeletingMessages where instance HasLockStatusCol 'TeamFeatureGuestLinks where lockStatusCol = "guest_links_lock_status" +instance HasLockStatusCol 'TeamFeatureFileSharing where + lockStatusCol = "file_sharing_lock_status" + instance MaybeHasLockStatusCol 'TeamFeatureLegalHold where maybeLockStatusCol = Nothing instance MaybeHasLockStatusCol 'TeamFeatureSSO where maybeLockStatusCol = Nothing @@ -80,6 +83,4 @@ instance MaybeHasLockStatusCol 'TeamFeatureDigitalSignatures where maybeLockStat instance MaybeHasLockStatusCol 'TeamFeatureAppLock where maybeLockStatusCol = Nothing -instance MaybeHasLockStatusCol 'TeamFeatureFileSharing where maybeLockStatusCol = Nothing - instance MaybeHasLockStatusCol 'TeamFeatureConferenceCalling where maybeLockStatusCol = Nothing diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index f1428b2c4db..6ee4dc27b6a 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -123,7 +123,6 @@ tests s = test s "add team member to conversation without connection" (testAddTeamMemberToConv >> ensureQueueEmpty), test s "update conversation as member" (testUpdateTeamConv RoleMember roleNameWireAdmin), test s "update conversation as partner" (testUpdateTeamConv RoleExternalPartner roleNameWireMember), - test s "delete non-binding team" testDeleteTeam, test s "delete binding team internal single member" testDeleteBindingTeamSingleMember, test s "delete binding team (owner has passwd)" (testDeleteBindingTeam True), test s "delete binding team (owner has no passwd)" (testDeleteBindingTeam False), @@ -1001,55 +1000,6 @@ testUpdateTeamConv (rolePermissions -> perms) convRole = do where convRoleCheck = if isActionAllowed ModifyConversationName convRole == Just True then 200 else 403 -testDeleteTeam :: TestM () -testDeleteTeam = do - localDomain <- viewFederationDomain - g <- view tsGalley - c <- view tsCannon - owner <- Util.randomUser - qOwner <- Qualified <$> pure owner <*> viewFederationDomain - let p = Util.symmPermissions [DoNotUseDeprecatedAddRemoveConvMember] - member <- newTeamMember' p <$> Util.randomUser - qMember <- Qualified <$> pure (member ^. userId) <*> viewFederationDomain - extern <- Util.randomUser - qExtern <- Qualified <$> pure extern <*> viewFederationDomain - - let members = [owner, member ^. userId] - Util.connectUsers owner (list1 (member ^. userId) [extern]) - tid <- Util.createNonBindingTeam "foo" owner [member] - cid1 <- Util.createTeamConv owner tid [] (Just "blaa") Nothing Nothing - cid2 <- Util.createTeamConv owner tid members (Just "blup") Nothing Nothing - Util.assertConvMember qOwner cid2 - Util.assertConvMember qMember cid2 - Util.assertNotConvMember extern cid2 - Util.postMembers owner (list1 extern []) cid1 !!! const 200 === statusCode - Util.assertConvMember qOwner cid1 - Util.assertConvMember qExtern cid1 - Util.assertNotConvMember (member ^. userId) cid1 - void . WS.bracketR3 c owner extern (member ^. userId) $ \(wsOwner, wsExtern, wsMember) -> do - delete (g . paths ["teams", toByteString' tid] . zUser owner . zConn "conn") - !!! const 202 === statusCode - checkTeamDeleteEvent tid wsOwner - checkTeamDeleteEvent tid wsMember - -- team members should not receive conversation delete events - checkConvDeleteEvent (Qualified cid1 localDomain) wsExtern - WS.assertNoEvent timeout [wsOwner, wsExtern, wsMember] - get (g . paths ["teams", toByteString' tid] . zUser owner) - !!! const 404 === statusCode - get (g . paths ["teams", toByteString' tid, "members"] . zUser owner) - !!! const 403 === statusCode - get (g . paths ["teams", toByteString' tid, "conversations"] . zUser owner) - !!! const 403 === statusCode - for_ [owner, extern, member ^. userId] $ \u -> do - -- Ensure no user got deleted - Util.ensureDeletedState False owner u - for_ [cid1, cid2] $ \x -> do - Util.getConv u x !!! const 404 === statusCode - Util.getSelfMember u x !!! do - const 200 === statusCode - const (Just Null) === responseJsonMaybe - assertQueueEmpty - testDeleteBindingTeamSingleMember :: TestM () testDeleteBindingTeamSingleMember = do g <- view tsGalley diff --git a/services/galley/test/integration/API/Teams/Feature.hs b/services/galley/test/integration/API/Teams/Feature.hs index 81152271945..7bd706536b6 100644 --- a/services/galley/test/integration/API/Teams/Feature.hs +++ b/services/galley/test/integration/API/Teams/Feature.hs @@ -49,7 +49,7 @@ import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit (assertFailure, (@?=)) import TestHelpers (test) import TestSetup -import Wire.API.Event.FeatureConfig (EventData (EdFeatureWithoutConfigChanged)) +import Wire.API.Event.FeatureConfig (EventData (..)) import qualified Wire.API.Event.FeatureConfig as FeatureConfig import Wire.API.Team.Feature (TeamFeatureName (..), TeamFeatureStatusValue (..)) import qualified Wire.API.Team.Feature as Public @@ -63,7 +63,7 @@ tests s = test s "SearchVisibility" testSearchVisibility, test s "DigitalSignatures" $ testSimpleFlag @'Public.TeamFeatureDigitalSignatures Public.TeamFeatureDisabled, test s "ValidateSAMLEmails" $ testSimpleFlag @'Public.TeamFeatureValidateSAMLEmails Public.TeamFeatureDisabled, - test s "FileSharing" $ testSimpleFlag @'Public.TeamFeatureFileSharing Public.TeamFeatureEnabled, + test s "FileSharing with lock status" $ testSimpleFlagWithLockStatus @'Public.TeamFeatureFileSharing Public.TeamFeatureEnabled Public.Unlocked, test s "Classified Domains (enabled)" testClassifiedDomainsEnabled, test s "Classified Domains (disabled)" testClassifiedDomainsDisabled, test s "All features" testAllFeatures, @@ -71,7 +71,8 @@ tests s = test s "ConferenceCalling" $ testSimpleFlag @'Public.TeamFeatureConferenceCalling Public.TeamFeatureEnabled, test s "SelfDeletingMessages" testSelfDeletingMessages, test s "ConversationGuestLinks - public API" testGuestLinksPublic, - test s "ConversationGuestLinks - internal API" testGuestLinksInternal + test s "ConversationGuestLinks - internal API" testGuestLinksInternal, + test s "ConversationGuestLinks - lock status" $ testSimpleFlagWithLockStatus @'Public.TeamFeatureGuestLinks Public.TeamFeatureEnabled Public.Unlocked ] testSSO :: TestM () @@ -381,6 +382,101 @@ testSimpleFlag defaultValue = do setFlagInternal defaultValue getFlag defaultValue +testSimpleFlagWithLockStatus :: + forall (a :: Public.TeamFeatureName). + ( HasCallStack, + Typeable a, + Public.FeatureHasNoConfig 'Public.WithLockStatus a, + Public.FeatureHasNoConfig 'Public.WithoutLockStatus a, + Public.KnownTeamFeatureName a, + FromJSON (Public.TeamFeatureStatus 'Public.WithLockStatus a), + ToJSON (Public.TeamFeatureStatus 'Public.WithLockStatus a) + ) => + Public.TeamFeatureStatusValue -> + Public.LockStatusValue -> + TestM () +testSimpleFlagWithLockStatus defaultStatus defaultLockStatus = do + galley <- view tsGalley + let feature = Public.knownTeamFeatureName @a + owner <- Util.randomUser + member <- Util.randomUser + nonMember <- Util.randomUser + tid <- Util.createNonBindingTeam "foo" owner [] + Util.connectUsers owner (list1 member []) + Util.addTeamMember owner tid member (rolePermissions RoleMember) Nothing + let getFlag :: HasCallStack => Public.TeamFeatureStatusValue -> Public.LockStatusValue -> TestM () + getFlag expectedStatus expectedLockStatus = do + let flag = Util.getTeamFeatureFlag feature member tid + assertFlagNoConfigWithLockStatus @a flag expectedStatus expectedLockStatus + + getFeatureConfig :: HasCallStack => Public.TeamFeatureStatusValue -> Public.LockStatusValue -> TestM () + getFeatureConfig expectedStatus expectedLockStatus = do + let flag = Util.getFeatureConfig feature member + assertFlagNoConfigWithLockStatus @a flag expectedStatus expectedLockStatus + + getFlagInternal :: HasCallStack => Public.TeamFeatureStatusValue -> Public.LockStatusValue -> TestM () + getFlagInternal expectedStatus expectedLockStatus = do + let flag = Util.getTeamFeatureFlagInternal feature tid + assertFlagNoConfigWithLockStatus @a flag expectedStatus expectedLockStatus + + getFlags expectedStatus expectedLockStatus = do + getFlag expectedStatus expectedLockStatus + getFeatureConfig expectedStatus expectedLockStatus + getFlagInternal expectedStatus expectedLockStatus + + setFlagWithGalley :: Public.TeamFeatureStatusValue -> TestM () + setFlagWithGalley statusValue = + Util.putTeamFeatureFlagWithGalley @a galley owner tid (Public.TeamFeatureStatusNoConfig statusValue) + !!! statusCode === const 200 + + assertSetStatusForbidden :: Public.TeamFeatureStatusValue -> TestM () + assertSetStatusForbidden statusValue = + Util.putTeamFeatureFlagWithGalley @a galley owner tid (Public.TeamFeatureStatusNoConfig statusValue) + !!! statusCode === const 409 + + setLockStatus :: Public.LockStatusValue -> TestM () + setLockStatus lockStatus = + Util.setLockStatusInternal @a galley tid lockStatus + !!! statusCode === const 200 + + assertFlagForbidden $ Util.getTeamFeatureFlag feature nonMember tid + + let otherStatus = case defaultStatus of + Public.TeamFeatureDisabled -> Public.TeamFeatureEnabled + Public.TeamFeatureEnabled -> Public.TeamFeatureDisabled + + -- Initial status and lock status should be the defaults + getFlags defaultStatus defaultLockStatus + + -- unlock feature if it is locked + when (defaultLockStatus == Public.Locked) $ setLockStatus Public.Unlocked + + -- setting should work + cannon <- view tsCannon + -- should receive an event + WS.bracketR cannon member $ \ws -> do + setFlagWithGalley otherStatus + void . liftIO $ + WS.assertMatch (5 # Second) ws $ + wsAssertFeatureConfigWithLockStatusUpdate feature otherStatus Public.Unlocked + + getFlags otherStatus Public.Unlocked + + -- lock feature + setLockStatus Public.Locked + -- feature status should now be the default again + getFlags defaultStatus Public.Locked + assertSetStatusForbidden defaultStatus + -- unlock feature + setLockStatus Public.Unlocked + -- feature status should be the previously set value + getFlags otherStatus Public.Unlocked + + -- clean up + setFlagWithGalley defaultStatus + setLockStatus defaultLockStatus + getFlags defaultStatus defaultLockStatus + testSelfDeletingMessages :: TestM () testSelfDeletingMessages = do defLockStatus :: Public.LockStatusValue <- @@ -566,7 +662,7 @@ testAllFeatures = do .= Public.TeamFeatureStatusWithConfig TeamFeatureEnabled (Public.TeamFeatureAppLockConfig (Public.EnforceAppLock False) (60 :: Int32)), - toS TeamFeatureFileSharing .= Public.TeamFeatureStatusNoConfig TeamFeatureEnabled, + toS TeamFeatureFileSharing .= Public.TeamFeatureStatusNoConfigAndLockStatus TeamFeatureEnabled Public.Unlocked, toS TeamFeatureClassifiedDomains .= Public.TeamFeatureStatusWithConfig TeamFeatureEnabled @@ -639,6 +735,24 @@ assertFlagNoConfig res expected = do ) === const (Right expected) +assertFlagNoConfigWithLockStatus :: + forall (a :: Public.TeamFeatureName). + ( HasCallStack, + Typeable a, + Public.FeatureHasNoConfig 'Public.WithLockStatus a, + FromJSON (Public.TeamFeatureStatus 'Public.WithLockStatus a), + Public.KnownTeamFeatureName a + ) => + TestM ResponseLBS -> + Public.TeamFeatureStatusValue -> + Public.LockStatusValue -> + TestM () +assertFlagNoConfigWithLockStatus res expectedStatus expectedLockStatus = do + res !!! do + statusCode === const 200 + responseJsonEither @(Public.TeamFeatureStatus 'Public.WithLockStatus a) + === const (Right (Public.TeamFeatureStatusNoConfigAndLockStatus expectedStatus expectedLockStatus)) + assertFlagWithConfig :: forall cfg m. ( HasCallStack, @@ -666,3 +780,12 @@ wsAssertFeatureConfigUpdate teamFeature status notification = do FeatureConfig._eventType e @?= FeatureConfig.Update FeatureConfig._eventFeatureName e @?= teamFeature FeatureConfig._eventData e @?= EdFeatureWithoutConfigChanged (Public.TeamFeatureStatusNoConfig status) + +wsAssertFeatureConfigWithLockStatusUpdate :: Public.TeamFeatureName -> Public.TeamFeatureStatusValue -> Public.LockStatusValue -> Notification -> IO () +wsAssertFeatureConfigWithLockStatusUpdate teamFeature status lockStatus notification = do + let e :: FeatureConfig.Event = List1.head (WS.unpackPayload notification) + FeatureConfig._eventType e @?= FeatureConfig.Update + FeatureConfig._eventFeatureName e @?= teamFeature + FeatureConfig._eventData e + @?= EdFeatureWithoutConfigAndLockStatusChanged + (Public.TeamFeatureStatusNoConfigAndLockStatus status lockStatus) diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index b4823b1554f..d3166347b84 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -51,10 +51,10 @@ library Spar.Sem.DefaultSsoCode.Spec Spar.Sem.GalleyAccess Spar.Sem.GalleyAccess.Http - Spar.Sem.IdP - Spar.Sem.IdP.Cassandra - Spar.Sem.IdP.Mem - Spar.Sem.IdP.Spec + Spar.Sem.IdPConfigStore + Spar.Sem.IdPConfigStore.Cassandra + Spar.Sem.IdPConfigStore.Mem + Spar.Sem.IdPConfigStore.Spec Spar.Sem.IdPRawMetadataStore Spar.Sem.IdPRawMetadataStore.Cassandra Spar.Sem.IdPRawMetadataStore.Mem @@ -86,6 +86,7 @@ library Spar.Sem.ScimUserTimesStore Spar.Sem.ScimUserTimesStore.Cassandra Spar.Sem.ScimUserTimesStore.Mem + Spar.Sem.Utils Spar.Sem.VerdictFormatStore Spar.Sem.VerdictFormatStore.Cassandra Spar.Sem.VerdictFormatStore.Mem @@ -726,8 +727,8 @@ test-suite spec Test.Spar.Roundtrip.ByteString Test.Spar.ScimSpec Test.Spar.Sem.DefaultSsoCodeSpec + Test.Spar.Sem.IdPConfigStoreSpec Test.Spar.Sem.IdPRawMetadataStoreSpec - Test.Spar.Sem.IdPSpec Test.Spar.Sem.NowSpec Test.Spar.Sem.ScimExternalIdStoreSpec Test.Spar.TypesSpec diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index a5759c754d2..595020bc10a 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -75,8 +75,8 @@ import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import qualified Spar.Sem.DefaultSsoCode as DefaultSsoCode import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.GalleyAccess as GalleyAccess -import Spar.Sem.IdP (GetIdPResult (..), Replaced (..), Replacing (..)) -import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.IdPConfigStore (GetIdPResult (..), IdPConfigStore, Replaced (..), Replacing (..)) +import qualified Spar.Sem.IdPConfigStore as IdPConfigStore import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore) import qualified Spar.Sem.IdPRawMetadataStore as IdPRawMetadataStore import Spar.Sem.Logger (Logger) @@ -122,7 +122,7 @@ api :: ScimUserTimesStore, ScimTokenStore, DefaultSsoCode, - IdPEffect.IdP, + IdPConfigStore, IdPRawMetadataStore, SAMLUserStore, Random, @@ -159,7 +159,7 @@ apiSSO :: AReqIDStore, ScimTokenStore, DefaultSsoCode, - IdPEffect.IdP, + IdPConfigStore, Random, Error SparError, SAML2, @@ -186,7 +186,7 @@ apiIDP :: GalleyAccess, BrigAccess, ScimTokenStore, - IdPEffect.IdP, + IdPConfigStore, IdPRawMetadataStore, SAMLUserStore, Error SparError @@ -205,7 +205,7 @@ apiINTERNAL :: Members '[ ScimTokenStore, DefaultSsoCode, - IdPEffect.IdP, + IdPConfigStore, Error SparError, SAMLUserStore ] @@ -224,7 +224,7 @@ appName = "spar" authreqPrecheck :: Members - '[ IdPEffect.IdP, + '[ IdPConfigStore, Error SparError ] r => @@ -249,7 +249,7 @@ authreq :: SAML2, SamlProtocolSettings, Error SparError, - IdPEffect.IdP + IdPConfigStore ] r => NominalDiffTime -> @@ -264,7 +264,7 @@ authreq _ DoInitiateBind Nothing _ _ _ = throwSparSem SparInitBindWithoutAuth authreq authreqttl _ zusr msucc merr idpid = do vformat <- validateAuthreqParams msucc merr form@(SAML.FormRedirect _ ((^. SAML.rqID) -> reqid)) <- do - idp :: IdP <- IdPEffect.getConfig idpid >>= maybe (throwSparSem (SparIdPNotFound (cs $ show idpid))) pure + idp :: IdP <- IdPConfigStore.getConfig idpid >>= maybe (throwSparSem (SparIdPNotFound (cs $ show idpid))) pure let mbtid :: Maybe TeamId mbtid = case fromMaybe defWireIdPAPIVersion (idp ^. SAML.idpExtraInfo . wiApiVersion) of WireIdPAPIV1 -> Nothing @@ -331,7 +331,7 @@ authresp :: VerdictFormatStore, AReqIDStore, ScimTokenStore, - IdPEffect.IdP, + IdPConfigStore, SAML2, SamlProtocolSettings, Error SparError, @@ -368,7 +368,7 @@ ssoSettings = do SsoSettings <$> DefaultSsoCode.get ---------------------------------------------------------------------------- --- IdP API +-- IdPConfigStore API idpGet :: Members @@ -376,7 +376,7 @@ idpGet :: Logger String, GalleyAccess, BrigAccess, - IdPEffect.IdP, + IdPConfigStore, Error SparError ] r => @@ -392,7 +392,7 @@ idpGetRaw :: Members '[ GalleyAccess, BrigAccess, - IdPEffect.IdP, + IdPConfigStore, IdPRawMetadataStore, Error SparError ] @@ -413,7 +413,7 @@ idpGetAll :: Logger String, GalleyAccess, BrigAccess, - IdPEffect.IdP, + IdPConfigStore, Error SparError ] r => @@ -421,7 +421,7 @@ idpGetAll :: Sem r IdPList idpGetAll zusr = withDebugLog "idpGetAll" (const Nothing) $ do teamid <- Brig.getZUsrCheckPerm zusr ReadIdp - _idplProviders <- IdPEffect.getConfigsByTeam teamid + _idplProviders <- IdPConfigStore.getConfigsByTeam teamid pure IdPList {..} -- | Delete empty IdPs, or if @"purge=true"@ in the HTTP query, delete all users @@ -441,7 +441,7 @@ idpDelete :: BrigAccess, ScimTokenStore, SAMLUserStore, - IdPEffect.IdP, + IdPConfigStore, IdPRawMetadataStore, Error SparError ] @@ -478,7 +478,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons when (stiIdP == Just idpid) $ ScimTokenStore.delete team stiId -- Delete IdP config do - IdPEffect.deleteConfig idp + IdPConfigStore.deleteConfig idp IdPRawMetadataStore.delete idpid return NoContent where @@ -494,7 +494,7 @@ idpDelete zusr idpid (fromMaybe False -> purge) = withDebugLog "idpDelete" (cons updateReplacingIdP :: IdP -> Sem r () updateReplacingIdP idp = forM_ (idp ^. SAML.idpExtraInfo . wiOldIssuers) $ \oldIssuer -> do getIdPIdByIssuer oldIssuer (idp ^. SAML.idpExtraInfo . wiTeam) >>= \case - GetIdPFound iid -> IdPEffect.clearReplacedBy $ Replaced iid + GetIdPFound iid -> IdPConfigStore.clearReplacedBy $ Replaced iid GetIdPNotFound -> pure () GetIdPDanglingId _ -> pure () GetIdPNonUnique _ -> pure () @@ -510,7 +510,7 @@ idpCreate :: BrigAccess, ScimTokenStore, IdPRawMetadataStore, - IdPEffect.IdP, + IdPConfigStore, Error SparError ] r => @@ -529,7 +529,7 @@ idpCreateXML :: GalleyAccess, BrigAccess, ScimTokenStore, - IdPEffect.IdP, + IdPConfigStore, IdPRawMetadataStore, Error SparError ] @@ -548,7 +548,7 @@ idpCreateXML zusr raw idpmeta mReplaces (fromMaybe defWireIdPAPIVersion -> apive IdPRawMetadataStore.store (idp ^. SAML.idpId) raw storeIdPConfig idp forM_ mReplaces $ \replaces -> do - IdPEffect.setReplacedBy (Replaced replaces) (Replacing (idp ^. SAML.idpId)) + IdPConfigStore.setReplacedBy (Replaced replaces) (Replacing (idp ^. SAML.idpId)) pure idp -- | In teams with a scim access token, only one IdP is allowed. The reason is that scim user @@ -559,14 +559,14 @@ assertNoScimOrNoIdP :: Members '[ ScimTokenStore, Error SparError, - IdPEffect.IdP + IdPConfigStore ] r => TeamId -> Sem r () assertNoScimOrNoIdP teamid = do numTokens <- length <$> ScimTokenStore.lookupByTeam teamid - numIdps <- length <$> IdPEffect.getConfigsByTeam teamid + numIdps <- length <$> IdPConfigStore.getConfigsByTeam teamid when (numTokens > 0 && numIdps > 0) $ do throwSparSem $ SparProvisioningMoreThanOneIdP @@ -598,7 +598,7 @@ validateNewIdP :: Members '[ Random, Logger String, - IdPEffect.IdP, + IdPConfigStore, Error SparError ] r => @@ -612,7 +612,7 @@ validateNewIdP apiversion _idpMetadata teamId mReplaces = withDebugLog "validate oldIssuers :: [SAML.Issuer] <- case mReplaces of Nothing -> pure [] Just replaces -> do - idp <- IdPEffect.getConfig replaces >>= maybe (throwSparSem (SparIdPNotFound (cs $ show mReplaces))) pure + idp <- IdPConfigStore.getConfig replaces >>= maybe (throwSparSem (SparIdPNotFound (cs $ show mReplaces))) pure pure $ (idp ^. SAML.idpMetadata . SAML.edIssuer) : (idp ^. SAML.idpExtraInfo . wiOldIssuers) let requri = _idpMetadata ^. SAML.edRequestURI _idpExtraInfo = WireIdP teamId (Just apiversion) oldIssuers Nothing @@ -653,7 +653,7 @@ idpUpdate :: Logger String, GalleyAccess, BrigAccess, - IdPEffect.IdP, + IdPConfigStore, IdPRawMetadataStore, Error SparError ] @@ -670,7 +670,7 @@ idpUpdateXML :: Logger String, GalleyAccess, BrigAccess, - IdPEffect.IdP, + IdPConfigStore, IdPRawMetadataStore, Error SparError ] @@ -702,7 +702,7 @@ validateIdPUpdate :: Logger String, GalleyAccess, BrigAccess, - IdPEffect.IdP, + IdPConfigStore, Error SparError ] r => @@ -712,7 +712,7 @@ validateIdPUpdate :: m (TeamId, IdP) validateIdPUpdate zusr _idpMetadata _idpId = withDebugLog "validateNewIdP" (Just . show . (_2 %~ (^. SAML.idpId))) $ do previousIdP <- - IdPEffect.getConfig _idpId >>= \case + IdPConfigStore.getConfig _idpId >>= \case Nothing -> throw errUnknownIdPId Just idp -> pure idp teamId <- authorizeIdP zusr previousIdP @@ -776,7 +776,7 @@ internalStatus = pure NoContent -- | Cleanup handler that is called by Galley whenever a team is about to -- get deleted. -internalDeleteTeam :: Members '[ScimTokenStore, IdPEffect.IdP, SAMLUserStore] r => TeamId -> Sem r NoContent +internalDeleteTeam :: Members '[ScimTokenStore, IdPConfigStore, SAMLUserStore] r => TeamId -> Sem r NoContent internalDeleteTeam team = do deleteTeam team pure NoContent @@ -785,7 +785,7 @@ internalPutSsoSettings :: Members '[ DefaultSsoCode, Error SparError, - IdPEffect.IdP + IdPConfigStore ] r => SsoSettings -> @@ -794,7 +794,7 @@ internalPutSsoSettings SsoSettings {defaultSsoCode = Nothing} = do DefaultSsoCode.delete pure NoContent internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} = do - IdPEffect.getConfig code >>= \case + IdPConfigStore.getConfig code >>= \case Nothing -> -- this will return a 404, which is not quite right, -- but it's an internal endpoint and the message clearly says diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 1c0fdcc4e2b..1287b94f111 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -86,8 +86,8 @@ import Spar.Sem.BrigAccess (BrigAccess) import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.GalleyAccess as GalleyAccess -import Spar.Sem.IdP (GetIdPResult (..)) -import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.IdPConfigStore (GetIdPResult (..), IdPConfigStore) +import qualified Spar.Sem.IdPConfigStore as IdPConfigStore import Spar.Sem.Logger (Logger) import qualified Spar.Sem.Logger as Logger import Spar.Sem.Random (Random) @@ -126,18 +126,18 @@ data Env = Env getIdPConfig :: Members - '[ IdPEffect.IdP, + '[ IdPConfigStore, Error SparError ] r => IdPId -> Sem r IdP -getIdPConfig = (>>= maybe (throwSparSem (SparIdPNotFound mempty)) pure) . IdPEffect.getConfig +getIdPConfig = (>>= maybe (throwSparSem (SparIdPNotFound mempty)) pure) . IdPConfigStore.getConfig -storeIdPConfig :: Member IdPEffect.IdP r => IdP -> Sem r () -storeIdPConfig idp = IdPEffect.storeConfig idp +storeIdPConfig :: Member IdPConfigStore r => IdP -> Sem r () +storeIdPConfig idp = IdPConfigStore.storeConfig idp -getIdPConfigByIssuerOptionalSPId :: Members '[IdPEffect.IdP, Error SparError] r => Issuer -> Maybe TeamId -> Sem r IdP +getIdPConfigByIssuerOptionalSPId :: Members '[IdPConfigStore, Error SparError] r => Issuer -> Maybe TeamId -> Sem r IdP getIdPConfigByIssuerOptionalSPId issuer mbteam = do getIdPConfigByIssuerAllowOld issuer mbteam >>= \case GetIdPFound idp -> pure idp @@ -248,7 +248,7 @@ autoprovisionSamlUser :: GalleyAccess, BrigAccess, ScimTokenStore, - IdPEffect.IdP, + IdPConfigStore, Error SparError, SAMLUserStore ] @@ -268,7 +268,7 @@ autoprovisionSamlUserWithId :: '[ GalleyAccess, BrigAccess, ScimTokenStore, - IdPEffect.IdP, + IdPConfigStore, Error SparError, SAMLUserStore ] @@ -323,7 +323,7 @@ bindUser :: forall r. Members '[ BrigAccess, - IdPEffect.IdP, + IdPConfigStore, Error SparError, SAMLUserStore ] @@ -377,7 +377,7 @@ verdictHandler :: AReqIDStore, VerdictFormatStore, ScimTokenStore, - IdPEffect.IdP, + IdPConfigStore, Error SparError, Reporter, SAMLUserStore @@ -421,7 +421,7 @@ verdictHandlerResult :: BrigAccess, BindCookieStore, ScimTokenStore, - IdPEffect.IdP, + IdPConfigStore, Error SparError, Reporter, SAMLUserStore @@ -462,7 +462,7 @@ findUserIdWithOldIssuer :: forall r. Members '[ BrigAccess, - IdPEffect.IdP, + IdPConfigStore, SAMLUserStore, Error SparError ] @@ -496,7 +496,7 @@ verdictHandlerResultCore :: BrigAccess, BindCookieStore, ScimTokenStore, - IdPEffect.IdP, + IdPConfigStore, Error SparError, SAMLUserStore ] @@ -698,16 +698,16 @@ errorPage err mpInputs mcky = -- single solution can be found without. getIdPIdByIssuerAllowOld :: (HasCallStack) => - Member IdPEffect.IdP r => + Member IdPConfigStore r => SAML.Issuer -> Maybe TeamId -> Sem r (GetIdPResult SAML.IdPId) getIdPIdByIssuerAllowOld issuer mbteam = do - mbv2 <- maybe (pure Nothing) (IdPEffect.getIdByIssuerWithTeam issuer) mbteam - mbv1v2 <- maybe (IdPEffect.getIdByIssuerWithoutTeam issuer) (pure . GetIdPFound) mbv2 + mbv2 <- maybe (pure Nothing) (IdPConfigStore.getIdByIssuerWithTeam issuer) mbteam + mbv1v2 <- maybe (IdPConfigStore.getIdByIssuerWithoutTeam issuer) (pure . GetIdPFound) mbv2 case (mbv1v2, mbteam) of (GetIdPFound idpid, Just team) -> do - IdPEffect.getConfig idpid >>= \case + IdPConfigStore.getConfig idpid >>= \case Nothing -> do pure $ GetIdPDanglingId idpid Just idp -> @@ -719,7 +719,7 @@ getIdPIdByIssuerAllowOld issuer mbteam = do -- | See 'getIdPIdByIssuer'. getIdPConfigByIssuer :: - (HasCallStack, Member IdPEffect.IdP r) => + (HasCallStack, Member IdPConfigStore r) => SAML.Issuer -> TeamId -> Sem r (GetIdPResult IdP) @@ -728,7 +728,7 @@ getIdPConfigByIssuer issuer = -- | See 'getIdPIdByIssuerAllowOld'. getIdPConfigByIssuerAllowOld :: - (HasCallStack, Member IdPEffect.IdP r) => + (HasCallStack, Member IdPConfigStore r) => SAML.Issuer -> Maybe TeamId -> Sem r (GetIdPResult IdP) @@ -738,7 +738,7 @@ getIdPConfigByIssuerAllowOld issuer = do -- | Lookup idp in table `issuer_idp_v2` (using both issuer entityID and teamid); if nothing -- is found there or if teamid is 'Nothing', lookup under issuer in `issuer_idp`. getIdPIdByIssuer :: - (HasCallStack, Member IdPEffect.IdP r) => + (HasCallStack, Member IdPConfigStore r) => SAML.Issuer -> TeamId -> Sem r (GetIdPResult SAML.IdPId) @@ -746,8 +746,8 @@ getIdPIdByIssuer issuer = getIdPIdByIssuerAllowOld issuer . Just -- | (There are probably category theoretical models for what we're doing here, but it's more -- straight-forward to just handle the one instance we need.) -mapGetIdPResult :: (HasCallStack, Member IdPEffect.IdP r) => GetIdPResult SAML.IdPId -> Sem r (GetIdPResult IdP) -mapGetIdPResult (GetIdPFound i) = IdPEffect.getConfig i <&> maybe (GetIdPDanglingId i) GetIdPFound +mapGetIdPResult :: (HasCallStack, Member IdPConfigStore r) => GetIdPResult SAML.IdPId -> Sem r (GetIdPResult IdP) +mapGetIdPResult (GetIdPFound i) = IdPConfigStore.getConfig i <&> maybe (GetIdPDanglingId i) GetIdPFound mapGetIdPResult GetIdPNotFound = pure GetIdPNotFound mapGetIdPResult (GetIdPDanglingId i) = pure (GetIdPDanglingId i) mapGetIdPResult (GetIdPNonUnique is) = pure (GetIdPNonUnique is) @@ -755,18 +755,18 @@ mapGetIdPResult (GetIdPWrongTeam i) = pure (GetIdPWrongTeam i) -- | Delete all tokens belonging to a team. deleteTeam :: - (HasCallStack, Members '[ScimTokenStore, SAMLUserStore, IdPEffect.IdP] r) => + (HasCallStack, Members '[ScimTokenStore, SAMLUserStore, IdPConfigStore] r) => TeamId -> Sem r () deleteTeam team = do ScimTokenStore.deleteByTeam team -- Since IdPs are not shared between teams, we can look at the set of IdPs -- used by the team, and remove everything related to those IdPs, too. - idps <- IdPEffect.getConfigsByTeam team + idps <- IdPConfigStore.getConfigsByTeam team for_ idps $ \idp -> do let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer SAMLUserStore.deleteByIssuer issuer - IdPEffect.deleteConfig idp + IdPConfigStore.deleteConfig idp sparToServerErrorWithLogging :: Member Reporter r => SparError -> Sem r ServerError sparToServerErrorWithLogging err = do diff --git a/services/spar/src/Spar/CanonicalInterpreter.hs b/services/spar/src/Spar/CanonicalInterpreter.hs index 5fe32e4900a..4c939f165fb 100644 --- a/services/spar/src/Spar/CanonicalInterpreter.hs +++ b/services/spar/src/Spar/CanonicalInterpreter.hs @@ -17,7 +17,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.CanonicalInterpreter where +module Spar.CanonicalInterpreter + ( CanonicalEffs, + runSparToIO, + runSparToHandler, + ) +where import qualified Cassandra as Cas import Control.Monad.Except @@ -30,7 +35,7 @@ import Spar.App hiding (sparToServerErrorWithLogging) import Spar.Error import Spar.Orphans () import Spar.Sem.AReqIDStore (AReqIDStore) -import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra, ttlErrorToSparError) +import Spar.Sem.AReqIDStore.Cassandra (aReqIDStoreToCassandra) import Spar.Sem.AssIDStore (AssIDStore) import Spar.Sem.AssIDStore.Cassandra (assIDStoreToCassandra) import Spar.Sem.BindCookieStore (BindCookieStore) @@ -41,8 +46,8 @@ import Spar.Sem.DefaultSsoCode (DefaultSsoCode) import Spar.Sem.DefaultSsoCode.Cassandra (defaultSsoCodeToCassandra) import Spar.Sem.GalleyAccess (GalleyAccess) import Spar.Sem.GalleyAccess.Http (galleyAccessToHttp) -import qualified Spar.Sem.IdP as IdPEffect -import Spar.Sem.IdP.Cassandra (idPToCassandra) +import Spar.Sem.IdPConfigStore (IdPConfigStore) +import Spar.Sem.IdPConfigStore.Cassandra (idPToCassandra) import Spar.Sem.IdPRawMetadataStore (IdPRawMetadataStore) import Spar.Sem.IdPRawMetadataStore.Cassandra (idpRawMetadataStoreToCassandra) import Spar.Sem.Logger (Logger) @@ -56,7 +61,7 @@ import Spar.Sem.Reporter.Wai (reporterToTinyLogWai) import Spar.Sem.SAML2 (SAML2) import Spar.Sem.SAML2.Library (saml2ToSaml2WebSso) import Spar.Sem.SAMLUserStore (SAMLUserStore) -import Spar.Sem.SAMLUserStore.Cassandra (interpretClientToIO, samlUserStoreToCassandra) +import Spar.Sem.SAMLUserStore.Cassandra (samlUserStoreToCassandra) import Spar.Sem.SamlProtocolSettings (SamlProtocolSettings) import Spar.Sem.SamlProtocolSettings.Servant (sparRouteToServant) import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) @@ -65,6 +70,7 @@ import Spar.Sem.ScimTokenStore (ScimTokenStore) import Spar.Sem.ScimTokenStore.Cassandra (scimTokenStoreToCassandra) import Spar.Sem.ScimUserTimesStore (ScimUserTimesStore) import Spar.Sem.ScimUserTimesStore.Cassandra (scimUserTimesStoreToCassandra) +import Spar.Sem.Utils (interpretClientToIO, ttlErrorToSparError) import Spar.Sem.VerdictFormatStore (VerdictFormatStore) import Spar.Sem.VerdictFormatStore.Cassandra (verdictFormatStoreToCassandra) import qualified System.Logger as TinyLog @@ -81,7 +87,7 @@ type CanonicalEffs = ScimUserTimesStore, ScimTokenStore, DefaultSsoCode, - IdPEffect.IdP, + IdPConfigStore, IdPRawMetadataStore, SAMLUserStore, Embed (Cas.Client), diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index a630bd58afe..1b456ae7de4 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -82,7 +82,7 @@ import Spar.Scim.Auth import Spar.Scim.User import Spar.Sem.BrigAccess (BrigAccess) import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.IdPConfigStore (IdPConfigStore) import Spar.Sem.Logger (Logger) import Spar.Sem.Now (Now) import Spar.Sem.Random (Random) @@ -125,7 +125,7 @@ apiScim :: ScimUserTimesStore, ScimTokenStore, Reporter, - IdPEffect.IdP, + IdPConfigStore, -- TODO(sandy): Only necessary for 'fromExceptionSem'. But can these errors even happen? Final IO, SAMLUserStore diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index 3b48bbcccc8..43797008658 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -54,7 +54,8 @@ import qualified Spar.Intra.BrigApp as Intra.Brig import Spar.Sem.BrigAccess (BrigAccess) import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.IdPConfigStore (IdPConfigStore) +import qualified Spar.Sem.IdPConfigStore as IdPConfigStore import Spar.Sem.Now (Now) import qualified Spar.Sem.Now as Now import Spar.Sem.Random (Random) @@ -93,7 +94,7 @@ apiScimToken :: BrigAccess, ScimTokenStore, Now, - IdPEffect.IdP, + IdPConfigStore, Error E.SparError ] r => @@ -114,7 +115,7 @@ createScimToken :: GalleyAccess, BrigAccess, ScimTokenStore, - IdPEffect.IdP, + IdPConfigStore, Now, Error E.SparError ] @@ -132,7 +133,7 @@ createScimToken zusr CreateScimToken {..} = do maxTokens <- inputs maxScimTokens unless (tokenNumber < maxTokens) $ throwSparSem E.SparProvisioningTokenLimitReached - idps <- IdPEffect.getConfigsByTeam teamid + idps <- IdPConfigStore.getConfigsByTeam teamid let caseOneOrNoIdP :: Maybe SAML.IdPId -> Sem r CreateScimTokenResponse caseOneOrNoIdP midpid = do diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 9e04f3ee2f0..cf57fdd0e33 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -73,7 +73,8 @@ import Spar.Scim.Types (normalizeLikeStored) import qualified Spar.Scim.Types as ST import Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.GalleyAccess (GalleyAccess) -import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.IdPConfigStore (IdPConfigStore) +import qualified Spar.Sem.IdPConfigStore as IdPConfigStore import Spar.Sem.Logger (Logger) import qualified Spar.Sem.Logger as Logger import Spar.Sem.Now (Now) @@ -122,7 +123,7 @@ instance BrigAccess, ScimExternalIdStore, ScimUserTimesStore, - IdPEffect.IdP, + IdPConfigStore, SAMLUserStore ] r => @@ -141,7 +142,7 @@ instance . logFilter filter' ) $ do - mIdpConfig <- maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP + mIdpConfig <- maybe (pure Nothing) (lift . IdPConfigStore.getConfig) stiIdP case filter' of Scim.FilterAttrCompare (Scim.AttrPath schema attrName _subAttr) Scim.OpEq (Scim.ValString val) | Scim.isUserSchema schema -> do @@ -164,7 +165,7 @@ instance . logTokenInfo tokeninfo ) $ do - mIdpConfig <- maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP + mIdpConfig <- maybe (pure Nothing) (lift . IdPConfigStore.getConfig) stiIdP let notfound = Scim.notFound "User" (idToText uid) brigUser <- lift (BrigAccess.getAccount Brig.WithPendingInvitations uid) >>= maybe (throwError notfound) pure unless (userTeam (accountUser brigUser) == Just stiTeam) (throwError notfound) @@ -203,7 +204,7 @@ instance validateScimUser :: forall m r. (m ~ Scim.ScimHandler (Sem r)) => - Members '[Input Opts, IdPEffect.IdP] r => + Members '[Input Opts, IdPConfigStore] r => Text -> -- | Used to decide what IdP to assign the user to ScimTokenInfo -> @@ -214,9 +215,9 @@ validateScimUser errloc tokinfo user = do richInfoLimit <- lift $ inputs richInfoLimit validateScimUser' errloc mIdpConfig richInfoLimit user -tokenInfoToIdP :: Member IdPEffect.IdP r => ScimTokenInfo -> Scim.ScimHandler (Sem r) (Maybe IdP) +tokenInfoToIdP :: Member IdPConfigStore r => ScimTokenInfo -> Scim.ScimHandler (Sem r) (Maybe IdP) tokenInfoToIdP ScimTokenInfo {stiIdP} = do - maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP + maybe (pure Nothing) (lift . IdPConfigStore.getConfig) stiIdP -- | Validate a handle (@userName@). validateHandle :: MonadError Scim.ScimError m => Text -> m Handle @@ -505,7 +506,7 @@ updateValidScimUser :: BrigAccess, ScimExternalIdStore, ScimUserTimesStore, - IdPEffect.IdP, + IdPConfigStore, SAMLUserStore ] r => @@ -647,7 +648,7 @@ deleteScimUser :: ScimExternalIdStore, ScimUserTimesStore, SAMLUserStore, - IdPEffect.IdP + IdPConfigStore ] r => ScimTokenInfo -> @@ -674,7 +675,7 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = throwError $ Scim.notFound "user" (idToText uid) - mIdpConfig <- maybe (pure Nothing) (lift . IdPEffect.getConfig) stiIdP + mIdpConfig <- maybe (pure Nothing) (lift . IdPConfigStore.getConfig) stiIdP case Brig.veidFromBrigUser brigUser ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of Left _ -> pure () diff --git a/services/spar/src/Spar/Sem/AReqIDStore.hs b/services/spar/src/Spar/Sem/AReqIDStore.hs index 12f5b7b10eb..a3f377989fd 100644 --- a/services/spar/src/Spar/Sem/AReqIDStore.hs +++ b/services/spar/src/Spar/Sem/AReqIDStore.hs @@ -15,7 +15,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.AReqIDStore where +module Spar.Sem.AReqIDStore + ( AReqIDStore (..), + store, + unStore, + isAlive, + ) +where import Imports import Polysemy diff --git a/services/spar/src/Spar/Sem/AReqIDStore/Cassandra.hs b/services/spar/src/Spar/Sem/AReqIDStore/Cassandra.hs index 6692ad8c146..bbd945a3199 100644 --- a/services/spar/src/Spar/Sem/AReqIDStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/AReqIDStore/Cassandra.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.AReqIDStore.Cassandra where +module Spar.Sem.AReqIDStore.Cassandra + ( aReqIDStoreToCassandra, + ) +where import Cassandra as Cas import Control.Lens @@ -28,7 +31,6 @@ import SAML2.WebSSO (fromTime) import qualified SAML2.WebSSO as SAML import qualified Spar.Data as Data import Spar.Data.Instances () -import Spar.Error import Spar.Sem.AReqIDStore import Spar.Sem.Now (Now) import qualified Spar.Sem.Now as Now @@ -49,9 +51,6 @@ aReqIDStoreToCassandra = interpret $ \case UnStore itla -> embed @m $ unStoreAReqID itla IsAlive itla -> embed @m $ isAliveAReqID itla -ttlErrorToSparError :: Member (Error SparError) r => Sem (Error TTLError ': r) a -> Sem r a -ttlErrorToSparError = mapError (SAML.CustomError . SparCassandraTTLError) - storeAReqID :: (HasCallStack, MonadReader Data.Env m, MonadClient m, MonadError TTLError m) => AReqId -> diff --git a/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs b/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs index 1ede1d5fb2a..23cecb68038 100644 --- a/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs +++ b/services/spar/src/Spar/Sem/AReqIDStore/Mem.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.AReqIDStore.Mem where +module Spar.Sem.AReqIDStore.Mem + ( aReqIDStoreToMem, + ) +where import qualified Data.Map as M import Imports diff --git a/services/spar/src/Spar/Sem/AssIDStore.hs b/services/spar/src/Spar/Sem/AssIDStore.hs index 845e08184fa..9aa5703996a 100644 --- a/services/spar/src/Spar/Sem/AssIDStore.hs +++ b/services/spar/src/Spar/Sem/AssIDStore.hs @@ -15,7 +15,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.AssIDStore where +module Spar.Sem.AssIDStore + ( AssIDStore (..), + store, + unStore, + isAlive, + ) +where import Imports import Polysemy diff --git a/services/spar/src/Spar/Sem/AssIDStore/Cassandra.hs b/services/spar/src/Spar/Sem/AssIDStore/Cassandra.hs index 118bac7b0e8..d98891dcd8b 100644 --- a/services/spar/src/Spar/Sem/AssIDStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/AssIDStore/Cassandra.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.AssIDStore.Cassandra where +module Spar.Sem.AssIDStore.Cassandra + ( assIDStoreToCassandra, + ) +where import Cassandra as Cas import Control.Lens diff --git a/services/spar/src/Spar/Sem/AssIDStore/Mem.hs b/services/spar/src/Spar/Sem/AssIDStore/Mem.hs index c5e8e65f208..c9a4517acbb 100644 --- a/services/spar/src/Spar/Sem/AssIDStore/Mem.hs +++ b/services/spar/src/Spar/Sem/AssIDStore/Mem.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.AssIDStore.Mem where +module Spar.Sem.AssIDStore.Mem + ( assIdStoreToMem, + ) +where import qualified Data.Map as M import Imports diff --git a/services/spar/src/Spar/Sem/BindCookieStore.hs b/services/spar/src/Spar/Sem/BindCookieStore.hs index 39fbde3bc68..e459a5fb560 100644 --- a/services/spar/src/Spar/Sem/BindCookieStore.hs +++ b/services/spar/src/Spar/Sem/BindCookieStore.hs @@ -15,11 +15,16 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.BindCookieStore where +module Spar.Sem.BindCookieStore + ( BindCookieStore (..), + insert, + lookup, + ) +where import Data.Id (UserId) import Data.Time (NominalDiffTime) -import Imports +import Imports (Maybe) import Polysemy import Wire.API.Cookie diff --git a/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs b/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs index 3af3426a006..b85b623837a 100644 --- a/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/BindCookieStore/Cassandra.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.BindCookieStore.Cassandra where +module Spar.Sem.BindCookieStore.Cassandra + ( bindCookieStoreToCassandra, + ) +where import Cassandra as Cas import Control.Lens diff --git a/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs b/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs index 8ac759a0eb5..d2ac377477a 100644 --- a/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs +++ b/services/spar/src/Spar/Sem/BindCookieStore/Mem.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.BindCookieStore.Mem where +module Spar.Sem.BindCookieStore.Mem + ( bindCookieStoreToMem, + ) +where import Data.Id (UserId) import qualified Data.Map as M diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs index 0720dea0fb4..ee1730875c3 100644 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ b/services/spar/src/Spar/Sem/BrigAccess.hs @@ -15,7 +15,29 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.BrigAccess where +module Spar.Sem.BrigAccess + ( BrigAccess (..), + createSAML, + createNoSAML, + updateEmail, + getAccount, + getByHandle, + getByEmail, + setName, + setHandle, + setManagedBy, + setVeid, + setRichInfo, + getRichInfo, + checkHandleAvailable, + delete, + ensureReAuthorised, + ssoLogin, + getStatus, + getStatusMaybe, + setStatus, + ) +where import Brig.Types.Intra import Brig.Types.User diff --git a/services/spar/src/Spar/Sem/BrigAccess/Http.hs b/services/spar/src/Spar/Sem/BrigAccess/Http.hs index 78a7f41216a..55673fcd415 100644 --- a/services/spar/src/Spar/Sem/BrigAccess/Http.hs +++ b/services/spar/src/Spar/Sem/BrigAccess/Http.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.BrigAccess.Http where +module Spar.Sem.BrigAccess.Http + ( brigAccessToHttp, + ) +where import Bilge import Imports @@ -24,8 +27,8 @@ import Polysemy.Error (Error) import Spar.Error (SparError) import qualified Spar.Intra.Brig as Intra import Spar.Sem.BrigAccess -import Spar.Sem.GalleyAccess.Http (RunHttpEnv (..), viaRunHttp) import Spar.Sem.Logger (Logger) +import Spar.Sem.Utils (RunHttpEnv (..), viaRunHttp) import qualified System.Logger as TinyLog brigAccessToHttp :: diff --git a/services/spar/src/Spar/Sem/DefaultSsoCode.hs b/services/spar/src/Spar/Sem/DefaultSsoCode.hs index 8693a96daf6..0c6741cb68e 100644 --- a/services/spar/src/Spar/Sem/DefaultSsoCode.hs +++ b/services/spar/src/Spar/Sem/DefaultSsoCode.hs @@ -15,7 +15,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.DefaultSsoCode where +module Spar.Sem.DefaultSsoCode + ( DefaultSsoCode (..), + get, + store, + delete, + ) +where import Imports import Polysemy diff --git a/services/spar/src/Spar/Sem/DefaultSsoCode/Cassandra.hs b/services/spar/src/Spar/Sem/DefaultSsoCode/Cassandra.hs index c8c0bee1354..d501064368b 100644 --- a/services/spar/src/Spar/Sem/DefaultSsoCode/Cassandra.hs +++ b/services/spar/src/Spar/Sem/DefaultSsoCode/Cassandra.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.DefaultSsoCode.Cassandra where +module Spar.Sem.DefaultSsoCode.Cassandra + ( defaultSsoCodeToCassandra, + ) +where import Cassandra import Imports diff --git a/services/spar/src/Spar/Sem/DefaultSsoCode/Mem.hs b/services/spar/src/Spar/Sem/DefaultSsoCode/Mem.hs index aee46151f97..c684eaa1a66 100644 --- a/services/spar/src/Spar/Sem/DefaultSsoCode/Mem.hs +++ b/services/spar/src/Spar/Sem/DefaultSsoCode/Mem.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.DefaultSsoCode.Mem where +module Spar.Sem.DefaultSsoCode.Mem + ( defaultSsoCodeToMem, + ) +where import Imports import Polysemy diff --git a/services/spar/src/Spar/Sem/GalleyAccess.hs b/services/spar/src/Spar/Sem/GalleyAccess.hs index 18eb6a1beed..022d9dd9b38 100644 --- a/services/spar/src/Spar/Sem/GalleyAccess.hs +++ b/services/spar/src/Spar/Sem/GalleyAccess.hs @@ -15,7 +15,14 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.GalleyAccess where +module Spar.Sem.GalleyAccess + ( GalleyAccess (..), + getTeamMembers, + assertHasPermission, + assertSSOEnabled, + isEmailValidationEnabledTeam, + ) +where import Data.Id (TeamId, UserId) import Galley.Types.Teams (IsPerm, TeamMember) diff --git a/services/spar/src/Spar/Sem/GalleyAccess/Http.hs b/services/spar/src/Spar/Sem/GalleyAccess/Http.hs index 6ff9aa7db1a..34024e2e5a3 100644 --- a/services/spar/src/Spar/Sem/GalleyAccess/Http.hs +++ b/services/spar/src/Spar/Sem/GalleyAccess/Http.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -17,70 +15,23 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.GalleyAccess.Http where +module Spar.Sem.GalleyAccess.Http + ( RunHttpEnv (..), + viaRunHttp, + galleyAccessToHttp, + ) +where import Bilge -import Control.Monad.Except import Imports hiding (log) import Polysemy import Polysemy.Error import Spar.Error (SparError) -import Spar.Intra.Brig (MonadSparToBrig (..)) -import Spar.Intra.Galley (MonadSparToGalley) import qualified Spar.Intra.Galley as Intra import Spar.Sem.GalleyAccess import Spar.Sem.Logger (Logger) -import qualified Spar.Sem.Logger as Logger -import Spar.Sem.Logger.TinyLog (fromLevel) +import Spar.Sem.Utils import qualified System.Logger as TinyLog -import qualified System.Logger.Class as TinyLog - -data RunHttpEnv r = RunHttpEnv - { rheManager :: Bilge.Manager, - rheRequest :: Bilge.Request - } - -newtype RunHttp r a = RunHttp - { unRunHttp :: ReaderT (RunHttpEnv r) (ExceptT SparError (HttpT (Sem r))) a - } - deriving newtype (Functor, Applicative, Monad, MonadError SparError, MonadReader (RunHttpEnv r)) - -instance Member (Embed IO) r => MonadIO (RunHttp r) where - liftIO = semToRunHttp . embed - -instance Member (Embed IO) r => MonadHttp (RunHttp r) where - handleRequestWithCont r fribia = - RunHttp $ - lift $ - lift $ - handleRequestWithCont r fribia - -semToRunHttp :: Sem r a -> RunHttp r a -semToRunHttp = RunHttp . lift . lift . lift - -viaRunHttp :: - Members '[Error SparError, Embed IO] r => - RunHttpEnv r -> - RunHttp r a -> - Sem r a -viaRunHttp env m = do - ma <- runHttpT (rheManager env) $ runExceptT $ flip runReaderT env $ unRunHttp m - case ma of - Left err -> throw err - Right a -> pure a - -instance Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r => TinyLog.MonadLogger (RunHttp r) where - log lvl msg = semToRunHttp $ Logger.log (fromLevel lvl) msg - -instance Members '[Logger (TinyLog.Msg -> TinyLog.Msg), Embed IO] r => MonadSparToGalley (RunHttp r) where - call modreq = do - req <- asks rheRequest - httpLbs req modreq - -instance Members '[Logger (TinyLog.Msg -> TinyLog.Msg), Embed IO] r => MonadSparToBrig (RunHttp r) where - call modreq = do - req <- asks rheRequest - httpLbs req modreq galleyAccessToHttp :: Members '[Logger (TinyLog.Msg -> TinyLog.Msg), Error SparError, Embed IO] r => diff --git a/services/spar/src/Spar/Sem/IdP.hs b/services/spar/src/Spar/Sem/IdPConfigStore.hs similarity index 65% rename from services/spar/src/Spar/Sem/IdP.hs rename to services/spar/src/Spar/Sem/IdPConfigStore.hs index 8b4593457d2..708dde9bfc4 100644 --- a/services/spar/src/Spar/Sem/IdP.hs +++ b/services/spar/src/Spar/Sem/IdPConfigStore.hs @@ -15,7 +15,21 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.IdP where +module Spar.Sem.IdPConfigStore + ( IdPConfigStore (..), + Replacing (..), + Replaced (..), + GetIdPResult (..), + storeConfig, + getConfig, + getIdByIssuerWithoutTeam, + getIdByIssuerWithTeam, + getConfigsByTeam, + deleteConfig, + setReplacedBy, + clearReplacedBy, + ) +where import Data.Id import Imports @@ -44,19 +58,19 @@ newtype Replaced = Replaced SAML.IdPId newtype Replacing = Replacing SAML.IdPId deriving (Eq, Ord, Show) -data IdP m a where - StoreConfig :: IP.IdP -> IdP m () - GetConfig :: SAML.IdPId -> IdP m (Maybe IP.IdP) - GetIdByIssuerWithoutTeam :: SAML.Issuer -> IdP m (GetIdPResult SAML.IdPId) - GetIdByIssuerWithTeam :: SAML.Issuer -> TeamId -> IdP m (Maybe SAML.IdPId) - GetConfigsByTeam :: TeamId -> IdP m [IP.IdP] - DeleteConfig :: IP.IdP -> IdP m () +data IdPConfigStore m a where + StoreConfig :: IP.IdP -> IdPConfigStore m () + GetConfig :: SAML.IdPId -> IdPConfigStore m (Maybe IP.IdP) + GetIdByIssuerWithoutTeam :: SAML.Issuer -> IdPConfigStore m (GetIdPResult SAML.IdPId) + GetIdByIssuerWithTeam :: SAML.Issuer -> TeamId -> IdPConfigStore m (Maybe SAML.IdPId) + GetConfigsByTeam :: TeamId -> IdPConfigStore m [IP.IdP] + DeleteConfig :: IP.IdP -> IdPConfigStore m () -- affects _wiReplacedBy in GetConfig - SetReplacedBy :: Replaced -> Replacing -> IdP m () - ClearReplacedBy :: Replaced -> IdP m () + SetReplacedBy :: Replaced -> Replacing -> IdPConfigStore m () + ClearReplacedBy :: Replaced -> IdPConfigStore m () -deriving stock instance Show (IdP m a) +deriving stock instance Show (IdPConfigStore m a) -- TODO(sandy): Inline this definition --- no TH -makeSem ''IdP -deriveGenericK ''IdP +makeSem ''IdPConfigStore +deriveGenericK ''IdPConfigStore diff --git a/services/spar/src/Spar/Sem/IdP/Cassandra.hs b/services/spar/src/Spar/Sem/IdPConfigStore/Cassandra.hs similarity index 93% rename from services/spar/src/Spar/Sem/IdP/Cassandra.hs rename to services/spar/src/Spar/Sem/IdPConfigStore/Cassandra.hs index efecf935e25..15623a7627b 100644 --- a/services/spar/src/Spar/Sem/IdP/Cassandra.hs +++ b/services/spar/src/Spar/Sem/IdPConfigStore/Cassandra.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.IdP.Cassandra where +module Spar.Sem.IdPConfigStore.Cassandra + ( idPToCassandra, + ) +where import Cassandra import Control.Lens ((^.)) @@ -29,31 +32,30 @@ import Imports import Polysemy import qualified SAML2.WebSSO as SAML import Spar.Data.Instances () -import Spar.Sem.IdP (GetIdPResult (..), Replaced (..), Replacing (..)) -import qualified Spar.Sem.IdP as Eff +import Spar.Sem.IdPConfigStore (GetIdPResult (..), IdPConfigStore (..), Replaced (..), Replacing (..)) import URI.ByteString import Wire.API.User.IdentityProvider idPToCassandra :: forall m r a. (MonadClient m, Member (Embed m) r) => - Sem (Eff.IdP ': r) a -> + Sem (IdPConfigStore ': r) a -> Sem r a idPToCassandra = interpret $ embed @m . \case - Eff.StoreConfig iw -> storeIdPConfig iw - Eff.GetConfig i -> getIdPConfig i - Eff.GetIdByIssuerWithoutTeam i -> getIdPIdByIssuerWithoutTeam i - Eff.GetIdByIssuerWithTeam i t -> getIdPIdByIssuerWithTeam i t - Eff.GetConfigsByTeam itlt -> getIdPConfigsByTeam itlt - Eff.DeleteConfig idp -> + StoreConfig iw -> storeIdPConfig iw + GetConfig i -> getIdPConfig i + GetIdByIssuerWithoutTeam i -> getIdPIdByIssuerWithoutTeam i + GetIdByIssuerWithTeam i t -> getIdPIdByIssuerWithTeam i t + GetConfigsByTeam itlt -> getIdPConfigsByTeam itlt + DeleteConfig idp -> let idpid = idp ^. SAML.idpId issuer = idp ^. SAML.idpMetadata . SAML.edIssuer team = idp ^. SAML.idpExtraInfo . wiTeam in deleteIdPConfig idpid issuer team - Eff.SetReplacedBy r r11 -> setReplacedBy r r11 - Eff.ClearReplacedBy r -> clearReplacedBy r + SetReplacedBy r r11 -> setReplacedBy r r11 + ClearReplacedBy r -> clearReplacedBy r type IdPConfigRow = (SAML.IdPId, SAML.Issuer, URI, SignedCertificate, [SignedCertificate], TeamId, Maybe WireIdPAPIVersion, [SAML.Issuer], Maybe SAML.IdPId) diff --git a/services/spar/src/Spar/Sem/IdP/Mem.hs b/services/spar/src/Spar/Sem/IdPConfigStore/Mem.hs similarity index 78% rename from services/spar/src/Spar/Sem/IdP/Mem.hs rename to services/spar/src/Spar/Sem/IdPConfigStore/Mem.hs index 2ca37f90a14..9007580131e 100644 --- a/services/spar/src/Spar/Sem/IdP/Mem.hs +++ b/services/spar/src/Spar/Sem/IdPConfigStore/Mem.hs @@ -17,7 +17,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.IdP.Mem (idPToMem, TypedState) where +module Spar.Sem.IdPConfigStore.Mem (idPToMem, TypedState) where import Control.Lens ((.~), (^.)) import Data.Id (TeamId) @@ -26,37 +26,37 @@ import Imports import Polysemy import Polysemy.State import qualified SAML2.WebSSO.Types as SAML -import qualified Spar.Sem.IdP as Eff +import Spar.Sem.IdPConfigStore (GetIdPResult (..), IdPConfigStore (..), Replaced (..), Replacing (..)) import qualified Wire.API.User.IdentityProvider as IP type TypedState = Map SAML.IdPId IP.IdP idPToMem :: forall r a. - Sem (Eff.IdP ': r) a -> + Sem (IdPConfigStore ': r) a -> Sem r (TypedState, a) idPToMem = evState . evEff where evState :: Sem (State TypedState : r) a -> Sem r (TypedState, a) evState = runState mempty - evEff :: Sem (Eff.IdP ': r) a -> Sem (State TypedState ': r) a + evEff :: Sem (IdPConfigStore ': r) a -> Sem (State TypedState ': r) a evEff = reinterpret @_ @(State TypedState) $ \case - Eff.StoreConfig iw -> + StoreConfig iw -> modify' (storeConfig iw) - Eff.GetConfig i -> + GetConfig i -> gets (getConfig i) - Eff.GetIdByIssuerWithoutTeam iss -> + GetIdByIssuerWithoutTeam iss -> gets (getIdByIssuerWithoutTeam iss) - Eff.GetIdByIssuerWithTeam iss team -> + GetIdByIssuerWithTeam iss team -> gets (getIdByIssuerWithTeam iss team) - Eff.GetConfigsByTeam team -> + GetConfigsByTeam team -> gets (getConfigsByTeam team) - Eff.DeleteConfig idp -> + DeleteConfig idp -> modify' (deleteConfig idp) - Eff.SetReplacedBy (Eff.Replaced replaced) (Eff.Replacing replacing) -> + SetReplacedBy (Replaced replaced) (Replacing replacing) -> modify' (updateReplacedBy (Just replacing) replaced <$>) - Eff.ClearReplacedBy (Eff.Replaced replaced) -> + ClearReplacedBy (Replaced replaced) -> modify' (updateReplacedBy Nothing replaced <$>) storeConfig :: IP.IdP -> TypedState -> TypedState @@ -73,12 +73,12 @@ storeConfig iw = getConfig :: SAML.IdPId -> TypedState -> Maybe IP.IdP getConfig = M.lookup -getIdByIssuerWithoutTeam :: SAML.Issuer -> TypedState -> Eff.GetIdPResult SAML.IdPId +getIdByIssuerWithoutTeam :: SAML.Issuer -> TypedState -> GetIdPResult SAML.IdPId getIdByIssuerWithoutTeam iss mp = case filter (\idp -> idp ^. SAML.idpMetadata . SAML.edIssuer == iss) $ M.elems mp of - [] -> Eff.GetIdPNotFound - [a] -> Eff.GetIdPFound (a ^. SAML.idpId) - as@(_ : _ : _) -> Eff.GetIdPNonUnique ((^. SAML.idpId) <$> as) + [] -> GetIdPNotFound + [a] -> GetIdPFound (a ^. SAML.idpId) + as@(_ : _ : _) -> GetIdPNonUnique ((^. SAML.idpId) <$> as) getIdByIssuerWithTeam :: SAML.Issuer -> TeamId -> TypedState -> Maybe SAML.IdPId getIdByIssuerWithTeam iss team mp = @@ -86,8 +86,8 @@ getIdByIssuerWithTeam iss team mp = [] -> Nothing [a] -> Just (a ^. SAML.idpId) (_ : _ : _) -> - -- (Eff.StoreConfig doesn't let this happen) - error "Eff.GetIdByIssuerWithTeam: impossible" + -- (StoreConfig doesn't let this happen) + error "GetIdByIssuerWithTeam: impossible" where fl :: IP.IdP -> Bool fl idp = diff --git a/services/spar/src/Spar/Sem/IdP/Spec.hs b/services/spar/src/Spar/Sem/IdPConfigStore/Spec.hs similarity index 67% rename from services/spar/src/Spar/Sem/IdP/Spec.hs rename to services/spar/src/Spar/Sem/IdPConfigStore/Spec.hs index a4623be94bf..4edc680f99b 100644 --- a/services/spar/src/Spar/Sem/IdP/Spec.hs +++ b/services/spar/src/Spar/Sem/IdPConfigStore/Spec.hs @@ -21,7 +21,7 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.IdP.Spec (propsForInterpreter) where +module Spar.Sem.IdPConfigStore.Spec (propsForInterpreter) where import Control.Arrow import Control.Lens @@ -31,7 +31,7 @@ import Polysemy import Polysemy.Check import SAML2.WebSSO.Types import qualified SAML2.WebSSO.Types as SAML -import qualified Spar.Sem.IdP as E +import Spar.Sem.IdPConfigStore import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck @@ -39,10 +39,10 @@ import qualified Wire.API.User.IdentityProvider as IP deriving instance Data IdPId -deriving instance Data (E.GetIdPResult IdPId) +deriving instance Data (GetIdPResult IdPId) propsForInterpreter :: - (Member E.IdP r, PropConstraints r f) => + (Member IdPConfigStore r, PropConstraints r f) => String -> (forall x. f x -> x) -> (forall x. Show x => Maybe (f x -> String)) -> @@ -62,18 +62,18 @@ propsForInterpreter interpreter extract labeler lower = do prop "storeConfig/storeConfig (different keys)" $ prop_storeStoreInterleave Nothing lower prop "storeConfig/storeConfig (same keys)" $ prop_storeStore Nothing lower -getReplacedBy :: Member E.IdP r => SAML.IdPId -> Sem r (Maybe (Maybe SAML.IdPId)) -getReplacedBy idpid = fmap (view $ SAML.idpExtraInfo . IP.wiReplacedBy) <$> E.getConfig idpid +getReplacedBy :: Member IdPConfigStore r => SAML.IdPId -> Sem r (Maybe (Maybe SAML.IdPId)) +getReplacedBy idpid = fmap (view $ SAML.idpExtraInfo . IP.wiReplacedBy) <$> getConfig idpid -- | All the constraints we need to generalize properties in this module. -- A regular type synonym doesn't work due to dreaded impredicative -- polymorphism. class - (Arbitrary Issuer, CoArbitrary Issuer, Arbitrary E.Replaced, Arbitrary E.Replaced, Arbitrary E.Replacing, Arbitrary IdPId, CoArbitrary IdPId, Arbitrary IP.IdP, CoArbitrary IP.IdP, CoArbitrary (E.GetIdPResult IdPId), Functor f, Member E.IdP r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + (Arbitrary Issuer, CoArbitrary Issuer, Arbitrary Replaced, Arbitrary Replaced, Arbitrary Replacing, Arbitrary IdPId, CoArbitrary IdPId, Arbitrary IP.IdP, CoArbitrary IP.IdP, CoArbitrary (GetIdPResult IdPId), Functor f, Member IdPConfigStore r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => PropConstraints r f instance - (Arbitrary Issuer, CoArbitrary Issuer, Arbitrary E.Replaced, Arbitrary E.Replaced, Arbitrary E.Replacing, Arbitrary IdPId, CoArbitrary IdPId, Arbitrary IP.IdP, CoArbitrary IP.IdP, CoArbitrary (E.GetIdPResult IdPId), Functor f, Member E.IdP r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => + (Arbitrary Issuer, CoArbitrary Issuer, Arbitrary Replaced, Arbitrary Replaced, Arbitrary Replacing, Arbitrary IdPId, CoArbitrary IdPId, Arbitrary IP.IdP, CoArbitrary IP.IdP, CoArbitrary (GetIdPResult IdPId), Functor f, Member IdPConfigStore r, forall z. Show z => Show (f z), forall z. Eq z => Eq (f z)) => PropConstraints r f prop_storeStore :: @@ -82,18 +82,18 @@ prop_storeStore :: (forall x. Sem r x -> IO (f x)) -> Property prop_storeStore = - prepropLaw @'[E.IdP] $ do + prepropLaw @'[IdPConfigStore] $ do s <- arbitrary s' <- arbitrary pure $ Law { lawLhs = do - E.storeConfig $ s & SAML.idpId .~ s' ^. SAML.idpId - E.storeConfig s', + storeConfig $ s & SAML.idpId .~ s' ^. SAML.idpId + storeConfig s', lawRhs = do - E.storeConfig s', + storeConfig s', lawPrelude = [], - lawPostlude = [E.getConfig $ s' ^. SAML.idpId] + lawPostlude = [getConfig $ s' ^. SAML.idpId] } prop_storeStoreInterleave :: @@ -102,7 +102,7 @@ prop_storeStoreInterleave :: (forall x. Sem r x -> IO (f x)) -> Property prop_storeStoreInterleave = - prepropLaw @'[E.IdP] $ do + prepropLaw @'[IdPConfigStore] $ do s <- arbitrary s' <- arbitrary !_ <- @@ -110,13 +110,13 @@ prop_storeStoreInterleave = pure $ Law { lawLhs = do - E.storeConfig s - E.storeConfig s', + storeConfig s + storeConfig s', lawRhs = do - E.storeConfig s' - E.storeConfig s, + storeConfig s' + storeConfig s, lawPrelude = [], - lawPostlude = [E.getConfig $ s ^. SAML.idpId, E.getConfig $ s' ^. SAML.idpId] + lawPostlude = [getConfig $ s ^. SAML.idpId, getConfig $ s' ^. SAML.idpId] } prop_storeGet :: @@ -125,17 +125,17 @@ prop_storeGet :: (forall x. Sem r x -> IO (f x)) -> Property prop_storeGet = - prepropLaw @'[E.IdP] $ + prepropLaw @'[IdPConfigStore] $ do s <- arbitrary pure $ simpleLaw ( do - E.storeConfig s - E.getConfig $ s ^. idpId + storeConfig s + getConfig $ s ^. idpId ) ( do - E.storeConfig s + storeConfig s pure (Just s) ) @@ -145,18 +145,18 @@ prop_deleteGet :: (forall x. Sem r x -> IO (f x)) -> Property prop_deleteGet = - prepropLaw @'[E.IdP] $ do + prepropLaw @'[IdPConfigStore] $ do s <- arbitrary pure $ Law { lawLhs = do - E.deleteConfig s - E.getConfig $ s ^. SAML.idpId, + deleteConfig s + getConfig $ s ^. SAML.idpId, lawRhs = do - E.deleteConfig s + deleteConfig s pure Nothing, lawPrelude = - [ E.storeConfig s + [ storeConfig s ], lawPostlude = [] :: [Sem r ()] } @@ -167,37 +167,37 @@ prop_deleteDelete :: (forall x. Sem r x -> IO (f x)) -> Property prop_deleteDelete = - prepropLaw @'[E.IdP] $ do + prepropLaw @'[IdPConfigStore] $ do s <- arbitrary pure $ simpleLaw ( do - E.deleteConfig s - E.deleteConfig s + deleteConfig s + deleteConfig s ) ( do - E.deleteConfig s + deleteConfig s ) prop_storeGetByIssuer :: PropConstraints r f => - Maybe (f (E.GetIdPResult IdPId) -> String) -> + Maybe (f (GetIdPResult IdPId) -> String) -> (forall x. Sem r x -> IO (f x)) -> Property prop_storeGetByIssuer = - prepropLaw @'[E.IdP] $ + prepropLaw @'[IdPConfigStore] $ do s <- arbitrary pure $ simpleLaw ( do - E.storeConfig s - E.getIdByIssuerWithoutTeam $ s ^. idpMetadata . edIssuer + storeConfig s + getIdByIssuerWithoutTeam $ s ^. idpMetadata . edIssuer ) ( do - E.storeConfig s - -- NOT TRUE! This can also return E.GetIdPNonUnique with nonzero probability! - pure $ E.GetIdPFound $ s ^. idpId + storeConfig s + -- NOT TRUE! This can also return GetIdPNonUnique with nonzero probability! + pure $ GetIdPFound $ s ^. idpId ) prop_setClear :: @@ -206,23 +206,23 @@ prop_setClear :: (forall x. Sem r x -> IO (f x)) -> Property prop_setClear = - prepropLaw @'[E.IdP] $ + prepropLaw @'[IdPConfigStore] $ do idp <- arbitrary replaced_id <- arbitrary - let replaced = E.Replaced replaced_id + let replaced = Replaced replaced_id replacing <- arbitrary pure $ Law { lawLhs = do - E.setReplacedBy replaced replacing - E.clearReplacedBy replaced + setReplacedBy replaced replacing + clearReplacedBy replaced getReplacedBy replaced_id, lawRhs = do - E.clearReplacedBy replaced + clearReplacedBy replaced getReplacedBy replaced_id, lawPrelude = - [ E.storeConfig $ idp & SAML.idpId .~ replaced_id + [ storeConfig $ idp & SAML.idpId .~ replaced_id ], lawPostlude = [] @(Sem _ ()) } @@ -234,19 +234,19 @@ prop_getGet :: (forall x. Sem r x -> IO (f x)) -> Property prop_getGet = - prepropLaw @'[E.IdP] $ + prepropLaw @'[IdPConfigStore] $ do idpid <- arbitrary idp <- arbitrary pure $ Law { lawLhs = do - liftA2 (,) (E.getConfig idpid) (E.getConfig idpid), + liftA2 (,) (getConfig idpid) (getConfig idpid), lawRhs = do - cfg <- E.getConfig idpid + cfg <- getConfig idpid pure (cfg, cfg), lawPrelude = - [ E.storeConfig $ idp & SAML.idpId .~ idpid + [ storeConfig $ idp & SAML.idpId .~ idpid ], lawPostlude = [] :: [Sem r ()] } @@ -257,7 +257,7 @@ prop_getStore :: (forall x. Sem r x -> IO (f x)) -> Property prop_getStore = - prepropLaw @'[E.IdP] $ + prepropLaw @'[IdPConfigStore] $ do idpid <- arbitrary s <- arbitrary @@ -265,15 +265,15 @@ prop_getStore = pure $ Law { lawLhs = do - r <- E.getConfig idpid - maybe (pure ()) E.storeConfig r + r <- getConfig idpid + maybe (pure ()) storeConfig r pure r, lawRhs = do - E.getConfig idpid, + getConfig idpid, lawPrelude = - [E.storeConfig s'], + [storeConfig s'], lawPostlude = - [E.getConfig idpid] + [getConfig idpid] } prop_setSet :: @@ -282,25 +282,25 @@ prop_setSet :: (forall x. Sem r x -> IO (f x)) -> Property prop_setSet = - prepropLaw @'[E.IdP] $ + prepropLaw @'[IdPConfigStore] $ do replaced_id <- arbitrary s <- arbitrary let s' = s & SAML.idpId .~ replaced_id - let replaced = E.Replaced replaced_id + let replaced = Replaced replaced_id replacing <- arbitrary replacing' <- arbitrary pure $ Law { lawLhs = do - E.setReplacedBy replaced replacing - E.setReplacedBy replaced replacing' + setReplacedBy replaced replacing + setReplacedBy replaced replacing' getReplacedBy replaced_id, lawRhs = do - E.setReplacedBy replaced replacing' + setReplacedBy replaced replacing' getReplacedBy replaced_id, lawPrelude = - [E.storeConfig s'], + [storeConfig s'], lawPostlude = [] @(Sem _ ()) } @@ -310,23 +310,23 @@ prop_setGet :: (forall x. Sem r x -> IO (f x)) -> Property prop_setGet = - prepropLaw @'[E.IdP] $ + prepropLaw @'[IdPConfigStore] $ do idp <- arbitrary replaced_id <- arbitrary - let replaced = E.Replaced replaced_id + let replaced = Replaced replaced_id replacing_id <- arbitrary - let replacing = E.Replacing replacing_id + let replacing = Replacing replacing_id pure $ Law { lawLhs = do - E.setReplacedBy replaced replacing + setReplacedBy replaced replacing getReplacedBy replaced_id, lawRhs = do - E.setReplacedBy replaced replacing - (Just replacing_id <$) <$> E.getConfig replaced_id, + setReplacedBy replaced replacing + (Just replacing_id <$) <$> getConfig replaced_id, lawPrelude = - [ E.storeConfig $ idp & SAML.idpId .~ replaced_id + [ storeConfig $ idp & SAML.idpId .~ replaced_id ], lawPostlude = [] :: [Sem r ()] } diff --git a/services/spar/src/Spar/Sem/IdPRawMetadataStore.hs b/services/spar/src/Spar/Sem/IdPRawMetadataStore.hs index d7c714baad3..5876a74f9dc 100644 --- a/services/spar/src/Spar/Sem/IdPRawMetadataStore.hs +++ b/services/spar/src/Spar/Sem/IdPRawMetadataStore.hs @@ -15,7 +15,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.IdPRawMetadataStore where +module Spar.Sem.IdPRawMetadataStore + ( IdPRawMetadataStore (..), + store, + get, + delete, + ) +where import Imports import Polysemy diff --git a/services/spar/src/Spar/Sem/IdPRawMetadataStore/Cassandra.hs b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Cassandra.hs index ec9c8699371..e3e8111bc9c 100644 --- a/services/spar/src/Spar/Sem/IdPRawMetadataStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/IdPRawMetadataStore/Cassandra.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.IdPRawMetadataStore.Cassandra where +module Spar.Sem.IdPRawMetadataStore.Cassandra + ( idpRawMetadataStoreToCassandra, + ) +where import Cassandra as Cas import Control.Lens diff --git a/services/spar/src/Spar/Sem/Now.hs b/services/spar/src/Spar/Sem/Now.hs index 4ae386d1894..990be73846b 100644 --- a/services/spar/src/Spar/Sem/Now.hs +++ b/services/spar/src/Spar/Sem/Now.hs @@ -15,7 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.Now where +module Spar.Sem.Now + ( Now (..), + get, + boolTTL, + ) +where import Imports import Polysemy diff --git a/services/spar/src/Spar/Sem/Now/IO.hs b/services/spar/src/Spar/Sem/Now/IO.hs index 5332de646c4..da14981f176 100644 --- a/services/spar/src/Spar/Sem/Now/IO.hs +++ b/services/spar/src/Spar/Sem/Now/IO.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.Now.IO where +module Spar.Sem.Now.IO + ( nowToIO, + ) +where import Imports import Polysemy diff --git a/services/spar/src/Spar/Sem/Now/Input.hs b/services/spar/src/Spar/Sem/Now/Input.hs index f425f5cfcf8..b00743be48f 100644 --- a/services/spar/src/Spar/Sem/Now/Input.hs +++ b/services/spar/src/Spar/Sem/Now/Input.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.Now.Input where +module Spar.Sem.Now.Input + ( nowToInput, + ) +where import Imports import Polysemy diff --git a/services/spar/src/Spar/Sem/Random.hs b/services/spar/src/Spar/Sem/Random.hs index e89b540f05f..1b626a10a02 100644 --- a/services/spar/src/Spar/Sem/Random.hs +++ b/services/spar/src/Spar/Sem/Random.hs @@ -15,7 +15,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.Random where +module Spar.Sem.Random + ( Random (..), + bytes, + uuid, + scimTokenId, + ) +where import Data.Id (ScimTokenId) import Data.UUID (UUID) diff --git a/services/spar/src/Spar/Sem/Random/IO.hs b/services/spar/src/Spar/Sem/Random/IO.hs index f3a6b553f52..e5d2e95ef47 100644 --- a/services/spar/src/Spar/Sem/Random/IO.hs +++ b/services/spar/src/Spar/Sem/Random/IO.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.Random.IO where +module Spar.Sem.Random.IO + ( randomToIO, + ) +where import Data.Id (randomId) import qualified Data.UUID.V4 as UUID diff --git a/services/spar/src/Spar/Sem/Reporter.hs b/services/spar/src/Spar/Sem/Reporter.hs index cb988ca2d15..9b4b77214ad 100644 --- a/services/spar/src/Spar/Sem/Reporter.hs +++ b/services/spar/src/Spar/Sem/Reporter.hs @@ -15,7 +15,11 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.Reporter where +module Spar.Sem.Reporter + ( Reporter (..), + report, + ) +where import Imports import qualified Network.Wai as Wai diff --git a/services/spar/src/Spar/Sem/Reporter/Wai.hs b/services/spar/src/Spar/Sem/Reporter/Wai.hs index 100934b3687..a5ae93fe5ca 100644 --- a/services/spar/src/Spar/Sem/Reporter/Wai.hs +++ b/services/spar/src/Spar/Sem/Reporter/Wai.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.Reporter.Wai where +module Spar.Sem.Reporter.Wai + ( reporterToTinyLogWai, + ) +where import Imports import qualified Network.Wai.Utilities.Server as Wai diff --git a/services/spar/src/Spar/Sem/SAML2.hs b/services/spar/src/Spar/Sem/SAML2.hs index ece4d90101f..7e053f105e8 100644 --- a/services/spar/src/Spar/Sem/SAML2.hs +++ b/services/spar/src/Spar/Sem/SAML2.hs @@ -15,15 +15,22 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.SAML2 where +module Spar.Sem.SAML2 + ( SAML2 (..), + authReq, + authResp, + meta, + toggleCookie, + ) +where import Data.Id (TeamId) import Data.String.Conversions (SBS, ST) import Data.Time (NominalDiffTime) import GHC.TypeLits (KnownSymbol) -import Imports hiding (log) +import Imports (Maybe) import Polysemy -import SAML2.WebSSO +import SAML2.WebSSO hiding (meta, toggleCookie) import URI.ByteString (URI) data SAML2 m a where diff --git a/services/spar/src/Spar/Sem/SAML2/Library.hs b/services/spar/src/Spar/Sem/SAML2/Library.hs index d6f331e4edc..176152b475f 100644 --- a/services/spar/src/Spar/Sem/SAML2/Library.hs +++ b/services/spar/src/Spar/Sem/SAML2/Library.hs @@ -39,7 +39,7 @@ import Spar.Sem.AReqIDStore (AReqIDStore) import qualified Spar.Sem.AReqIDStore as AReqIDStore import Spar.Sem.AssIDStore (AssIDStore) import qualified Spar.Sem.AssIDStore as AssIDStore -import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.IdPConfigStore (IdPConfigStore) import Spar.Sem.Logger (Logger) import qualified Spar.Sem.Logger as Logger import Spar.Sem.SAML2 @@ -88,7 +88,7 @@ instance Members '[Error SparError, Final IO, AssIDStore] r => SPStoreID Asserti unStoreID = wrapMonadClientSPImpl . AssIDStore.unStore isAliveID = wrapMonadClientSPImpl . AssIDStore.isAlive -instance Members '[Error SparError, IdPEffect.IdP, Final IO] r => SPStoreIdP SparError (SPImpl r) where +instance Members '[Error SparError, IdPConfigStore, Final IO] r => SPStoreIdP SparError (SPImpl r) where type IdPConfigExtra (SPImpl r) = WireIdP type IdPConfigSPId (SPImpl r) = TeamId @@ -109,7 +109,7 @@ saml2ToSaml2WebSso :: '[ AReqIDStore, AssIDStore, Error SparError, - IdPEffect.IdP, + IdPConfigStore, Input Opts, Logger String, Embed IO, @@ -149,7 +149,7 @@ inspectOrBomb :: '[ AReqIDStore, AssIDStore, Error SparError, - IdPEffect.IdP, + IdPConfigStore, Logger String, Input Opts, Embed IO, diff --git a/services/spar/src/Spar/Sem/SAMLUserStore.hs b/services/spar/src/Spar/Sem/SAMLUserStore.hs index 8c867dac2a2..638fe0dc947 100644 --- a/services/spar/src/Spar/Sem/SAMLUserStore.hs +++ b/services/spar/src/Spar/Sem/SAMLUserStore.hs @@ -15,7 +15,16 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.SAMLUserStore where +module Spar.Sem.SAMLUserStore + ( SAMLUserStore (..), + insert, + get, + getAnyByIssuer, + getSomeByIssuer, + deleteByIssuer, + delete, + ) +where import Data.Id import Imports diff --git a/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs b/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs index 38b8a4db47f..ea46bf0ff7c 100644 --- a/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/SAMLUserStore/Cassandra.hs @@ -17,22 +17,20 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.SAMLUserStore.Cassandra where +module Spar.Sem.SAMLUserStore.Cassandra + ( samlUserStoreToCassandra, + ) +where import Cassandra as Cas import Control.Lens -import qualified Control.Monad.Catch as Catch import Control.Monad.Except import Data.Id -import Data.String.Conversions import Imports import Polysemy -import Polysemy.Error -import Polysemy.Final import qualified SAML2.WebSSO as SAML import qualified Spar.Data as Data import Spar.Data.Instances () -import Spar.Error import Spar.Sem.SAMLUserStore samlUserStoreToCassandra :: @@ -50,19 +48,6 @@ samlUserStoreToCassandra = DeleteByIssuer is -> deleteSAMLUsersByIssuer is Delete uid ur -> deleteSAMLUser uid ur --- TODO(sandy): move me -interpretClientToIO :: - Members '[Error SparError, Final IO] r => - ClientState -> - Sem (Embed Client ': r) a -> - Sem r a -interpretClientToIO ctx = interpret $ \case - Embed action -> withStrategicToFinal @IO $ do - action' <- liftS $ runClient ctx action - st <- getInitialStateS - handler' <- bindS $ throw @SparError . SAML.CustomError . SparCassandraError . cs . show @SomeException - pure $ action' `Catch.catch` \e -> handler' $ e <$ st - -- | Add new user. If user with this 'SAML.UserId' exists, overwrite it. insertSAMLUser :: (HasCallStack, MonadClient m) => SAML.UserRef -> UserId -> m () insertSAMLUser (SAML.UserRef tenant subject) uid = retry x5 . write ins $ params LocalQuorum (tenant, Data.normalizeQualifiedNameId subject, subject, uid) diff --git a/services/spar/src/Spar/Sem/SAMLUserStore/Mem.hs b/services/spar/src/Spar/Sem/SAMLUserStore/Mem.hs index 2ff916517b1..f5ea68272e8 100644 --- a/services/spar/src/Spar/Sem/SAMLUserStore/Mem.hs +++ b/services/spar/src/Spar/Sem/SAMLUserStore/Mem.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.SAMLUserStore.Mem where +module Spar.Sem.SAMLUserStore.Mem + ( samlUserStoreToMem, + ) +where import Control.Lens (view) import Data.Coerce (coerce) diff --git a/services/spar/src/Spar/Sem/SamlProtocolSettings.hs b/services/spar/src/Spar/Sem/SamlProtocolSettings.hs index f2bbc33bb57..d99582349dc 100644 --- a/services/spar/src/Spar/Sem/SamlProtocolSettings.hs +++ b/services/spar/src/Spar/Sem/SamlProtocolSettings.hs @@ -15,7 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.SamlProtocolSettings where +module Spar.Sem.SamlProtocolSettings + ( SamlProtocolSettings (..), + spIssuer, + responseURI, + ) +where import Data.Id (TeamId) import Imports diff --git a/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs index 0407b76a0e3..64bac454109 100644 --- a/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs +++ b/services/spar/src/Spar/Sem/SamlProtocolSettings/Servant.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.SamlProtocolSettings.Servant where +module Spar.Sem.SamlProtocolSettings.Servant + ( sparRouteToServant, + ) +where import Imports import Polysemy diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore.hs index 29a1b1d9dbe..c21a95b3cdd 100644 --- a/services/spar/src/Spar/Sem/ScimExternalIdStore.hs +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore.hs @@ -15,10 +15,16 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.ScimExternalIdStore where +module Spar.Sem.ScimExternalIdStore + ( ScimExternalIdStore (..), + insert, + lookup, + delete, + ) +where import Data.Id (TeamId, UserId) -import Imports +import Imports (Maybe, Show) import Polysemy import Polysemy.Check (deriveGenericK) import Wire.API.User.Identity (Email) diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore/Cassandra.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore/Cassandra.hs index 02549c5f826..f6ed28adce7 100644 --- a/services/spar/src/Spar/Sem/ScimExternalIdStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore/Cassandra.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.ScimExternalIdStore.Cassandra where +module Spar.Sem.ScimExternalIdStore.Cassandra + ( scimExternalIdStoreToCassandra, + ) +where import Brig.Types.Common (Email, fromEmail) import Cassandra diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs index 2f57d3cfa5b..03b742c3a60 100644 --- a/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.ScimExternalIdStore.Mem where +module Spar.Sem.ScimExternalIdStore.Mem + ( scimExternalIdStoreToMem, + ) +where import Data.Id (TeamId, UserId) import qualified Data.Map as M diff --git a/services/spar/src/Spar/Sem/ScimTokenStore.hs b/services/spar/src/Spar/Sem/ScimTokenStore.hs index 0cafcfd2997..1c42d5e98b1 100644 --- a/services/spar/src/Spar/Sem/ScimTokenStore.hs +++ b/services/spar/src/Spar/Sem/ScimTokenStore.hs @@ -15,10 +15,18 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.ScimTokenStore where +module Spar.Sem.ScimTokenStore + ( ScimTokenStore (..), + insert, + lookup, + lookupByTeam, + delete, + deleteByTeam, + ) +where import Data.Id -import Imports +import Imports (Maybe) import Polysemy import Wire.API.User.Scim diff --git a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs index 4b9b7a1ee8c..e2b7f727920 100644 --- a/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/ScimTokenStore/Cassandra.hs @@ -18,7 +18,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.ScimTokenStore.Cassandra where +module Spar.Sem.ScimTokenStore.Cassandra + ( scimTokenStoreToCassandra, + ) +where import Cassandra as Cas import Control.Arrow (Arrow ((&&&))) diff --git a/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs b/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs index c815f823055..7793369ab1a 100644 --- a/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs +++ b/services/spar/src/Spar/Sem/ScimTokenStore/Mem.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.ScimTokenStore.Mem where +module Spar.Sem.ScimTokenStore.Mem + ( scimTokenStoreToMem, + ) +where import qualified Data.Map as M import Imports diff --git a/services/spar/src/Spar/Sem/ScimUserTimesStore.hs b/services/spar/src/Spar/Sem/ScimUserTimesStore.hs index 61c940384d3..afbd89e1075 100644 --- a/services/spar/src/Spar/Sem/ScimUserTimesStore.hs +++ b/services/spar/src/Spar/Sem/ScimUserTimesStore.hs @@ -15,11 +15,17 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.ScimUserTimesStore where +module Spar.Sem.ScimUserTimesStore + ( ScimUserTimesStore (..), + write, + read, + delete, + ) +where import Data.Id (UserId) import Data.Json.Util (UTCTimeMillis) -import Imports +import Imports (Maybe) import Polysemy import Web.Scim.Schema.Common (WithId) import Web.Scim.Schema.Meta (WithMeta) diff --git a/services/spar/src/Spar/Sem/ScimUserTimesStore/Cassandra.hs b/services/spar/src/Spar/Sem/ScimUserTimesStore/Cassandra.hs index ec8036eab92..689b47b9b63 100644 --- a/services/spar/src/Spar/Sem/ScimUserTimesStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/ScimUserTimesStore/Cassandra.hs @@ -15,7 +15,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.ScimUserTimesStore.Cassandra where +module Spar.Sem.ScimUserTimesStore.Cassandra + ( scimUserTimesStoreToCassandra, + ) +where import Cassandra as Cas import Data.Id diff --git a/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs b/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs index 1330f3938a3..85a2e5ab0e6 100644 --- a/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs +++ b/services/spar/src/Spar/Sem/ScimUserTimesStore/Mem.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.ScimUserTimesStore.Mem where +module Spar.Sem.ScimUserTimesStore.Mem + ( scimUserTimesStoreToMem, + ) +where import Data.Id (UserId) import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) diff --git a/services/spar/src/Spar/Sem/Utils.hs b/services/spar/src/Spar/Sem/Utils.hs new file mode 100644 index 00000000000..b082e57142a --- /dev/null +++ b/services/spar/src/Spar/Sem/Utils.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Spar.Sem.Utils (viaRunHttp, RunHttpEnv (..), interpretClientToIO, ttlErrorToSparError) where + +import Bilge +import Cassandra as Cas +import qualified Control.Monad.Catch as Catch +import Control.Monad.Except +import Data.String.Conversions +import Imports hiding (log) +import Polysemy +import Polysemy.Error +import Polysemy.Final +import qualified SAML2.WebSSO as SAML +import Spar.Error +import Spar.Intra.Brig (MonadSparToBrig (..)) +import Spar.Intra.Galley (MonadSparToGalley) +import qualified Spar.Intra.Galley as Intra +import Spar.Sem.Logger (Logger) +import qualified Spar.Sem.Logger as Logger +import Spar.Sem.Logger.TinyLog (fromLevel) +import qualified System.Logger as TinyLog +import qualified System.Logger.Class as TinyLog +import Wire.API.User.Saml + +-- | Run an embedded Cassandra 'Client' in @Final IO@. +interpretClientToIO :: + Members '[Error SparError, Final IO] r => + ClientState -> + Sem (Embed Client ': r) a -> + Sem r a +interpretClientToIO ctx = interpret $ \case + Embed action -> withStrategicToFinal @IO $ do + action' <- liftS $ runClient ctx action + st <- getInitialStateS + handler' <- bindS $ throw @SparError . SAML.CustomError . SparCassandraError . cs . show @SomeException + pure $ action' `Catch.catch` \e -> handler' $ e <$ st + +ttlErrorToSparError :: Member (Error SparError) r => Sem (Error TTLError ': r) a -> Sem r a +ttlErrorToSparError = mapError (SAML.CustomError . SparCassandraTTLError) + +data RunHttpEnv r = RunHttpEnv + { rheManager :: Bilge.Manager, + rheRequest :: Bilge.Request + } + +newtype RunHttp r a = RunHttp + { unRunHttp :: ReaderT (RunHttpEnv r) (ExceptT SparError (HttpT (Sem r))) a + } + deriving newtype (Functor, Applicative, Monad, MonadError SparError, MonadReader (RunHttpEnv r)) + +instance Member (Embed IO) r => MonadIO (RunHttp r) where + liftIO = semToRunHttp . embed + +instance Member (Embed IO) r => MonadHttp (RunHttp r) where + handleRequestWithCont r fribia = + RunHttp $ + lift $ + lift $ + handleRequestWithCont r fribia + +semToRunHttp :: Sem r a -> RunHttp r a +semToRunHttp = RunHttp . lift . lift . lift + +viaRunHttp :: + Members '[Error SparError, Embed IO] r => + RunHttpEnv r -> + RunHttp r a -> + Sem r a +viaRunHttp env m = do + ma <- runHttpT (rheManager env) $ runExceptT $ flip runReaderT env $ unRunHttp m + case ma of + Left err -> throw err + Right a -> pure a + +instance Member (Logger (TinyLog.Msg -> TinyLog.Msg)) r => TinyLog.MonadLogger (RunHttp r) where + log lvl msg = semToRunHttp $ Logger.log (fromLevel lvl) msg + +instance Members '[Logger (TinyLog.Msg -> TinyLog.Msg), Embed IO] r => MonadSparToGalley (RunHttp r) where + call modreq = do + req <- asks rheRequest + httpLbs req modreq + +instance Members '[Logger (TinyLog.Msg -> TinyLog.Msg), Embed IO] r => MonadSparToBrig (RunHttp r) where + call modreq = do + req <- asks rheRequest + httpLbs req modreq diff --git a/services/spar/src/Spar/Sem/VerdictFormatStore.hs b/services/spar/src/Spar/Sem/VerdictFormatStore.hs index 648214edd7a..0c4cb8e4a00 100644 --- a/services/spar/src/Spar/Sem/VerdictFormatStore.hs +++ b/services/spar/src/Spar/Sem/VerdictFormatStore.hs @@ -15,7 +15,12 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.VerdictFormatStore where +module Spar.Sem.VerdictFormatStore + ( VerdictFormatStore (..), + store, + get, + ) +where import Data.Time (NominalDiffTime) import Imports diff --git a/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs b/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs index aad436c686d..9c1f559fcd7 100644 --- a/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/VerdictFormatStore/Cassandra.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.VerdictFormatStore.Cassandra where +module Spar.Sem.VerdictFormatStore.Cassandra + ( verdictFormatStoreToCassandra, + ) +where import Cassandra as Cas import Control.Lens diff --git a/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs b/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs index 68457e971ab..62ea6a974eb 100644 --- a/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs +++ b/services/spar/src/Spar/Sem/VerdictFormatStore/Mem.hs @@ -17,7 +17,10 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Spar.Sem.VerdictFormatStore.Mem where +module Spar.Sem.VerdictFormatStore.Mem + ( verdictFormatStoreToMem, + ) +where import qualified Data.Map as M import Imports diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index e8213c0bba6..1ddf267512f 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -74,7 +74,7 @@ import SAML2.WebSSO.Test.Util import qualified Spar.Intra.BrigApp as Intra import qualified Spar.Sem.AReqIDStore as AReqIDStore import qualified Spar.Sem.BrigAccess as BrigAccess -import qualified Spar.Sem.IdP as IdPEffect +import qualified Spar.Sem.IdPConfigStore as IdPEffect import Text.XML.DSig (SignPrivCreds, mkSignCredsWithCert) import qualified URI.ByteString as URI import URI.ByteString.QQ (uri) diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index c29b402ba2d..f12c1217198 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -37,8 +37,8 @@ import Spar.Intra.BrigApp (veidFromUserSSOId) import qualified Spar.Sem.AReqIDStore as AReqIDStore import qualified Spar.Sem.AssIDStore as AssIDStore import qualified Spar.Sem.BindCookieStore as BindCookieStore -import Spar.Sem.IdP (GetIdPResult (..), Replaced (..), Replacing (..)) -import qualified Spar.Sem.IdP as IdPEffect +import Spar.Sem.IdPConfigStore (GetIdPResult (..), Replaced (..), Replacing (..)) +import qualified Spar.Sem.IdPConfigStore as IdPEffect import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import qualified Spar.Sem.VerdictFormatStore as VerdictFormatStore diff --git a/services/spar/test/Arbitrary.hs b/services/spar/test/Arbitrary.hs index 43143aa72f0..da0c37e79ac 100644 --- a/services/spar/test/Arbitrary.hs +++ b/services/spar/test/Arbitrary.hs @@ -32,7 +32,7 @@ import SAML2.WebSSO.Test.Arbitrary () import SAML2.WebSSO.Types import Servant.API.ContentTypes import Spar.Scim -import qualified Spar.Sem.IdP as E +import qualified Spar.Sem.IdPConfigStore as E import Test.QuickCheck import URI.ByteString import Wire.API.User.IdentityProvider diff --git a/services/spar/test/Test/Spar/Sem/IdPSpec.hs b/services/spar/test/Test/Spar/Sem/IdPConfigStoreSpec.hs similarity index 91% rename from services/spar/test/Test/Spar/Sem/IdPSpec.hs rename to services/spar/test/Test/Spar/Sem/IdPConfigStoreSpec.hs index b262380fd85..961f27773f1 100644 --- a/services/spar/test/Test/Spar/Sem/IdPSpec.hs +++ b/services/spar/test/Test/Spar/Sem/IdPConfigStoreSpec.hs @@ -21,13 +21,13 @@ -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . -module Test.Spar.Sem.IdPSpec where +module Test.Spar.Sem.IdPConfigStoreSpec where import Arbitrary () import Imports import Polysemy -import Spar.Sem.IdP.Mem -import Spar.Sem.IdP.Spec +import Spar.Sem.IdPConfigStore.Mem +import Spar.Sem.IdPConfigStore.Spec import Test.Hspec import Test.Hspec.QuickCheck diff --git a/stack.yaml.lock b/stack.yaml.lock index 1e1c531b533..29788eece7e 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -225,15 +225,15 @@ packages: commit: 7546a1a25635ef65183e3d44c1052285e8401608 - completed: name: hsaml2 - version: '0.1' + version: 0.1.1 git: https://github.com/wireapp/hsaml2 pantry-tree: - size: 3918 - sha256: 072d64ee1d974ed2170e4b0dacfeef2cb13ae62fe066211e93c0be0073f959a3 - commit: b652ec6e69d1647e827cbee0fa290605ac09dc63 + size: 3973 + sha256: a8f67572fb5a29f55b5c20e8257950f3350d0c808f2ae24703f4aa25c1b4c76a + commit: ef7b1de45ab0ea3a0a333b335579a02d8f88340c original: git: https://github.com/wireapp/hsaml2 - commit: b652ec6e69d1647e827cbee0fa290605ac09dc63 + commit: ef7b1de45ab0ea3a0a333b335579a02d8f88340c - completed: subdir: http-client name: http-client