[Sugar] fun to create users with password

src/Gargantext/API/Admin/Settings.hs

@@ -45,7 +45,7 @@ import qualified Data.ByteString.Lazy as L
 import Gargantext.API.Admin.Types
 import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
 import Gargantext.API.Ngrams (saveRepo)
-import Gargantext.Database.Prelude (databaseParameters, Cmd', runCmd, HasConfig(..))
+import Gargantext.Database.Prelude (databaseParameters, Cmd', Cmd'', runCmd, HasConfig(..))
 import Gargantext.Prelude
 import Gargantext.Prelude.Config (GargConfig(..), gc_repofilepath, readConfig, defaultConfig)
 
@@ -216,10 +216,10 @@ withDevEnv iniPath k = do
 
 -- | Run Cmd Sugar for the Repl (GHCI)
 
-runCmdRepl :: Show err => Cmd' DevEnv err a -> IO a
+runCmdRepl :: Show err => Cmd'' DevEnv err a -> IO a
 runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
 
-runCmdReplServantErr :: Cmd' DevEnv ServerError a -> IO a
+runCmdReplServantErr :: Cmd'' DevEnv ServerError a -> IO a
 runCmdReplServantErr = runCmdRepl
 
 -- Use only for dev
@@ -227,7 +227,7 @@ runCmdReplServantErr = runCmdRepl
 -- the command.
 -- This function is constrained to the DevEnv rather than
 -- using HasConnectionPool and HasRepoVar.
-runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
+runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
 runCmdDev env f =
   (either (fail . show) pure =<< runCmd env f)
     `finally`

src/Gargantext/API/Dev.hs

@@ -9,5 +9,5 @@ import Gargantext.Database.Prelude
 import Gargantext.Prelude
 
 -------------------------------------------------------------------
-runCmdReplEasy :: Cmd' DevEnv GargError a -> IO a
+runCmdReplEasy :: Cmd'' DevEnv GargError a -> IO a
 runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f

src/Gargantext/API/Ngrams/Types.hs

@@ -13,10 +13,8 @@ import Codec.Serialise (Serialise())
 import Control.Category ((>>>))
 import Control.Concurrent
 import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~))
-import Control.Monad.Error.Class (MonadError)
 import Control.Monad.Reader
 import Control.Monad.State
-import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson hiding ((.=))
 import Data.Aeson.TH (deriveJSON)
 import Data.Either (Either(..))
@@ -51,7 +49,7 @@ import Gargantext.Core.Text (size)
 import Gargantext.Core.Types (ListType(..), NodeId)
 import Gargantext.Core.Types (TODO)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger, wellNamedSchema)
-import Gargantext.Database.Prelude (fromField')
+import Gargantext.Database.Prelude (fromField', CmdM')
 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 
 ------------------------------------------------------------------------
@@ -710,9 +708,7 @@ instance HasRepoSaver RepoEnv where
   repoSaver = renv_saver
 
 type RepoCmdM   env err m =
-  ( MonadReader env     m
-  , MonadError      err m
-  , MonadBaseControl IO m
+  ( CmdM' env err m
   , HasRepo     env
   )
 

src/Gargantext/API/Prelude.hs

@@ -87,11 +87,12 @@ type GargServerC env err m =
     , HasConfig    env
     )
 
-type GargServerT env err m api = GargServerC env err m => ServerT api m
 
 type GargServer api =
   forall env err m. GargServerT env err m api
 
+type GargServerT env err m api = GargServerC env err m => ServerT api m
+
 -- This is the concrete monad. It needs to be used as little as possible,
 -- instead, prefer GargServer, GargServerT, GargServerC.
 type GargServerM env err = ReaderT env (ExceptT err IO)
@@ -106,6 +107,9 @@ type EnvC env =
 
 -------------------------------------------------------------------
 -- | This Type is needed to prepare the function before the GargServer
+type GargNoServer t =
+  forall env err m. GargNoServer' env err m => m t
+
 type GargNoServer' env err m =
   ( CmdM           env err m
   , HasRepo        env
@@ -113,8 +117,6 @@ type GargNoServer' env err m =
   , HasNodeError       err
   )
 
-type GargNoServer t =
-  forall env err m. GargNoServer' env err m => m t
 -------------------------------------------------------------------
 
 data GargError

src/Gargantext/Core/Types/Individu.hs

@@ -49,6 +49,7 @@ data NewUser a = NewUser { _nu_username :: Username
                          , _nu_email    :: Email
                          , _nu_password :: a
                          }
+  deriving (Show)
 
 arbitraryUsername :: [Username]
 arbitraryUsername = ["gargantua"] <> users

src/Gargantext/Database/Action/User.hs

@@ -15,28 +15,54 @@ module Gargantext.Database.Action.User
   where
 
 -- import Data.Maybe (catMaybes)
-import Data.Text (Text, unlines)
+import Data.Text (Text, unlines, splitOn)
 import Gargantext.Database.Query.Table.User
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Prelude
+import Control.Monad.Random
 import Gargantext.Prelude
 import Gargantext.Prelude.Mail (gargMail, GargMail(..))
 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..))
 import Gargantext.Database.Action.Flow (getOrMkRoot)
+import Gargantext.Prelude.Crypto.Pass.User (gargPass)
 
+type EmailAddress = Text
+
+------------------------------------------------------------------------
+newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err) => Text -> [Text] -> m Int64
+newUsers address us = do
+  us' <- mapM newUserQuick us
+  newUsers' address us'
 ------------------------------------------------------------------------
-mkUser :: HasNodeError err => Text -> NewUser GargPassword -> Cmd err Int64
-mkUser address u = mkUsers address [u]
+newUserQuick :: (MonadRandom m) => Text -> m (NewUser GargPassword)
+newUserQuick n = do
+  pass <- gargPass
+  let (u,_m) = guessUserName n
+  pure (NewUser u n (GargPassword pass))
+
+-- | TODO better check for invalid email adress
+guessUserName :: Text -> (Text,Text)
+guessUserName n = case splitOn "@" n of
+    [u',m'] -> if m' /= "" then (u',m')
+                           else panic "Email Invalid"
+    _  -> panic "Email invalid"
 
-mkUsers :: HasNodeError err => Text -> [NewUser GargPassword] -> Cmd err Int64
-mkUsers address us = do
+------------------------------------------------------------------------
+newUser' :: HasNodeError err
+        => Text -> NewUser GargPassword -> Cmd err Int64
+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'
   _   <- mapM getOrMkRoot $ map (\u -> UserName (_nu_username u)) us
   _   <- liftBase    $ mapM (mail Invitation address) us
   pure r
 ------------------------------------------------------------------------
-updateUser :: HasNodeError err => Text -> NewUser GargPassword -> Cmd err Int64
+updateUser :: HasNodeError err
+           => Text -> NewUser GargPassword -> Cmd err Int64
 updateUser address u = do
   u' <- liftBase   $ toUserHash   u
   n  <- updateUserDB $ toUserWrite  u'
@@ -66,8 +92,8 @@ logInstructions address (NewUser u _ (GargPassword p)) =
   unlines [ "Hello"
           , "You have been invited to test the new GarganText platform!"
           , ""
-          , "You can log on to: "  <> address
-          , "Your login is: "      <> u
+          , "You can log in to: " <> address
+          , "Your username is: "  <> u
           , "Your password is: "  <> p
           , ""
           , "Please read the full terms of use on:"
@@ -88,8 +114,8 @@ updateInstructions address (NewUser u _ (GargPassword p)) =
   unlines [ "Hello"
           , "Your account have been updated on the GarganText platform!"
           , ""
-          , "You can log on to: "  <> address
-          , "Your login is: "      <> u
+          , "You can log in to: " <> address
+          , "Your username is: "  <> u
           , "Your password is: "  <> p
           , ""
           , "As reminder, please read the full terms of use on:"
@@ -106,7 +132,6 @@ updateInstructions address (NewUser u _ (GargPassword p)) =
           ]
 
 
-
 ------------------------------------------------------------------------
 rmUser :: HasNodeError err => User -> Cmd err Int64
 rmUser (UserName un) = deleteUsers [un]

src/Gargantext/Database/Prelude.hs

@@ -18,6 +18,7 @@ import Control.Lens (Getter, view)
 import Control.Monad.Error.Class -- (MonadError(..), Error)
 import Control.Monad.Except
 import Control.Monad.Reader
+import Control.Monad.Random
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
 import Data.ByteString.Char8 (hPutStrLn)
@@ -58,10 +59,19 @@ instance HasConfig GargConfig where
 -------------------------------------------------------
 type JSONB = QueryRunnerColumnDefault PGJsonb
 -------------------------------------------------------
+
+type CmdM'' env err m =
+  ( MonadReader     env     m
+  , MonadError          err m
+  , MonadBaseControl IO     m
+  , MonadRandom             m
+  )
+
 type CmdM' env err m =
   ( MonadReader     env     m
   , MonadError          err m
   , MonadBaseControl IO     m
+  -- , MonadRandom             m
   )
 
 type CmdM env err m =
@@ -70,10 +80,16 @@ type CmdM env err m =
   , HasConfig         env
   )
 
+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
 
+
+
+
+
+
+
 fromInt64ToInt :: Int64 -> Int
 fromInt64ToInt = fromIntegral
 
@@ -85,7 +101,7 @@ mkCmd k = do
 
 runCmd :: (HasConnectionPool env)
        => env
-       -> Cmd' env err a
+       -> Cmd'' env err a
        -> IO (Either err a)
 runCmd env m = runExceptT $ runReaderT m env
 
@@ -107,8 +123,9 @@ formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
 
-runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m,
-                PGS.FromRow r, PGS.ToRow q, HasConnectionPool env, HasConfig env)
+runPGSQuery :: ( CmdM env err m
+               , PGS.FromRow r, PGS.ToRow q
+               )
                => PGS.Query -> q -> m [r]
 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
   where

src/Gargantext/Prelude/Crypto/Pass/User.hs

@@ -7,7 +7,8 @@ Maintainer  : team@gargantext.org
 Stability   : experimental
 Portability : POSIX
 
-Easy password manager for User (easy to memorize).
+1) quick password generator for first invitations
+2) Easy password manager for User (easy to memorize) (needs list of words)
 
 -}
 
@@ -15,17 +16,61 @@ Easy password manager for User (easy to memorize).
 module Gargantext.Prelude.Crypto.Pass.User
       where
 
-import Data.List ((!!))
+
+-- | 1) Quick password generator imports
+import Data.Text (Text)
+import Data.String (String)
+import Control.Monad
+import Control.Monad.Random
+import Data.List hiding (sum)
+
+-- | 2) Easy password manager imports
 import Gargantext.Prelude
 import Gargantext.Prelude.Utils (shuffle)
-import System.Random
 
+
+-- | 1) Quick password generator
+-- | Inspired by Rosetta code
+-- https://www.rosettacode.org/wiki/Password_generator#Haskell
+gargPass :: MonadRandom m => m Text
+gargPass = cs <$> gargPass' chars 33
+  where
+    chars = zipWith (\\) charSets visualySimilar
+
+    charSets = [ ['a'..'z']
+               , ['A'..'Z']
+               , ['0'..'9']
+               , "!\"#$%&'()*+,-./:;<=>?@[]^_{|}~"
+               ]
+ 
+    visualySimilar = ["l","IOSZ","012","!|.,'\""]
+
+gargPass' :: MonadRandom m => [String] -> Int -> m String
+gargPass' charSets n = do
+  parts <- getPartition n
+  chars <- zipWithM replicateM parts (uniform <$> charSets)
+  shuffle' (concat chars)
+  where
+    getPartition n' = adjust <$> replicateM (k-1) (getRandomR (1, n' `div` k))
+    k = length charSets
+    adjust p = (n - sum p) : p
+ 
+shuffle' :: (Eq a, MonadRandom m) => [a] -> m [a]
+shuffle' [] = pure []
+shuffle' lst = do
+  x <- uniform lst
+  xs <- shuffle (delete x lst)
+  return (x : xs)
+
+
+
+-- | 2) Easy password manager
 -- TODO add this as parameter to gargantext.ini
-gargPassUser :: (Num a, Enum a, Integral a) => a -> [b] -> IO [b]
-gargPassUser n = gargPassUser' (100 * fromIntegral n) n
+gargPassUserEasy :: (Num a, Enum a, Integral a) => a -> [b] -> IO [b]
+gargPassUserEasy n = gargPassUserEasy' (100 * fromIntegral n) n
 
-gargPassUser' :: (Num a, Enum a) => Int -> a -> [b] -> IO [b]
-gargPassUser' threshold size wlist
+gargPassUserEasy' :: (Num a, Enum a) => Int -> a -> [b] -> IO [b]
+gargPassUserEasy' threshold size wlist
   | length wlist > threshold  = generatePassword size wlist
   | otherwise                 = panic "List to short"