Various cleanups of Qualified and related types

changelog.d/5-internal/refactor-tagged-qualified

@@ -0,0 +1 @@
+Improve the `Qualified` abstraction and make local/remote tagging safer

changelog.d/6-federation/unqualify-conv-id

@@ -0,0 +1 @@
+Make conversation ID of `RemoteConversation` unqualified and move it out of the metadata record.

libs/galley-types/src/Galley/Types.hs

@@ -24,7 +24,6 @@ module Galley.Types
     -- * re-exports
     ConversationMetadata (..),
     Conversation (..),
-    cnvQualifiedId,
     cnvType,
     cnvCreator,
     cnvAccess,

libs/galley-types/src/Galley/Types/Conversations/Members.hs

@@ -30,7 +30,6 @@ where
 import Data.Domain
 import Data.Id as Id
 import Data.Qualified
-import Data.Tagged
 import Imports
 import Wire.API.Conversation
 import Wire.API.Conversation.Role (RoleName)
@@ -46,7 +45,7 @@ data RemoteMember = RemoteMember
 remoteMemberToOther :: RemoteMember -> OtherMember
 remoteMemberToOther x =
   OtherMember
-    { omQualifiedId = unTagged (rmId x),
+    { omQualifiedId = qUntagged (rmId x),
       omService = Nothing,
       omConvRoleName = rmConvRoleName x
     }

libs/types-common/src/Data/Id.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -22,7 +21,36 @@
 
 -- for UUID instances
 
-module Data.Id where
+module Data.Id
+  ( -- * Tagged IDs
+    Id (..),
+    IdTag,
+    KnownIdTag (..),
+    idTagName,
+    randomId,
+    AssetId,
+    InvitationId,
+    ConvId,
+    UserId,
+    ProviderId,
+    ServiceId,
+    TeamId,
+    ScimTokenId,
+    parseIdFromText,
+    idToText,
+    IdObject (..),
+
+    -- * Client IDs
+    ClientId (..),
+    newClientId,
+
+    -- * Other IDs
+    ConnId (..),
+    RequestId (..),
+    BotId (..),
+    NoId,
+  )
+where
 
 import Cassandra hiding (S)
 import Control.Lens ((?~))
@@ -56,39 +84,54 @@ import Servant (FromHttpApiData (..), ToHttpApiData (..))
 import Test.QuickCheck
 import Test.QuickCheck.Instances ()
 
-data A
+data IdTag = A | C | I | U | P | S | T | STo
 
-data C
+idTagName :: IdTag -> Text
+idTagName A = "Asset"
+idTagName C = "Conv"
+idTagName I = "Invitation"
+idTagName U = "User"
+idTagName P = "Provider"
+idTagName S = "Service"
+idTagName T = "Team"
+idTagName STo = "ScimToken"
 
-data I
+class KnownIdTag (t :: IdTag) where
+  idTagValue :: IdTag
 
-data U
+instance KnownIdTag 'A where idTagValue = A
 
-data P
+instance KnownIdTag 'C where idTagValue = C
 
-data S
+instance KnownIdTag 'I where idTagValue = I
 
-data T
+instance KnownIdTag 'U where idTagValue = U
 
-data STo
+instance KnownIdTag 'P where idTagValue = P
 
-type AssetId = Id A
+instance KnownIdTag 'S where idTagValue = S
 
-type InvitationId = Id I
+instance KnownIdTag 'T where idTagValue = T
+
+instance KnownIdTag 'STo where idTagValue = STo
+
+type AssetId = Id 'A
+
+type InvitationId = Id 'I
 
 -- | A local conversation ID
-type ConvId = Id C
+type ConvId = Id 'C
 
 -- | A local user ID
-type UserId = Id U
+type UserId = Id 'U
 
-type ProviderId = Id P
+type ProviderId = Id 'P
 
-type ServiceId = Id S
+type ServiceId = Id 'S
 
-type TeamId = Id T
+type TeamId = Id 'T
 
-type ScimTokenId = Id STo
+type ScimTokenId = Id 'STo
 
 -- Id -------------------------------------------------------------------------
 

libs/types-common/src/Data/Misc.hs

@@ -350,5 +350,5 @@ instance Arbitrary PlainTextPassword where
 --
 -- Example:
 -- >>> let (FutureWork @'LegalholdPlusFederationNotImplemented -> _remoteUsers, localUsers)
--- >>>      = partitionRemoteOrLocalIds domain qualifiedUids
+-- >>>      = partitionQualified domain qualifiedUids
 newtype FutureWork label payload = FutureWork payload

libs/types-common/src/Data/Qualified.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE StrictData #-}
 
@@ -21,35 +22,33 @@
 module Data.Qualified
   ( -- * Qualified
     Qualified (..),
+    QualifiedWithTag,
+    tUnqualified,
+    tUnqualifiedL,
+    tDomain,
+    qUntagged,
+    qTagUnsafe,
     Remote,
-    toRemote,
+    toRemoteUnsafe,
     Local,
-    toLocal,
-    lUnqualified,
-    lDomain,
+    toLocalUnsafe,
     qualifyAs,
     foldQualified,
-    renderQualifiedId,
-    partitionRemoteOrLocalIds,
-    partitionRemoteOrLocalIds',
     partitionQualified,
+    indexQualified,
+    indexRemote,
     deprecatedSchema,
-    partitionRemote,
   )
 where
 
-import Control.Lens ((?~))
+import Control.Lens (Lens, lens, (?~))
 import Data.Aeson (FromJSON (..), ToJSON (..))
-import Data.Bifunctor (first)
-import Data.Domain (Domain, domainText)
+import Data.Domain (Domain)
 import Data.Handle (Handle (..))
-import Data.Id (Id (toUUID))
+import Data.Id
 import qualified Data.Map as Map
 import Data.Schema
-import Data.String.Conversions (cs)
 import qualified Data.Swagger as S
-import Data.Tagged
-import qualified Data.UUID as UUID
 import Imports hiding (local)
 import Test.QuickCheck (Arbitrary (arbitrary))
 
@@ -62,72 +61,85 @@ data Qualified a = Qualified
   }
   deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable)
 
--- | A type to differentiate between generally Qualified values, and values
--- where it is known if they are coming from a Remote backend or not.
--- Use 'toRemote' or 'partitionRemoteOrLocalIds\'' to get Remote values and use
--- 'unTagged' to convert from a Remote value back to a plain Qualified one.
-type Remote a = Tagged "remote" (Qualified a)
+data QTag = QLocal | QRemote
+  deriving (Eq, Show)
 
--- | Convert a Qualified something to a Remote something.
-toRemote :: Qualified a -> Remote a
-toRemote = Tagged
+-- | A type to differentiate between generally 'Qualified' values, and "tagged" values,
+-- for which it is known whether they are coming from a remote or local backend.
+-- Use 'foldQualified', 'partitionQualified' or 'qualifyLocal' to get tagged values and use
+-- 'qUntagged' to convert from a tagged value back to a plain 'Qualified' one.
+newtype QualifiedWithTag (t :: QTag) a = QualifiedWithTag {qUntagged :: Qualified a}
+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
+  deriving newtype (Arbitrary)
 
--- | A type representing a Qualified value where the domain is guaranteed to be
--- the local one.
-type Local a = Tagged "local" (Qualified a)
+qTagUnsafe :: forall t a. Qualified a -> QualifiedWithTag t a
+qTagUnsafe = QualifiedWithTag
 
-toLocal :: Qualified a -> Local a
-toLocal = Tagged
+tUnqualified :: QualifiedWithTag t a -> a
+tUnqualified = qUnqualified . qUntagged
 
-lUnqualified :: Local a -> a
-lUnqualified = qUnqualified . unTagged
+tDomain :: QualifiedWithTag t a -> Domain
+tDomain = qDomain . qUntagged
 
-lDomain :: Local a -> Domain
-lDomain = qDomain . unTagged
+tUnqualifiedL :: Lens (QualifiedWithTag t a) (QualifiedWithTag t b) a b
+tUnqualifiedL = lens tUnqualified qualifyAs
+
+-- | A type representing a 'Qualified' value where the domain is guaranteed to
+-- be remote.
+type Remote = QualifiedWithTag 'QRemote
+
+-- | Convert a 'Domain' and an @a@ to a 'Remote' value. This is only safe if we
+-- already know that the domain is remote.
+toRemoteUnsafe :: Domain -> a -> Remote a
+toRemoteUnsafe d a = qTagUnsafe $ Qualified a d
+
+-- | A type representing a 'Qualified' value where the domain is guaranteed to
+-- be local.
+type Local = QualifiedWithTag 'QLocal
+
+-- | Convert a 'Domain' and an @a@ to a 'Local' value. This is only safe if we
+-- already know that the domain is local.
+toLocalUnsafe :: Domain -> a -> Local a
+toLocalUnsafe d a = qTagUnsafe $ Qualified a d
 
 -- | Convert an unqualified value to a qualified one, with the same tag as the
 -- given tagged qualified value.
-qualifyAs :: Tagged t (Qualified x) -> a -> Tagged t (Qualified a)
-qualifyAs (Tagged q) x = Tagged (q $> x)
+qualifyAs :: QualifiedWithTag t x -> a -> QualifiedWithTag t a
+qualifyAs = ($>)
 
 foldQualified :: Local x -> (Local a -> b) -> (Remote a -> b) -> Qualified a -> b
 foldQualified loc f g q
-  | lDomain loc == qDomain q =
-    f (toLocal q)
+  | tDomain loc == qDomain q =
+    f (qTagUnsafe q)
   | otherwise =
-    g (toRemote q)
-
--- | FUTUREWORK: Maybe delete this, it is only used in printing federation not
--- implemented errors
-renderQualified :: (a -> Text) -> Qualified a -> Text
-renderQualified renderLocal (Qualified localPart domain) =
-  renderLocal localPart <> "@" <> domainText domain
-
--- FUTUREWORK: we probably want to use the primed function everywhere. Refactor these two functions to only have one.
-partitionRemoteOrLocalIds :: Foldable f => Domain -> f (Qualified a) -> ([Qualified a], [a])
-partitionRemoteOrLocalIds localDomain = foldMap $ \qualifiedId ->
-  if qDomain qualifiedId == localDomain
-    then (mempty, [qUnqualified qualifiedId])
-    else ([qualifiedId], mempty)
-
-partitionRemoteOrLocalIds' :: Foldable f => Domain -> f (Qualified a) -> ([Remote a], [a])
-partitionRemoteOrLocalIds' localDomain xs = first (fmap toRemote) $ partitionRemoteOrLocalIds localDomain xs
-
--- | Index a list of qualified values by domain
-partitionQualified :: Foldable f => f (Qualified a) -> Map Domain [a]
-partitionQualified = foldr add mempty
+    g (qTagUnsafe q)
+
+-- Partition a collection of qualified values into locals and remotes.
+--
+-- Note that the local values are returned as unqualified values, as a (probably
+-- insignificant) optimisation. Use 'partitionQualifiedAndTag' to get them as
+-- 'Local' values.
+partitionQualified :: Foldable f => Local x -> f (Qualified a) -> ([a], [Remote a])
+partitionQualified loc =
+  foldMap $
+    foldQualified loc (\l -> ([tUnqualified l], mempty)) (\r -> (mempty, [r]))
+
+-- | Index a list of qualified values by domain.
+indexQualified :: Foldable f => f (Qualified a) -> Map Domain [a]
+indexQualified = foldr add mempty
   where
     add :: Qualified a -> Map Domain [a] -> Map Domain [a]
     add (Qualified x domain) = Map.insertWith (<>) domain [x]
 
-partitionRemote :: (Functor f, Foldable f) => f (Remote a) -> [(Domain, [a])]
-partitionRemote remotes = Map.assocs $ partitionQualified (unTagged <$> remotes)
+indexRemote :: (Functor f, Foldable f) => f (Remote a) -> [Remote [a]]
+indexRemote =
+  map (uncurry toRemoteUnsafe)
+    . Map.assocs
+    . indexQualified
+    . fmap qUntagged
 
 ----------------------------------------------------------------------
 
-renderQualifiedId :: Qualified (Id a) -> Text
-renderQualifiedId = renderQualified (cs . UUID.toString . toUUID)
-
 deprecatedSchema :: S.HasDescription doc (Maybe Text) => Text -> ValueSchema doc a -> ValueSchema doc a
 deprecatedSchema new = doc . description ?~ ("Deprecated, use " <> new)
 
@@ -142,19 +154,19 @@ qualifiedSchema name fieldName sch =
       <$> qUnqualified .= field fieldName sch
       <*> qDomain .= field "domain" schema
 
-instance ToSchema (Qualified (Id a)) where
-  schema = qualifiedSchema "UserId" "id" schema
+instance KnownIdTag t => ToSchema (Qualified (Id t)) where
+  schema = qualifiedSchema (idTagName (idTagValue @t) <> "Id") "id" schema
 
 instance ToSchema (Qualified Handle) where
   schema = qualifiedSchema "Handle" "handle" schema
 
-instance ToJSON (Qualified (Id a)) where
+instance KnownIdTag t => ToJSON (Qualified (Id t)) where
   toJSON = schemaToJSON
 
-instance FromJSON (Qualified (Id a)) where
+instance KnownIdTag t => FromJSON (Qualified (Id t)) where
   parseJSON = schemaParseJSON
 
-instance S.ToSchema (Qualified (Id a)) where
+instance KnownIdTag t => S.ToSchema (Qualified (Id t)) where
   declareNamedSchema = schemaToSwagger
 
 instance ToJSON (Qualified Handle) where

libs/types-common/test/Test/Qualified.hs

@@ -22,14 +22,11 @@ where
 
 import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON))
 import qualified Data.Aeson.Types as Aeson
-import Data.Domain (Domain (..))
 import Data.Handle (Handle)
-import Data.Id (Id (..), UserId)
-import Data.Qualified (Qualified (..), renderQualifiedId)
-import qualified Data.UUID as UUID
+import Data.Id (UserId)
+import Data.Qualified (Qualified (..))
 import Imports
 import Test.Tasty
-import Test.Tasty.HUnit
 import Test.Tasty.QuickCheck
 import Type.Reflection (typeRep)
 
@@ -42,13 +39,7 @@ tests =
 
 testQualifiedSerialization :: [TestTree]
 testQualifiedSerialization =
-  [ testCase "render 61a73a52-e526-4892-82a9-3d638d77629f@example.com" $ do
-      uuid <-
-        maybe (assertFailure "invalid UUID") pure $
-          UUID.fromString "61a73a52-e526-4892-82a9-3d638d77629f"
-      assertEqual "" "61a73a52-e526-4892-82a9-3d638d77629f@example.com" $
-        (renderQualifiedId (Qualified (Id uuid) (Domain "example.com"))),
-    jsonRoundtrip @(Qualified Handle),
+  [ jsonRoundtrip @(Qualified Handle),
     jsonRoundtrip @(Qualified UserId)
   ]