Move and create federation-related types (#997)

* federator: some churn

* move Handle to common-types

* introduce Qualified to types-common

* move EmailDomain to Data.Domain

* define opaque user and conversation IDs

* clarify terminology inside/outside the codebase

* Add Data.IdMapping

libs/brig-types/src/Brig/Types/Common.hs

@@ -14,7 +14,6 @@ import Data.Aeson hiding ((<?>))
 import qualified Data.Aeson.Types as Json
 import Data.Attoparsec.Text
 import Data.ByteString.Conversion
-import Data.Hashable (Hashable)
 import Data.ISO3166_CountryCodes
 import Data.Json.Util ((#))
 import Data.LanguageCodes
@@ -23,48 +22,10 @@ import qualified Data.Text as Text
 import Data.Time.Clock
 import Imports
 
---------------------------------------------------------------------------------
--- Handle
-
-newtype Handle
-  = Handle
-      {fromHandle :: Text}
-  deriving (Eq, Show, ToJSON, ToByteString, Hashable, Generic)
-
-instance FromByteString Handle where
-  parser = parser >>= maybe (fail "Invalid handle") return . parseHandle
-
-instance FromJSON Handle where
-  parseJSON =
-    withText "Handle" $
-      maybe (fail "Invalid handle") pure . parseHandle
-
-parseHandle :: Text -> Maybe Handle
-parseHandle t
-  | isValidHandle t = Just (Handle t)
-  | otherwise = Nothing
-
-isValidHandle :: Text -> Bool
-isValidHandle t =
-  either (const False) (const True) $
-    parseOnly handle t
-  where
-    handle =
-      count 2 (satisfy chars)
-        *> count 254 (optional (satisfy chars))
-        *> endOfInput
-    -- NOTE: Ensure that characters such as `@` and `+` should _NOT_
-    -- be used so that "phone numbers", "emails", and "handles" remain
-    -- disjoint sets.
-    -- The rationale behind max size here relates to the max length of
-    -- an email address as defined here:
-    -- http://www.rfc-editor.org/errata_search.php?rfc=3696&eid=1690
-    -- with the intent that in the enterprise world handle =~ email address
-    chars = inClass "a-z0-9_.-"
-
 --------------------------------------------------------------------------------
 -- Name
 
+-- | Usually called display name.
 newtype Name
   = Name
       {fromName :: Text}

libs/brig-types/src/Brig/Types/Provider/External.hs

@@ -16,6 +16,7 @@ where
 import Brig.Types.Client.Prekey
 import Brig.Types.Common
 import Data.Aeson
+import Data.Handle (Handle)
 import Data.Id
 import Data.Json.Util ((#))
 import Galley.Types.Bot

libs/brig-types/src/Brig/Types/Test/Arbitrary.hs

@@ -96,11 +96,6 @@ instance Arbitrary TurnURI where
       <*> arbitrary
       <*> arbitrary
 
-instance Arbitrary Handle where
-  arbitrary = Handle . ST.pack <$> do
-    let many n = replicateM n (elements $ ['a' .. 'z'] <> ['0' .. '9'] <> ['_'] <> ['-'] <> ['.'])
-    ((<>) <$> many 2 <*> (many =<< choose (0, 254)))
-
 instance Arbitrary Name where
   arbitrary =
     Name . ST.pack

libs/brig-types/src/Brig/Types/User.hs

@@ -24,6 +24,7 @@ import Data.ByteString.Conversion
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Currency as Currency
+import Data.Handle (Handle)
 import qualified Data.HashMap.Strict as HM
 import qualified Data.HashMap.Strict as HashMap
 import Data.Hashable (Hashable)

libs/brig-types/src/Brig/Types/User/Auth.hs

@@ -10,6 +10,7 @@ import Brig.Types.Common
 import Data.Aeson
 import qualified Data.Aeson.Types as Aeson
 import Data.ByteString.Conversion
+import Data.Handle (Handle)
 import Data.Id (UserId)
 import Data.Misc (PlainTextPassword (..))
 import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)

libs/brig-types/test/unit/Test/Brig/Types/Common.hs

@@ -28,8 +28,7 @@ tests :: TestTree
 tests =
   testGroup
     "Common (types vs. aeson)"
-    [ run @Handle,
-      run @Name,
+    [ run @Name,
       run @ColourId,
       run @Email,
       run @Phone,

libs/galley-types/package.yaml

@@ -23,7 +23,6 @@ library:
   - containers >=0.5
   - currency-codes >=2.0
   - data-default >=0.5
-  - email-validate >=2.0
   - errors
   - exceptions >=0.10.0
   - gundeck-types >=1.15.13

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

@@ -45,9 +45,6 @@ module Galley.Types
     ConversationMessageTimerUpdate (..),
     ConvType (..),
     CustomBackend (..),
-    EmailDomain,
-    emailDomainText,
-    mkEmailDomain,
     Invite (..),
     NewConv (..),
     NewConvManaged (..),
@@ -68,8 +65,6 @@ where
 import Control.Lens ((.~))
 import Data.Aeson
 import Data.Aeson.Types (Parser)
-import qualified Data.Attoparsec.ByteString as Atto
-import Data.Bifunctor (bimap)
 import Data.ByteString.Conversion
 import qualified Data.Code as Code
 import qualified Data.HashMap.Strict as HashMap
@@ -85,7 +80,6 @@ import Galley.Types.Bot.Service (ServiceRef)
 import Galley.Types.Conversations.Roles
 import Gundeck.Types.Push (Priority)
 import Imports
-import qualified Text.Email.Validate as Email
 import URI.ByteString
 
 -- Conversations ------------------------------------------------------------
@@ -582,30 +576,6 @@ data CustomBackend
       }
   deriving (Eq, Show)
 
--- | FUTUREWORK: move this type upstream into the email-validate package.
-newtype EmailDomain
-  = EmailDomain
-      { _emailDomainText :: Text
-      }
-  deriving (Eq, Generic, Show)
-
-emailDomainText :: EmailDomain -> Text
-emailDomainText = _emailDomainText
-
-mkEmailDomain :: ByteString -> Either String EmailDomain
-mkEmailDomain = bimap show EmailDomain . T.decodeUtf8' <=< validateDomain
-  where
-    -- this is a slightly hacky way of validating an email domain,
-    -- but Text.Email.Validate doesn't expose the parser for the domain.
-    validateDomain = fmap Email.domainPart . Email.validate . ("local-part@" <>)
-
-instance FromByteString EmailDomain where
-  parser = do
-    bs <- Atto.takeByteString
-    case mkEmailDomain bs of
-      Left err -> fail ("Failed parsing ByteString as EmailDomain: " <> err)
-      Right domain -> pure domain
-
 -- Instances ----------------------------------------------------------------
 
 -- JSON

libs/types-common/package.yaml

@@ -29,6 +29,7 @@ library:
   - data-default >=0.5
   - deepseq >=1.4
   - directory >=1.2
+  - email-validate >=2.3
   - errors >=2.0
   - ghc-prim
   - hashable >=1.2
@@ -42,6 +43,7 @@ library:
   - safe >=0.3
   - scientific >=0.3.4
   - semigroups >=0.12
+  - servant >=0.16
   - singletons >=2.0
   - string-conversions
   - swagger >=0.3

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

@@ -0,0 +1,54 @@
+module Data.Domain where
+
+import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON))
+import qualified Data.Aeson as Aeson
+import qualified Data.Attoparsec.ByteString as Atto
+import Data.Bifunctor (bimap, first)
+import Data.ByteString.Conversion
+import qualified Data.Text.Encoding as Text.E
+import Imports
+import Test.QuickCheck (Arbitrary (arbitrary), elements)
+import qualified Text.Email.Validate as Email
+
+-- | FUTUREWORK: move this type upstream into the email-validate package?
+-- or become independent of email validation.
+newtype Domain
+  = Domain {_domainText :: Text}
+  deriving (Eq, Generic, Show)
+
+domainText :: Domain -> Text
+domainText = _domainText
+
+mkDomain :: Text -> Either String Domain
+mkDomain =
+  bimap show Domain . Text.E.decodeUtf8'
+    <=< validateDomain . Text.E.encodeUtf8
+  where
+    -- this is a slightly hacky way of validating a domain,
+    -- but Text.Email.Validate doesn't expose the parser for the domain.
+    validateDomain = fmap Email.domainPart . Email.validate . ("local-part@" <>)
+
+instance FromByteString Domain where
+  parser = do
+    bs <- Atto.takeByteString
+    case mkDomain =<< first show (Text.E.decodeUtf8' bs) of
+      Left err -> fail ("Failed parsing ByteString as Domain: " <> err)
+      Right domain -> pure domain
+
+instance ToJSON Domain where
+  toJSON = Aeson.String . domainText
+
+instance FromJSON Domain where
+  parseJSON = Aeson.withText "Domain" $ either fail pure . mkDomain
+
+instance Arbitrary Domain where
+  arbitrary =
+    either (error "arbitrary @Domain") id . mkDomain
+      <$> elements
+        [ "example.com",
+          "beispiel.com"
+          -- unicode domains are not supported, sadly:
+          -- "例.com",
+          -- "مثال.com",
+          -- "dæmi.com"
+        ]

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

@@ -0,0 +1,59 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Data.Handle where
+
+import Control.Applicative (optional)
+import Data.Aeson hiding ((<?>))
+import Data.Attoparsec.Text
+import Data.ByteString.Conversion
+import Data.Hashable (Hashable)
+import qualified Data.Text as Text
+import Imports
+import Test.QuickCheck (Arbitrary (arbitrary), choose, elements)
+
+--------------------------------------------------------------------------------
+-- Handle
+
+-- | Also called username.
+newtype Handle
+  = Handle
+      {fromHandle :: Text}
+  deriving stock (Eq, Show, Generic)
+  deriving newtype (ToJSON, ToByteString, Hashable)
+
+instance FromByteString Handle where
+  parser = parser >>= maybe (fail "Invalid handle") return . parseHandle
+
+instance FromJSON Handle where
+  parseJSON =
+    withText "Handle" $
+      maybe (fail "Invalid handle") pure . parseHandle
+
+parseHandle :: Text -> Maybe Handle
+parseHandle t
+  | isValidHandle t = Just (Handle t)
+  | otherwise = Nothing
+
+isValidHandle :: Text -> Bool
+isValidHandle t =
+  either (const False) (const True) $
+    parseOnly handle t
+  where
+    handle =
+      count 2 (satisfy chars)
+        *> count 254 (optional (satisfy chars))
+        *> endOfInput
+    -- NOTE: Ensure that characters such as `@` and `+` should _NOT_
+    -- be used so that "phone numbers", "emails", and "handles" remain
+    -- disjoint sets.
+    -- The rationale behind max size here relates to the max length of
+    -- an email address as defined here:
+    -- http://www.rfc-editor.org/errata_search.php?rfc=3696&eid=1690
+    -- with the intent that in the enterprise world handle =~ email address
+    chars = inClass "a-z0-9_.-"
+
+instance Arbitrary Handle where
+  arbitrary = Handle . Text.pack <$> do
+    let many n = replicateM n (elements $ ['a' .. 'z'] <> ['0' .. '9'] <> ['_'] <> ['-'] <> ['.'])
+    ((<>) <$> many 2 <*> (many =<< choose (0, 254)))

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

@@ -47,14 +47,48 @@ data T
 
 data STo
 
+data Mapped a
+
+data Opaque a
+
 type AssetId = Id A
 
+type InvitationId = Id I
+
+-- | A local conversation ID
 type ConvId = Id C
 
-type InvitationId = Id I
+-- | A UUID local to this backend, for which we know a mapping to a
+-- remote qualified conversation ID exists.
+-- These IDs should never leak to other backends or their clients.
+type MappedConvId = Id (Mapped C)
 
+-- | A UUID local to this backend, which can either be a local or a mapped conversation ID.
+-- Which one it is can be found out by checking whether there exists a corresponding
+-- local conversation or mapping in the database.
+-- This is how clients refer to conversations, they don't need to know about the mapping.
+type OpaqueConvId = Id (Opaque C)
+
+-- | A local user ID
 type UserId = Id U
 
+-- | A UUID local to this backend, for which we know a mapping to a
+-- remote qualified user ID exists.
+-- These IDs should never leak to other backends or their clients.
+type MappedUserId = Id (Mapped U)
+
+-- | A UUID local to this backend, which can either be a local or a mapped user ID.
+-- Which one it is can be found out by checking whether there exists a corresponding
+-- local user or mapping in the database.
+-- This is how clients refer to users, they don't need to know about the mapping.
+type OpaqueUserId = Id (Opaque U)
+
+makeIdOpaque :: Id a -> Id (Opaque a)
+makeIdOpaque (Id userId) = Id userId
+
+makeMappedIdOpaque :: Id (Mapped a) -> Id (Opaque a)
+makeMappedIdOpaque (Id userId) = Id userId
+
 type ProviderId = Id P
 
 type ServiceId = Id S

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

@@ -0,0 +1,34 @@
+{-# LANGUAGE StrictData #-}
+
+module Data.IdMapping where
+
+import Data.Id
+import Data.Qualified
+import Imports
+import Test.QuickCheck (Arbitrary (arbitrary), oneof)
+
+data MappedOrLocalId a
+  = Mapped (IdMapping a)
+  | Local (Id a)
+  deriving (Show)
+
+opaqueIdFromMappedOrLocal :: MappedOrLocalId a -> Id (Opaque a)
+opaqueIdFromMappedOrLocal = \case
+  Local localId -> makeIdOpaque localId
+  Mapped IdMapping {idMappingLocal} -> makeMappedIdOpaque idMappingLocal
+
+data IdMapping a
+  = IdMapping
+      { idMappingLocal :: Id (Mapped a),
+        idMappingGlobal :: Qualified (Id a)
+      }
+  deriving (Show)
+
+----------------------------------------------------------------------
+-- ARBITRARY
+
+instance Arbitrary a => Arbitrary (MappedOrLocalId a) where
+  arbitrary = oneof [Mapped <$> arbitrary, Local <$> arbitrary]
+
+instance Arbitrary a => Arbitrary (IdMapping a) where
+  arbitrary = IdMapping <$> arbitrary <*> arbitrary