[auth] forgot password sets uuid now

Still, email is missing and the handling of user click.

gargantext.cabal

@@ -95,7 +95,6 @@ library
       Gargantext.Core.Viz.Phylo.SynchronicClustering
       Gargantext.Core.Viz.Types
   other-modules:
-      ConcurrentTest
       Gargantext.API.Admin.Auth
       Gargantext.API.Admin.FrontEnd
       Gargantext.API.Admin.Orchestrator

src/Gargantext/API/Admin/Auth.hs

@@ -25,6 +25,7 @@ TODO-ACCESS Critical
 
 module Gargantext.API.Admin.Auth
   ( auth
+  , forgotPassword
   , withAccess
   )
   where
@@ -32,6 +33,8 @@ module Gargantext.API.Admin.Auth
 import Control.Lens (view)
 import Data.Text.Lazy (toStrict)
 import Data.Text.Lazy.Encoding (decodeUtf8)
+import Data.UUID (UUID)
+import Data.UUID.V4 (nextRandom)
 import Servant
 import Servant.Auth.Server
 import qualified Gargantext.Prelude.Crypto.Auth as Auth
@@ -70,7 +73,7 @@ checkAuthRequest u (GargPassword p) = do
   candidate <- head <$> getUsersWith u
   case candidate of
     Nothing -> pure InvalidUser
-    Just (UserLight id _u _email (GargPassword h)) ->
+    Just (UserLight { userLight_password = GargPassword h, .. }) ->
       case Auth.checkPassword (Auth.mkPassword p) (Auth.PasswordHash h) of
         Auth.PasswordCheckFail    -> pure InvalidPassword
         Auth.PasswordCheckSuccess -> do
@@ -79,7 +82,7 @@ checkAuthRequest u (GargPassword p) = do
             Nothing  -> pure InvalidUser
             Just uid -> do
               token <- makeTokenForUser uid
-              pure $ Valid token uid id
+              pure $ Valid token uid userLight_id
 
 auth :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
      => AuthRequest -> Cmd' env err AuthResponse
@@ -134,3 +137,42 @@ User can create Team in Teams Folder.
 User can invite User in Team as NodeNode only if Team in his parents.
 All users can access to the Team folder as if they were owner.
 -}
+
+forgotPassword :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
+     => ForgotPasswordRequest -> Cmd' env err ForgotPasswordResponse
+forgotPassword (ForgotPasswordRequest email) = do
+  us <- getUsersWithEmail email
+  case us of
+    [u] -> forgotUserPassword u
+    _ -> pure ()
+
+  -- NOTE Sending anything else here could leak information about
+  -- users' emails
+  pure $ ForgotPasswordResponse "ok"
+
+forgotUserPassword :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
+     => UserLight -> Cmd' env err ()
+forgotUserPassword user@(UserLight { .. }) = do
+  printDebug "[forgotUserPassword] userLight_id" userLight_id
+  -- generate uuid for email
+  uuid <- generateForgotPasswordUUID
+
+  -- save user with that uuid
+  _ <- updateUserForgotPasswordUUID user uuid
+
+  -- send email with uuid link
+
+  -- on uuid link enter: change user password and present it to the
+  -- user
+
+  pure ()
+
+-- Generate a unique (in whole DB) UUID for passwords.
+generateForgotPasswordUUID :: (HasSettings env, HasConnectionPool env, HasJoseError err, HasConfig env, HasMail env)
+  => Cmd' env err UUID
+generateForgotPasswordUUID = do
+  uuid <- liftBase $ nextRandom
+  us <- getUsersWithForgotPasswordUUID uuid
+  case us of
+    [] -> pure uuid
+    _ -> generateForgotPasswordUUID

src/Gargantext/API/Admin/Auth/Types.hs

@@ -111,7 +111,7 @@ data PathId = PathNode NodeId | PathNodeNode ListId DocId
 
 ---------------------------
 
-type Email = String
+type Email = Text
 
 data ForgotPasswordRequest = ForgotPasswordRequest { _fpReq_email :: Email }
   deriving (Generic )
@@ -119,7 +119,7 @@ $(deriveJSON (unPrefix "_fpReq_") ''ForgotPasswordRequest)
 instance ToSchema ForgotPasswordRequest where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_fpReq_")
 
-data ForgotPasswordResponse = ForgotPasswordRespones { _fpRes_status :: String }
+data ForgotPasswordResponse = ForgotPasswordResponse { _fpRes_status :: Text }
   deriving (Generic )
 $(deriveJSON (unPrefix "_fpRes_") ''ForgotPasswordResponse)
 instance ToSchema ForgotPasswordResponse where

src/Gargantext/API/Client.hs

@@ -64,6 +64,7 @@ getBackendVersion :: ClientM Text
 
 -- * auth API
 postAuth :: AuthRequest -> ClientM AuthResponse
+forgotPassword :: ForgotPasswordRequest -> ClientM ForgotPasswordResponse
 
 -- * admin api
 getRoots :: Token -> ClientM [Node HyperdataUser]
@@ -438,6 +439,7 @@ clientApi = client (flatten apiGarg)
 getMetricsSample :<|> getMetricSample :<|> _ = client (Proxy :: Proxy (Flat EkgAPI))
 
 postAuth
+  :<|> forgotPassword
   :<|> getBackendVersion
   :<|> getRoots
   :<|> putRoots

src/Gargantext/API/GraphQL/UserInfo.hs

@@ -137,10 +137,8 @@ updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
           -- The userLight_email is more important: it is used for login and sending mail.
           -- Therefore we update ui_cwTouchMail and userLight_email.
           -- ui_cwTouchMail is to be removed in the future.
-          let u' = UserLight { userLight_id
-                            , userLight_username
-                            , userLight_email = fromMaybe userLight_email $ view ui_cwTouchMailL u_hyperdata
-                            , userLight_password }
+          let u' = UserLight { userLight_email = fromMaybe userLight_email $ view ui_cwTouchMailL u_hyperdata
+                             , .. }
           -- lift $ printDebug "[updateUserInfo] with firstName" u_hyperdata'
           _ <- lift $ updateHyperdata (node_u ^. node_id) u_hyperdata'
           _ <- lift $ updateUserEmail u'

src/Gargantext/API/Routes.hs

@@ -29,7 +29,7 @@ import Servant.Job.Async
 import Servant.Swagger.UI
 
 import Gargantext.API.Admin.Auth (withAccess)
-import Gargantext.API.Admin.Auth.Types (AuthRequest, AuthResponse, AuthenticatedUser(..), PathId(..))
+import Gargantext.API.Admin.Auth.Types (AuthRequest, AuthResponse, AuthenticatedUser(..), ForgotPasswordRequest, ForgotPasswordResponse, PathId(..))
 import Gargantext.API.Admin.FrontEnd (FrontEndAPI)
 import Gargantext.API.Context
 import Gargantext.API.Count  (CountAPI, count, Query)

src/Gargantext/API/Server.hs

@@ -28,7 +28,7 @@ import qualified Paths_gargantext           as PG -- cabal magic build module
 import qualified Gargantext.API.Public      as Public
 
 import Gargantext.API.Admin.Auth.Types (AuthContext)
-import Gargantext.API.Admin.Auth (auth)
+import Gargantext.API.Admin.Auth (auth, forgotPassword)
 import Gargantext.API.Admin.FrontEnd (frontEndServer)
 import qualified Gargantext.API.GraphQL as GraphQL
 import Gargantext.API.Prelude
@@ -44,6 +44,7 @@ import Gargantext.Prelude.Config (gc_url_backend_api)
 serverGargAPI :: ToJSON err => Text -> GargServerM env err GargAPI
 serverGargAPI baseUrl -- orchestrator
        =  auth
+     :<|> forgotPassword
      :<|> gargVersion
      :<|> serverPrivateGargAPI
      :<|> Public.api baseUrl

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

@@ -27,6 +27,7 @@ module Gargantext.Database.Query.Table.User
   , getUsersWithHyperdata
   , getUsersWithNodeHyperdata
   , updateUserEmail
+  , updateUserForgotPasswordUUID
   , getUser
   , insertNewUsers
   , selectUsersLightWith
@@ -34,6 +35,8 @@ module Gargantext.Database.Query.Table.User
   , userWithId
   , userLightWithId
   , getUsersWith
+  , getUsersWithEmail
+  , getUsersWithForgotPasswordUUID
   , getUsersWithId
   , module Gargantext.Database.Schema.User
   )
@@ -44,6 +47,7 @@ import Control.Lens ((^.))
 import Data.List (find)
 import Data.Text (Text)
 import Data.Time (UTCTime)
+import qualified Data.UUID as UUID
 import Gargantext.Core.Types.Individu
 import qualified Gargantext.Prelude.Crypto.Auth as Auth
 import Gargantext.Database.Admin.Config (nodeTypeId)
@@ -75,25 +79,34 @@ updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
     updateUserQuery :: UserWrite -> Update Int64
     updateUserQuery us' = Update
       { uTable      = userTable
-      , uUpdateWith = updateEasy (\ (UserDB _id _p ll su un fn ln _em is ia dj)
-                                  -> UserDB _id p' ll su un fn ln em' is ia dj
+      , uUpdateWith = updateEasy (\ (UserDB { .. })
+                                  -> UserDB { user_password = p'
+                                            , user_email = em'
+                                            , .. }
                                  )
       , uWhere      = (\row -> user_username row .== un')
       , uReturning  = rCount
       }
         where
-          UserDB _ p' _ _ un' _ _ em' _ _ _ = us'
+          UserDB { user_password = p'
+                 , user_username = un'
+                 , user_email = em' } = us'
 
 -----------------------------------------------------------------------
 toUserWrite :: NewUser HashPassword -> UserWrite
 toUserWrite (NewUser u m (Auth.PasswordHash p)) = 
-  UserDB (Nothing) (sqlStrictText p)
-         (Nothing) (sqlBool True) (sqlStrictText u)
-         (sqlStrictText "first_name")
-         (sqlStrictText "last_name")
-         (sqlStrictText m)
-         (sqlBool True)
-         (sqlBool True) Nothing
+  UserDB { user_id = Nothing
+         , user_password = sqlStrictText p
+         , user_lastLogin = Nothing
+         , user_isSuperUser = sqlBool True
+         , user_username = sqlStrictText u
+         , user_firstName = sqlStrictText "first_name"
+         , user_lastName = sqlStrictText "last_name"
+         , user_email = sqlStrictText m
+         , user_isStaff = sqlBool True
+         , user_isActive = sqlBool True
+         , user_dateJoined = Nothing
+         , user_forgot_password_uuid = Nothing }
 
 ------------------------------------------------------------------
 getUsersWith :: Username -> Cmd err [UserLight]
@@ -105,6 +118,24 @@ selectUsersLightWith u = proc () -> do
       restrict -< user_username row .== sqlStrictText u
       returnA  -< row
 
+getUsersWithEmail :: Text -> Cmd err [UserLight]
+getUsersWithEmail e = map toUserLight <$> runOpaQuery (selectUsersLightWithEmail e)
+
+selectUsersLightWithEmail :: Text -> Select UserRead
+selectUsersLightWithEmail e = proc () -> do
+      row      <- queryUserTable -< ()
+      restrict -< user_email row .== sqlStrictText e
+      returnA  -< row
+
+getUsersWithForgotPasswordUUID :: UUID.UUID -> Cmd err [UserLight]
+getUsersWithForgotPasswordUUID uuid = map toUserLight <$> runOpaQuery (selectUsersLightWithForgotPasswordUUID uuid)
+
+selectUsersLightWithForgotPasswordUUID :: UUID.UUID -> Select UserRead
+selectUsersLightWithForgotPasswordUUID uuid = proc () -> do
+      row      <- queryUserTable -< ()
+      restrict -< user_forgot_password_uuid row .== sqlStrictText (UUID.toText uuid)
+      returnA  -< row
+
 ----------------------------------------------------------
 getUsersWithId :: Int -> Cmd err [UserLight]
 getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
@@ -165,12 +196,20 @@ updateUserEmail (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
     updateUserQuery :: Update Int64
     updateUserQuery = Update
       { uTable      = userTable
-      , uUpdateWith = updateEasy (\ (UserDB _id _p _ll _su _un _fn _ln _em _is _ia _dj)
-                                  -> UserDB _id _p _ll _su _un _fn _ln (sqlStrictText userLight_email) _is _ia _dj)
+      , uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_email = sqlStrictText userLight_email, .. } )
       , uWhere      = (\row -> user_id row .== (sqlInt4 userLight_id))
       , uReturning  = rCount }
 
 
+updateUserForgotPasswordUUID :: UserLight -> UUID.UUID -> Cmd err Int64
+updateUserForgotPasswordUUID (UserLight { .. }) uuid = mkCmd $ \c -> runUpdate_ c updateUserQuery
+  where
+    updateUserQuery :: Update Int64
+    updateUserQuery = Update
+      { uTable      = userTable
+      , uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_forgot_password_uuid = sqlStrictText $ UUID.toText uuid, .. })
+      , uWhere      = (\row -> user_id row .== (sqlInt4 userLight_id))
+      , uReturning  = rCount }
 ------------------------------------------------------------------
 -- | Select User with some parameters
 -- Not optimized version

src/Gargantext/Database/Schema/User.hs

@@ -45,18 +45,27 @@ data UserLight = UserLight { userLight_id       :: !Int
                            , userLight_username             :: !Text
                            , userLight_email                :: !Text
                            , userLight_password             :: !GargPassword
+                           , userLight_forgot_password_uuid :: !(Maybe Text)
                            } deriving (Show, Generic)
 
 instance GQLType UserLight where
   typeOptions _ = GAGU.unPrefix "userLight_"
 
 toUserLight :: UserDB -> UserLight
-toUserLight (UserDB id p _ _ u _ _ e _ _ _ ) = UserLight id u e (toGargPassword p)
+toUserLight (UserDB { user_id
+                    , user_password
+                    , user_username
+                    , user_email }) = UserLight { userLight_id = user_id
+                                                , userLight_username = user_username
+                                                , userLight_email = user_email
+                                                , userLight_password = toGargPassword user_password
+                                                , userLight_forgot_password_uuid = Nothing }
 
 
 data UserPoly id pass llogin suser
               uname fname lname
-              mail staff active djoined =
+              mail staff active djoined
+              fpuuid =
     UserDB { user_id                   :: !id
            , user_password             :: !pass
            , user_lastLogin            :: !llogin
@@ -70,6 +79,8 @@ data UserPoly id pass llogin suser
            , user_isStaff              :: !staff
            , user_isActive             :: !active
            , user_dateJoined           :: !djoined
+
+           , user_forgot_password_uuid :: !fpuuid
            } deriving (Show, Generic)
 
 
@@ -79,6 +90,7 @@ type UserWrite = UserPoly (Maybe (Column SqlInt4))        (Column SqlText)
                                  (Column SqlText)         (Column SqlText)
                                  (Column SqlBool)         (Column SqlBool)
                                  (Maybe (Column SqlTimestamptz))
+                                 (Maybe (Column SqlText))
 
 type UserRead  = UserPoly        (Column SqlInt4)         (Column SqlText)
                                  (Column SqlTimestamptz)  (Column SqlBool)
@@ -86,6 +98,7 @@ type UserRead  = UserPoly        (Column SqlInt4)         (Column SqlText)
                                  (Column SqlText)         (Column SqlText)
                                  (Column SqlBool)         (Column SqlBool)
                                  (Column SqlTimestamptz)
+                                 (Column SqlText)
 
 type UserReadNull = UserPoly     (Column (Nullable SqlInt4))         (Column (Nullable SqlText))
                                  (Column (Nullable SqlTimestamptz))  (Column (Nullable SqlBool))
@@ -93,8 +106,9 @@ type UserReadNull = UserPoly     (Column (Nullable SqlInt4))         (Column (Nu
                                  (Column (Nullable SqlText))         (Column (Nullable SqlText))
                                  (Column (Nullable SqlBool))         (Column (Nullable SqlBool))
                                  (Column (Nullable SqlTimestamptz))
+                                 (Column (Nullable SqlText))
 
-type UserDB = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime
+type UserDB = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime (Maybe Text)
 
 $(makeAdaptorAndInstance "pUserDB"   ''UserPoly)
 $(makeLensesWith abbreviatedFields   ''UserPoly)
@@ -112,6 +126,7 @@ userTable = Table "auth_user"
                   , user_isStaff              = requiredTableField "is_staff"
                   , user_isActive             = requiredTableField "is_active"
                   , user_dateJoined           = optionalTableField "date_joined"
+                  , user_forgot_password_uuid = optionalTableField "forgot_password_uuid"
                   }
       )