Skip to content

Commit

Permalink
improve json serde and golden tests
Browse files Browse the repository at this point in the history
  • Loading branch information
battermann committed Dec 6, 2024
1 parent ebeb81d commit 43678eb
Show file tree
Hide file tree
Showing 16 changed files with 296 additions and 75 deletions.
162 changes: 87 additions & 75 deletions libs/wire-api/src/Wire/API/EnterpriseLogin.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,8 +2,10 @@

module Wire.API.EnterpriseLogin where

import Control.Lens (Field1 (_1), makePrisms)
import Control.Arrow
import Control.Lens (makePrisms)
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson qualified as Aeson
import Data.Domain
import Data.Id
import Data.Misc
Expand All @@ -19,6 +21,7 @@ data DomainRedirect
| Backend HttpsUrl
| NoRegistration
| PreAuthorized
deriving stock (Eq, Show)

makePrisms ''DomainRedirect

Expand All @@ -30,52 +33,56 @@ data DomainRedirectTag
| NoRegistrationTag
| PreAuthorizedTag
deriving (Eq, Enum, Bounded)
deriving (ToJSON, FromJSON, OpenApi.ToSchema) via Schema DomainRedirectTag

tagSchema :: ValueSchema NamedSwaggerDoc DomainRedirectTag
tagSchema =
enum @Text "DomainRedirect Tag" $
mconcat
[ element "none" NoneTag,
element "locked" LockedTag,
element "sso" SSOTag,
element "backend" BackendTag,
element "no-registration" NoRegistrationTag,
element "pre-authorized" PreAuthorizedTag
]

domainRedirectSchema :: ValueSchema NamedSwaggerDoc DomainRedirect
instance ToSchema DomainRedirectTag where
schema =
enum @Text "DomainRedirect Tag" $
mconcat
[ element "none" NoneTag,
element "locked" LockedTag,
element "sso" SSOTag,
element "backend" BackendTag,
element "no-registration" NoRegistrationTag,
element "pre-authorized" PreAuthorizedTag
]

domainRedirectTagSchema :: ObjectSchema SwaggerDoc DomainRedirectTag
domainRedirectTagSchema = field "domain_redirect" schema

domainRedirectSchema :: ObjectSchema SwaggerDoc DomainRedirect
domainRedirectSchema =
object "DomainRedirect" $
fromTagged
<$> toTagged
.= bind
(fst .= field "tag" tagSchema)
(snd .= fieldOver _1 "value" untaggedSchema)
snd
<$> (toTagged &&& id)
.= bind
(fst .= domainRedirectTagSchema)
(snd .= dispatch domainRedirectDataSchema)
where
toTagged :: DomainRedirect -> (DomainRedirectTag, DomainRedirect)
toTagged None = (NoneTag, None)
toTagged Locked = (LockedTag, Locked)
toTagged (SSO idpid) = (SSOTag, SSO idpid)
toTagged (Backend url) = (BackendTag, Backend url)
toTagged NoRegistration = (NoRegistrationTag, NoRegistration)
toTagged PreAuthorized = (PreAuthorizedTag, PreAuthorized)

fromTagged :: (DomainRedirectTag, DomainRedirect) -> DomainRedirect
fromTagged = snd

untaggedSchema = dispatch $ \case
NoneTag -> tag _None null_
LockedTag -> tag _Locked null_
SSOTag -> tag _SSO (unnamed samlIdPIdSchema)
BackendTag -> tag _Backend (unnamed schema)
NoRegistrationTag -> tag _NoRegistration null_
PreAuthorizedTag -> tag _PreAuthorized null_

samlIdPIdSchema :: ValueSchema NamedSwaggerDoc SAML.IdPId
samlIdPIdSchema = SAML.IdPId <$> SAML.fromIdPId .= uuidSchema
toTagged :: DomainRedirect -> DomainRedirectTag
toTagged None = NoneTag
toTagged Locked = LockedTag
toTagged (SSO _) = SSOTag
toTagged (Backend _) = BackendTag
toTagged NoRegistration = NoRegistrationTag
toTagged PreAuthorized = PreAuthorizedTag

domainRedirectDataSchema :: DomainRedirectTag -> ObjectSchema SwaggerDoc DomainRedirect
domainRedirectDataSchema = \case
NoneTag -> tag _None (pure ())
LockedTag -> tag _Locked (pure ())
SSOTag -> tag _SSO samlIdPIdSchema
BackendTag -> tag _Backend backendUrlSchema
NoRegistrationTag -> tag _NoRegistration (pure ())
PreAuthorizedTag -> tag _PreAuthorized (pure ())

samlIdPIdSchema :: ObjectSchema SwaggerDoc SAML.IdPId
samlIdPIdSchema = SAML.IdPId <$> SAML.fromIdPId .= field "sso_idp_id" uuidSchema

backendUrlSchema :: ObjectSchema SwaggerDoc HttpsUrl
backendUrlSchema = field "backend_url" schema

instance ToSchema DomainRedirect where
schema = domainRedirectSchema
schema = object "DomainRedirect " domainRedirectSchema

deriving via (Schema DomainRedirect) instance FromJSON DomainRedirect

Expand All @@ -87,6 +94,7 @@ data TeamInvite
= Allowed
| NotAllowed
| Team TeamId
deriving stock (Eq, Show)

makePrisms ''TeamInvite

Expand All @@ -95,40 +103,41 @@ data TeamInviteTag
| NotAllowedTag
| TeamTag
deriving (Eq, Enum, Bounded)
deriving (ToJSON, FromJSON, OpenApi.ToSchema) via Schema TeamInviteTag

instance ToSchema TeamInviteTag where
schema =
enum @Text "TeamInvite Tag" $
mconcat
[ element "allowed" AllowedTag,
element "not-allowed" NotAllowedTag,
element "team" TeamTag
]

teamInviteTagSchema :: ValueSchema NamedSwaggerDoc TeamInviteTag
teamInviteTagSchema =
enum @Text "TeamInvite Tag" $
mconcat
[ element "allowed" AllowedTag,
element "not-allowed" NotAllowedTag,
element "team" TeamTag
]
teamInviteTagSchema :: ObjectSchema SwaggerDoc TeamInviteTag
teamInviteTagSchema = field "team_invite" schema

teamInviteSchema :: ValueSchema NamedSwaggerDoc TeamInvite
teamInviteSchema :: ObjectSchema SwaggerDoc TeamInvite
teamInviteSchema =
object "TeamInvite" $
fromTagged
<$> toTagged
.= bind
(fst .= field "tag" teamInviteTagSchema)
(snd .= fieldOver _1 "value" untaggedSchema)
snd
<$> (toTagged &&& id)
.= bind
(fst .= teamInviteTagSchema)
(snd .= dispatch teamInviteDataSchema)
where
toTagged :: TeamInvite -> (TeamInviteTag, TeamInvite)
toTagged Allowed = (AllowedTag, Allowed)
toTagged NotAllowed = (NotAllowedTag, NotAllowed)
toTagged (Team teamId) = (TeamTag, Team teamId)

fromTagged :: (TeamInviteTag, TeamInvite) -> TeamInvite
fromTagged = snd
toTagged :: TeamInvite -> TeamInviteTag
toTagged Allowed = AllowedTag
toTagged NotAllowed = NotAllowedTag
toTagged (Team _) = TeamTag

untaggedSchema = dispatch $ \case
AllowedTag -> tag _Allowed null_
NotAllowedTag -> tag _NotAllowed null_
TeamTag -> tag _Team (unnamed schema)
teamInviteDataSchema :: TeamInviteTag -> ObjectSchema SwaggerDoc TeamInvite
teamInviteDataSchema = \case
AllowedTag -> tag _Allowed (pure ())
NotAllowedTag -> tag _NotAllowed (pure ())
TeamTag -> tag _Team (field "team" schema)

instance ToSchema TeamInvite where
schema = teamInviteSchema
schema = object "TeamInvite" teamInviteSchema

deriving via (Schema TeamInvite) instance FromJSON TeamInvite

Expand All @@ -137,6 +146,7 @@ deriving via (Schema TeamInvite) instance ToJSON TeamInvite
deriving via (Schema TeamInvite) instance OpenApi.ToSchema TeamInvite

newtype DnsVerificationToken = DnsVerificationToken {unDnsVerificationToken :: Text}
deriving stock (Eq, Show)
deriving (ToJSON, FromJSON, OpenApi.ToSchema) via Schema DnsVerificationToken

instance ToSchema DnsVerificationToken where
Expand All @@ -146,28 +156,30 @@ data DomainRegistrationUpdate = DomainRegistrationUpdate
{ domainRedirect :: DomainRedirect,
teamInvite :: TeamInvite
}
deriving stock (Eq, Show)
deriving (ToJSON, FromJSON, OpenApi.ToSchema) via Schema DomainRegistrationUpdate

instance ToSchema DomainRegistrationUpdate where
schema =
object "DomainRegistrationUpdate" $
DomainRegistrationUpdate
<$> (.domainRedirect) .= field "domain-redirect" schema
<*> (.teamInvite) .= field "team-invite" schema
<$> (.domainRedirect) .= domainRedirectSchema
<*> (.teamInvite) .= teamInviteSchema

data DomainRegistration = DomainRegistration
{ domain :: Domain,
domainRedirect :: DomainRedirect,
teamInvite :: TeamInvite,
dnsVerificationToken :: DnsVerificationToken
dnsVerificationToken :: Maybe DnsVerificationToken
}
deriving stock (Eq, Show)
deriving (ToJSON, FromJSON, OpenApi.ToSchema) via Schema DomainRegistration

instance ToSchema DomainRegistration where
schema =
object "DomainRegistration" $
DomainRegistration
<$> (.domain) .= field "domain" schema
<*> (.domainRedirect) .= field "domain-redirect" schema
<*> (.teamInvite) .= field "team-invite" schema
<*> (.dnsVerificationToken) .= field "dns-verification-token" schema
<*> (.domainRedirect) .= domainRedirectSchema
<*> (.teamInvite) .= teamInviteSchema
<*> (.dnsVerificationToken) .= optField "dns_verification_token" (maybeWithDefault Aeson.Null schema)
19 changes: 19 additions & 0 deletions libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,7 @@ import Test.Wire.API.Golden.Manual.ConversationsResponse
import Test.Wire.API.Golden.Manual.CreateGroupConversation
import Test.Wire.API.Golden.Manual.CreateScimToken
import Test.Wire.API.Golden.Manual.CreateScimTokenResponse
import Test.Wire.API.Golden.Manual.EnterpriseLogin
import Test.Wire.API.Golden.Manual.FeatureConfigEvent
import Test.Wire.API.Golden.Manual.FederationDomainConfig
import Test.Wire.API.Golden.Manual.FederationRestriction
Expand Down Expand Up @@ -317,5 +318,23 @@ tests =
testObjects
[ (testObject_InvitationUserView_team_1, "testObject_InvitationUserView_team_1.json"),
(testObject_InvitationUserView_team_2, "testObject_InvitationUserView_team_2.json")
],
testGroup "DomainRegistration" $
testObjects
[ (testObject_DomainRegistration_1, "testObject_DomainRegistration_1.json"),
(testObject_DomainRegistration_2, "testObject_DomainRegistration_2.json"),
(testObject_DomainRegistration_3, "testObject_DomainRegistration_3.json"),
(testObject_DomainRegistration_4, "testObject_DomainRegistration_4.json"),
(testObject_DomainRegistration_5, "testObject_DomainRegistration_5.json"),
(testObject_DomainRegistration_6, "testObject_DomainRegistration_6.json")
],
testGroup "DomainRegistrationUpdate" $
testObjects
[ (testObject_DomainRegistrationUpdate_1, "testObject_DomainRegistrationUpdate_1.json"),
(testObject_DomainRegistrationUpdate_2, "testObject_DomainRegistrationUpdate_2.json"),
(testObject_DomainRegistrationUpdate_3, "testObject_DomainRegistrationUpdate_3.json"),
(testObject_DomainRegistrationUpdate_4, "testObject_DomainRegistrationUpdate_4.json"),
(testObject_DomainRegistrationUpdate_5, "testObject_DomainRegistrationUpdate_5.json"),
(testObject_DomainRegistrationUpdate_6, "testObject_DomainRegistrationUpdate_6.json")
]
]
Original file line number Diff line number Diff line change
@@ -0,0 +1,123 @@
-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <[email protected]>
--
-- 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 <https://www.gnu.org/licenses/>.

module Test.Wire.API.Golden.Manual.EnterpriseLogin where

import Data.Domain (Domain (Domain))
import Data.Id
import Data.Misc (HttpsUrl (HttpsUrl))
import Data.UUID qualified as UUID
import Imports
import SAML2.WebSSO qualified as SAML
import URI.ByteString (parseURI, strictURIParserOptions)
import Wire.API.EnterpriseLogin

testObject_DomainRegistration_1 :: DomainRegistration
testObject_DomainRegistration_1 =
DomainRegistration
{ domain = Domain "example.com",
domainRedirect = Locked,
teamInvite = Allowed,
dnsVerificationToken = Nothing
}

testObject_DomainRegistration_2 :: DomainRegistration
testObject_DomainRegistration_2 =
DomainRegistration
{ domain = Domain "example.com",
domainRedirect = None,
teamInvite = NotAllowed,
dnsVerificationToken = Nothing
}

testObject_DomainRegistration_3 :: DomainRegistration
testObject_DomainRegistration_3 =
DomainRegistration
{ domain = Domain "example.com",
domainRedirect = SSO (SAML.IdPId $ fromJust (UUID.fromString "abf7c0b2-f4e6-4588-8fbb-3b4bf2344284")),
teamInvite = Team $ Id (fromJust (UUID.fromString "abf7c0b2-f4e6-4588-8fbb-3b4bf2344284")),
dnsVerificationToken = Nothing
}

testObject_DomainRegistration_4 :: DomainRegistration
testObject_DomainRegistration_4 =
DomainRegistration
{ domain = Domain "example.com",
domainRedirect = Backend (HttpsUrl (fromRight' (parseURI strictURIParserOptions "https://example.com/inv14"))),
teamInvite = Allowed,
dnsVerificationToken = Nothing
}

testObject_DomainRegistration_5 :: DomainRegistration
testObject_DomainRegistration_5 =
DomainRegistration
{ domain = Domain "example.com",
domainRedirect = NoRegistration,
teamInvite = Allowed,
dnsVerificationToken = Nothing
}

testObject_DomainRegistration_6 :: DomainRegistration
testObject_DomainRegistration_6 =
DomainRegistration
{ domain = Domain "example.com",
domainRedirect = PreAuthorized,
teamInvite = Allowed,
dnsVerificationToken = Just $ DnsVerificationToken "wire-domain-<auth-token>::example.com"
}

testObject_DomainRegistrationUpdate_1 :: DomainRegistrationUpdate
testObject_DomainRegistrationUpdate_1 =
DomainRegistrationUpdate
{ domainRedirect = Locked,
teamInvite = Allowed
}

testObject_DomainRegistrationUpdate_2 :: DomainRegistrationUpdate
testObject_DomainRegistrationUpdate_2 =
DomainRegistrationUpdate
{ domainRedirect = None,
teamInvite = NotAllowed
}

testObject_DomainRegistrationUpdate_3 :: DomainRegistrationUpdate
testObject_DomainRegistrationUpdate_3 =
DomainRegistrationUpdate
{ domainRedirect = SSO (SAML.IdPId $ fromJust (UUID.fromString "abf7c0b2-f4e6-4588-8fbb-3b4bf2344284")),
teamInvite = Allowed
}

testObject_DomainRegistrationUpdate_4 :: DomainRegistrationUpdate
testObject_DomainRegistrationUpdate_4 =
DomainRegistrationUpdate
{ domainRedirect = Backend (HttpsUrl (fromRight' (parseURI strictURIParserOptions "https://example.com/inv14"))),
teamInvite = Allowed
}

testObject_DomainRegistrationUpdate_5 :: DomainRegistrationUpdate
testObject_DomainRegistrationUpdate_5 =
DomainRegistrationUpdate
{ domainRedirect = PreAuthorized,
teamInvite = Allowed
}

testObject_DomainRegistrationUpdate_6 :: DomainRegistrationUpdate
testObject_DomainRegistrationUpdate_6 =
DomainRegistrationUpdate
{ domainRedirect = NoRegistration,
teamInvite = Team $ Id (fromJust (UUID.fromString "abf7c0b2-f4e6-4588-8fbb-3b4bf2344284"))
}
Loading

0 comments on commit 43678eb

Please sign in to comment.