Commit 20879d3c authored by Alexandre Delanoë's avatar Alexandre Delanoë

[MERGE] dev

parents eb01d47d d6d78ff1
module Gargantext.AsyncTasks where
import Data.Argonaut (decodeJson, class EncodeJson, encodeJson, (:=), (~>), (.:))
import Data.Argonaut.Parser (jsonParser)
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import DOM.Simple.Console (log2)
import Effect (Effect)
import Web.Storage.Storage as WSS
import Gargantext.Prelude
import Gargantext.Types as GT
import Gargantext.Utils.Reactix as R2
localStorageKey :: String
localStorageKey = "garg-async-tasks"
type Storage = Map.Map Int (Array GT.AsyncTaskWithType)
empty :: Storage
empty = Map.empty
getAsyncTasks :: Effect Storage
getAsyncTasks = R2.getls >>= WSS.getItem localStorageKey >>= handleMaybe
where
handleMaybe (Just val) = handleEither (parse val >>= decode)
handleMaybe Nothing = pure empty
-- either parsing or decoding could fail, hence two errors
handleEither (Left err) = err *> pure empty
handleEither (Right ss) = pure ss
parse s = mapLeft (log2 "Error parsing serialised sessions:") (jsonParser s)
decode j = mapLeft (log2 "Error decoding serialised sessions:") (decodeJson j)
mapLeft :: forall l m r. (l -> m) -> Either l r -> Either m r
mapLeft f (Left l) = Left (f l)
mapLeft _ (Right r) = Right r
removeTaskFromList :: Array GT.AsyncTaskWithType -> GT.AsyncTaskWithType -> Array GT.AsyncTaskWithType
removeTaskFromList ts (GT.AsyncTaskWithType { task: GT.AsyncTask { id: id' } }) =
A.filter (\(GT.AsyncTaskWithType { task: GT.AsyncTask { id: id'' } }) -> id' /= id'') ts
......@@ -3,6 +3,7 @@ module Gargantext.Components.Forest where
import Gargantext.Prelude
import Data.Array as A
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as Set
import Data.Tuple (fst)
......@@ -11,6 +12,7 @@ import Effect (Effect)
import Reactix as R
import Reactix.DOM.HTML as H
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Forest.Tree (treeView)
import Gargantext.Components.Forest.Tree.Node.Action (Reload)
import Gargantext.Ends (Frontends)
......@@ -35,15 +37,16 @@ forestCpt = R.hooksComponent "G.C.Forest.forest" cpt where
-- NOTE: this is a hack to reload the tree view on demand
reload <- R.useState' (0 :: Reload)
openNodes <- R2.useLocalStorageState R2.openNodesKey (Set.empty :: OpenNodes)
asyncTasks <- R2.useLocalStorageState GAT.localStorageKey GAT.empty
R2.useCache
(frontends /\ route /\ sessions /\ fst openNodes /\ fst extReload /\ fst reload)
(cpt' openNodes reload showLogin)
cpt' openNodes reload showLogin (frontends /\ route /\ sessions /\ _ /\ _ /\ _) = do
(frontends /\ route /\ sessions /\ fst openNodes /\ fst extReload /\ fst reload /\ fst asyncTasks)
(cpt' openNodes asyncTasks reload showLogin)
cpt' openNodes asyncTasks reload showLogin (frontends /\ route /\ sessions /\ _ /\ _ /\ _ /\ _) = do
pure $ R.fragment $ A.cons (plus showLogin) trees
where
trees = tree <$> unSessions sessions
tree s@(Session {treeId}) =
treeView { root: treeId, frontends, mCurrentRoute: Just route, session: s, openNodes, reload }
treeView { root: treeId, asyncTasks, frontends, mCurrentRoute: Just route, session: s, openNodes, reload }
plus :: R2.Setter Boolean -> R.Element
plus showLogin =
......
module Gargantext.Components.Forest.Tree where
import DOM.Simple.Console (log2)
import Data.Array as A
import Data.Maybe (Maybe)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.Tuple (Tuple(..), fst, snd)
import Data.Tuple.Nested ((/\))
import DOM.Simple.Console (log2)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Reactix as R
......@@ -13,13 +15,14 @@ import Reactix.DOM.HTML as H
import Record as Record
import Record.Extra as RecordE
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Forest.Tree.Node.Action (Action(..), FTree, ID, LNode(..), NTree(..), Reload, RenameValue(..), Tree, deleteNode, loadNode, renameNode)
import Gargantext.Components.Forest.Tree.Node.Action.Add (AddNodeValue(..), addNode)
import Gargantext.Components.Forest.Tree.Node.Action.Add (AddNodeValue(..), addNode)
import Gargantext.Components.Forest.Tree.Node.Action.Upload (uploadFile)
import Gargantext.Components.Forest.Tree.Node.Box (nodeMainSpan)
import Gargantext.Components.Forest.Tree.Node.Box (nodeMainSpan, Tasks, tasksStruct)
import Gargantext.Ends (Frontends)
import Gargantext.Hooks.Loader (useLoader)
import Gargantext.Prelude (Unit, bind, const, discard, map, pure, void, ($), (+), (/=), (<>))
import Gargantext.Prelude (Unit, bind, const, discard, map, pure, void, ($), (+), (/=), (<>), identity)
import Gargantext.Routes (AppRoute)
import Gargantext.Sessions (OpenNodes, Session, mkNodeId)
import Gargantext.Types as GT
......@@ -36,6 +39,7 @@ type CommonProps =
------------------------------------------------------------------------
type Props = ( root :: ID
, asyncTasks :: R.State GAT.Storage
| CommonProps
)
......@@ -55,20 +59,23 @@ treeLoadView p = R.createElement treeLoadViewCpt p []
treeLoadViewCpt :: R.Component Props
treeLoadViewCpt = R.hooksComponent "TreeLoadView" cpt
where
cpt {root, mCurrentRoute, session, frontends, openNodes, reload} _ = do
cpt { root, asyncTasks, mCurrentRoute, session, frontends, openNodes, reload } _children = do
let fetch _ = loadNode session root
let paint loaded = loadedTreeView { tree: loaded
let paint loaded = loadedTreeView {
asyncTasks
, frontends
, mCurrentRoute
, openNodes
, reload
, session
, frontends
, openNodes, reload
, tasks: tasksStruct root asyncTasks reload
, tree: loaded
}
useLoader { root
, counter: fst reload
}
fetch paint
useLoader { root, counter: fst reload } fetch paint
type TreeViewProps = ( tree :: FTree
type TreeViewProps = ( asyncTasks :: R.State GAT.Storage
, tree :: FTree
, tasks :: Record Tasks
| CommonProps
)
......@@ -78,29 +85,28 @@ loadedTreeView p = R.createElement loadedTreeViewCpt p []
loadedTreeViewCpt :: R.Component TreeViewProps
loadedTreeViewCpt = R.hooksComponent "LoadedTreeView" cpt
where
cpt {tree, mCurrentRoute, session, frontends, openNodes, reload} _ = do
tasks <- R.useState' []
cpt { asyncTasks, frontends, mCurrentRoute, openNodes, reload, tasks, tree, session } _ = do
pure $ H.div {className: "tree"}
[ toHtml { frontends, mCurrentRoute, openNodes, reload, session, tasks, tree } ]
[ toHtml { asyncTasks, frontends, mCurrentRoute, openNodes, reload, session, tasks, tree } ]
------------------------------------------------------------------------
type ToHtmlProps =
(
tasks :: R.State (Array GT.AsyncTaskWithType)
asyncTasks :: R.State GAT.Storage
, tasks :: Record Tasks
, tree :: FTree
| CommonProps
)
toHtml :: Record ToHtmlProps -> R.Element
toHtml p@{ frontends
toHtml p@{ asyncTasks
, frontends
, mCurrentRoute
, openNodes
, reload: reload@(_ /\ setReload)
, session
, tasks: tasks@(asyncTasks /\ setAsyncTasks)
, tree: tree@(NTree (LNode {id, name, nodeType}) ary)
} = R.createElement el {} []
, tasks: tasks@{ onTaskAdd, onTaskFinish, tasks: tasks' }
, tree: tree@(NTree (LNode {id, name, nodeType}) ary) } = R.createElement el {} []
where
el = R.hooksComponent "NodeView" cpt
commonProps = RecordE.pick p :: Record CommonProps
......@@ -118,31 +124,26 @@ toHtml p@{ frontends
pure $ H.ul {}
[ H.li {}
( [ nodeMainSpan { id
, asyncTasks
, dispatch: pAction
, folderOpen
, frontends
, mCurrentRoute
, name
, nodeType
, onAsyncTaskFinish
, session
, tasks
} ]
<> childNodes (Record.merge commonProps
{ children: ary
{ asyncTasks
, children: ary
, folderOpen })
)
]
onAsyncTaskFinish (GT.AsyncTaskWithType {task: GT.AsyncTask {id: id'}}) = do
setAsyncTasks $ const newAsyncTasks
setReload (_ + 1)
where
newAsyncTasks = A.filter (\(GT.AsyncTaskWithType {task: GT.AsyncTask {id: id''}}) -> id' /= id'') asyncTasks
type ChildNodesProps =
( children :: Array FTree
( asyncTasks :: R.State GAT.Storage
, children :: Array FTree
, folderOpen :: R.State Boolean
| CommonProps
)
......@@ -150,24 +151,23 @@ type ChildNodesProps =
childNodes :: Record ChildNodesProps -> Array R.Element
childNodes { children: [] } = []
childNodes { folderOpen: (false /\ _) } = []
childNodes props@{ children } =
map (\ctree -> childNode {tree: ctree, asyncTasks: []}) $ sorted children
where
commonProps = RecordE.pick props :: Record CommonProps
sorted :: Array FTree -> Array FTree
sorted = A.sortWith (\(NTree (LNode {id}) _) -> id)
childNode :: Tree -> R.Element
childNode props = R.createElement el props []
el = R.hooksComponent "ChildNodeView" cpt
cpt {tree, asyncTasks} _ = do
tasks <- R.useState' asyncTasks
pure $ toHtml (Record.merge commonProps { tasks, tree })
childNodes props@{ asyncTasks, children, reload } =
map (\ctree@(NTree (LNode {id}) _) ->
toHtml (Record.merge commonProps {
asyncTasks
, tasks: tasksStruct id asyncTasks reload
, tree: ctree
})) $ sorted children
where
commonProps = RecordE.pick props :: Record CommonProps
sorted :: Array FTree -> Array FTree
sorted = A.sortWith (\(NTree (LNode {id}) _) -> id)
type PerformActionProps =
( openNodes :: R.State OpenNodes
, reload :: R.State Reload
, session :: Session
, tasks :: R.State (Array GT.AsyncTaskWithType)
, tasks :: Record Tasks
, tree :: FTree
)
......@@ -185,10 +185,9 @@ performAction p@{ openNodes: (_ /\ setOpenNodes)
performAction { reload: (_ /\ setReload)
, session
, tasks: (_ /\ setAsyncTasks)
, tree: (NTree (LNode {id}) _)
} (SearchQuery task) = do
liftEffect $ setAsyncTasks $ A.cons task
, tasks: { onTaskAdd }
, tree: (NTree (LNode {id}) _) } (SearchQuery task) = do
liftEffect $ onTaskAdd task
liftEffect $ log2 "[performAction] SearchQuery task:" task
performAction { reload: (_ /\ setReload)
......@@ -206,21 +205,18 @@ performAction p@{ reload: (_ /\ setReload)
performAction p@{ openNodes: (_ /\ setOpenNodes)
, reload: (_ /\ setReload)
, tasks: (_ /\ setAsyncTasks)
, session
, tree: (NTree (LNode {id}) _) } (CreateSubmit name nodeType) = do
-- task <- createNodeAsync session id $ CreateValue {name, nodeType}
task <- addNode session id $ AddNodeValue {name, nodeType}
-- liftEffect $ setAsyncTasks $ A.cons task
liftEffect do
setOpenNodes (Set.insert (mkNodeId session id))
performAction p RefreshTree
performAction { session
, tasks: (_ /\ setAsyncTasks)
, tasks: { onTaskAdd }
, tree: (NTree (LNode {id}) _) } (UploadFile nodeType fileType mName contents) = do
task <- uploadFile session nodeType id fileType {mName, contents}
liftEffect $ setAsyncTasks $ A.cons task
liftEffect $ onTaskAdd task
liftEffect $ log2 "uploaded, task:" task
performAction { reload: (_ /\ setReload) } RefreshTree = do
......
module Gargantext.Components.Forest.Tree.Node.Box where
import Gargantext.Prelude
import Data.Array as A
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (Nullable, null)
import Data.Tuple (fst, Tuple(..))
import Data.Tuple.Nested ((/\))
import DOM.Simple as DOM
import DOM.Simple.Event
import DOM.Simple.EventListener
import DOM.Simple.Types
import DOM.Simple.Window
import Data.Maybe (Maybe(..))
import Data.Nullable (Nullable, null)
import Data.Tuple (fst, Tuple(..))
import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Effect.Aff (Aff, launchAff, launchAff_)
import Effect.Class (liftEffect)
import Effect.Console
import Effect.Uncurried (mkEffectFn1)
import React.SyntheticEvent as E
import Reactix as R
import Reactix.DOM.HTML as H
import URI.Extra.QueryPairs as NQP
import URI.Query as Query
import Web.File.FileReader.Aff (readAsText)
import Gargantext.Prelude
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Forest.Tree.Node (NodeAction(..), SettingsBox(..), glyphiconNodeAction, settingsBox)
import Gargantext.Components.Forest.Tree.Node.Action (Action(..), DroppedFile(..), FileType(..), ID, Name, UploadFileContents(..))
import Gargantext.Components.Forest.Tree.Node.Action (Action(..), DroppedFile(..), FileType(..), ID, Name, Reload, UploadFileContents(..))
import Gargantext.Components.Forest.Tree.Node.Action.Add (NodePopup(..), addNodeView)
import Gargantext.Components.Forest.Tree.Node.Action.Rename (renameBox)
import Gargantext.Components.Forest.Tree.Node.Action.Upload (uploadFileView, fileTypeView, uploadTermListView, copyFromCorpusView)
......@@ -38,15 +48,27 @@ import Gargantext.Types as GT
import Gargantext.Utils (glyphicon, glyphiconActive)
import Gargantext.Utils.Popover as Popover
import Gargantext.Utils.Reactix as R2
import React.SyntheticEvent as E
import Reactix as R
import Reactix.DOM.HTML as H
import URI.Extra.QueryPairs as NQP
import URI.Query as Query
import Web.File.FileReader.Aff (readAsText)
type Dispatch = Action -> Aff Unit
type Tasks =
(
onTaskAdd :: GT.AsyncTaskWithType -> Effect Unit
, onTaskFinish :: GT.AsyncTaskWithType -> Effect Unit
, tasks :: Array GT.AsyncTaskWithType
)
tasksStruct :: Int -> R.State GAT.Storage -> R.State Reload -> Record Tasks
tasksStruct id (asyncTasks /\ setAsyncTasks) (_ /\ setReload) = { onTaskAdd, onTaskFinish, tasks }
where
tasks = maybe [] identity $ Map.lookup id asyncTasks
onTaskAdd t = do
setReload (_ + 1)
setAsyncTasks $ Map.alter (maybe (Just [t]) $ (\ts -> Just $ A.cons t ts)) id
onTaskFinish t = do
setReload (_ + 1)
setAsyncTasks $ Map.alter (maybe Nothing $ (\ts -> Just $ GAT.removeTaskFromList ts t)) id
type CommonProps =
( dispatch :: Dispatch
, session :: Session
......@@ -55,13 +77,12 @@ type CommonProps =
-- Main Node
type NodeMainSpanProps =
( id :: ID
, asyncTasks :: Array GT.AsyncTaskWithType
, folderOpen :: R.State Boolean
, frontends :: Frontends
, mCurrentRoute :: Maybe Routes.AppRoute
, name :: Name
, nodeType :: GT.NodeType
, onAsyncTaskFinish :: GT.AsyncTaskWithType -> Effect Unit
, tasks :: Record Tasks
| CommonProps
)
......@@ -70,7 +91,7 @@ nodeMainSpan :: Record NodeMainSpanProps
nodeMainSpan p@{ dispatch, folderOpen, frontends, session } = R.createElement el p []
where
el = R.hooksComponent "G.C.F.T.N.B.NodeMainSpan" cpt
cpt props@{id, asyncTasks, mCurrentRoute, name, nodeType, onAsyncTaskFinish} _ = do
cpt props@{id, mCurrentRoute, name, nodeType, tasks: { onTaskFinish, tasks }} _ = do
-- only 1 popup at a time is allowed to be opened
droppedFile <- R.useState' (Nothing :: Maybe DroppedFile)
isDragOver <- R.useState' false
......@@ -102,8 +123,8 @@ nodeMainSpan p@{ dispatch, folderOpen, frontends, session } = R.createElement el
, H.div {} (map (\t -> asyncProgressBar { asyncTask: t
, barType: Pie
, corpusId: id
, onFinish: const $ onAsyncTaskFinish t
, session }) asyncTasks)
, onFinish: const $ onTaskFinish t
, session }) tasks)
]
where
SettingsBox {show: showBox} = settingsBox nodeType
......
......@@ -439,14 +439,11 @@ type AffTableResult a = Aff (TableResult a)
data Mode = Authors | Sources | Institutes | Terms
derive instance genericMode :: Generic Mode _
instance showMode :: Show Mode where
show = genericShow
derive instance eqMode :: Eq Mode
instance ordMode :: Ord Mode where
compare = genericCompare
instance encodeMode :: EncodeJson Mode where
encodeJson x = encodeJson $ show x
......@@ -457,41 +454,51 @@ modeTabType Institutes = CTabInstitutes
modeTabType Terms = CTabTerms
modeFromString :: String -> Maybe Mode
modeFromString "Authors" = Just Authors
modeFromString "Sources" = Just Sources
modeFromString "Authors" = Just Authors
modeFromString "Sources" = Just Sources
modeFromString "Institutes" = Just Institutes
modeFromString "Terms" = Just Terms
modeFromString _ = Nothing
modeFromString "Terms" = Just Terms
modeFromString _ = Nothing
-- | Async tasks
-- Async tasks
-- corresponds to /add/form/async or /add/query/async
data AsyncTaskType = Form
| GraphT
| Query
| AddNode
| UpdateNode
derive instance genericAsyncTaskType :: Generic AsyncTaskType _
instance eqAsyncTaskType :: Eq AsyncTaskType where
eq = genericEq
instance showAsyncTaskType :: Show AsyncTaskType where
show = genericShow
instance encodeJsonAsyncTaskType :: EncodeJson AsyncTaskType where
encodeJson t = encodeJson $ show t
instance decodeJsonAsyncTaskType :: DecodeJson AsyncTaskType where
decodeJson json = do
obj <- decodeJson json
case obj of
"Form" -> pure Form
"GraphT" -> pure GraphT
"Query" -> pure Query
"AddNode" -> pure AddNode
s -> Left ("Unknown string " <> s)
asyncTaskTypePath :: AsyncTaskType -> String
asyncTaskTypePath Form = "add/form/async/"
asyncTaskTypePath Query = "query/"
asyncTaskTypePath GraphT = "async/"
asyncTaskTypePath AddNode = "async/nobody/"
asyncTaskTypePath UpdateNode = "async/"
type AsyncTaskID = String
data AsyncTaskStatus = Running
| Pending
| Received
| Started
| Failed
| Finished
| Killed
data AsyncTaskStatus = Running | Pending | Received | Started | Failed | Finished | Killed
derive instance genericAsyncTaskStatus :: Generic AsyncTaskStatus _
instance showAsyncTaskStatus :: Show AsyncTaskStatus where
show = genericShow
derive instance eqAsyncTaskStatus :: Eq AsyncTaskStatus
instance encodeJsonAsyncTaskStatus :: EncodeJson AsyncTaskStatus where
encodeJson s = encodeJson $ show s
instance decodeJsonAsyncTaskStatus :: DecodeJson AsyncTaskStatus where
decodeJson json = do
obj <- decodeJson json
......@@ -507,46 +514,64 @@ readAsyncTaskStatus "IsRunning" = Running
readAsyncTaskStatus "IsStarted" = Started
readAsyncTaskStatus _ = Running
newtype AsyncTask =
AsyncTask { id :: AsyncTaskID
, status :: AsyncTaskStatus
}
newtype AsyncTask = AsyncTask {
id :: AsyncTaskID
, status :: AsyncTaskStatus
}
derive instance genericAsyncTask :: Generic AsyncTask _
instance eqAsyncTask :: Eq AsyncTask where
eq = genericEq
instance encodeJsonAsyncTask :: EncodeJson AsyncTask where
encodeJson (AsyncTask { id, status }) =
"id" := id
~> "status" := status
~> jsonEmptyObject
instance decodeJsonAsyncTask :: DecodeJson AsyncTask where
decodeJson json = do
obj <- decodeJson json
id <- obj .: "id"
id <- obj .: "id"
status <- obj .: "status"
pure $ AsyncTask {id, status}
newtype AsyncTaskWithType =
AsyncTaskWithType { task :: AsyncTask
, typ :: AsyncTaskType
}
newtype AsyncProgress =
AsyncProgress { id :: AsyncTaskID
, log :: Array AsyncTaskLog
, status :: AsyncTaskStatus
}
pure $ AsyncTask { id, status }
newtype AsyncTaskWithType = AsyncTaskWithType {
task :: AsyncTask
, typ :: AsyncTaskType
}
derive instance genericAsyncTaskWithType :: Generic AsyncTaskWithType _
instance eqAsyncTaskWithType :: Eq AsyncTaskWithType where
eq = genericEq
instance encodeJsonAsyncTaskWithType :: EncodeJson AsyncTaskWithType where
encodeJson (AsyncTaskWithType { task, typ }) =
"task" := task
~> "typ" := typ
~> jsonEmptyObject
instance decodeJsonAsyncTaskWithType :: DecodeJson AsyncTaskWithType where
decodeJson json = do
obj <- decodeJson json
task <- obj .: "task"
typ <- obj .: "typ"
pure $ AsyncTaskWithType { task, typ }
newtype AsyncProgress = AsyncProgress {
id :: AsyncTaskID
, log :: Array AsyncTaskLog
, status :: AsyncTaskStatus
}
derive instance genericAsyncProgress :: Generic AsyncProgress _
instance decodeJsonAsyncProgress :: DecodeJson AsyncProgress where
decodeJson json = do
obj <- decodeJson json
id <- obj .: "id"
id <- obj .: "id"
log <- obj .: "log"
status <- obj .: "status"
pure $ AsyncProgress {id, log, status}
newtype AsyncTaskLog =
AsyncTaskLog { events :: Array String
, failed :: Int
, remaining :: Int
, succeeded :: Int
}
newtype AsyncTaskLog = AsyncTaskLog {
events :: Array String
, failed :: Int
, remaining :: Int
, succeeded :: Int
}
derive instance genericAsyncTaskLog :: Generic AsyncTaskLog _
instance decodeJsonAsyncTaskLog :: DecodeJson AsyncTaskLog where
decodeJson json = do
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment