Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
P
purescript-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
142
Issues
142
List
Board
Labels
Milestones
Merge Requests
4
Merge Requests
4
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
purescript-gargantext
Commits
317f5942
Verified
Commit
317f5942
authored
Jan 09, 2024
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[errors] refactoring for new kind of errors
Also, refactoring of Node/Action/Tools to use proper components.
parent
0f377b27
Pipeline
#5471
failed with stage
in 0 seconds
Changes
15
Pipelines
1
Show whitespace changes
Inline
Side-by-side
Showing
15 changed files
with
432 additions
and
252 deletions
+432
-252
Add.purs
src/Gargantext/Components/Forest/Tree/Node/Action/Add.purs
+7
-6
Delete.purs
...Gargantext/Components/Forest/Tree/Node/Action/Delete.purs
+17
-13
Documentation.purs
...ext/Components/Forest/Tree/Node/Action/Documentation.purs
+5
-5
Download.purs
...rgantext/Components/Forest/Tree/Node/Action/Download.purs
+16
-10
Link.purs
src/Gargantext/Components/Forest/Tree/Node/Action/Link.purs
+17
-14
ManageTeam.purs
...antext/Components/Forest/Tree/Node/Action/ManageTeam.purs
+7
-4
Merge.purs
src/Gargantext/Components/Forest/Tree/Node/Action/Merge.purs
+25
-23
Move.purs
src/Gargantext/Components/Forest/Tree/Node/Action/Move.purs
+11
-8
Share.purs
src/Gargantext/Components/Forest/Tree/Node/Action/Share.purs
+25
-13
Update.purs
...Gargantext/Components/Forest/Tree/Node/Action/Update.purs
+44
-39
Upload.purs
...Gargantext/Components/Forest/Tree/Node/Action/Upload.purs
+8
-8
WriteNodesDocuments.purs
...mponents/Forest/Tree/Node/Action/WriteNodesDocuments.purs
+77
-73
Tools.purs
src/Gargantext/Components/Forest/Tree/Node/Tools.purs
+65
-22
REST.purs
src/Gargantext/Config/REST.purs
+105
-8
Sessions.purs
src/Gargantext/Sessions.purs
+3
-6
No files found.
src/Gargantext/Components/Forest/Tree/Node/Action/Add.purs
View file @
317f5942
...
@@ -13,7 +13,7 @@ import Effect (Effect)
...
@@ -13,7 +13,7 @@ import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Effect.Aff (Aff, launchAff_)
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Settings (SettingsBox(..), settingsBox)
import Gargantext.Components.Forest.Tree.Node.Settings (SettingsBox(..), settingsBox)
import Gargantext.Components.Forest.Tree.Node.Tools
(formChoice, panel, submitButton)
import Gargantext.Components.Forest.Tree.Node.Tools
as Tools
import Gargantext.Components.InputWithEnter (inputWithEnterWithKey)
import Gargantext.Components.InputWithEnter (inputWithEnterWithKey)
import Gargantext.Components.Lang (Lang(..), translate)
import Gargantext.Components.Lang (Lang(..), translate)
import Gargantext.Config.REST (RESTError, AffRESTError)
import Gargantext.Config.REST (RESTError, AffRESTError)
...
@@ -92,7 +92,7 @@ addNodeViewCpt = here.component "addNodeView" cpt where
...
@@ -92,7 +92,7 @@ addNodeViewCpt = here.component "addNodeView" cpt where
T.write_ (GT.prettyNodeType nt) nodeName
T.write_ (GT.prettyNodeType nt) nodeName
T.write_ nt nodeType
T.write_ nt nodeType
(maybeChoose /\ nt') = if length nodeTypes > 1
(maybeChoose /\ nt') = if length nodeTypes > 1
then ([ formChoice { items: nodeTypes
then ([
Tools.
formChoice { items: nodeTypes
, default: nodeType'
, default: nodeType'
, callback: setNodeType'
, callback: setNodeType'
, print: print hasChromeAgent' } [] ] /\ nodeType')
, print: print hasChromeAgent' } [] ] /\ nodeType')
...
@@ -120,7 +120,8 @@ addNodeViewCpt = here.component "addNodeView" cpt where
...
@@ -120,7 +120,8 @@ addNodeViewCpt = here.component "addNodeView" cpt where
else H.div {} []
else H.div {} []
]
]
pure $ panel (maybeChoose <> maybeEdit) (submitButton (AddNode nodeName' nt') dispatch)
pure $ Tools.panelWithSubmitButton { action: AddNode nodeName' nt'
, dispatch } (maybeChoose <> maybeEdit)
-- END Create Node
-- END Create Node
...
...
src/Gargantext/Components/Forest/Tree/Node/Action/Delete.purs
View file @
317f5942
...
@@ -6,7 +6,7 @@ import Gargantext.Prelude
...
@@ -6,7 +6,7 @@ import Gargantext.Prelude
import Data.Maybe (Maybe(..))
import Data.Maybe (Maybe(..))
import Effect.Aff (Aff)
import Effect.Aff (Aff)
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Tools
(submitButton, panel)
import Gargantext.Components.Forest.Tree.Node.Tools
as Tools
import Gargantext.Config.REST (AffRESTError)
import Gargantext.Config.REST (AffRESTError)
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, delete, put_)
import Gargantext.Sessions (Session, delete, put_)
...
@@ -53,21 +53,25 @@ actionDeleteUser = R.createElement actionDeleteUserCpt
...
@@ -53,21 +53,25 @@ actionDeleteUser = R.createElement actionDeleteUserCpt
actionDeleteUserCpt :: R.Component Delete
actionDeleteUserCpt :: R.Component Delete
actionDeleteUserCpt = here.component "actionDeleteUser" cpt where
actionDeleteUserCpt = here.component "actionDeleteUser" cpt where
cpt _ _ = do
cpt _ _ = do
pure $ panel [ H.div { style: {margin: "10px"}}
pure $
Tools.panelNoFooter {}
[ H.div { style: {margin: "10px"}}
[ H.text $ "Yes, we are RGPD compliant!"
[ H.text $ "Yes, we are RGPD compliant!"
<> " But you can not delete User Node yet."
<> " But you can not delete User Node yet."
<> " We are still on development."
<> " We are still on development."
<> " Thanks for your comprehensin."
<> " Thanks for your comprehensin."
]
]
] (H.div {} [])
]
actionDeleteOther :: R2.Component Delete
actionDeleteOther :: R2.Component Delete
actionDeleteOther = R.createElement actionDeleteOtherCpt
actionDeleteOther = R.createElement actionDeleteOtherCpt
actionDeleteOtherCpt :: R.Component Delete
actionDeleteOtherCpt :: R.Component Delete
actionDeleteOtherCpt = here.component "actionDeleteOther" cpt where
actionDeleteOtherCpt = here.component "actionDeleteOther" cpt where
cpt { dispatch, nodeType } _ = do
cpt { dispatch, nodeType } _ = do
pure $ panel (map (\t -> H.p {} [H.text t])
pure $
Tools.panelWithSubmitButton { action: DeleteNode nodeType
, dispatch }
(map (\t -> H.p {} [H.text t])
[ "Are your sure you want to delete it ?"
[ "Are your sure you want to delete it ?"
, "If yes, click again below."
, "If yes, click again below."
]
])
) (submitButton (DeleteNode nodeType) dispatch)
src/Gargantext/Components/Forest/Tree/Node/Action/Documentation.purs
View file @
317f5942
...
@@ -5,7 +5,7 @@ import Reactix.DOM.HTML as H
...
@@ -5,7 +5,7 @@ import Reactix.DOM.HTML as H
import Gargantext.Prelude (map, pure, show, ($), (<>))
import Gargantext.Prelude (map, pure, show, ($), (<>))
import Gargantext.Components.Forest.Tree.Node.Tools
(panel)
import Gargantext.Components.Forest.Tree.Node.Tools
as Tools
import Gargantext.Types (NodeType)
import Gargantext.Types (NodeType)
import Gargantext.Types as GT
import Gargantext.Types as GT
import Gargantext.Utils.Reactix as R2
import Gargantext.Utils.Reactix as R2
...
@@ -22,10 +22,10 @@ actionDoc = R.createElement actionDocCpt
...
@@ -22,10 +22,10 @@ actionDoc = R.createElement actionDocCpt
actionDocCpt :: R.Component ActionDoc
actionDocCpt :: R.Component ActionDoc
actionDocCpt = here.component "actionDoc" cpt where
actionDocCpt = here.component "actionDoc" cpt where
cpt { nodeType } _ = do
cpt { nodeType } _ = do
pure $
panel ([ infoTitle nodeType ]
pure $
<> (map (\info -> H.p {} [H.text info]) $ docOf nodeType)
Tools.panelNoFooter {}
)
([ infoTitle nodeType ]
(H.div {} []
)
<> (map (\info -> H.p {} [H.text info]) $ docOf nodeType)
)
where
where
infoTitle :: NodeType -> R.Element
infoTitle :: NodeType -> R.Element
infoTitle nt = H.div { style: {margin: "10px"}}
infoTitle nt = H.div { style: {margin: "10px"}}
...
...
src/Gargantext/Components/Forest/Tree/Node/Action/Download.purs
View file @
317f5942
...
@@ -41,8 +41,10 @@ actionDownloadCorpus = R.createElement actionDownloadCorpusCpt
...
@@ -41,8 +41,10 @@ actionDownloadCorpus = R.createElement actionDownloadCorpusCpt
actionDownloadCorpusCpt :: R.Component ActionDownload
actionDownloadCorpusCpt :: R.Component ActionDownload
actionDownloadCorpusCpt = here.component "actionDownloadCorpus" cpt where
actionDownloadCorpusCpt = here.component "actionDownloadCorpus" cpt where
cpt { id, session } _ = do
cpt { id, session } _ = do
pure $ panel [H.div {} [H.text info]]
pure $ panel {} [ H.div {} [H.text info]
(submitButtonHref DownloadNode href)
-- footer
, submitButtonHref DownloadNode href ]
where
where
href = url session $ Routes.NodeAPI GT.Corpus (Just id) "export"
href = url session $ Routes.NodeAPI GT.Corpus (Just id) "export"
info = "Download as JSON"
info = "Download as JSON"
...
@@ -52,8 +54,10 @@ actionDownloadGraph = R.createElement actionDownloadGraphCpt
...
@@ -52,8 +54,10 @@ actionDownloadGraph = R.createElement actionDownloadGraphCpt
actionDownloadGraphCpt :: R.Component ActionDownload
actionDownloadGraphCpt :: R.Component ActionDownload
actionDownloadGraphCpt = here.component "actionDownloadGraph" cpt where
actionDownloadGraphCpt = here.component "actionDownloadGraph" cpt where
cpt { id, session } _ = do
cpt { id, session } _ = do
pure $ panel [H.div {} [H.text info]]
pure $ panel {} [ H.div {} [H.text info]
(submitButtonHref DownloadNode href)
-- footer
, submitButtonHref DownloadNode href ]
where
where
href = url session $ Routes.NodeAPI GT.Graph (Just id) "gexf"
href = url session $ Routes.NodeAPI GT.Graph (Just id) "gexf"
info = "Info about the Graph as GEXF format"
info = "Info about the Graph as GEXF format"
...
@@ -79,15 +83,16 @@ actionDownloadNodeListCpt = here.component "actionDownloadNodeList" cpt where
...
@@ -79,15 +83,16 @@ actionDownloadNodeListCpt = here.component "actionDownloadNodeList" cpt where
downloadFormat <- T.useBox NL_JSON
downloadFormat <- T.useBox NL_JSON
downloadFormat' <- T.useLive T.unequal downloadFormat
downloadFormat' <- T.useLive T.unequal downloadFormat
pure $ panel
pure $ panel
{}
[ R2.select { className: "form-control"
[ R2.select { className: "form-control"
, defaultValue: show downloadFormat'
, defaultValue: show downloadFormat'
, on: { change: onChange downloadFormat } }
, on: { change: onChange downloadFormat } }
[ opt NL_CSV downloadFormat
[ opt NL_CSV downloadFormat
, opt NL_JSON downloadFormat ]
, opt NL_JSON downloadFormat ]
, H.div {} [ H.text $ info downloadFormat' ]
, H.div {} [ H.text $ info downloadFormat' ]
]
(submitButtonHref DownloadNode $ href downloadFormat')
-- footer
, submitButtonHref DownloadNode $ href downloadFormat' ]
where
where
opt t downloadFormat = H.option { value: show t } [ H.text $ show t ]
opt t downloadFormat = H.option { value: show t } [ H.text $ show t ]
where
where
...
@@ -122,15 +127,16 @@ actionDownloadNodeTextsCpt = here.component "actionDownloadNodeTexts" cpt where
...
@@ -122,15 +127,16 @@ actionDownloadNodeTextsCpt = here.component "actionDownloadNodeTexts" cpt where
downloadFormat <- T.useBox NT_JSON
downloadFormat <- T.useBox NT_JSON
downloadFormat' <- T.useLive T.unequal downloadFormat
downloadFormat' <- T.useLive T.unequal downloadFormat
pure $ panel
pure $ panel
{}
[ R2.select { className: "form-control"
[ R2.select { className: "form-control"
, defaultValue: show downloadFormat'
, defaultValue: show downloadFormat'
, on: { change: onChange downloadFormat } }
, on: { change: onChange downloadFormat } }
[ opt NT_CSV downloadFormat
[ opt NT_CSV downloadFormat
, opt NT_JSON downloadFormat ]
, opt NT_JSON downloadFormat ]
, H.div {} [ H.text $ info downloadFormat' ]
, H.div {} [ H.text $ info downloadFormat' ]
]
(submitButtonHref DownloadNode $ href downloadFormat')
-- footer
, submitButtonHref DownloadNode $ href downloadFormat' ]
where
where
opt t downloadFormat = H.option { value: show t } [ H.text $ show t ]
opt t downloadFormat = H.option { value: show t } [ H.text $ show t ]
where
where
...
...
src/Gargantext/Components/Forest/Tree/Node/Action/Link.purs
View file @
317f5942
...
@@ -6,7 +6,7 @@ import Data.Either (Either)
...
@@ -6,7 +6,7 @@ import Data.Either (Either)
import Data.Maybe (Maybe(..))
import Data.Maybe (Maybe(..))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Update.Types (LinkNodeReq(..), UpdateNodeParams(..))
import Gargantext.Components.Forest.Tree.Node.Action.Update.Types (LinkNodeReq(..), UpdateNodeParams(..))
import Gargantext.Components.Forest.Tree.Node.Tools
(submitButton, panel)
import Gargantext.Components.Forest.Tree.Node.Tools
as Tools
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (subTreeView, SubTreeParamsIn)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (subTreeView, SubTreeParamsIn)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree.Types (SubTreeOut(..))
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree.Types (SubTreeOut(..))
import Gargantext.Config.REST (AffRESTError, RESTError)
import Gargantext.Config.REST (AffRESTError, RESTError)
...
@@ -70,14 +70,15 @@ linkNodeCpt' = here.component "__clone__" cpt
...
@@ -70,14 +70,15 @@ linkNodeCpt' = here.component "__clone__" cpt
button = case action' of
button = case action' of
LinkNode { params } -> case params of
LinkNode { params } -> case params of
Just (SubTreeOut { in: inId }) ->
submitButton
Just (SubTreeOut { in: inId }) ->
(toParams nodeType inId)
Tools.submitButton { action: toParams nodeType inId
dispatch
, dispatch }
Nothing -> mempty
Nothing -> mempty
_ -> mempty
_ -> mempty
pure $ panel [
pure $
subTreeView { action
Tools.panel {}
[ subTreeView { action
, boxes
, boxes
, dispatch
, dispatch
, id
, id
...
@@ -85,7 +86,9 @@ linkNodeCpt' = here.component "__clone__" cpt
...
@@ -85,7 +86,9 @@ linkNodeCpt' = here.component "__clone__" cpt
, session
, session
, subTreeParams
, subTreeParams
} []
} []
] button
-- footer
, button ]
toParams :: GT.NodeType -> GT.ID -> Action
toParams :: GT.NodeType -> GT.ID -> Action
toParams nodeType id
toParams nodeType id
...
...
src/Gargantext/Components/Forest/Tree/Node/Action/ManageTeam.purs
View file @
317f5942
...
@@ -80,10 +80,13 @@ teamLayoutRowsCpt :: R.Component TeamRowProps
...
@@ -80,10 +80,13 @@ teamLayoutRowsCpt :: R.Component TeamRowProps
teamLayoutRowsCpt = here.component "teamLayoutRows" cpt where
teamLayoutRowsCpt = here.component "teamLayoutRows" cpt where
cpt { team, nodeId, session, error, team', error', team_owner_username} _ = do
cpt { team, nodeId, session, error, team', error', team_owner_username} _ = do
case null team' of
pure $
true -> pure $ H.div { style: {margin: "10px"}}
if null team' then
H.div { style: {margin: "10px"}}
[ H.h4 {} [H.text "Your team is empty, you can send some invitations."]]
[ H.h4 {} [H.text "Your team is empty, you can send some invitations."]]
false -> pure $ Tools.panel (makeLeader team_owner_username : (map makeTeam team')) (H.div {} [H.text error'])
else
Tools.panel {}
((makeLeader team_owner_username : (map makeTeam team')) <> [ H.div {} [H.text error'] ])
where
where
makeTeam :: TeamMember -> R.Element
makeTeam :: TeamMember -> R.Element
...
...
src/Gargantext/Components/Forest/Tree/Node/Action/Merge.purs
View file @
317f5942
...
@@ -5,7 +5,7 @@ import Gargantext.Prelude
...
@@ -5,7 +5,7 @@ import Gargantext.Prelude
import Data.Maybe (Maybe(..))
import Data.Maybe (Maybe(..))
import Data.Set as Set
import Data.Set as Set
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Tools
(submitButton, panel, checkbox, checkboxesListGroup)
import Gargantext.Components.Forest.Tree.Node.Tools
as Tools
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (subTreeView, SubTreeParamsIn)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (subTreeView, SubTreeParamsIn)
import Gargantext.Config.REST (AffRESTError)
import Gargantext.Config.REST (AffRESTError)
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Routes (SessionRoute(..))
...
@@ -37,11 +37,12 @@ mergeNodeCpt = here.component "mergeNode" cpt
...
@@ -37,11 +37,12 @@ mergeNodeCpt = here.component "mergeNode" cpt
let button = case action' of
let button = case action' of
MergeNode {params} -> case params of
MergeNode {params} -> case params of
Just val -> submitButton (MergeNode {params: Just val}) dispatch
Just val -> Tools.submitButton { action: MergeNode {params: Just val}
, dispatch }
Nothing -> H.div {} []
Nothing -> H.div {} []
_ -> H.div {} []
_ -> H.div {} []
pure $
panel
pure $
Tools.panel {}
[ subTreeView { action
[ subTreeView { action
, boxes
, boxes
, dispatch
, dispatch
...
@@ -53,7 +54,7 @@ mergeNodeCpt = here.component "mergeNode" cpt
...
@@ -53,7 +54,7 @@ mergeNodeCpt = here.component "mergeNode" cpt
, H.ul { className:"merge mx-auto list-group"}
, H.ul { className:"merge mx-auto list-group"}
([ H.li { className: "list-group-item" }
([ H.li { className: "list-group-item" }
[ H.h5 { className: "mb-1" } [ H.text "Merge which list?" ]
[ H.h5 { className: "mb-1" } [ H.text "Merge which list?" ]
,
checkboxesListGroup { groups: [ GT.MapTerm, GT.CandidateTerm, GT.StopTerm ]
, Tools.
checkboxesListGroup { groups: [ GT.MapTerm, GT.CandidateTerm, GT.StopTerm ]
, options } []
, options } []
]
]
])
])
...
@@ -63,10 +64,11 @@ mergeNodeCpt = here.component "mergeNode" cpt
...
@@ -63,10 +64,11 @@ mergeNodeCpt = here.component "mergeNode" cpt
]
]
, H.li { className: "list-group-item" }
, H.li { className: "list-group-item" }
[ H.div { className: " form-check" }
[ H.div { className: " form-check" }
[
checkbox { value: merge }
[ Tools.
checkbox { value: merge }
, H.label { className: "form-check-label" } [ H.text "Merge data?" ]
, H.label { className: "form-check-label" } [ H.text "Merge data?" ]
]
]
]
]
]
]
]
button
-- footer
, button ]
src/Gargantext/Components/Forest/Tree/Node/Action/Move.purs
View file @
317f5942
...
@@ -7,7 +7,7 @@ import Gargantext.Prelude
...
@@ -7,7 +7,7 @@ import Gargantext.Prelude
import Data.Maybe (Maybe(..))
import Data.Maybe (Maybe(..))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Tools
(submitButton, panel)
import Gargantext.Components.Forest.Tree.Node.Tools
as Tools
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (SubTreeParamsIn, subTreeView)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree (SubTreeParamsIn, subTreeView)
import Gargantext.Config.REST (AffRESTError)
import Gargantext.Config.REST (AffRESTError)
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Routes (SessionRoute(..))
...
@@ -60,13 +60,14 @@ moveNodeCpt' = here.component "__clone__" cpt where
...
@@ -60,13 +60,14 @@ moveNodeCpt' = here.component "__clone__" cpt where
let button = case action' of
let button = case action' of
MoveNode { params } -> case params of
MoveNode { params } -> case params of
Just val -> submitButton (MoveNode {params: Just val}) dispatch
Just val -> Tools.submitButton { action: MoveNode {params: Just val}
, dispatch }
Nothing -> H.div {} []
Nothing -> H.div {} []
_ -> H.div {} []
_ -> H.div {} []
pure $
pure $
panel
Tools.panel {}
[ subTreeView { action
[ subTreeView { action
, boxes
, boxes
, dispatch
, dispatch
...
@@ -75,4 +76,6 @@ moveNodeCpt' = here.component "__clone__" cpt where
...
@@ -75,4 +76,6 @@ moveNodeCpt' = here.component "__clone__" cpt where
, session
, session
, subTreeParams
, subTreeParams
} []
} []
] button
-- footer
, button ]
src/Gargantext/Components/Forest/Tree/Node/Action/Share.purs
View file @
317f5942
...
@@ -4,11 +4,13 @@ import Gargantext.Prelude
...
@@ -4,11 +4,13 @@ import Gargantext.Prelude
import Data.Array (filter, nub)
import Data.Array (filter, nub)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep (class Generic)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Maybe (Maybe(..))
import Data.Show.Generic (genericShow)
import Data.Show.Generic (genericShow)
import Data.String (Pattern(..), contains, trim)
import Data.String (Pattern(..), contains, trim)
import Data.Tuple.Nested ((/\))
import Data.Tuple.Nested ((/\))
import Effect.Aff (Aff, launchAff_)
import Effect.Aff (Aff, launchAff_)
import Effect.Class (liftEffect)
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Bootstrap.Types (Elevation(Level1))
import Gargantext.Components.Bootstrap.Types (Elevation(Level1))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action)
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action)
...
@@ -62,26 +64,27 @@ instance Show ShareNodeParams where show = genericShow
...
@@ -62,26 +64,27 @@ instance Show ShareNodeParams where show = genericShow
type ShareNode =
type ShareNode =
( id :: ID
( id :: ID
, dispatch :: Action -> Aff Unit
, dispatch :: Action -> Aff Unit
, session :: Session)
, session :: Session
)
shareNode :: R2.Component ShareNode
shareNode :: R2.Component ShareNode
shareNode = R.createElement shareNodeCpt
shareNode = R.createElement shareNodeCpt
shareNodeCpt :: R.Component ShareNode
shareNodeCpt :: R.Component ShareNode
shareNodeCpt = here.component "shareNode" cpt
shareNodeCpt = here.component "shareNode" cpt
where
where
cpt {
session, dispatch
} _ = do
cpt {
dispatch, id, session
} _ = do
useLoader {
useLoader {
loader: getCompletionsReq
loader: getCompletionsReq
, path: { session }
, path: { session }
, render: \completions -> shareNodeInner { completions,
dispatch
} []
, render: \completions -> shareNodeInner { completions,
id, session
} []
, errorHandler
, errorHandler
}
}
where
where
errorHandler = logRESTError here "[shareNode]"
errorHandler = logRESTError here "[shareNode]"
type ShareNodeInner =
type ShareNodeInner =
( dispatch :: Action -> Aff Unit
( completions :: Array String
, completions :: Array String
, id :: ID
, session :: Session
)
)
shareNodeInner :: R2.Component ShareNodeInner
shareNodeInner :: R2.Component ShareNodeInner
...
@@ -89,11 +92,11 @@ shareNodeInner = R.createElement shareNodeInnerCpt
...
@@ -89,11 +92,11 @@ shareNodeInner = R.createElement shareNodeInnerCpt
shareNodeInnerCpt :: R.Component ShareNodeInner
shareNodeInnerCpt :: R.Component ShareNodeInner
shareNodeInnerCpt = here.component "shareNodeInner" cpt
shareNodeInnerCpt = here.component "shareNodeInner" cpt
where
where
cpt {
dispatch, completions
} _ = do
cpt {
completions, id, session
} _ = do
state' /\ state <- R2.useBox' ""
state' /\ state <- R2.useBox' ""
text' /\ text <- R2.useBox' ""
text' /\ text <- R2.useBox' ""
pure $ Tools.panel
pure $ Tools.panel
{}
[ inputWithAutocomplete { autoFocus: true
[ inputWithAutocomplete { autoFocus: true
, autocompleteSearch
, autocompleteSearch
, classes: "share-users-completions d-flex align-items-center"
, classes: "share-users-completions d-flex align-items-center"
...
@@ -107,13 +110,19 @@ shareNodeInnerCpt = here.component "shareNodeInner" cpt
...
@@ -107,13 +110,19 @@ shareNodeInnerCpt = here.component "shareNodeInner" cpt
, elevation: Level1
, elevation: Level1
, name: "send"
, name: "send"
, title: "Submit" } ]
, title: "Submit" } ]
] (H.div {} [ H.text text' ])
-- footer
, H.div {} [ H.text text' ] ]
where
where
autocompleteSearch input = pure $ nub $ filter (contains (Pattern input)) completions
autocompleteSearch input = pure $ nub $ filter (contains (Pattern input)) completions
onAutocompleteClick _ = pure unit
onAutocompleteClick _ = pure unit
onEnterPress text val = do
onEnterPress text val = do
launchAff_ $ dispatch (shareAction val)
-- launchAff_ $ dispatch (shareAction val)
T.write_ ("Invited " <> val <> " to the team") text
launchAff_ do
eRes <- shareReq session id $ ShareTeamParams { username: val }
liftEffect $ case eRes of
Left err -> T.write_ (show err) text
Right _ -> T.write_ ("Invited " <> val <> " to the team") text
title = "Enter a username or an email address (space characters are not allowed)"
title = "Enter a username or an email address (space characters are not allowed)"
------------------------------------------------------------------------
------------------------------------------------------------------------
publishNode :: R2.Component SubTreeParamsIn
publishNode :: R2.Component SubTreeParamsIn
...
@@ -127,11 +136,12 @@ publishNodeCpt = here.component "publishNode" cpt
...
@@ -127,11 +136,12 @@ publishNodeCpt = here.component "publishNode" cpt
let button = case action' of
let button = case action' of
Action.SharePublic { params } -> case params of
Action.SharePublic { params } -> case params of
Just val -> Tools.submitButton (Action.SharePublic {params: Just val}) dispatch
Just val -> Tools.submitButton { action: Action.SharePublic {params: Just val}
, dispatch }
Nothing -> H.div {} []
Nothing -> H.div {} []
_ -> H.div {} []
_ -> H.div {} []
pure $ Tools.panel
pure $ Tools.panel
{}
[ subTreeView { action
[ subTreeView { action
, boxes
, boxes
, dispatch
, dispatch
...
@@ -140,4 +150,6 @@ publishNodeCpt = here.component "publishNode" cpt
...
@@ -140,4 +150,6 @@ publishNodeCpt = here.component "publishNode" cpt
, session
, session
, subTreeParams
, subTreeParams
} []
} []
] button
-- footer
, button ]
src/Gargantext/Components/Forest/Tree/Node/Action/Update.purs
View file @
317f5942
...
@@ -11,7 +11,7 @@ import Effect (Effect)
...
@@ -11,7 +11,7 @@ import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Effect.Aff (Aff, launchAff_)
import Gargantext.Components.Bootstrap.Types (ComponentStatus(..))
import Gargantext.Components.Bootstrap.Types (ComponentStatus(..))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Tools
(formChoiceSafe, submitButton, panel)
import Gargantext.Components.Forest.Tree.Node.Tools
as Tools
import Gargantext.Components.PhyloExplorer.API as Phylo
import Gargantext.Components.PhyloExplorer.API as Phylo
import Gargantext.Components.PhyloExplorer.Config.ConfigForm as PhyloForm
import Gargantext.Components.PhyloExplorer.Config.ConfigForm as PhyloForm
import Gargantext.Components.PhyloExplorer.ConfigFormParser as PhyloHook
import Gargantext.Components.PhyloExplorer.ConfigFormParser as PhyloHook
...
@@ -62,13 +62,15 @@ updateDashboardCpt = here.component "updateDashboard" cpt where
...
@@ -62,13 +62,15 @@ updateDashboardCpt = here.component "updateDashboard" cpt where
methodBoard <- T.useBox All
methodBoard <- T.useBox All
methodBoard' <- T.useLive T.unequal methodBoard
methodBoard' <- T.useLive T.unequal methodBoard
pure $ panel [ -- H.text "Update with"
pure $
formChoiceSafe { items: [All, Sources, Authors, Institutes, Ngrams]
Tools.panelWithSubmitButton { action: UpdateNode $ UpdateNodeParamsBoard { methodBoard: methodBoard' }
, dispatch }
[ -- H.text "Update with"
Tools.formChoiceSafe { items: [All, Sources, Authors, Institutes, Ngrams]
, default: methodBoard'
, default: methodBoard'
, callback: \val -> T.write_ val methodBoard
, callback: \val -> T.write_ val methodBoard
, print: show } []
, print: show } []
]
]
(submitButton (UpdateNode $ UpdateNodeParamsBoard { methodBoard: methodBoard' }) dispatch)
updateGraph :: R2.Component UpdateProps
updateGraph :: R2.Component UpdateProps
updateGraph = R.createElement updateGraphCpt
updateGraph = R.createElement updateGraphCpt
...
@@ -97,12 +99,22 @@ updateGraphCpt = here.component "updateGraph" cpt where
...
@@ -97,12 +99,22 @@ updateGraphCpt = here.component "updateGraph" cpt where
callback :: Action -> Aff Unit
callback :: Action -> Aff Unit
callback = dispatch >=> \_ -> dispatch CloseBox
callback = dispatch >=> \_ -> dispatch CloseBox
pure $ panel [ H.text "Show subjects with Order1 or concepts with Order2 ?"
let action = UpdateNode $ UpdateNodeParamsGraph { methodGraphMetric: methodGraphMetric'
, formChoiceSafe { items: [Order1, Order2_A, Order2_B]
, methodGraphClustering: methodGraphClustering'
, methodGraphBridgeness: methodGraphBridgeness'
, methodGraphEdgesStrength : methodGraphEdgesStrength'
, methodGraphNodeType1 : methodGraphNodeType1'
, methodGraphNodeType2 : methodGraphNodeType2'
}
pure $
Tools.panelWithSubmitButton { action, dispatch: callback }
[ H.text "Show subjects with Order1 or concepts with Order2 ?"
, Tools.formChoiceSafe { items: [Order1, Order2_A, Order2_B]
, default: methodGraphMetric'
, default: methodGraphMetric'
, callback: \val -> T.write_ val methodGraphMetric
, callback: \val -> T.write_ val methodGraphMetric
, print: show } []
, print: show } []
]
{-
{-
...
@@ -138,16 +150,6 @@ updateGraphCpt = here.component "updateGraph" cpt where
...
@@ -138,16 +150,6 @@ updateGraphCpt = here.component "updateGraph" cpt where
, callback: \val -> T.write_ val methodGraphClustering
, callback: \val -> T.write_ val methodGraphClustering
, print: show } []
, print: show } []
-}
-}
]
(submitButton (UpdateNode $ UpdateNodeParamsGraph { methodGraphMetric: methodGraphMetric'
, methodGraphClustering: methodGraphClustering'
, methodGraphBridgeness: methodGraphBridgeness'
, methodGraphEdgesStrength : methodGraphEdgesStrength'
, methodGraphNodeType1 : methodGraphNodeType1'
, methodGraphNodeType2 : methodGraphNodeType2'
}
) callback
)
...
@@ -214,13 +216,15 @@ updateNodeListCpt = here.component "updateNodeList" cpt where
...
@@ -214,13 +216,15 @@ updateNodeListCpt = here.component "updateNodeList" cpt where
methodList <- T.useBox Basic
methodList <- T.useBox Basic
methodList' <- T.useLive T.unequal methodList
methodList' <- T.useLive T.unequal methodList
pure $ panel [ -- H.text "Update with"
pure $
formChoiceSafe { items: [Basic, Advanced, WithModel]
Tools.panelWithSubmitButton { action: UpdateNode $ UpdateNodeParamsList { methodList: methodList' }
, dispatch }
[ -- H.text "Update with"
Tools.formChoiceSafe { items: [Basic, Advanced, WithModel]
, default: methodList'
, default: methodList'
, callback: \val -> T.write_ val methodList
, callback: \val -> T.write_ val methodList
, print: show } []
, print: show } []
]
]
(submitButton (UpdateNode $ UpdateNodeParamsList { methodList: methodList' }) dispatch)
updateTexts :: R2.Component UpdateProps
updateTexts :: R2.Component UpdateProps
updateTexts = R.createElement updateTextsCpt
updateTexts = R.createElement updateTextsCpt
...
@@ -230,14 +234,15 @@ updateTextsCpt = here.component "updateTexts" cpt where
...
@@ -230,14 +234,15 @@ updateTextsCpt = here.component "updateTexts" cpt where
-- methodTexts <- T.useBox NewNgrams
-- methodTexts <- T.useBox NewNgrams
-- methodTexts' <- T.useLive T.unequal methodTexts
-- methodTexts' <- T.useLive T.unequal methodTexts
pure $ panel [ -- H.text "Update with"
pure $
Tools.panelWithSubmitButton { action: UpdateNode $ UpdateNodeParamsTexts { methodTexts: Both }
, dispatch }
[] -- H.text "Update with"
-- formChoiceSafe { items: [NewNgrams, NewTexts, Both]
-- formChoiceSafe { items: [NewNgrams, NewTexts, Both]
-- , default: methodTexts'
-- , default: methodTexts'
-- , callback: \val -> T.write_ val methodTexts
-- , callback: \val -> T.write_ val methodTexts
-- , print: show } []
-- , print: show } []
]
-- (submitButton (UpdateNode $ UpdateNodeParamsTexts { methodTexts: methodTexts' }) dispatch)
-- (submitButton (UpdateNode $ UpdateNodeParamsTexts { methodTexts: methodTexts' }) dispatch)
(submitButton (UpdateNode $ UpdateNodeParamsTexts { methodTexts: Both }) dispatch)
updateOther :: R2.Component UpdateProps
updateOther :: R2.Component UpdateProps
...
...
src/Gargantext/Components/Forest/Tree/Node/Action/Upload.purs
View file @
317f5942
...
@@ -194,7 +194,7 @@ uploadFileViewWithLangsCpt = here.component "uploadFileViewWithLangs" cpt
...
@@ -194,7 +194,7 @@ uploadFileViewWithLangsCpt = here.component "uploadFileViewWithLangs" cpt
, selection
, selection
} []
} []
]
]
pure $ panel
bodies footer
pure $ panel
{} (bodies <> [ footer ])
onChangeContents :: forall e. T.Box (Maybe UploadFile) -> E.SyntheticEvent_ e -> Effect Unit
onChangeContents :: forall e. T.Box (Maybe UploadFile) -> E.SyntheticEvent_ e -> Effect Unit
...
@@ -318,7 +318,7 @@ uploadListViewCpt = here.component "uploadListView" cpt where
...
@@ -318,7 +318,7 @@ uploadListViewCpt = here.component "uploadListView" cpt where
-- Render
-- Render
pure $
pure $
panel
panel
{}
-- Body
-- Body
[
[
-- Upload
-- Upload
...
@@ -423,9 +423,9 @@ uploadListViewCpt = here.component "uploadListView" cpt where
...
@@ -423,9 +423,9 @@ uploadListViewCpt = here.component "uploadListView" cpt where
} []
} []
]
]
]
]
]
-- Footer
-- Footer
(
,
H.div
H.div
{}
{}
[
[
...
@@ -439,7 +439,7 @@ uploadListViewCpt = here.component "uploadListView" cpt where
...
@@ -439,7 +439,7 @@ uploadListViewCpt = here.component "uploadListView" cpt where
, nodeType: GT.Annuaire
, nodeType: GT.Annuaire
} []
} []
]
]
)
]
-- START File Type View
-- START File Type View
type FileTypeProps =
type FileTypeProps =
...
@@ -663,12 +663,12 @@ uploadTermListViewCpt = here.component "uploadTermListView" cpt
...
@@ -663,12 +663,12 @@ uploadTermListViewCpt = here.component "uploadTermListView" cpt
}
}
]
]
pure $ panel
pure $ panel
{}
[ H.form {}
[ H.form {}
[ R2.row [ R2.col 12 [ input ] ]
[ R2.row [ R2.col 12 [ input ] ]
, R2.row [ R2.col 12 [ uploadTypeHtml ] ]
, R2.row [ R2.col 12 [ uploadTypeHtml ] ]
]
]
] footer
, footer ]
onChangeContents :: forall e. T.Box (Maybe UploadFile)
onChangeContents :: forall e. T.Box (Maybe UploadFile)
-> E.SyntheticEvent_ e
-> E.SyntheticEvent_ e
...
@@ -815,7 +815,7 @@ uploadFrameCalcViewWithLangsCpt = here.component "uploadFrameCalcViewWithLangs"
...
@@ -815,7 +815,7 @@ uploadFrameCalcViewWithLangsCpt = here.component "uploadFrameCalcViewWithLangs"
[ H.text "Upload!" ]
[ H.text "Upload!" ]
]
]
pure $ panel
bodies footer
pure $ panel
{} (bodies <> [ footer ])
where
where
onClick lang' selection' _ = do
onClick lang' selection' _ = do
...
...
src/Gargantext/Components/Forest/Tree/Node/Action/WriteNodesDocuments.purs
View file @
317f5942
...
@@ -11,7 +11,7 @@ import Gargantext.Components.App.Store (Boxes)
...
@@ -11,7 +11,7 @@ import Gargantext.Components.App.Store (Boxes)
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Utils (loadLanguages)
import Gargantext.Components.Forest.Tree.Node.Action.Utils (loadLanguages)
import Gargantext.Components.Forest.Tree.Node.Tools
(panel, submitButton)
import Gargantext.Components.Forest.Tree.Node.Tools
as Tools
import Gargantext.Components.Lang (Lang(..))
import Gargantext.Components.Lang (Lang(..))
import Gargantext.Components.ListSelection as ListSelection
import Gargantext.Components.ListSelection as ListSelection
import Gargantext.Components.ListSelection.Types as ListSelection
import Gargantext.Components.ListSelection.Types as ListSelection
...
@@ -71,7 +71,13 @@ actionWriteNodesDocumentsWithLangsCpt = here.component "actionWriteNodesDocument
...
@@ -71,7 +71,13 @@ actionWriteNodesDocumentsWithLangsCpt = here.component "actionWriteNodesDocument
paragraphs' /\ paragraphBox
paragraphs' /\ paragraphBox
<- R2.useBox' "7"
<- R2.useBox' "7"
let bodies = [
pure $
Tools.panelWithSubmitButton { action: DocumentsFromWriteNodes { id
, lang: lang'
, selection: selection'
, paragraphs: paragraphs' }
, dispatch }
[
H.div
H.div
{ className: "col-12 flex-space-around" }
{ className: "col-12 flex-space-around" }
[ H.h4 {}
[ H.h4 {}
...
@@ -144,8 +150,6 @@ actionWriteNodesDocumentsWithLangsCpt = here.component "actionWriteNodesDocument
...
@@ -144,8 +150,6 @@ actionWriteNodesDocumentsWithLangsCpt = here.component "actionWriteNodesDocument
]
]
]
]
pure $ panel bodies (submitButton (DocumentsFromWriteNodes { id, lang: lang', selection: selection', paragraphs: paragraphs' }) dispatch)
type Params =
type Params =
( id :: GT.ID
( id :: GT.ID
...
...
src/Gargantext/Components/Forest/Tree/Node/Tools.purs
View file @
317f5942
...
@@ -2,10 +2,12 @@ module Gargantext.Components.Forest.Tree.Node.Tools where
...
@@ -2,10 +2,12 @@ module Gargantext.Components.Forest.Tree.Node.Tools where
import Gargantext.Prelude
import Gargantext.Prelude
import Data.Maybe (fromMaybe)
import Data.Array as A
import Data.Maybe (fromMaybe, Maybe(..))
import Data.Set (Set)
import Data.Set (Set)
import Data.Set as Set
import Data.Set as Set
import Data.String as S
import Data.String as S
import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Effect (Effect)
import Effect.Aff (Aff, launchAff, launchAff_)
import Effect.Aff (Aff, launchAff, launchAff_)
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Bootstrap as B
...
@@ -19,6 +21,7 @@ import Gargantext.Utils.Reactix as R2
...
@@ -19,6 +21,7 @@ import Gargantext.Utils.Reactix as R2
import Gargantext.Utils.Show as GUS
import Gargantext.Utils.Show as GUS
import Reactix as R
import Reactix as R
import Reactix.DOM.HTML as H
import Reactix.DOM.HTML as H
import Record.Extra as RX
import Toestand as T
import Toestand as T
here :: R2.Here
here :: R2.Here
...
@@ -27,20 +30,52 @@ here = R2.here "Gargantext.Components.Forest.Tree.Node.Tools"
...
@@ -27,20 +30,52 @@ here = R2.here "Gargantext.Components.Forest.Tree.Node.Tools"
fragmentPT :: String -> R.Element
fragmentPT :: String -> R.Element
fragmentPT text = H.div { style: { margin: "10px" }} [ H.text text ]
fragmentPT text = H.div { style: { margin: "10px" }} [ H.text text ]
type Body = Array R.Element
type
Footer = R.Element
type
PanelProps = ()
panel :: Body -> Footer -> R.Element
-- | Last element of panel's children goes to footer, all others go to body
panel bodies submit =
panel :: R2.Component PanelProps
R.fragment
panel = R.createElement panelCpt
panelCpt :: R.Component PanelProps
panelCpt = here.component "panel" cpt where
cpt {} children =
pure $ R.fragment
[ H.div { className: "card-body" }
[ H.div { className: "card-body" }
[ H.div { className: "row" }
[ H.div { className: "row" }
-- TODO add type for text or form here [ H.form {className: "form-horizontal"} bodies ]
-- TODO add type for text or form here [ H.form {className: "form-horizontal"} bodies ]
[ H.div { className: "col-12" } bodies ]]
[ H.div { className: "col-12" } bodies ]]
, H.div {className: "card-footer"}
, H.div {className: "card-footer"}
[ H.div { className: "row" }
[ H.div { className: "row" }
[ H.div { className: "mx-auto"} [ submit ] ]]]
[ H.div { className: "mx-auto"} [ footer ] ]]]
where
bodies /\ footer =
case A.unsnoc children of
Nothing -> [] /\ (H.div {} [])
Just { init, last } -> init /\ last
panelNoFooter :: R2.Component PanelProps
panelNoFooter = R.createElement panelNoFooterCpt
panelNoFooterCpt :: R.Component PanelProps
panelNoFooterCpt = here.component "panelNoFooter" cpt where
cpt props children =
pure $ panel props (children <> [ H.div {} [] ])
type PanelWithSubmitButtonProps =
( action :: Action
, dispatch :: Action -> Aff Unit
| PanelProps )
panelWithSubmitButton :: R2.Component PanelWithSubmitButtonProps
panelWithSubmitButton = R.createElement panelWithSubmitButtonCpt
panelWithSubmitButtonCpt :: R.Component PanelWithSubmitButtonProps
panelWithSubmitButtonCpt = here.component "panelWithSubmitButton" cpt where
cpt props@{ action, dispatch } children = do
let pProps = (RX.pick props :: Record PanelProps)
pure $ panel pProps (children
-- footer
<> [ submitButton { action, dispatch } ])
type TextInputBoxProps =
type TextInputBoxProps =
( id :: GT.ID
( id :: GT.ID
...
@@ -252,9 +287,17 @@ formButtonCpt = here.component "formButton" cpt where
...
@@ -252,9 +287,17 @@ formButtonCpt = here.component "formButton" cpt where
------------------------------------------------------------------------
------------------------------------------------------------------------
------------------------------------------------------------------------
------------------------------------------------------------------------
submitButton :: Action -> (Action -> Aff Unit) -> R.Element
type SubmitButtonProps =
submitButton action dispatch =
( action :: Action
H.button { className : "btn btn-primary fa fa-" <> icon action
, dispatch :: Action -> Aff Unit )
submitButton :: R2.Leaf SubmitButtonProps
submitButton = R2.leaf submitButtonCpt
submitButtonCpt :: R.Component SubmitButtonProps
submitButtonCpt = here.component "submitButton" cpt where
cpt { action
, dispatch } _ = do
pure $ H.button { className : "btn btn-primary fa fa-" <> icon action
, type: "button"
, type: "button"
, id: S.toLower $ show action
, id: S.toLower $ show action
, title: show action
, title: show action
...
...
src/Gargantext/Config/REST.purs
View file @
317f5942
...
@@ -14,6 +14,7 @@ import Data.Generic.Rep (class Generic)
...
@@ -14,6 +14,7 @@ import Data.Generic.Rep (class Generic)
import Data.HTTP.Method (Method(..))
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Data.Maybe (Maybe(..))
import Data.MediaType.Common (applicationFormURLEncoded, applicationJSON, multipartFormData)
import Data.MediaType.Common (applicationFormURLEncoded, applicationJSON, multipartFormData)
import Data.Show.Generic (genericShow)
import Data.Tuple (Tuple)
import Data.Tuple (Tuple)
import Effect (Effect)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Aff (Aff)
...
@@ -31,6 +32,7 @@ type Token = String
...
@@ -31,6 +32,7 @@ type Token = String
data RESTError =
data RESTError =
CustomError String
CustomError String
| FE FrontendError
| ReadJSONError Foreign.MultipleErrors
| ReadJSONError Foreign.MultipleErrors
| SendResponseError Affjax.Error
| SendResponseError Affjax.Error
| ServerError String
| ServerError String
...
@@ -38,6 +40,7 @@ data RESTError =
...
@@ -38,6 +40,7 @@ data RESTError =
derive instance Generic RESTError _
derive instance Generic RESTError _
instance Show RESTError where
instance Show RESTError where
show (CustomError s) = "CustomError " <> s
show (CustomError s) = "CustomError " <> s
show (FE e) = show e
show (ReadJSONError e) = "ReadJSONError " <> show e
show (ReadJSONError e) = "ReadJSONError " <> show e
show (SendResponseError e) = "SendResponseError " <> showError e
show (SendResponseError e) = "SendResponseError " <> showError e
where
where
...
@@ -52,6 +55,87 @@ instance Eq RESTError where
...
@@ -52,6 +55,87 @@ instance Eq RESTError where
-- this is crude but we need it only because of useLoader
-- this is crude but we need it only because of useLoader
eq _ _ = false
eq _ _ = false
data FrontendError =
EC_400__node_creation_failed_insert_node { user_id :: Int
, parent_id :: Int }
| EC_400__node_creation_failed_no_parent { user_id :: Int }
| EC_400__node_creation_failed_parent_exists { parent_id :: Int
, user_id :: Int }
| EC_400__node_creation_failed_user_negative_id { user_id :: Int }
| EC_400__node_lookup_failed_user_too_many_roots { user_id :: Int
, roots :: Array Int }
| EC_400__node_needs_configuration
| EC_403__login_failed_error { node_id :: Int
, user_id :: Int }
| EC_403__login_failed_invalid_username_or_password
| EC_404__node_context_not_found { context_id :: Int }
| EC_404__node_lookup_failed_not_found { node_id :: Int }
| EC_404__node_lookup_failed_parent_not_found { node_id :: Int }
| EC_404__node_lookup_failed_username_not_found { username :: String }
| EC_404__node_list_not_found { list_id :: Int }
| EC_404__node_root_not_found
| EC_500__node_generic_exception { error :: String }
| EC_500__node_not_implemented_yet
derive instance Generic FrontendError _
instance Show FrontendError where
show EC_403__login_failed_invalid_username_or_password = "Invalid username or password"
show (EC_404__node_lookup_failed_username_not_found { username }) = "User '" <> username <> "' not found"
show a = genericShow a
instance JSON.ReadForeign FrontendError where
readImpl f = do
{ type: type_ } <- JSON.readImpl f :: Foreign.F { type :: String }
case type_ of
"EC_400__node_creation_failed_insert_node" -> do
{ data: { parent_id, user_id } } <- JSON.readImpl f :: Foreign.F { data :: { parent_id :: Int
, user_id :: Int } }
pure $ EC_400__node_creation_failed_insert_node { parent_id, user_id }
"EC_400__node_creation_failed_no_parent" -> do
{ data: { user_id } } <- JSON.readImpl f :: Foreign.F { data :: { user_id :: Int } }
pure $ EC_400__node_creation_failed_no_parent { user_id }
"EC_400__node_creation_failed_parent_exists" -> do
{ data: { parent_id, user_id } } <- JSON.readImpl f :: Foreign.F { data :: { parent_id :: Int
, user_id :: Int } }
pure $ EC_400__node_creation_failed_parent_exists { parent_id, user_id }
"EC_400__node_creation_failed_user_negative_id" -> do
{ data: { user_id } } <- JSON.readImpl f :: Foreign.F { data :: { user_id :: Int } }
pure $ EC_400__node_creation_failed_user_negative_id { user_id }
"EC_400__node_lookup_failed_user_too_many_roots" -> do
{ data: { user_id, roots } } <- JSON.readImpl f :: Foreign.F { data :: { user_id :: Int
, roots :: Array Int } }
pure $ EC_400__node_lookup_failed_user_too_many_roots { user_id, roots }
"EC_400__node_needs_configuration" -> do
pure $ EC_400__node_needs_configuration
"EC_403__login_failed_error" -> do
{ data: { node_id, user_id } } <- JSON.readImpl f :: Foreign.F { data :: { node_id :: Int
, user_id :: Int } }
pure $ EC_403__login_failed_error { node_id, user_id }
"EC_403__login_failed_invalid_username_or_password" -> do
pure $ EC_403__login_failed_invalid_username_or_password
"EC_404__node_context_not_found" -> do
{ data: { context_id } } <- JSON.readImpl f :: Foreign.F { data :: { context_id :: Int } }
pure $ EC_404__node_context_not_found { context_id }
"EC_404__node_lookup_failed_not_found" -> do
{ data: { node_id } } <- JSON.readImpl f :: Foreign.F { data :: { node_id :: Int } }
pure $ EC_404__node_lookup_failed_not_found { node_id }
"EC_404__node_lookup_failed_parent_not_found" -> do
{ data: { node_id } } <- JSON.readImpl f :: Foreign.F { data :: { node_id :: Int } }
pure $ EC_404__node_lookup_failed_parent_not_found { node_id }
"EC_404__node_lookup_failed_username_not_found" -> do
{ data: { username } } <- JSON.readImpl f :: Foreign.F { data :: { username :: String } }
pure $ EC_404__node_lookup_failed_username_not_found { username }
"EC_404__node_list_not_found" -> do
{ data: { list_id } } <- JSON.readImpl f :: Foreign.F { data :: { list_id :: Int } }
pure $ EC_404__node_list_not_found { list_id }
"EC_404__node_root_not_found" -> do
pure $ EC_404__node_root_not_found
"EC_500__node_generic_exception" -> do
{ data: { error } } <- JSON.readImpl f :: Foreign.F { data :: { error :: String } }
pure $ EC_500__node_generic_exception { error }
"EC_500__node_not_implemented_yet" -> do
pure $ EC_500__node_not_implemented_yet
_ -> Foreign.fail $ Foreign.ForeignError $ "deserialization for '" <> type_ <> "' not implemented"
logRESTError :: R2.Here -> String -> RESTError -> Effect Unit
logRESTError :: R2.Here -> String -> RESTError -> Effect Unit
logRESTError here' prefix e = here'.warn2 (prefix <> " " <> show e) e
logRESTError here' prefix e = here'.warn2 (prefix <> " " <> show e) e
-- logRESTError here prefix (SendResponseError e) = here.warn2 (prefix <> " SendResponseError ") e -- TODO: No show
-- logRESTError here prefix (SendResponseError e) = here.warn2 (prefix <> " SendResponseError ") e -- TODO: No show
...
@@ -61,8 +145,8 @@ logRESTError here' prefix e = here'.warn2 (prefix <> " " <> show e) e
...
@@ -61,8 +145,8 @@ logRESTError here' prefix e = here'.warn2 (prefix <> " " <> show e) e
type AffRESTError a = Aff (Either RESTError a)
type AffRESTError a = Aff (Either RESTError a)
readJSON :: forall a. JSON.ReadForeign a
=>
readJSON :: forall a. JSON.ReadForeign a
Either Affjax.Error (Affjax.Response AC.Json)
=>
Either Affjax.Error (Affjax.Response AC.Json)
-> Either RESTError a
-> Either RESTError a
readJSON affResp =
readJSON affResp =
case affResp of
case affResp of
...
@@ -74,15 +158,27 @@ readJSON affResp =
...
@@ -74,15 +158,27 @@ readJSON affResp =
--_ <- liftEffect $ log json.status
--_ <- liftEffect $ log json.status
--_ <- liftEffect $ log json.headers
--_ <- liftEffect $ log json.headers
--_ <- liftEffect $ log json.body
--_ <- liftEffect $ log json.body
case resp.status of
case resp.status of
StatusCode 500 ->
StatusCode 200 ->
case (JSON.readJSON $ AC.stringify resp.body :: JSON.E { error :: String }) of
Right ({ error }) -> Left $ ServerError error
Left _ -> Left $ UnknownServerError $ AC.stringify resp.body
_ ->
case (JSON.readJSON $ AC.stringify resp.body) of
case (JSON.readJSON $ AC.stringify resp.body) of
Left err -> Left $ ReadJSONError err
Left err -> Left $ ReadJSONError err
Right r -> Right r
Right r -> Right r
_ -> case (JSON.readJSON $ AC.stringify resp.body :: JSON.E FrontendError) of
Right err -> Left $ FE err
Left _ -> Left $ UnknownServerError $ AC.stringify resp.body
-- _ -> Left $ parseServerError resp
parseServerError :: Affjax.Response AC.Json -> RESTError
parseServerError { body } =
case (JSON.readJSON $ AC.stringify body :: JSON.E { type :: String }) of
Right { type: "EC_404__node_lookup_failed_username_not_found" } ->
ServerError "username not found"
-- TODO Add more errors for the frontend
Right { type: type_ } ->
UnknownServerError $ "Server error of type '" <> type_ <> "' not supported"
Left _ -> UnknownServerError $ AC.stringify body
-- TODO too much duplicate code in `postWwwUrlencoded`
-- TODO too much duplicate code in `postWwwUrlencoded`
send :: forall body res. JSON.WriteForeign body => JSON.ReadForeign res =>
send :: forall body res. JSON.WriteForeign body => JSON.ReadForeign res =>
...
@@ -94,6 +190,7 @@ send m mtoken url reqbody = do
...
@@ -94,6 +190,7 @@ send m mtoken url reqbody = do
, method = Left m
, method = Left m
, headers = [ ARH.ContentType applicationJSON
, headers = [ ARH.ContentType applicationJSON
, ARH.Accept applicationJSON
, ARH.Accept applicationJSON
, ARH.RequestHeader "X-Garg-Error-Scheme" $ "new"
] <>
] <>
foldMap (\token ->
foldMap (\token ->
[ARH.RequestHeader "Authorization" $ "Bearer " <> token]
[ARH.RequestHeader "Authorization" $ "Bearer " <> token]
...
@@ -106,7 +203,7 @@ send m mtoken url reqbody = do
...
@@ -106,7 +203,7 @@ send m mtoken url reqbody = do
let cookie = "JWT-Cookie=" <> token <> "; Path=/;" --" HttpOnly; Secure; SameSite=Lax"
let cookie = "JWT-Cookie=" <> token <> "; Path=/;" --" HttpOnly; Secure; SameSite=Lax"
R2.setCookie cookie
R2.setCookie cookie
affResp <- request req
affResp <- request req
liftEffect $ here.log2 "[send] affResp" affResp
--
liftEffect $ here.log2 "[send] affResp" affResp
pure $ readJSON affResp
pure $ readJSON affResp
noReqBody :: Maybe String
noReqBody :: Maybe String
...
...
src/Gargantext/Sessions.purs
View file @
317f5942
...
@@ -115,12 +115,9 @@ postAuthRequest :: Backend -> AuthRequest -> Aff (Either String Session)
...
@@ -115,12 +115,9 @@ postAuthRequest :: Backend -> AuthRequest -> Aff (Either String Session)
postAuthRequest backend ar@(AuthRequest {username}) =
postAuthRequest backend ar@(AuthRequest {username}) =
decode <$> REST.post Nothing (toUrl backend "auth") ar
decode <$> REST.post Nothing (toUrl backend "auth") ar
where
where
decode (Left err) = Left $ "Error when sending REST.post: " <> show err
decode (Left err) = Left $ show err
decode (Right (AuthResponse ar2))
decode (Right (AuthData { token, tree_id, user_id })) =
| {inval: Just (AuthInvalid {message})} <- ar2 = Left message
| {valid: Just (AuthData {token, tree_id, user_id})} <- ar2 =
Right $ Session { backend, caches: Map.empty, token, treeId: tree_id, username, userId: user_id }
Right $ Session { backend, caches: Map.empty, token, treeId: tree_id, username, userId: user_id }
| otherwise = Left "Invalid response from server"
postForgotPasswordRequest :: Backend -> String -> Aff (Either String { status :: String })
postForgotPasswordRequest :: Backend -> String -> Aff (Either String { status :: String })
postForgotPasswordRequest backend email =
postForgotPasswordRequest backend email =
...
...
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