[FEAT] Invitation through Shared node

src/Gargantext/API/Node/Share.hs

@@ -25,6 +25,8 @@ import Test.QuickCheck.Arbitrary
 
 import Gargantext.API.Prelude
 import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Database.Action.User
+import Gargantext.Database.Action.User.New
 import Gargantext.Database.Action.Share (ShareNodeWith(..))
 import Gargantext.Database.Action.Share as DB (shareNodeWith, unPublish)
 import Gargantext.Database.Admin.Types.Node
@@ -52,10 +54,21 @@ instance Arbitrary ShareNodeParams where
 api :: HasNodeError err
     => NodeId
     -> ShareNodeParams
-    -> Cmd err Int
-api nId (ShareTeamParams user) =
+    -> CmdR err Int
+api nId (ShareTeamParams user') = do
+  user <- case guessUserName user' of
+    Nothing    -> pure user'
+    Just (u,_) -> do
+      isRegistered <- getUserId' (UserName u)
+      case isRegistered of
+        Just _  -> pure u
+        Nothing -> do
+          _ <- newUsers [u]
+          pure u
+
   fromIntegral <$> DB.shareNodeWith (ShareNodeWith_User NodeFolderShared (UserName user)) nId 
 api nId2 (SharePublicParams nId1) =
+
   fromIntegral <$> DB.shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId1) nId2
 
 ------------------------------------------------------------------------

src/Gargantext/API/Prelude.hs

@@ -68,7 +68,7 @@ type ErrC err =
   )
 
 type GargServerC env err m =
-  ( CmdM' env err m
+  ( CmdRandom env err m
   , EnvC  env
   , ErrC      err
   )

src/Gargantext/Database/Action/Share.hs

@@ -32,13 +32,12 @@ publicNodeTypes :: [NodeType]
 publicNodeTypes = [NodeDashboard, NodeGraph, NodePhylo, NodeFile]
 
 ------------------------------------------------------------------------
-
 data ShareNodeWith = ShareNodeWith_User { snwu_nodetype :: NodeType
-                                        , snwu_user    :: User }
+                                        , snwu_user     :: User
+                                        }
                    | ShareNodeWith_Node { snwn_nodetype :: NodeType
-                                        , snwn_node_id :: NodeId
+                                        , snwn_node_id  :: NodeId
                                         }
-
 ------------------------------------------------------------------------
 shareNodeWith :: HasNodeError err
               => ShareNodeWith
@@ -86,7 +85,6 @@ delFolderTeam u nId = do
   folderSharedId <- getFolderId u NodeFolderShared
   deleteNodeNode folderSharedId nId
 
-
 unPublish :: HasNodeError err
           => ParentId -> NodeId
           -> Cmd err Int

src/Gargantext/Database/Action/User.hs

@@ -27,16 +27,25 @@ import Gargantext.Prelude
 getUserId :: HasNodeError err
           => User
           -> Cmd err UserId
-getUserId (UserDBId uid) = pure uid
-getUserId (RootId   rid) = do
+getUserId u = do
+  maybeUser <- getUserId' u
+  case maybeUser of
+    Nothing -> nodeError NoUserFound
+    Just u  -> pure u
+
+getUserId' :: HasNodeError err
+          => User
+          -> Cmd err (Maybe UserId)
+getUserId' (UserDBId uid) = pure (Just uid)
+getUserId' (RootId   rid) = do
   n <- getNode rid
-  pure $ _node_userId n
-getUserId (UserName u  ) = do
+  pure $ Just $ _node_userId n
+getUserId' (UserName u  ) = do
   muser <- getUser u
   case muser of
-    Just user -> pure $ userLight_id user
-    Nothing   -> nodeError NoUserFound
-getUserId UserPublic = nodeError NoUserFound
+    Just user -> pure $ Just $ userLight_id user
+    Nothing   -> pure Nothing
+getUserId' UserPublic = pure Nothing
 
 ------------------------------------------------------------------------
 -- | Username = Text

src/Gargantext/Database/Action/User/New.hs

@@ -26,7 +26,7 @@ import Gargantext.Prelude
 import Gargantext.Prelude.Config
 import Gargantext.Prelude.Crypto.Pass.User (gargPass)
 import Gargantext.Prelude.Mail (gargMail, GargMail(..))
-
+import qualified Data.List as List
 
 ------------------------------------------------------------------------
 type EmailAddress = Text
@@ -42,14 +42,19 @@ newUserQuick :: (MonadRandom m)
              => Text -> m (NewUser GargPassword)
 newUserQuick n = do
   pass <- gargPass
-  let (u,_m) = guessUserName n
+  let u = case guessUserName n of
+        Just  (u', _m) -> u'
+        Nothing        -> panic "Email invalid"
   pure (NewUser u n (GargPassword pass))
 
-guessUserName :: Text -> (Text,Text)
+isEmail :: Text -> Bool
+isEmail = ((==) 2) . List.length . (splitOn "@")
+
+guessUserName :: Text -> Maybe (Text,Text)
 guessUserName n = case splitOn "@" n of
-    [u',m'] -> if m' /= "" then (u',m')
-                           else panic "Email Invalid"
-    _  -> panic "Email invalid"
+    [u',m'] -> if m' /= "" then Just (u',m')
+                           else Nothing
+    _       -> Nothing
 ------------------------------------------------------------------------
 newUser' :: HasNodeError err
         => Text -> NewUser GargPassword -> Cmd err Int64
@@ -58,18 +63,18 @@ newUser' address u = newUsers' address [u]
 newUsers' :: HasNodeError err
          => Text -> [NewUser GargPassword] -> Cmd err Int64
 newUsers' address us = do
-  us' <- liftBase    $ mapM toUserHash us
-  r   <- insertUsers $ map toUserWrite us'
+  us' <- liftBase         $ mapM toUserHash us
+  r   <- insertUsers      $ map toUserWrite us'
   _   <- mapM getOrMkRoot $ map (\u -> UserName (_nu_username u)) us
-  _   <- liftBase    $ mapM (mail Invitation address) us
+  _   <- liftBase         $ mapM (mail Invitation address) us
   pure r
 ------------------------------------------------------------------------
 updateUser :: HasNodeError err
            => Text -> NewUser GargPassword -> Cmd err Int64
 updateUser address u = do
-  u' <- liftBase   $ toUserHash   u
+  u' <- liftBase     $ toUserHash   u
   n  <- updateUserDB $ toUserWrite  u'
-  _  <- liftBase   $ mail Update address u
+  _  <- liftBase     $ mail Update address u
   pure n
 
 ------------------------------------------------------------------------

src/Gargantext/Database/Prelude.hs

@@ -80,10 +80,17 @@ type CmdM env err m =
   , HasConfig         env
   )
 
+type CmdRandom env err m =
+  ( CmdM'             env err m
+  , HasConnectionPool env
+  , HasConfig         env
+  , MonadRandom             m
+  )
+
 type Cmd'' env err a = forall m.     CmdM'' env err m => m a
 type Cmd'  env err a = forall m.     CmdM'  env err m => m a
 type Cmd       err a = forall m env. CmdM   env err m => m a
-
+type CmdR      err a = forall m env. CmdRandom   env err m => m a