[FIX MERGE] with dev and testing (social lists)

bin/gargantext-import/Main.hs

@@ -29,7 +29,6 @@ import Gargantext.API.Prelude (GargError)
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Types.Individu (User(..))
 import Gargantext.Database.Action.Flow (FlowCmdM, flowCorpusFile, flowAnnuaire, TermType(..))
-import Gargantext.Database.Query.Table.User (insertUsersDemo)
 import Gargantext.Database.Admin.Types.Hyperdata (toHyperdataDocument)
 import Gargantext.Database.Admin.Types.Node (CorpusId)
 import Gargantext.Database.Prelude (Cmd)
@@ -42,9 +41,6 @@ main = do
 
   --{-
 
-  let createUsers :: Cmd GargError Int64
-      createUsers = insertUsersDemo
-  
   let
     --tt = (Unsupervised EN 6 0 Nothing)
     tt = (Multi EN)
@@ -70,10 +66,6 @@ main = do
   --}
 
   withDevEnv iniPath $ \env -> do
-    _ <- if fun == "users"
-          then runCmdDev env createUsers
-          else pure 0 --(cs "false")
-
     _ <- if fun == "corpus"
           then runCmdDev env corpus
           else pure 0 --(cs "false")

bin/gargantext-init/Main.hs

@@ -20,10 +20,10 @@ import Data.Either (Either(..))
 import Gargantext.API.Dev (withDevEnv, runCmdDev)
 import Gargantext.API.Prelude (GargError)
 import Gargantext.API.Node () -- instances only
-import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Core.Types.Individu (User(..), arbitraryNewUsers, NewUser(..), arbitraryUsername, GargPassword(..))
 import Gargantext.Database.Action.Flow (getOrMkRoot, getOrMk_RootWithCorpus)
 import Gargantext.Database.Query.Table.Node (getOrMkList)
-import Gargantext.Database.Query.Table.User (insertUsersDemo)
+import Gargantext.Database.Query.Table.User (insertNewUsers, )
 import Gargantext.Database.Admin.Config (userMaster, corpusMasterName)
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Admin.Trigger.Init (initFirstTriggers, initLastTriggers)
@@ -31,6 +31,7 @@ import Gargantext.Database.Admin.Types.Hyperdata (HyperdataCorpus)
 import Gargantext.Database.Prelude (Cmd, )
 import Gargantext.Prelude
 import System.Environment (getArgs)
+import Prelude (getLine)
 
 -- TODO put this in gargantext.ini
 secret :: Text
@@ -40,12 +41,21 @@ main :: IO ()
 main = do
   [iniPath] <- getArgs
 
+  putStrLn "Enter master user (gargantua) _password_ :"
+  password  <- getLine
+
+  putStrLn "Enter master user (gargantua) _email_ :"
+  email     <- getLine
+
+
   let createUsers :: Cmd GargError Int64
-      createUsers = insertUsersDemo
+      createUsers = insertNewUsers (NewUser "gargantua" (cs email) (GargPassword $ cs password)
+                                   : arbitraryNewUsers
+                                   )
 
   let
     mkRoots :: Cmd GargError [(UserId, RootId)]
-    mkRoots = mapM getOrMkRoot $ map UserName ["gargantua", "user1", "user2", "user3"]
+    mkRoots = mapM getOrMkRoot $ map UserName ("gargantua" : arbitraryUsername)
     -- TODO create all users roots
 
   let

build-shell.nix

 { ghc
-, pkgs ? import ./pinned.nix {}
+, pkgs ? import ./pinned-20.09.nix {}
 }:
 let
   buildInputs = with pkgs; [

pinned-20.09.nix

+# this version of nixpkgs contains liblapack at ?
+# this version of nixpkgs contains gsl at ?
+import (builtins.fetchGit {
+  # Descriptive name to make the store path easier to identify
+  name = "nixos-20.09";
+  url = "https://github.com/nixos/nixpkgs/";
+  # Last commit hash for nixos-unstable
+  # `git ls-remote https://github.com/nixos/nixpkgs-channels nixos-20.09`
+  ref = "refs/heads/nixos-20.09";
+  rev = "19db3e5ea2777daa874563b5986288151f502e27";
+})

src/Gargantext/API/Ngrams.hs

@@ -419,6 +419,7 @@ tableNgramsPostChartsAsync utn logStatus = do
               -- printDebug "[tableNgramsPut] Terms, updating Metrics (Histo), cId" cId
               (logRef, logRefSuccess, getRef) <- runJobLog 6 logStatus
               logRef
+{-
               _ <- Metrics.updateChart cId (Just listId) tabType Nothing
               logRefSuccess
               _ <- Metrics.updatePie cId (Just listId) tabType Nothing
@@ -430,6 +431,7 @@ tableNgramsPostChartsAsync utn logStatus = do
               _ <- Metrics.updateTree cId (Just listId) tabType CandidateTerm
               logRefSuccess
               _ <- Metrics.updateTree cId (Just listId) tabType MapTerm
+-}
               logRefSuccess
 
               getRef

src/Gargantext/API/Node.hs

@@ -210,10 +210,10 @@ nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode
            -- TODO gather it
            :<|> tableApi             id'
            :<|> apiNgramsTableCorpus id'
-            
+
            :<|> catApi      id'
            :<|> Search.api  id'
-           :<|> Share.api   id'
+           :<|> Share.api   (RootId $ NodeId uId) id'
            -- Pairing Tools
            :<|> pairWith    id'
            :<|> pairs       id'

src/Gargantext/API/Node/Share.hs

@@ -19,20 +19,21 @@ import Data.Aeson
 import Data.Swagger
 import Data.Text (Text)
 import GHC.Generics (Generic)
-import Servant
-import Test.QuickCheck (elements)
-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.Core.Types.Individu (User(..), arbitraryUsername)
 import Gargantext.Database.Action.Share (ShareNodeWith(..))
 import Gargantext.Database.Action.Share as DB (shareNodeWith, unPublish)
+import Gargantext.Database.Action.User
+import Gargantext.Database.Action.User.New
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Prelude
+import Gargantext.Database.Query.Tree (findNodesId)
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
 import Gargantext.Prelude
+import Servant
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary
+import qualified Data.List as List
 
 ------------------------------------------------------------------------
 data ShareNodeParams = ShareTeamParams   { username :: Text  }
@@ -51,23 +52,42 @@ instance Arbitrary ShareNodeParams where
                        ]
 ------------------------------------------------------------------------
 -- TODO permission
+-- TODO refactor userId which is used twice
+-- TODO change return type for better warning/info/success/error handling on the front
 api :: HasNodeError err
-    => NodeId
+    => User
+    -> NodeId
     -> ShareNodeParams
     -> CmdR err Int
-api nId (ShareTeamParams user') = do
+api userInviting 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
+        Just _  -> do
+          printDebug "[G.A.N.Share.api]" ("Team shared with " <> u)
+          pure u
         Nothing -> do
-          _ <- newUsers [u]
+          username' <- getUsername userInviting
+          _ <- case List.elem username' arbitraryUsername of
+            True  -> do
+              printDebug "[G.A.N.Share.api]" ("demo users are not allowed to invite" :: Text)
+              pure ()
+            False -> do
+              children <- findNodesId nId [NodeCorpus]
+              _ <- case List.null children of
+                True -> do
+                  printDebug "[G.A.N.Share.api]" ("Invitation is enabled if you share a corpus at least" :: Text)
+                  pure 0
+                False -> do 
+                  printDebug "[G.A.N.Share.api]" ("Your invitation is sent to: " <> user')
+                  newUsers [user']
+              pure ()
           pure u
 
-  fromIntegral <$> DB.shareNodeWith (ShareNodeWith_User NodeFolderShared (UserName user)) nId 
-api nId2 (SharePublicParams nId1) =
+  fromIntegral <$> DB.shareNodeWith (ShareNodeWith_User NodeFolderShared (UserName user)) nId
+api _uId nId2 (SharePublicParams nId1) =
 
   fromIntegral <$> DB.shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId1) nId2
 

src/Gargantext/Core/Text/List.hs

@@ -98,7 +98,7 @@ buildNgramsOthersList user uCid groupParams (nt, MapListSize mapListSize) = do
   socialLists' :: FlowCont Text FlowListScores
     <- flowSocialList' MySelfFirst user nt ( FlowCont Map.empty
                                                       $ Map.fromList
-                                                      $ List.zip (Map.keys allTerms) 
+                                                      $ List.zip (Map.keys allTerms)
                                                                  (List.cycle [mempty])
                                            )
   let
@@ -136,7 +136,6 @@ buildNgramsTermsList :: ( HasNodeError err
 buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
 
 -- | Filter 0 With Double
-
 -- Computing global speGen score
   allTerms :: Map Text Double <- getTficf uCid mCid nt
 
@@ -171,6 +170,7 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
 -- Filter 1 With Set NodeId and SpeGen
     selectedTerms = Set.toList $ hasTerms (groupedMonoHead <> groupedMultHead)
  
+
  -- TO remove (and remove HasNodeError instance)
   userListId    <- defaultList uCid
   masterListId  <- defaultList mCid
@@ -214,7 +214,7 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
     (monoScored, multScored) = Map.partitionWithKey (\t _v -> size t < 2) groupedTreeScores_SpeGen
 
       -- filter with max score
-    partitionWithMaxScore = Map.partition (\g -> (view scored_genInc $ view gts'_score g) 
+    partitionWithMaxScore = Map.partition (\g -> (view scored_genInc $ view gts'_score g)
                                                > (view scored_speExc $ view gts'_score g)
                                           )
 
@@ -228,8 +228,8 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
     inclSize = 0.4  :: Double
     exclSize = 1 - inclSize
 
-    splitAt' n' = (both (Map.fromList)) . (List.splitAt (round $ n' * listSizeLocal)) 
-    sortOn   f  = (List.sortOn (Down . (view (gts'_score . f)) . snd)) . Map.toList 
+    splitAt' n' = (both (Map.fromList)) . (List.splitAt (round $ n' * listSizeLocal))
+    sortOn   f  = (List.sortOn (Down . (view (gts'_score . f)) . snd)) . Map.toList
 
 
     monoInc_size = splitAt' $ monoSize * inclSize / 2

src/Gargantext/Core/Text/List/Group/WithStem.hs

@@ -67,7 +67,7 @@ groupWith :: GroupParams
             -> Text
             -> Text
 groupWith GroupIdentity  = identity
-groupWith (GroupParams l _m _n _) = 
+groupWith (GroupParams l _m _n _) =
                     Text.intercalate " "
                   . map (stem l)
                   -- . take n
@@ -81,7 +81,7 @@ groupWithStem_SetNodeId :: GroupParams
                -> FlowCont Text (GroupedTreeScores (Set NodeId))
                -> FlowCont Text (GroupedTreeScores (Set NodeId))
 groupWithStem_SetNodeId g flc
-    | g == GroupIdentity = FlowCont ( (<>) 
+    | g == GroupIdentity = FlowCont ( (<>)
                                       (view flc_scores flc)
                                       (view flc_cont   flc)
                                     ) mempty
@@ -91,7 +91,7 @@ groupWithStem_Double :: GroupParams
                      -> FlowCont Text (GroupedTreeScores Double)
                      -> FlowCont Text (GroupedTreeScores Double)
 groupWithStem_Double g flc
-    | g == GroupIdentity = FlowCont ( (<>) 
+    | g == GroupIdentity = FlowCont ( (<>)
                                       (view flc_scores flc)
                                       (view flc_cont   flc)
                                     ) mempty

src/Gargantext/Core/Types/Individu.hs

@@ -52,7 +52,7 @@ data NewUser a = NewUser { _nu_username :: Username
   deriving (Show)
 
 arbitraryUsername :: [Username]
-arbitraryUsername = ["gargantua"] <> users
+arbitraryUsername = {- ["gargantua"] <> -} users
   where
     users = zipWith (\a b -> a <> (pack . show) b) 
                     (repeat "user") ([1..20]::[Int])
@@ -68,12 +68,13 @@ toUserHash (NewUser u m (GargPassword p)) = do
   h <- Auth.createPasswordHash p
   pure $ NewUser u m h
 
+-- TODO remove
 arbitraryUsersHash :: MonadIO m
                   => m [NewUser HashPassword]
-arbitraryUsersHash = mapM toUserHash arbitraryUsers
+arbitraryUsersHash = mapM toUserHash arbitraryNewUsers
 
-arbitraryUsers :: [NewUser GargPassword]
-arbitraryUsers = map (\u -> NewUser u (u <> "@gargantext.org") (GargPassword $ reverse u))
+arbitraryNewUsers :: [NewUser GargPassword]
+arbitraryNewUsers = map (\u -> NewUser u (u <> "@gargantext.org") (GargPassword $ reverse u))
                      arbitraryUsername
 
 

src/Gargantext/Database/Action/User.hs

@@ -31,7 +31,7 @@ getUserId u = do
   maybeUser <- getUserId' u
   case maybeUser of
     Nothing -> nodeError NoUserFound
-    Just u  -> pure u
+    Just u'  -> pure u'
 
 getUserId' :: HasNodeError err
           => User

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

@@ -44,9 +44,10 @@ newUserQuick n = do
   pass <- gargPass
   let u = case guessUserName n of
         Just  (u', _m) -> u'
-        Nothing        -> panic "Email invalid"
+        Nothing        -> panic "[G.D.A.U.N.newUserQuick]: Email invalid"
   pure (NewUser u n (GargPassword pass))
 
+------------------------------------------------------------------------
 isEmail :: Text -> Bool
 isEmail = ((==) 2) . List.length . (splitOn "@")
 
@@ -69,12 +70,17 @@ newUsers' address us = do
   _   <- liftBase         $ mapM (mail Invitation address) us
   pure r
 ------------------------------------------------------------------------
+
+data SendEmail = SendEmail Bool
+
 updateUser :: HasNodeError err
-           => Text -> NewUser GargPassword -> Cmd err Int64
-updateUser address u = do
+           => SendEmail -> Text -> NewUser GargPassword -> Cmd err Int64
+updateUser (SendEmail send) address u = do
   u' <- liftBase     $ toUserHash   u
   n  <- updateUserDB $ toUserWrite  u'
-  _  <- liftBase     $ mail Update address u
+  _  <- case send of
+     True  -> liftBase     $ mail Update address u
+     False -> pure ()
   pure n
 
 ------------------------------------------------------------------------

src/Gargantext/Database/Query/Table/User.hs

@@ -24,7 +24,7 @@ module Gargantext.Database.Query.Table.User
   , updateUserDB
   , queryUserTable
   , getUser
-  , insertUsersDemo
+  , insertNewUsers
   , selectUsersLightWith
   , userWithUsername
   , userWithId
@@ -81,7 +81,7 @@ toUserWrite (NewUser u m (Auth.PasswordHash p)) =
          (pgStrictText "first_name")
          (pgStrictText "last_name")
          (pgStrictText m)
-         (pgBool True) 
+         (pgBool True)
          (pgBool True) Nothing
 
 ------------------------------------------------------------------
@@ -141,9 +141,9 @@ getUser u = userLightWithUsername u <$> usersLight
 
 
 ----------------------------------------------------------------------
-insertUsersDemo :: Cmd err Int64
-insertUsersDemo = do
-  users <- liftBase arbitraryUsersHash
+insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
+insertNewUsers newUsers = do
+  users <- liftBase $ mapM toUserHash newUsers
   insertUsers $ map toUserWrite users
 
 ----------------------------------------------------------------------

src/Gargantext/Prelude/Job.hs

@@ -48,6 +48,8 @@ runJobLog num logStatus = do
       logStatus jl
     logRefSuccessF ref = do
       jl <- liftBase $ readIORef ref
-      liftBase $ writeIORef ref $ jobLogSuccess jl
+      let jl' = jobLogSuccess jl
+      liftBase $ writeIORef ref jl'
+      logStatus jl'
     getRefF ref = do
       liftBase $ readIORef ref