servantify /self endpoint

libs/api-bot/src/Network/Wire/Bot/Cache.hs

@@ -28,8 +28,10 @@ module Network.Wire.Bot.Cache
 where
 
 import Data.ByteString.Conversion
+import Data.Domain
 import Data.LanguageCodes
 import Data.Misc
+import Data.Qualified
 import Data.Text.Encoding
 import qualified Data.Text.Lazy as Text
 import qualified Data.Text.Lazy.IO as Text
@@ -51,11 +53,11 @@ data CachedUser = CachedUser !PlainTextPassword !User
 -- user2's UUID,email2,password2
 -- ...
 -- @
-fromFile :: Logger -> GenIO -> FilePath -> IO Cache
-fromFile logger gen path = do
+fromFile :: Logger -> GenIO -> Domain -> FilePath -> IO Cache
+fromFile logger gen domain path = do
   triples <- map (Text.splitOn ",") . Text.lines <$> Text.readFile path
   shuffled <- V.toList <$> uniformShuffle (V.fromList triples) gen
-  c <- newIORef =<< foldM (toUser logger) [] shuffled
+  c <- newIORef =<< foldM (toUser logger domain) [] shuffled
   return (Cache c)
 
 empty :: IO Cache
@@ -73,8 +75,8 @@ get c = liftIO . atomicModifyIORef (cache c) $ \u ->
 put :: MonadIO m => Cache -> CachedUser -> m ()
 put c a = liftIO . atomicModifyIORef (cache c) $ \u -> (a : u, ())
 
-toUser :: HasCallStack => Logger -> [CachedUser] -> [LText] -> IO [CachedUser]
-toUser _ acc [i, e, p] = do
+toUser :: HasCallStack => Logger -> Domain -> [CachedUser] -> [LText] -> IO [CachedUser]
+toUser _ domain acc [i, e, p] = do
   let pw = PlainTextPassword . Text.toStrict $ Text.strip p
   let iu = error "Cache.toUser: invalid user"
   let ie = error "Cache.toUser: invalid email"
@@ -85,6 +87,7 @@ toUser _ acc [i, e, p] = do
       pw
       User
         { userId = ui,
+          userQualifiedId = Qualified ui domain,
           userDisplayName = Name $ "Fakebot-" <> Text.toStrict (Text.strip i),
           userPict = Pict [],
           userAssets = [],
@@ -98,6 +101,6 @@ toUser _ acc [i, e, p] = do
           userTeam = Nothing,
           userManagedBy = ManagedByWire
         }
-toUser g acc entry = do
+toUser g _ acc entry = do
   warn g $ msg (val "invalid entry: " +++ show entry)
   return acc

libs/api-bot/src/Network/Wire/Bot/Monad.hs

@@ -149,7 +149,8 @@ data BotNetEnv = BotNetEnv
 newBotNetEnv :: Manager -> Logger -> BotNetSettings -> IO BotNetEnv
 newBotNetEnv manager logger o = do
   gen <- MWC.createSystemRandom
-  usr <- maybe Cache.empty (Cache.fromFile logger gen) (setBotNetUsersFile o)
+  let domain = setBotNetFederationDomain o
+  usr <- maybe Cache.empty (Cache.fromFile logger gen domain) (setBotNetUsersFile o)
   mbx <- maybe (return []) loadMailboxConfig (setBotNetMailboxConfig o)
   met <- initMetrics
   let srv =

libs/api-bot/src/Network/Wire/Bot/Settings.hs

@@ -34,8 +34,11 @@ module Network.Wire.Bot.Settings
   )
 where
 
+import qualified Data.Attoparsec.ByteString as A
 import Data.ByteString.Char8 (pack)
+import Data.Domain
 import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
 import Data.Time.Clock (NominalDiffTime)
 import Imports
 import Network.Wire.Client.API.User (Email (..), parseEmail)
@@ -54,6 +57,7 @@ data BotNetSettings = BotNetSettings
     setBotNetMailboxConfig :: !(Maybe FilePath),
     setBotNetSender :: !Email,
     setBotNetUsersFile :: !(Maybe FilePath),
+    setBotNetFederationDomain :: !Domain,
     setBotNetReportDir :: !(Maybe FilePath),
     setBotNetBotSettings :: !BotSettings,
     setBotNetMailboxFolders :: ![String]
@@ -72,6 +76,7 @@ botNetSettingsParser =
     <*> mailboxConfigOption
     <*> mailSenderOption
     <*> usersFileOption
+    <*> usersFederationDomain
     <*> reportDirOption
     <*> botSettingsParser
     <*> mailboxFoldersOption
@@ -142,6 +147,14 @@ usersFileOption =
         \ containing a list of ALREADY EXISTING users with the columns: \
         \ User-Id,Email,Password"
 
+usersFederationDomain :: Parser (Domain)
+usersFederationDomain =
+  domainOption $
+    long "users-federation-domain"
+      <> metavar "DOMAIN"
+      <> help
+        "federationDomain of all users from the usersFile CSV"
+
 reportDirOption :: Parser (Maybe FilePath)
 reportDirOption =
   optional . strOption $
@@ -276,3 +289,9 @@ emailOption =
     maybe (Left "Invalid email") Right
       . parseEmail
       . Text.pack
+
+attoReadM :: A.Parser a -> ReadM a
+attoReadM p = eitherReader (A.parseOnly p . Text.encodeUtf8 . Text.pack)
+
+domainOption :: Mod OptionFields Domain -> Parser Domain
+domainOption = option $ attoReadM domainParser

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE StrictData #-}
 
 -- This file is part of the Wire Server implementation.
@@ -35,15 +36,18 @@ module Data.Qualified
 where
 
 import Control.Applicative (optional)
-import Data.Aeson (FromJSON, ToJSON, withText)
+import Control.Lens ((.~), (?~))
+import Data.Aeson (FromJSON, ToJSON, withObject, withText, (.:), (.=))
 import qualified Data.Aeson as Aeson
 import qualified Data.Attoparsec.ByteString.Char8 as Atto
 import Data.Bifunctor (first)
 import Data.ByteString.Conversion (FromByteString (parser))
 import Data.Domain (Domain, domainText)
 import Data.Handle (Handle (..))
 import Data.Id (Id (toUUID))
+import Data.Proxy (Proxy (..))
 import Data.String.Conversions (cs)
+import Data.Swagger
 import qualified Data.Text.Encoding as Text.E
 import qualified Data.UUID as UUID
 import Imports hiding (local)
@@ -129,11 +133,25 @@ renderQualifiedId = renderQualified (cs . UUID.toString . toUUID)
 mkQualifiedId :: Text -> Either String (Qualified (Id a))
 mkQualifiedId = Atto.parseOnly (parser <* Atto.endOfInput) . Text.E.encodeUtf8
 
+instance ToSchema (Qualified (Id a)) where
+  declareNamedSchema _ = do
+    idSchema <- declareSchemaRef (Proxy @(Id a))
+    domainSchema <- declareSchemaRef (Proxy @Domain)
+    return $
+      NamedSchema (Just "QualifiedUserId") $
+        mempty
+          & type_ ?~ SwaggerObject
+          & properties
+            .~ [ ("id", idSchema),
+                 ("domain", domainSchema)
+               ]
+
 instance ToJSON (Qualified (Id a)) where
-  toJSON = Aeson.String . renderQualifiedId
+  toJSON qu = Aeson.object ["id" .= _qLocalPart qu, "domain" .= _qDomain qu]
 
 instance FromJSON (Qualified (Id a)) where
-  parseJSON = withText "QualifiedUserId" $ either fail pure . mkQualifiedId
+  parseJSON = withObject "QualifiedUserId" $ \o ->
+    Qualified <$> o .: "id" <*> o .: "domain"
 
 instance FromHttpApiData (Qualified (Id a)) where
   parseUrlPiece = first cs . mkQualifiedId

libs/wire-api/package.yaml

@@ -35,6 +35,7 @@ library:
   - generic-random >=1.2
   - hashable
   - hostname-validate
+  - insert-ordered-containers
   - iproute >=1.5
   - iso3166-country-codes >=0.2
   - iso639 >=0.1

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

@@ -137,7 +137,6 @@ models =
     Team.Permission.modelPermissions,
     Team.SearchVisibility.modelTeamSearchVisibility,
     User.modelUserIdList,
-    User.modelSelf,
     User.modelUser,
     User.modelNewUser,
     User.modelUserUpdate,

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

@@ -76,23 +76,22 @@ module Wire.API.User
     module Wire.API.User.Profile,
 
     -- * Swagger
-    modelUserIdList,
-    modelSelf,
-    modelUser,
-    modelNewUser,
-    modelUserUpdate,
-    modelChangePassword,
+    modelChangeHandle,
     modelChangeLocale,
+    modelChangePassword,
+    modelDelete,
     modelEmailUpdate,
+    modelNewUser,
     modelPhoneUpdate,
-    modelChangeHandle,
-    modelDelete,
+    modelUser,
+    modelUserIdList,
+    modelUserUpdate,
     modelVerifyDelete,
   )
 where
 
 import Control.Error.Safe (rightMay)
-import Control.Lens (over)
+import Control.Lens (over, view)
 import Data.Aeson
   ( FromJSON (parseJSON),
     KeyValue ((.=)),
@@ -111,13 +110,15 @@ import qualified Data.Code as Code
 import qualified Data.Currency as Currency
 import Data.Handle (Handle)
 import qualified Data.HashMap.Strict as HashMap
+import qualified Data.HashMap.Strict.InsOrd as InsHashMap
 import Data.Id
 import Data.Json.Util (UTCTimeMillis, (#))
 import qualified Data.List as List
 import Data.Misc (PlainTextPassword (..))
 import Data.Proxy (Proxy (..))
+import Data.Qualified
 import Data.Range
-import Data.Swagger (ToSchema (..), genericDeclareNamedSchema, required, schema)
+import Data.Swagger (ToSchema (..), genericDeclareNamedSchema, properties, required, schema)
 import qualified Data.Swagger.Build.Api as Doc
 import Data.Text.Ascii
 import Data.UUID (UUID, nil)
@@ -271,43 +272,12 @@ instance FromJSON UserProfile where
 -- SelfProfile
 
 -- | A self profile.
-data SelfProfile = SelfProfile
+newtype SelfProfile = SelfProfile
   { selfUser :: User
   }
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform SelfProfile)
-
-modelSelf :: Doc.Model
-modelSelf = Doc.defineModel "Self" $ do
-  Doc.description "Self Profile"
-  Doc.property "id" Doc.bytes' $
-    Doc.description "User ID"
-  Doc.property "name" Doc.string' $
-    Doc.description "Name"
-  Doc.property "assets" (Doc.array (Doc.ref modelAsset)) $
-    Doc.description "Profile assets"
-  Doc.property "email" Doc.string' $ do
-    Doc.description "Email address"
-    Doc.optional
-  Doc.property "phone" Doc.string' $ do
-    Doc.description "E.164 Phone number"
-    Doc.optional
-  Doc.property "accent_id" Doc.int32' $ do
-    Doc.description "Accent colour ID"
-    Doc.optional
-  Doc.property "locale" Doc.string' $
-    Doc.description "Locale in <ln-cc> format."
-  Doc.property "handle" Doc.string' $ do
-    Doc.description "Unique handle."
-    Doc.optional
-  Doc.property "deleted" Doc.bool' $ do
-    Doc.description "Whether the account has been deleted."
-    Doc.optional
-  Doc.property "managed_by" typeManagedBy $ do
-    Doc.description
-      "What is the source of truth for this user; if it's SCIM \
-      \then the profile can't be edited via normal means"
-    Doc.optional
+  deriving newtype (ToSchema)
 
 instance ToJSON SelfProfile where
   toJSON (SelfProfile u) = toJSON u
@@ -324,6 +294,7 @@ instance FromJSON SelfProfile where
 -- | The data of an existing user.
 data User = User
   { userId :: UserId,
+    userQualifiedId :: Qualified UserId,
     -- | User identity. For endpoints like @/self@, it will be present in the response iff
     -- the user is activated, and the email/phone contained in it will be guaranteedly
     -- verified. {#RefActivation}
@@ -352,12 +323,42 @@ data User = User
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform User)
 
+-- Cannot use deriving (ToSchema) via (CustomSwagger ...) because we need to
+-- mark 'deleted' as optional, but it is not a 'Maybe'
+-- and we need to manually add the identity schema fields at the top level
+-- instead of nesting them under the 'identity' field.
+instance ToSchema User where
+  declareNamedSchema _ = do
+    identityProperties <- view (schema . properties) <$> declareNamedSchema (Proxy @UserIdentity)
+    genericSchema <-
+      genericDeclareNamedSchema
+        ( swaggerOptions
+            @'[ FieldLabelModifier
+                  ( StripPrefix "user",
+                    CamelToSnake,
+                    LabelMappings
+                      '[ "pict" ':-> "picture",
+                         "expire" ':-> "expires_at",
+                         "display_name" ':-> "name"
+                       ]
+                  )
+              ]
+        )
+        (Proxy @User)
+    pure $
+      genericSchema
+        & over (schema . required) (List.delete "deleted")
+        -- The UserIdentity fields need to be flat-included, not be in a sub-object
+        & over (schema . properties) (InsHashMap.delete "identity")
+        & over (schema . properties) (InsHashMap.union identityProperties)
+
 -- FUTUREWORK:
 -- disentangle json serializations for 'User', 'NewUser', 'UserIdentity', 'NewUserOrigin'.
 instance ToJSON User where
   toJSON u =
     object $
       "id" .= userId u
+        # "qualified_id" .= userQualifiedId u
         # "name" .= userDisplayName u
         # "picture" .= userPict u
         # "assets" .= userAssets u
@@ -379,6 +380,7 @@ instance FromJSON User where
     ssoid <- o .:? "sso_id"
     User
       <$> o .: "id"
+      <*> o .: "qualified_id"
       <*> parseIdentity ssoid o
       <*> o .: "name"
       <*> o .:? "picture" .!= noPict