Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
118
Issues
118
List
Board
Labels
Milestones
Merge Requests
7
Merge Requests
7
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
fc2afd68
Commit
fc2afd68
authored
May 16, 2022
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[auth] forgot password sets uuid now
Still, email is missing and the handling of user click.
parent
f06878f6
Pipeline
#2826
failed with stage
in 24 minutes and 50 seconds
Changes
9
Pipelines
1
Show whitespace changes
Inline
Side-by-side
Showing
9 changed files
with
150 additions
and
54 deletions
+150
-54
gargantext.cabal
gargantext.cabal
+0
-1
Auth.hs
src/Gargantext/API/Admin/Auth.hs
+44
-2
Types.hs
src/Gargantext/API/Admin/Auth/Types.hs
+2
-2
Client.hs
src/Gargantext/API/Client.hs
+2
-0
UserInfo.hs
src/Gargantext/API/GraphQL/UserInfo.hs
+2
-4
Routes.hs
src/Gargantext/API/Routes.hs
+1
-1
Server.hs
src/Gargantext/API/Server.hs
+2
-1
User.hs
src/Gargantext/Database/Query/Table/User.hs
+51
-12
User.hs
src/Gargantext/Database/Schema/User.hs
+46
-31
No files found.
gargantext.cabal
View file @
fc2afd68
...
...
@@ -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
View file @
fc2afd68
...
...
@@ -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
View file @
fc2afd68
...
...
@@ -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
=
ForgotPasswordRespon
es
{
_fpRes_status
::
String
}
data
ForgotPasswordResponse
=
ForgotPasswordRespon
se
{
_fpRes_status
::
Text
}
deriving
(
Generic
)
$
(
deriveJSON
(
unPrefix
"_fpRes_"
)
''
F
orgotPasswordResponse
)
instance
ToSchema
ForgotPasswordResponse
where
...
...
src/Gargantext/API/Client.hs
View file @
fc2afd68
...
...
@@ -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
View file @
fc2afd68
...
...
@@ -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
View file @
fc2afd68
...
...
@@ -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
View file @
fc2afd68
...
...
@@ -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
View file @
fc2afd68
...
...
@@ -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
View file @
fc2afd68
...
...
@@ -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"
''
U
serPoly
)
$
(
makeLensesWith
abbreviatedFields
''
U
serPoly
)
...
...
@@ -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"
}
)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment