basic enterprise login subsystem scaffold

libs/wire-api/src/Wire/API/EnterpriseLogin.hs

@@ -147,7 +147,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 stock (Ord, Eq, Show)
   deriving (ToJSON, FromJSON, OpenApi.ToSchema) via Schema DnsVerificationToken
 
 instance ToSchema DnsVerificationToken where
@@ -221,3 +221,9 @@ instance C.Cql TeamInviteTag where
     3 -> pure TeamTag
     n -> Left $ "Unexpected TeamInviteTag value: " ++ show n
   fromCql _ = Left "TeamInviteTag value: int expected"
+
+instance C.Cql DnsVerificationToken where
+  ctype = C.Tagged C.TextColumn
+  toCql = C.CqlText . unDnsVerificationToken
+  fromCql (C.CqlText t) = Right $ DnsVerificationToken t
+  fromCql _ = Left "DnsVerificationToken value: text expected"

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

@@ -18,7 +18,7 @@ data StoredDomainRegistration = StoredDomainRegistration
     idpId :: Maybe SAML.IdPId,
     backendUrl :: Maybe HttpsUrl,
     team :: Maybe TeamId,
-    dnsVerificationCode :: Maybe Text
+    dnsVerificationToken :: Maybe DnsVerificationToken
   }
   deriving (Show, Eq, Ord, Generic)
 

libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Wire.EnterpriseLoginSubsystem where
+
+import Data.Domain
+import Imports
+import Polysemy
+import Wire.API.EnterpriseLogin
+
+data EnterpriseLoginSubsystem m a where
+  LockDomain :: Domain -> EnterpriseLoginSubsystem m ()
+  GetDomainRegistration :: Domain -> EnterpriseLoginSubsystem m (Maybe DomainRegistration)
+
+makeSem ''EnterpriseLoginSubsystem

libs/wire-subsystems/src/Wire/EnterpriseLoginSubsystem/Interpreter.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Wire.EnterpriseLoginSubsystem.Interpreter
+  ( runEnterpriseLoginSubsystem,
+  )
+where
+
+import Imports hiding (lookup)
+import Polysemy
+import Wire.API.EnterpriseLogin
+import Wire.DomainRegistrationStore
+import Wire.EnterpriseLoginSubsystem
+
+runEnterpriseLoginSubsystem ::
+  ( Member DomainRegistrationStore r
+  ) =>
+  Sem (EnterpriseLoginSubsystem ': r) a ->
+  Sem r a
+runEnterpriseLoginSubsystem = interpret $
+  \case
+    LockDomain domain -> upsert $ StoredDomainRegistration domain LockedTag AllowedTag Nothing Nothing Nothing Nothing
+    GetDomainRegistration domain -> do
+      mStoredDomainRegistration <- lookup domain
+      let mDomainRegistration = mStoredDomainRegistration >>= fromStored
+      pure mDomainRegistration
+
+fromStored :: StoredDomainRegistration -> Maybe DomainRegistration
+fromStored sdr =
+  DomainRegistration sdr.domain
+    <$> getDomainRedirect sdr
+    <*> getTeamInvite sdr
+    <*> pure sdr.dnsVerificationToken
+
+getTeamInvite :: StoredDomainRegistration -> Maybe TeamInvite
+getTeamInvite = \case
+  StoredDomainRegistration _ _ ti _ _ _ _ -> case ti of
+    AllowedTag -> Just Allowed
+    _ -> Nothing
+
+getDomainRedirect :: StoredDomainRegistration -> Maybe DomainRedirect
+getDomainRedirect = \case
+  StoredDomainRegistration _ dr _ _ _ _ _ -> case dr of
+    NoneTag -> Just None
+    LockedTag -> Just Locked
+    _ -> Nothing

libs/wire-subsystems/wire-subsystems.cabal

@@ -87,6 +87,8 @@ library
     Wire.EmailSubsystem
     Wire.EmailSubsystem.Interpreter
     Wire.EmailSubsystem.Template
+    Wire.EnterpriseLoginSubsystem
+    Wire.EnterpriseLoginSubsystem.Interpreter
     Wire.Error
     Wire.Events
     Wire.FederationAPIAccess