[Clean] New Users fun

src/Gargantext/Core/Types/Individu.hs

@@ -30,6 +30,7 @@ data User = UserDBId UserId | UserName Text | RootId NodeId | UserPublic
 
 type Username = Text
 
+type HashPassword    = Auth.PasswordHash Auth.Argon2
 newtype GargPassword = GargPassword Text
   deriving (Generic)
 
@@ -40,12 +41,14 @@ instance ToJSON GargPassword
 instance FromJSON GargPassword
 
 instance ToSchema GargPassword
-
-type Email    = Text
-
+type Email          = Text
 type UsernameMaster = Username
 type UsernameSimple = Username
 
+data NewUser a = NewUser { _nu_username :: Username
+                         , _nu_email    :: Email
+                         , _nu_password :: a
+                         }
 
 arbitraryUsername :: [Username]
 arbitraryUsername = ["gargantua"] <> users
@@ -57,19 +60,19 @@ arbitraryPassword :: [GargPassword]
 arbitraryPassword = map (\u -> GargPassword (reverse u)) arbitraryUsername
 
 -----------------------------------------------------------
+userHash :: MonadIO m
+         =>    NewUser GargPassword
+         -> m (NewUser HashPassword)
+userHash (NewUser u m (GargPassword p)) = do
+  h <- Auth.createPasswordHash p
+  pure $ NewUser u m h
 
 arbitraryUsersHash :: MonadIO m
-                  => m [(Username, Email, Auth.PasswordHash Auth.Argon2)]
+                  => m [NewUser HashPassword]
 arbitraryUsersHash = mapM userHash arbitraryUsers
 
-userHash :: MonadIO m
-                  => (Username, Email, GargPassword)
-                  -> m (Username, Email, Auth.PasswordHash Auth.Argon2)
-userHash (u,m,GargPassword p) = do
-  h <- Auth.createPasswordHash p
-  pure (u, m, h)
-
-arbitraryUsers :: [(Username, Email, GargPassword)]
-arbitraryUsers = map (\u -> (u, u <> "@gargantext.org", GargPassword $ reverse u)) arbitraryUsername
+arbitraryUsers :: [NewUser GargPassword]
+arbitraryUsers = map (\u -> NewUser u (u <> "@gargantext.org") (GargPassword $ reverse u))
+                     arbitraryUsername
 
 

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

@@ -97,6 +97,3 @@ queryInsertNgrams = [sql|
     JOIN   ngrams c USING (terms);     -- columns of unique index
            |]
 
-
-
-

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

@@ -21,7 +21,6 @@ module Gargantext.Database.Query.Table.User
   ( insertUsers
   , queryUserTable
   , getUser
-  , gargUserWith
   , insertUsersDemo
   , selectUsersLightWith
   , userWithUsername
@@ -46,8 +45,6 @@ import Gargantext.Prelude
 import Opaleye
 
 ------------------------------------------------------------------------
-
-
 -- TODO: on conflict, nice message
 insertUsers :: [UserWrite] -> Cmd err Int64
 insertUsers us = mkCmd $ \c -> runInsert_ c insert
@@ -57,17 +54,18 @@ insertUsers us = mkCmd $ \c -> runInsert_ c insert
 insertUsersDemo :: Cmd err Int64
 insertUsersDemo = do
   users <- liftBase arbitraryUsersHash
-  insertUsers $ map (\(u,m,h) -> gargUserWith u m h) users
+  insertUsers $ map toUserWrite users
 
 -----------------------------------------------------------------------
-gargUserWith :: Username -> Email -> Auth.PasswordHash Auth.Argon2 -> UserWrite
-gargUserWith u m (Auth.PasswordHash p) = UserDB (Nothing) (pgStrictText p)
-                         (Nothing) (pgBool True) (pgStrictText u)
-                         (pgStrictText "first_name")
-                         (pgStrictText "last_name")
-                         (pgStrictText m)
-                         (pgBool True) 
-                         (pgBool True) Nothing
+toUserWrite :: NewUser HashPassword -> UserWrite
+toUserWrite (NewUser u m (Auth.PasswordHash p)) = 
+  UserDB (Nothing) (pgStrictText p)
+         (Nothing) (pgBool True) (pgStrictText u)
+         (pgStrictText "first_name")
+         (pgStrictText "last_name")
+         (pgStrictText m)
+         (pgBool True) 
+         (pgBool True) Nothing
 
 ------------------------------------------------------------------
 getUsersWith :: Username -> Cmd err [UserLight]
@@ -101,11 +99,7 @@ userLightWithUsername t xs = userWith userLight_username t xs
 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 userLightWithId t xs = userWith userLight_id t xs
 
-
-instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
-  queryRunnerColumnDefault = fieldQueryRunnerColumn
-
-
+----------------------------------------------------------------------
 users :: Cmd err [UserDB]
 users = runOpaQuery queryUserTable
 
@@ -115,3 +109,6 @@ usersLight = map toUserLight <$> users
 getUser :: Username -> Cmd err (Maybe UserLight)
 getUser u = userLightWithUsername u <$> usersLight
 
+----------------------------------------------------------------------
+instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
+  queryRunnerColumnDefault = fieldQueryRunnerColumn