Skip to content

Commit e83f366

Browse files
battermannbattermann
committed
postgres interpreter
1 parent 2987390 commit e83f366

4 files changed

Lines changed: 233 additions & 0 deletions

File tree

‎libs/wire-api/src/Wire/API/PostgresMarshall.hs‎

Lines changed: 59 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -36,12 +36,15 @@ import Data.Misc
3636
import Data.Profunctor
3737
import Data.Set qualified as Set
3838
import Data.Text qualified as Text
39+
import Data.Text.Ascii qualified as Ascii
3940
import Data.Text.Encoding qualified as Text
4041
import Data.UUID
4142
import Data.Vector (Vector)
4243
import Data.Vector qualified as V
4344
import Hasql.Statement
4445
import Imports
46+
import SAML2.WebSSO qualified as SAML
47+
import Wire.API.EnterpriseLogin
4548

4649
class PostgresMarshall db domain where
4750
postgresMarshall :: domain -> db
@@ -538,6 +541,33 @@ instance PostgresMarshall Text Code.Key where
538541
instance PostgresMarshall Text Code.Value where
539542
postgresMarshall = Text.decodeUtf8 . toByteString'
540543

544+
instance PostgresMarshall ByteString HttpsUrl where
545+
postgresMarshall = toByteString'
546+
547+
instance PostgresMarshall ByteString Token where
548+
postgresMarshall = (.unToken)
549+
550+
instance PostgresMarshall Text DnsVerificationToken where
551+
postgresMarshall = Ascii.toText . (.unDnsVerificationToken)
552+
553+
instance PostgresMarshall Int32 DomainRedirectTag where
554+
postgresMarshall = \case
555+
NoneTag -> 1
556+
LockedTag -> 2
557+
SSOTag -> 3
558+
BackendTag -> 4
559+
NoRegistrationTag -> 5
560+
PreAuthorizedTag -> 6
561+
562+
instance PostgresMarshall Int32 TeamInviteTag where
563+
postgresMarshall = \case
564+
AllowedTag -> 1
565+
NotAllowedTag -> 2
566+
TeamTag -> 3
567+
568+
instance PostgresMarshall UUID SAML.IdPId where
569+
postgresMarshall = SAML.fromIdPId
570+
541571
---
542572

543573
class PostgresUnmarshall db domain where
@@ -869,6 +899,35 @@ instance PostgresUnmarshall Text Code.Key where
869899
instance PostgresUnmarshall Text Code.Value where
870900
postgresUnmarshall = mapLeft Text.pack . BSC.runParser BSC.parser . Text.encodeUtf8
871901

902+
instance PostgresUnmarshall ByteString HttpsUrl where
903+
postgresUnmarshall = first Text.pack . BSC.runParser BSC.parser
904+
905+
instance PostgresUnmarshall ByteString Token where
906+
postgresUnmarshall = Right . Token
907+
908+
instance PostgresUnmarshall Text DnsVerificationToken where
909+
postgresUnmarshall = first Text.pack . fmap DnsVerificationToken . Ascii.validate
910+
911+
instance PostgresUnmarshall Int32 DomainRedirectTag where
912+
postgresUnmarshall = \case
913+
1 -> Right NoneTag
914+
2 -> Right LockedTag
915+
3 -> Right SSOTag
916+
4 -> Right BackendTag
917+
5 -> Right NoRegistrationTag
918+
6 -> Right PreAuthorizedTag
919+
n -> Left $ "Unexpected DomainRedirectTag value: " <> Text.pack (show n)
920+
921+
instance PostgresUnmarshall Int32 TeamInviteTag where
922+
postgresUnmarshall = \case
923+
1 -> Right AllowedTag
924+
2 -> Right NotAllowedTag
925+
3 -> Right TeamTag
926+
n -> Left $ "Unexpected TeamInviteTag value: " <> Text.pack (show n)
927+
928+
instance PostgresUnmarshall UUID SAML.IdPId where
929+
postgresUnmarshall = Right . SAML.IdPId
930+
872931
---
873932

874933
lmapPG :: (PostgresMarshall db domain, Profunctor p) => p db x -> p domain x

‎libs/wire-subsystems/src/Wire/DomainRegistrationStore.hs‎

Lines changed: 62 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE RecordWildCards #-}
12
{-# LANGUAGE TemplateHaskell #-}
23

34
-- This file is part of the Wire Server implementation.
@@ -25,6 +26,7 @@ module Wire.DomainRegistrationStore
2526
lookup,
2627
lookupByTeam,
2728
delete,
29+
DomainRegistrationRow,
2830
)
2931
where
3032

@@ -36,6 +38,7 @@ import Data.Domain as Domain
3638
import Data.Id
3739
import Data.Misc
3840
import Data.Text as T
41+
import Data.UUID (UUID)
3942
import Database.CQL.Protocol (Record (..), TupleType, recordInstance)
4043
import Imports hiding (lookup)
4144
import Polysemy
@@ -45,6 +48,7 @@ import Polysemy.TinyLog qualified as Log
4548
import SAML2.WebSSO qualified as SAML
4649
import System.Logger.Message qualified as Log
4750
import Wire.API.EnterpriseLogin
51+
import Wire.API.PostgresMarshall
4852

4953
newtype DomainKey = DomainKey {unDomainKey :: CI Text}
5054
deriving stock (Eq, Ord, Show)
@@ -61,6 +65,64 @@ instance Cql DomainKey where
6165
fromCql (CqlText txt) = pure . DomainKey . CI.mk $ txt
6266
fromCql _ = Left "DomainKey: Text expected"
6367

68+
instance PostgresMarshall Text DomainKey where
69+
postgresMarshall = CI.foldedCase . unDomainKey
70+
71+
instance PostgresUnmarshall Text DomainKey where
72+
postgresUnmarshall = Right . DomainKey . CI.mk
73+
74+
type DomainRegistrationRow =
75+
( Text,
76+
Maybe Int32,
77+
Maybe Int32,
78+
Maybe UUID,
79+
Maybe ByteString,
80+
Maybe UUID,
81+
Maybe Text,
82+
Maybe ByteString,
83+
Maybe UUID,
84+
Maybe ByteString
85+
)
86+
87+
instance PostgresMarshall DomainRegistrationRow StoredDomainRegistration where
88+
postgresMarshall StoredDomainRegistration {..} =
89+
( postgresMarshall domain,
90+
postgresMarshall domainRedirect,
91+
postgresMarshall teamInvite,
92+
postgresMarshall idpId,
93+
postgresMarshall backendUrl,
94+
postgresMarshall team,
95+
postgresMarshall dnsVerificationToken,
96+
postgresMarshall authTokenHash,
97+
postgresMarshall authorizedTeam,
98+
postgresMarshall webappUrl
99+
)
100+
101+
instance PostgresUnmarshall DomainRegistrationRow StoredDomainRegistration where
102+
postgresUnmarshall
103+
( domain,
104+
domainRedirect,
105+
teamInvite,
106+
idpId,
107+
backendUrl,
108+
team,
109+
dnsVerificationToken,
110+
authTokenHash,
111+
authorizedTeam,
112+
webappUrl
113+
) =
114+
StoredDomainRegistration
115+
<$> postgresUnmarshall domain
116+
<*> postgresUnmarshall domainRedirect
117+
<*> postgresUnmarshall teamInvite
118+
<*> postgresUnmarshall idpId
119+
<*> postgresUnmarshall backendUrl
120+
<*> postgresUnmarshall team
121+
<*> postgresUnmarshall dnsVerificationToken
122+
<*> postgresUnmarshall authTokenHash
123+
<*> postgresUnmarshall authorizedTeam
124+
<*> postgresUnmarshall webappUrl
125+
64126
data StoredDomainRegistration = StoredDomainRegistration
65127
{ domain :: DomainKey,
66128
domainRedirect :: Maybe DomainRedirectTag,

‎libs/wire-subsystems/src/Wire/DomainRegistrationStore/Postgres.hs‎

Lines changed: 111 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,111 @@
1+
{-# LANGUAGE RecordWildCards #-}
2+
3+
-- This file is part of the Wire Server implementation.
4+
--
5+
-- Copyright (C) 2026 Wire Swiss GmbH <opensource@wire.com>
6+
--
7+
-- This program is free software: you can redistribute it and/or modify it under
8+
-- the terms of the GNU Affero General Public License as published by the Free
9+
-- Software Foundation, either version 3 of the License, or (at your option) any
10+
-- later version.
11+
--
12+
-- This program is distributed in the hope that it will be useful, but WITHOUT
13+
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
14+
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
15+
-- details.
16+
--
17+
-- You should have received a copy of the GNU Affero General Public License along
18+
-- with this program. If not, see <https://www.gnu.org/licenses/>.
19+
20+
module Wire.DomainRegistrationStore.Postgres
21+
( interpretDomainRegistrationStoreToPostgres,
22+
)
23+
where
24+
25+
import Data.Id (TeamId)
26+
import Data.UUID (UUID)
27+
import Data.Vector (Vector)
28+
import Data.Vector qualified as Vector
29+
import Hasql.Statement qualified as Hasql
30+
import Hasql.TH
31+
import Imports hiding (lookup)
32+
import Polysemy
33+
import Wire.API.PostgresMarshall
34+
import Wire.DomainRegistrationStore
35+
import Wire.Postgres
36+
37+
interpretDomainRegistrationStoreToPostgres ::
38+
(PGConstraints r) =>
39+
InterpreterFor DomainRegistrationStore r
40+
interpretDomainRegistrationStoreToPostgres = interpret $ \case
41+
UpsertInternal dr -> upsertImpl dr
42+
LookupInternal domain -> lookupImpl domain
43+
LookupByTeamInternal tid -> lookupByTeamInternalImpl tid
44+
DeleteInternal domain -> deleteImpl domain
45+
46+
upsertImpl :: (PGConstraints r) => StoredDomainRegistration -> Sem r ()
47+
upsertImpl dr =
48+
runStatement dr upsertStatement
49+
where
50+
upsertStatement :: Hasql.Statement StoredDomainRegistration ()
51+
upsertStatement =
52+
lmapPG
53+
[resultlessStatement|INSERT INTO domain_registration
54+
(domain, domain_redirect, team_invite, idp_id, backend_url,
55+
team, dns_verification_token, ownership_token_hash, authorized_team, webapp_url)
56+
VALUES
57+
($1 :: text, $2 :: int?, $3 :: int?, $4 :: uuid?, $5 :: bytea?,
58+
$6 :: uuid?, $7 :: text?, $8 :: bytea?, $9 :: uuid?, $10 :: bytea?)
59+
ON CONFLICT (domain) DO UPDATE
60+
SET domain_redirect = ($2 :: int?),
61+
team_invite = ($3 :: int?),
62+
idp_id = ($4 :: uuid?),
63+
backend_url = ($5 :: bytea?),
64+
team = ($6 :: uuid?),
65+
dns_verification_token = ($7 :: text?),
66+
ownership_token_hash = ($8 :: bytea?),
67+
authorized_team = ($9 :: uuid?),
68+
webapp_url = ($10 :: bytea?)
69+
|]
70+
71+
lookupImpl :: (PGConstraints r) => DomainKey -> Sem r (Maybe StoredDomainRegistration)
72+
lookupImpl domain =
73+
runStatement domain selectStatement
74+
where
75+
selectStatement :: Hasql.Statement DomainKey (Maybe StoredDomainRegistration)
76+
selectStatement =
77+
dimapPG @Text @DomainKey @(Maybe DomainRegistrationRow) @(Maybe StoredDomainRegistration) $
78+
[maybeStatement|SELECT (domain :: text), (domain_redirect :: int?), (team_invite :: int?),
79+
(idp_id :: uuid?), (backend_url :: bytea?), (team :: uuid?),
80+
(dns_verification_token :: text?), (ownership_token_hash :: bytea?),
81+
(authorized_team :: uuid?), (webapp_url :: bytea?)
82+
FROM domain_registration
83+
WHERE domain = ($1 :: text)
84+
|]
85+
86+
lookupByTeamInternalImpl :: (PGConstraints r) => TeamId -> Sem r [StoredDomainRegistration]
87+
lookupByTeamInternalImpl tid = do
88+
rows <- runStatement tid selectByTeamStatement
89+
pure $ Vector.toList rows
90+
where
91+
selectByTeamStatement :: Hasql.Statement TeamId (Vector StoredDomainRegistration)
92+
selectByTeamStatement =
93+
dimapPG @UUID @TeamId @(Vector DomainRegistrationRow) @(Vector StoredDomainRegistration) $
94+
[vectorStatement|SELECT (domain :: text), (domain_redirect :: int?), (team_invite :: int?),
95+
(idp_id :: uuid?), (backend_url :: bytea?), (team :: uuid?),
96+
(dns_verification_token :: text?), (ownership_token_hash :: bytea?),
97+
(authorized_team :: uuid?), (webapp_url :: bytea?)
98+
FROM domain_registration
99+
WHERE authorized_team = ($1 :: uuid)
100+
|]
101+
102+
deleteImpl :: (PGConstraints r) => DomainKey -> Sem r ()
103+
deleteImpl domain =
104+
runStatement domain deleteStatement
105+
where
106+
deleteStatement :: Hasql.Statement DomainKey ()
107+
deleteStatement =
108+
lmapPG
109+
[resultlessStatement|DELETE FROM domain_registration
110+
WHERE domain = ($1 :: text)
111+
|]

‎libs/wire-subsystems/wire-subsystems.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -268,6 +268,7 @@ library
268268
Wire.DeleteQueue.InMemory
269269
Wire.DomainRegistrationStore
270270
Wire.DomainRegistrationStore.Cassandra
271+
Wire.DomainRegistrationStore.Postgres
271272
Wire.DomainVerificationChallengeStore
272273
Wire.DomainVerificationChallengeStore.Cassandra
273274
Wire.EmailSending

0 commit comments

Comments
 (0)