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
195
Issues
195
List
Board
Labels
Milestones
Merge Requests
12
Merge Requests
12
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
10c49b00
Commit
10c49b00
authored
Dec 02, 2024
by
Grégoire Locqueville
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Renamed `Cmd'` -> `Cmd`
parent
87b2e8dc
Changes
7
Show whitespace changes
Inline
Side-by-side
Showing
7 changed files
with
25 additions
and
25 deletions
+25
-25
Admin.hs
bin/gargantext-cli/CLI/Admin.hs
+1
-1
Auth.hs
src/Gargantext/API/Admin/Auth.hs
+7
-7
Dev.hs
src/Gargantext/API/Dev.hs
+7
-7
Utils.hs
src/Gargantext/API/GraphQL/Utils.hs
+2
-2
Jobs.hs
src/Gargantext/Core/Worker/Jobs.hs
+2
-2
Delete.hs
src/Gargantext/Database/Action/Delete.hs
+2
-2
Prelude.hs
src/Gargantext/Database/Prelude.hs
+4
-4
No files found.
bin/gargantext-cli/CLI/Admin.hs
View file @
10c49b00
...
@@ -21,7 +21,7 @@ import Prelude (String)
...
@@ -21,7 +21,7 @@ import Prelude (String)
adminCLI
::
AdminArgs
->
IO
()
adminCLI
::
AdminArgs
->
IO
()
adminCLI
(
AdminArgs
settingsPath
mails
)
=
do
adminCLI
(
AdminArgs
settingsPath
mails
)
=
do
withDevEnv
settingsPath
$
\
env
->
do
withDevEnv
settingsPath
$
\
env
->
do
x
<-
runCmdDev
env
((
newUsers
$
NE
.
map
cs
(
NE
.
fromList
mails
))
::
Cmd
''
DevEnv
BackendInternalError
(
NonEmpty
UserId
))
x
<-
runCmdDev
env
((
newUsers
$
NE
.
map
cs
(
NE
.
fromList
mails
))
::
Cmd
Random
DevEnv
BackendInternalError
(
NonEmpty
UserId
))
putStrLn
(
show
x
::
Text
)
putStrLn
(
show
x
::
Text
)
adminCmd
::
HasCallStack
=>
Mod
CommandFields
CLI
adminCmd
::
HasCallStack
=>
Mod
CommandFields
CLI
...
...
src/Gargantext/API/Admin/Auth.hs
View file @
10c49b00
...
@@ -62,7 +62,7 @@ import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
...
@@ -62,7 +62,7 @@ import Gargantext.Core.Types.Individu (User(..), Username, GargPassword(..))
import
Gargantext.Core.Worker.Jobs.Types
qualified
as
Jobs
import
Gargantext.Core.Worker.Jobs.Types
qualified
as
Jobs
import
Gargantext.Database.Action.User.New
(
guessUserName
)
import
Gargantext.Database.Action.User.New
(
guessUserName
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
),
UserId
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
(
..
),
UserId
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
IsDBEnvExtra
,
IsDBCmd
)
import
Gargantext.Database.Prelude
(
Cmd
,
IsDBEnvExtra
,
IsDBCmd
)
import
Gargantext.Database.Query.Table.User
import
Gargantext.Database.Query.Table.User
import
Gargantext.Database.Query.Tree
(
isDescendantOf
,
isIn
)
import
Gargantext.Database.Query.Tree
(
isDescendantOf
,
isIn
)
import
Gargantext.Database.Query.Tree.Root
(
getRoot
)
import
Gargantext.Database.Query.Tree.Root
(
getRoot
)
...
@@ -81,7 +81,7 @@ import Servant.Server.Generic (AsServerT)
...
@@ -81,7 +81,7 @@ import Servant.Server.Generic (AsServerT)
makeTokenForUser
::
(
HasJWTSettings
env
,
HasAuthenticationError
err
)
makeTokenForUser
::
(
HasJWTSettings
env
,
HasAuthenticationError
err
)
=>
NodeId
=>
NodeId
->
UserId
->
UserId
->
Cmd
'
env
err
Token
->
Cmd
env
err
Token
makeTokenForUser
nodeId
userId
=
do
makeTokenForUser
nodeId
userId
=
do
jwtS
<-
view
jwtSettings
jwtS
<-
view
jwtSettings
e
<-
liftBase
$
makeJWT
(
AuthenticatedUser
nodeId
userId
)
jwtS
Nothing
e
<-
liftBase
$
makeJWT
(
AuthenticatedUser
nodeId
userId
)
jwtS
Nothing
...
@@ -236,12 +236,12 @@ forgotPassword = Named.ForgotPasswordAPI
...
@@ -236,12 +236,12 @@ forgotPassword = Named.ForgotPasswordAPI
}
}
forgotPasswordPost
::
(
IsDBEnvExtra
env
)
forgotPasswordPost
::
(
IsDBEnvExtra
env
)
=>
ForgotPasswordRequest
->
Cmd
'
env
err
ForgotPasswordResponse
=>
ForgotPasswordRequest
->
Cmd
env
err
ForgotPasswordResponse
forgotPasswordPost
(
ForgotPasswordRequest
_email
)
=
do
forgotPasswordPost
(
ForgotPasswordRequest
_email
)
=
do
pure
$
ForgotPasswordResponse
"ok"
pure
$
ForgotPasswordResponse
"ok"
forgotPasswordGet
::
(
IsDBEnvExtra
env
,
HasServerError
err
)
forgotPasswordGet
::
(
IsDBEnvExtra
env
,
HasServerError
err
)
=>
Maybe
Text
->
Cmd
'
env
err
ForgotPasswordGet
=>
Maybe
Text
->
Cmd
env
err
ForgotPasswordGet
forgotPasswordGet
Nothing
=
pure
$
ForgotPasswordGet
""
forgotPasswordGet
Nothing
=
pure
$
ForgotPasswordGet
""
forgotPasswordGet
(
Just
uuid
)
=
do
forgotPasswordGet
(
Just
uuid
)
=
do
let
mUuid
=
fromText
uuid
let
mUuid
=
fromText
uuid
...
@@ -258,7 +258,7 @@ forgotPasswordGet (Just uuid) = do
...
@@ -258,7 +258,7 @@ forgotPasswordGet (Just uuid) = do
---------------------
---------------------
forgotPasswordGetUser
::
(
IsDBEnvExtra
env
)
forgotPasswordGetUser
::
(
IsDBEnvExtra
env
)
=>
UserLight
->
Cmd
'
env
err
ForgotPasswordGet
=>
UserLight
->
Cmd
env
err
ForgotPasswordGet
forgotPasswordGetUser
(
UserLight
{
..
})
=
do
forgotPasswordGetUser
(
UserLight
{
..
})
=
do
-- pick some random password
-- pick some random password
password
<-
liftBase
gargPass
password
<-
liftBase
gargPass
...
@@ -277,7 +277,7 @@ forgotPasswordGetUser (UserLight { .. }) = do
...
@@ -277,7 +277,7 @@ forgotPasswordGetUser (UserLight { .. }) = do
pure
$
ForgotPasswordGet
password
pure
$
ForgotPasswordGet
password
forgotUserPassword
::
(
IsDBEnvExtra
env
)
forgotUserPassword
::
(
IsDBEnvExtra
env
)
=>
UserLight
->
Cmd
'
env
err
()
=>
UserLight
->
Cmd
env
err
()
forgotUserPassword
(
UserLight
{
..
})
=
do
forgotUserPassword
(
UserLight
{
..
})
=
do
--printDebug "[forgotUserPassword] userLight_id" userLight_id
--printDebug "[forgotUserPassword] userLight_id" userLight_id
--logDebug $ "[forgotUserPassword]" :# ["userLight_id" .= userLight_id]
--logDebug $ "[forgotUserPassword]" :# ["userLight_id" .= userLight_id]
...
@@ -302,7 +302,7 @@ forgotUserPassword (UserLight { .. }) = do
...
@@ -302,7 +302,7 @@ forgotUserPassword (UserLight { .. }) = do
-- Generate a unique (in whole DB) UUID for passwords.
-- Generate a unique (in whole DB) UUID for passwords.
generateForgotPasswordUUID
::
(
IsDBEnvExtra
env
)
generateForgotPasswordUUID
::
(
IsDBEnvExtra
env
)
=>
Cmd
'
env
err
UUID
=>
Cmd
env
err
UUID
generateForgotPasswordUUID
=
do
generateForgotPasswordUUID
=
do
uuid
<-
liftBase
$
nextRandom
uuid
<-
liftBase
$
nextRandom
us
<-
getUsersWithForgotPasswordUUID
uuid
us
<-
getUsersWithForgotPasswordUUID
uuid
...
...
src/Gargantext/API/Dev.hs
View file @
10c49b00
...
@@ -23,7 +23,7 @@ import Gargantext.API.Prelude ( GargM )
...
@@ -23,7 +23,7 @@ import Gargantext.API.Prelude ( GargM )
import
Gargantext.Core.Config
(
_gc_database_config
)
import
Gargantext.Core.Config
(
_gc_database_config
)
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.Config.Types
(
SettingsFile
(
..
))
import
Gargantext.Core.NodeStory
(
fromDBNodeStoryEnv
)
import
Gargantext.Core.NodeStory
(
fromDBNodeStoryEnv
)
import
Gargantext.Database.Prelude
(
Cmd
'
,
Cmd
''
,
connPool
,
runCmd
)
import
Gargantext.Database.Prelude
(
Cmd
,
CmdRandom
,
connPool
,
runCmd
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.Core.Config.Utils
(
readConfig
)
import
Gargantext.System.Logging
(
withLoggerHoisted
)
import
Gargantext.System.Logging
(
withLoggerHoisted
)
...
@@ -52,17 +52,17 @@ defaultSettingsFile :: SettingsFile
...
@@ -52,17 +52,17 @@ defaultSettingsFile :: SettingsFile
defaultSettingsFile
=
SettingsFile
"gargantext-settings.toml"
defaultSettingsFile
=
SettingsFile
"gargantext-settings.toml"
-- | Run Cmd Sugar for the Repl (GHCI)
-- | Run Cmd Sugar for the Repl (GHCI)
runCmdRepl
::
Show
err
=>
Cmd
''
DevEnv
err
a
->
IO
a
runCmdRepl
::
Show
err
=>
Cmd
Random
DevEnv
err
a
->
IO
a
runCmdRepl
f
=
withDevEnv
defaultSettingsFile
$
\
env
->
runCmdDev
env
f
runCmdRepl
f
=
withDevEnv
defaultSettingsFile
$
\
env
->
runCmdDev
env
f
runCmdReplServantErr
::
Cmd
''
DevEnv
ServerError
a
->
IO
a
runCmdReplServantErr
::
Cmd
Random
DevEnv
ServerError
a
->
IO
a
runCmdReplServantErr
=
runCmdRepl
runCmdReplServantErr
=
runCmdRepl
-- In particular this writes the repo file after running
-- In particular this writes the repo file after running
-- the command.
-- the command.
-- This function is constrained to the DevEnv rather than
-- This function is constrained to the DevEnv rather than
-- using HasConnectionPool and HasRepoVar.
-- using HasConnectionPool and HasRepoVar.
runCmdDev
::
Show
err
=>
DevEnv
->
Cmd
''
DevEnv
err
a
->
IO
a
runCmdDev
::
Show
err
=>
DevEnv
->
Cmd
Random
DevEnv
err
a
->
IO
a
runCmdDev
env
f
=
runCmdDev
env
f
=
either
(
fail
.
show
)
pure
=<<
runCmd
env
f
either
(
fail
.
show
)
pure
=<<
runCmd
env
f
...
@@ -70,13 +70,13 @@ runCmdGargDev :: DevEnv -> GargM DevEnv BackendInternalError a -> IO a
...
@@ -70,13 +70,13 @@ runCmdGargDev :: DevEnv -> GargM DevEnv BackendInternalError a -> IO a
runCmdGargDev
env
cmd
=
runCmdGargDev
env
cmd
=
either
(
fail
.
show
)
pure
=<<
runExceptT
(
runReaderT
cmd
env
)
either
(
fail
.
show
)
pure
=<<
runExceptT
(
runReaderT
cmd
env
)
runCmdDevNoErr
::
DevEnv
->
Cmd
'
DevEnv
()
a
->
IO
a
runCmdDevNoErr
::
DevEnv
->
Cmd
DevEnv
()
a
->
IO
a
runCmdDevNoErr
=
runCmdDev
runCmdDevNoErr
=
runCmdDev
runCmdDevServantErr
::
DevEnv
->
Cmd
'
DevEnv
ServerError
a
->
IO
a
runCmdDevServantErr
::
DevEnv
->
Cmd
DevEnv
ServerError
a
->
IO
a
runCmdDevServantErr
=
runCmdDev
runCmdDevServantErr
=
runCmdDev
runCmdReplEasy
::
Cmd
''
DevEnv
BackendInternalError
a
->
IO
a
runCmdReplEasy
::
Cmd
Random
DevEnv
BackendInternalError
a
->
IO
a
runCmdReplEasy
f
=
withDevEnv
defaultSettingsFile
$
\
env
->
runCmdDev
env
f
runCmdReplEasy
f
=
withDevEnv
defaultSettingsFile
$
\
env
->
runCmdDev
env
f
-- | Execute a function that takes PSQL.Connection from the DB pool as
-- | Execute a function that takes PSQL.Connection from the DB pool as
...
...
src/Gargantext/API/GraphQL/Utils.hs
View file @
10c49b00
...
@@ -16,13 +16,13 @@ import Control.Lens (view)
...
@@ -16,13 +16,13 @@ import Control.Lens (view)
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
..
),
auth_node_id
)
import
Gargantext.API.Admin.Auth.Types
(
AuthenticatedUser
(
..
),
auth_node_id
)
import
Gargantext.Core.Config
(
HasJWTSettings
(
..
))
import
Gargantext.Core.Config
(
HasJWTSettings
(
..
))
import
Gargantext.Database.Admin.Types.Node
(
NodeId
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
)
import
Gargantext.Database.Prelude
(
Cmd
'
)
import
Gargantext.Database.Prelude
(
Cmd
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Servant.Auth.Server
(
verifyJWT
,
JWTSettings
)
import
Servant.Auth.Server
(
verifyJWT
,
JWTSettings
)
data
AuthStatus
=
Valid
|
Invalid
data
AuthStatus
=
Valid
|
Invalid
authUser
::
(
HasJWTSettings
env
)
=>
NodeId
->
Text
->
Cmd
'
env
err
AuthStatus
authUser
::
(
HasJWTSettings
env
)
=>
NodeId
->
Text
->
Cmd
env
err
AuthStatus
authUser
ui_id
token
=
do
authUser
ui_id
token
=
do
let
token'
=
encodeUtf8
token
let
token'
=
encodeUtf8
token
jwtS
<-
view
jwtSettings
jwtS
<-
view
jwtSettings
...
...
src/Gargantext/Core/Worker/Jobs.hs
View file @
10c49b00
...
@@ -20,14 +20,14 @@ import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..))
...
@@ -20,14 +20,14 @@ import Gargantext.Core.Config.Worker (WorkerSettings(..), WorkerDefinition(..))
import
Gargantext.Core.Worker.Broker
(
initBrokerWithDBCreate
)
import
Gargantext.Core.Worker.Broker
(
initBrokerWithDBCreate
)
import
Gargantext.Core.Worker.Jobs.Types
(
Job
(
..
))
import
Gargantext.Core.Worker.Jobs.Types
(
Job
(
..
))
import
Gargantext.Core.Worker.PGMQTypes
(
HasWorkerBroker
,
MessageId
,
SendJob
)
import
Gargantext.Core.Worker.PGMQTypes
(
HasWorkerBroker
,
MessageId
,
SendJob
)
import
Gargantext.Database.Prelude
(
Cmd
'
)
import
Gargantext.Database.Prelude
(
Cmd
)
import
Gargantext.Prelude
import
Gargantext.Prelude
import
Gargantext.System.Logging
(
logMsg
,
withLogger
,
LogLevel
(
..
))
import
Gargantext.System.Logging
(
logMsg
,
withLogger
,
LogLevel
(
..
))
sendJob
::
(
HasWorkerBroker
,
HasConfig
env
)
sendJob
::
(
HasWorkerBroker
,
HasConfig
env
)
=>
Job
=>
Job
->
Cmd
'
env
err
MessageId
->
Cmd
env
err
MessageId
sendJob
job
=
do
sendJob
job
=
do
gcConfig
<-
view
$
hasConfig
gcConfig
<-
view
$
hasConfig
liftBase
$
sendJobWithCfg
gcConfig
job
liftBase
$
sendJobWithCfg
gcConfig
job
...
...
src/Gargantext/Database/Action/Delete.hs
View file @
10c49b00
...
@@ -27,7 +27,7 @@ import Gargantext.Database.Action.User (getUserId)
...
@@ -27,7 +27,7 @@ import Gargantext.Database.Action.User (getUserId)
import
Gargantext.Database.Admin.Types.Hyperdata.File
(
HyperdataFile
(
..
)
)
import
Gargantext.Database.Admin.Types.Hyperdata.File
(
HyperdataFile
(
..
)
)
import
Gargantext.Database.Admin.Types.Node
(
NodeId
,
NodeType
(
..
)
)
-- (NodeType(..))
import
Gargantext.Database.Admin.Types.Node
(
NodeId
,
NodeType
(
..
)
)
-- (NodeType(..))
import
Gargantext.Database.GargDB
qualified
as
GargDB
import
Gargantext.Database.GargDB
qualified
as
GargDB
import
Gargantext.Database.Prelude
(
Cmd
'
,
IsDBEnvExtra
)
import
Gargantext.Database.Prelude
(
Cmd
,
IsDBEnvExtra
)
import
Gargantext.Database.Query.Table.Node
(
getNodeWith
)
import
Gargantext.Database.Query.Table.Node
(
getNodeWith
)
import
Gargantext.Database.Query.Table.Node
qualified
as
N
(
getNode
,
deleteNode
)
import
Gargantext.Database.Query.Table.Node
qualified
as
N
(
getNode
,
deleteNode
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
import
Gargantext.Database.Query.Table.Node.Error
(
HasNodeError
)
...
@@ -41,7 +41,7 @@ import Gargantext.Prelude
...
@@ -41,7 +41,7 @@ import Gargantext.Prelude
deleteNode
::
(
IsDBEnvExtra
env
,
HasNodeError
err
)
deleteNode
::
(
IsDBEnvExtra
env
,
HasNodeError
err
)
=>
User
=>
User
->
NodeId
->
NodeId
->
Cmd
'
env
err
Int
->
Cmd
env
err
Int
deleteNode
u
nodeId
=
do
deleteNode
u
nodeId
=
do
node'
<-
N
.
getNode
nodeId
node'
<-
N
.
getNode
nodeId
num
<-
case
(
view
node_typename
node'
)
of
num
<-
case
(
view
node_typename
node'
)
of
...
...
src/Gargantext/Database/Prelude.hs
View file @
10c49b00
...
@@ -87,7 +87,7 @@ type IsDBCmdExtra env err m =
...
@@ -87,7 +87,7 @@ type IsDBCmdExtra env err m =
,
IsDBEnvExtra
env
,
IsDBEnvExtra
env
)
)
type
CmdM''
env
err
m
=
type
IsCmdRandom
env
err
m
=
(
MonadReader
env
m
(
MonadReader
env
m
,
MonadError
err
m
,
MonadError
err
m
,
MonadBaseControl
IO
m
,
MonadBaseControl
IO
m
...
@@ -95,8 +95,8 @@ type CmdM'' env err m =
...
@@ -95,8 +95,8 @@ type CmdM'' env err m =
)
)
type
Cmd
''
env
err
a
=
forall
m
.
CmdM''
env
err
m
=>
m
a
type
Cmd
Random
env
err
a
=
forall
m
.
IsCmdRandom
env
err
m
=>
m
a
type
Cmd
'
env
err
a
=
forall
m
.
IsCmd
env
err
m
=>
m
a
type
Cmd
env
err
a
=
forall
m
.
IsCmd
env
err
m
=>
m
a
type
DBCmdExtra
err
a
=
forall
m
env
.
IsDBCmdExtra
env
err
m
=>
m
a
type
DBCmdExtra
err
a
=
forall
m
env
.
IsDBCmdExtra
env
err
m
=>
m
a
type
DBCmdWithEnv
env
err
a
=
forall
m
.
IsDBCmd
env
err
m
=>
m
a
type
DBCmdWithEnv
env
err
a
=
forall
m
.
IsDBCmd
env
err
m
=>
m
a
type
DBCmd
err
a
=
forall
m
env
.
IsDBCmd
env
err
m
=>
m
a
type
DBCmd
err
a
=
forall
m
env
.
IsDBCmd
env
err
m
=>
m
a
...
@@ -112,7 +112,7 @@ mkCmd k = do
...
@@ -112,7 +112,7 @@ mkCmd k = do
liftBase
$
withResource
pool
(
liftBase
.
k
)
liftBase
$
withResource
pool
(
liftBase
.
k
)
runCmd
::
env
runCmd
::
env
->
Cmd
''
env
err
a
->
Cmd
Random
env
err
a
->
IO
(
Either
err
a
)
->
IO
(
Either
err
a
)
runCmd
env
m
=
runExceptT
$
runReaderT
m
env
runCmd
env
m
=
runExceptT
$
runReaderT
m
env
...
...
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