Skip to content

P
purescript-gargantext
Commit 0f9e3220 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

Merge remote-tracking branch 'origin/async-workers' into dev

parents 27d6aa0f c2d0cae5
Hide whitespace changes
Inline Side-by-side
Showing with 477 additions and 630 deletions
package.json
View file @ 0f9e3220
......@@ -79,6 +79,6 @@
"xhr2": "~0.2.1"
},
"optionalDependencies": {
"purescript-language-server": "~0.17.1"
"purescript-language-server": "~0.18.2"
}
}
src/Gargantext/AsyncTasks.purs
View file @ 0f9e3220
module Gargantext.AsyncTasks (
TaskList
Task
, TaskList
, Storage(..)
, readAsyncTasks
, insert
, finish
, focus
, asyncTaskTTriggersAppReload
, asyncTaskTTriggersTreeReload
, asyncTaskTTriggersMainPageReload )
-- , asyncTaskTTriggersAppReload
-- , asyncTaskTTriggersTreeReload
-- , asyncTaskTTriggersMainPageReload
)
where
import Gargantext.Prelude
......@@ -33,7 +34,8 @@ import Toestand as T
import Web.Storage.Storage as WSS
type TaskList = Array GT.AsyncTaskWithType
type Task = GT.WorkerTask
type TaskList = Array Task
newtype Storage = Storage (Map.Map GT.NodeID TaskList)
derive newtype instance Semigroup Storage
derive newtype instance Monoid Storage
......@@ -47,32 +49,9 @@ instance JSON.WriteForeign Storage where
arr :: Array (Tuple String TaskList)
arr = (\(Tuple k v) -> Tuple (show k) v) <$> (Map.toUnfoldable s)
readAsyncTasks :: Effect Storage
readAsyncTasks = R2.loadLocalStorageState' R2.asyncTasksKey mempty
-- readAsyncTasks = R2.getls >>= WSS.getItem R2.asyncTasksKey >>= handleMaybe
-- where
-- handleMaybe (Just val) = handleEither (parse val)
-- 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 = GU.mapLeft (log2 "Error parsing serialised sessions:") (JSON.readJSON s)
writeAsyncTasks :: Storage -> Effect Unit
writeAsyncTasks = R2.setLocalStorageState R2.asyncTasksKey
-- writeAsyncTasks storage = R2.getls >>= WSS.setItem R2.asyncTasksKey storage
modifyAsyncTasks :: (Storage -> Storage) -> Effect Unit
modifyAsyncTasks f = readAsyncTasks >>= writeAsyncTasks <<< f
modifyTaskBox :: (Storage -> Storage) -> T.Box Storage -> Effect Unit
modifyTaskBox f box = do
s <- T.read box
let newS = f s
T.write_ newS box
modifyAsyncTasks (const newS)
modifyTaskBox f box = T.modify_ f box
-- modifyAsyncTasks (const newS)
getTasks :: GT.NodeID -> Storage -> TaskList
getTasks nodeId (Storage storage) = fromMaybe [] $ Map.lookup nodeId storage
......@@ -83,9 +62,9 @@ setTasks id tasks (Storage s) = Storage $ Map.insert id tasks s
focus :: GT.NodeID -> T.Box Storage -> R.Hooks (T.Box TaskList)
focus id tasks = T.useFocused (getTasks id) (setTasks id) tasks
removeTaskFromList :: TaskList -> GT.AsyncTaskWithType -> TaskList
removeTaskFromList ts (GT.AsyncTaskWithType { task: GT.AsyncTask { id: id' } }) =
A.filter (\(GT.AsyncTaskWithType { task: GT.AsyncTask { id: id'' } }) -> id' /= id'') ts
removeTaskFromList :: TaskList -> Task -> TaskList
removeTaskFromList ts (GT.WorkerTask { message_id }) =
A.filter (\(GT.WorkerTask { message_id: message_id' }) -> message_id /= message_id') ts
type ReductorProps = (
reloadForest :: T2.ReloadS
......@@ -93,39 +72,57 @@ type ReductorProps = (
, storage :: Storage
)
insert :: GT.NodeID -> GT.AsyncTaskWithType -> T.Box Storage -> Effect Unit
insert :: GT.NodeID -> Task -> T.Box Storage -> Effect Unit
insert id task storageBox = modifyTaskBox newStorage storageBox
where
newStorage (Storage s) = Storage $ Map.alter (maybe (Just [task]) (\ts -> Just $ A.cons task ts)) id s
newStorage (Storage s) = Storage $ Map.alter (maybe (Just [task]) (\ts -> Just $ A.nub $ A.cons task ts)) id s
finish :: GT.NodeID -> GT.AsyncTaskWithType -> T.Box Storage -> Effect Unit
finish :: GT.NodeID -> Task -> T.Box Storage -> Effect Unit
finish id task storage = remove id task storage
remove :: GT.NodeID -> GT.AsyncTaskWithType -> T.Box Storage -> Effect Unit
remove :: GT.NodeID -> Task -> T.Box Storage -> Effect Unit
remove id task storageBox = modifyTaskBox newStorage storageBox
where
newStorage (Storage s) = Storage $ Map.alter (maybe Nothing $ (\ts -> Just $ removeTaskFromList ts task)) id s
-- AsyncTaskWithType is deprecated, but we leave these functions here,
-- becuase they're a useful reference
-- When a task is finished: which tasks cause forest or app reload
asyncTaskTriggersAppReload :: GT.AsyncTaskType -> Boolean
asyncTaskTriggersAppReload _ = false
-- asyncTaskTriggersAppReload :: GT.AsyncTaskType -> Boolean
-- asyncTaskTriggersAppReload _ = false
-- asyncTaskTTriggersAppReload :: GT.AsyncTaskWithType -> Boolean
-- asyncTaskTTriggersAppReload (GT.AsyncTaskWithType { typ }) = asyncTaskTriggersAppReload typ
-- asyncTaskTriggersMainPageReload :: GT.AsyncTaskType -> Boolean
-- asyncTaskTriggersMainPageReload GT.UpdateNgramsCharts = true
-- asyncTaskTriggersMainPageReload _ = false
-- asyncTaskTTriggersMainPageReload :: GT.AsyncTaskWithType -> Boolean
-- asyncTaskTTriggersMainPageReload (GT.AsyncTaskWithType { typ }) = asyncTaskTriggersMainPageReload typ
-- asyncTaskTriggersTreeReload :: GT.AsyncTaskType -> Boolean
-- asyncTaskTriggersTreeReload GT.CorpusFormUpload = true
-- asyncTaskTriggersTreeReload GT.Query = true
-- asyncTaskTriggersTreeReload GT.UploadFile = true
-- asyncTaskTriggersTreeReload _ = false
-- asyncTaskTTriggersTreeReload :: GT.AsyncTaskWithType -> Boolean
-- asyncTaskTTriggersTreeReload (GT.AsyncTaskWithType { typ }) = asyncTaskTriggersTreeReload typ
asyncTaskTTriggersAppReload :: GT.AsyncTaskWithType -> Boolean
asyncTaskTTriggersAppReload (GT.AsyncTaskWithType { typ }) = asyncTaskTriggersAppReload typ
asyncTaskTriggersMainPageReload :: GT.AsyncTaskType -> Boolean
asyncTaskTriggersMainPageReload GT.UpdateNgramsCharts = true
asyncTaskTriggersMainPageReload _ = false
-- With push-based notifications, it doesn't make sense to store jobs in localStorage
-- readAsyncTasks :: Effect Storage
-- readAsyncTasks = R2.loadLocalStorageState' R2.asyncTasksKey mempty
asyncTaskTTriggersMainPageReload :: GT.AsyncTaskWithType -> Boolean
asyncTaskTTriggersMainPageReload (GT.AsyncTaskWithType { typ }) = asyncTaskTriggersMainPageReload typ
-- writeAsyncTasks :: Storage -> Effect Unit
-- writeAsyncTasks = R2.setLocalStorageState R2.asyncTasksKey
asyncTaskTriggersTreeReload :: GT.AsyncTaskType -> Boolean
asyncTaskTriggersTreeReload GT.CorpusFormUpload = true
asyncTaskTriggersTreeReload GT.Query = true
asyncTaskTriggersTreeReload GT.UploadFile = true
asyncTaskTriggersTreeReload _ = false
-- modifyAsyncTasks :: (Storage -> Storage) -> Effect Unit
-- modifyAsyncTasks f = readAsyncTasks >>= writeAsyncTasks <<< f
asyncTaskTTriggersTreeReload :: GT.AsyncTaskWithType -> Boolean
asyncTaskTTriggersTreeReload (GT.AsyncTaskWithType { typ }) = asyncTaskTriggersTreeReload typ
-- removeTaskFromList :: TaskList -> GT.AsyncTaskWithType -> TaskList
-- removeTaskFromList ts (GT.AsyncTaskWithType { task: GT.AsyncTask { id: id' } }) =
-- A.filter (\(GT.AsyncTaskWithType { task: GT.AsyncTask { id: id'' } }) -> id' /= id'') ts
src/Gargantext/Components/App/App.purs
View file @ 0f9e3220
......@@ -93,9 +93,14 @@ mainAppCpt = here.component "main" cpt where
R.useEffectOnce' $ do
void $ Sessions.load boxes.sessions
-- tasks <- GAT.useTasks boxes.reloadRoot boxes.reloadForest
R.useEffectOnce' $ do
tasksStorage <- GAT.readAsyncTasks
T.write_ tasksStorage boxes.tasks
-- NOTE Task storage is not needed with new-style notifications
-- and async workers. The tasks (with their pgoress) should be
-- pushed as soon as the worker computes the task's chunk
-- R.useEffectOnce' $ do
-- tasksStorage <- GAT.readAsyncTasks
-- T.write_ tasksStorage boxes.tasks
-- R.useEffectOnce' $ do
-- T.write (Just tasksReductor) tasks
R.useEffectOnce' $ do
......
src/Gargantext/Components/DocsTable.purs
View file @ 0f9e3220
......@@ -23,6 +23,7 @@ import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Effect.Class (liftEffect)
import Effect.Timer (setTimeout)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.App.Store as Store
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Bootstrap.Types (ComponentStatus(..), ModalSizing(..), Variant(..))
......@@ -169,15 +170,17 @@ docViewCpt = R2.hereComponent here "docView" hCpt where
liftEffect $
T.write_ true onDocumentCreationPendingBox
eTask <- DFC.create session nodeId fdata
_ <- DFC.create session nodeId fdata
handleRESTError hp errors eTask
\t -> liftEffect $ launchDocumentCreationProgress
errors
session
nodeId
t
onCreateDocumentEnd
liftEffect $ here.log "[docView] TODO onCreateDocumentEnd handler"
-- handleRESTError hp errors eTask
-- \t -> liftEffect $ launchDocumentCreationProgress
-- errors
-- session
-- nodeId
-- t
-- onCreateDocumentEnd
-- Render
pure $
......@@ -237,44 +240,44 @@ docViewCpt = R2.hereComponent here "docView" hCpt where
]
]
launchDocumentCreationProgress ::
T.Box (Array GT.FrontendError)
-> Session
-> GT.ID
-> GT.AsyncTaskWithType
-> (GT.AsyncProgress -> Effect Unit)
-> Effect Unit
launchDocumentCreationProgress errors session nodeId currentTask cbk
= void $ setTimeout 1000 $ launchAff_ $
scanDocumentCreationProgress errors session nodeId currentTask cbk
scanDocumentCreationProgress ::
T.Box (Array GT.FrontendError)
-> Session
-> GT.ID
-> GT.AsyncTaskWithType
-> (GT.AsyncProgress -> Effect Unit)
-> Aff Unit
scanDocumentCreationProgress errors session nodeId currentTask cbk = do
eTask <- DFC.createProgress session nodeId currentTask
handleRESTError (R2.herePrefix here "[scanDocumentCreationProgress]") errors eTask
\asyncProgress -> liftEffect do
let
GT.AsyncProgress { status } = asyncProgress
endingStatusList =
[ GT.IsFinished
, GT.IsKilled
, GT.IsFailure
]
hasEndingStatus s = any (eq s) endingStatusList
if (hasEndingStatus status)
then
cbk asyncProgress
else
launchDocumentCreationProgress errors session nodeId currentTask cbk
-- launchDocumentCreationProgress ::
-- T.Box (Array GT.FrontendError)
-- -> Session
-- -> GT.ID
-- -> GAT.Task
-- -> (GT.AsyncProgress -> Effect Unit)
-- -> Effect Unit
-- launchDocumentCreationProgress errors session nodeId currentTask cbk
-- = void $ setTimeout 1000 $ launchAff_ $
-- scanDocumentCreationProgress errors session nodeId currentTask cbk
-- scanDocumentCreationProgress ::
-- T.Box (Array GT.FrontendError)
-- -> Session
-- -> GT.ID
-- -> GAT.Task
-- -> (GT.AsyncProgress -> Effect Unit)
-- -> Aff Unit
-- scanDocumentCreationProgress errors session nodeId currentTask cbk = do
-- -- eTask <- DFC.createProgress session nodeId currentTask
-- handleRESTError (R2.herePrefix here "[scanDocumentCreationProgress]") errors eTask
-- \asyncProgress -> liftEffect do
-- let
-- GT.AsyncProgress { status } = asyncProgress
-- endingStatusList =
-- [ GT.IsFinished
-- , GT.IsKilled
-- , GT.IsFailure
-- ]
-- hasEndingStatus s = any (eq s) endingStatusList
-- if (hasEndingStatus status)
-- then
-- cbk asyncProgress
-- else
-- launchDocumentCreationProgress errors session nodeId currentTask cbk
---------------------------------------------------
......
src/Gargantext/Components/DocsTable/DocumentFormCreation.purs
View file @ 0f9e3220
module Gargantext.Components.DocsTable.DocumentFormCreation
( documentFormCreation
, FormData
, create, createProgress
, create
) where
import Gargantext.Prelude
......@@ -11,6 +11,7 @@ import Data.Either (Either(..))
import Data.Foldable (foldl, intercalate)
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Bootstrap.Types (ButtonVariant(..), ComponentStatus(..), Variant(..))
import Gargantext.Config.REST (AffRESTError)
......@@ -288,41 +289,15 @@ create ::
Session
-> GT.ID
-> Record FormData
-> AffRESTError GT.AsyncTaskWithType
-> AffRESTError GAT.Task
create session nodeId =
rename
>>> post session request
>=> case _ of
Left err -> pure $ Left err
Right task -> pure $ Right $ GT.AsyncTaskWithType
{ task
, typ: GT.NodeDocument
}
where
request = GR.NodeAPI GT.Node (Just nodeId)
(GT.asyncTaskTypePath GT.NodeDocument)
request = GR.NodeAPI GT.Node (Just nodeId) (GT.asyncTaskTypePath GT.NodeDocument)
rename = Record.rename
(Proxy :: Proxy "source")
(Proxy :: Proxy "sources")
createProgress ::
Session
-> GT.ID
-> GT.AsyncTaskWithType
-> AffRESTError GT.AsyncProgress
createProgress
session
nodeId
(GT.AsyncTaskWithType { task: GT.AsyncTask { id } })
=
get session request
where
request = GR.NodeAPI GT.Node (Just nodeId)
(GT.asyncTaskTypePath GT.NodeDocument <> pollParams)
pollParams = "/" <> id <> "/poll?limit1"
src/Gargantext/Components/FolderView.purs
View file @ 0f9e3220
......@@ -372,7 +372,8 @@ performAction = performAction' where
updateNode params { boxes: { errors, tasks }, nodeId: id, session } = do
eTask <- updateRequest params session id
handleRESTError (R2.herePrefix here "[updateNode]") errors eTask $ \task -> liftEffect $ do
GAT.insert id task tasks
-- GAT.insert id task tasks
here.log "[performAction] TODO: IMPLEMENT ME!"
sharePublic params p@{ boxes: { errors }, session } = traverse_ f params where
f (SubTreeOut { in: inId, out }) = do
......@@ -386,12 +387,14 @@ performAction = performAction' where
uploadFile' nodeType fileType fileFormat lang mName contents { boxes: { errors, tasks }, nodeId: id, session } selection = do
eTask <- uploadFile { contents, fileType, fileFormat, lang, id, nodeType, mName, selection, session }
handleRESTError (R2.herePrefix here "[uploadFile']") errors eTask $ \task -> liftEffect $ do
GAT.insert id task tasks
-- GAT.insert id task tasks
here.log "[performAction] TODO: IMPLEMENT ME!"
uploadArbitraryFile' fileFormat mName blob { boxes: { errors, tasks }, nodeId: id, session } = do
eTask <- uploadArbitraryFile session id { blob, fileFormat, mName }
handleRESTError (R2.herePrefix here "[uploadArbitraryFile']") errors eTask $ \task -> liftEffect $ do
GAT.insert id task tasks
-- GAT.insert id task tasks
here.log "[performAction] TODO: IMPLEMENT ME!"
moveNode params p@{ boxes: { errors }, session } = traverse_ f params where
f (SubTreeOut { in: in', out }) = do
......
src/Gargantext/Components/Forest/Tree.purs
View file @ 0f9e3220
......@@ -30,7 +30,7 @@ import Gargantext.Components.Forest.Tree.Node.Action.WriteNodesDocuments (docume
import Gargantext.Components.Forest.Tree.Node.Tools.FTree (FTree, LNode(..), NTree(..), fTreeID)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree.Types (SubTreeOut(..))
import Gargantext.Components.Notifications as Notifications
import Gargantext.Components.Notifications.Types as NotificationsT
import Gargantext.Components.Notifications.Types as NT
import Gargantext.Config.REST (AffRESTError, logRESTError)
import Gargantext.Config.Utils (handleRESTError)
import Gargantext.Ends (Frontends)
......@@ -181,12 +181,17 @@ treeCpt = here.component "tree" cpt where
-- rendered via 'childLoader'. However, we still need a hook
-- here, so that if e.g. the tree is pinned, it becomes its own
-- root and we want to see notifications of it as well.
let cb _ = do
here.log2 "[tree] callback!" root
-- The modal window has some problems closing when we refresh too early. This is a HACK
void $ setTimeout 400 $ T2.reload reload
let action = NotificationsT.InsertCallback (NotificationsT.UpdateTree root) ("tree-" <> show root) cb
let cb n = do
case n of
NT.NUpdateTree _ -> do
here.log2 "[tree] update tree" root
-- The modal window has some problems closing when we refresh too early. This is a HACK
void $ setTimeout 400 $ T2.reload reload
NT.NUpdateWorkerProgress ji jl -> do
here.log3 "[tree] update worker progress" ji jl
_ -> pure unit
ws <- T.read boxes.wsNotification
let action = NT.InsertCallback (NT.UpdateTree root) ("tree-" <> show root) cb
Notifications.performAction ws action
R.useEffect' do
......@@ -337,12 +342,15 @@ childLoaderCpt = R2.hereComponent here "childLoader" hCpt where
boxes <- Store.use
R.useEffectOnce' $ do
let cb _ = do
here.log2 "[childLoader] callback!" p.id
-- The modal window has some problems closing when we refresh too early. This is a HACK
void $ setTimeout 400 $ T2.reload reload
let action = NotificationsT.InsertCallback (NotificationsT.UpdateTree p.id) ("tree-" <> show p.id) cb
let cb n = do
case n of
NT.NUpdateTree _nId -> do
here.log2 "[childLoader] update tree" p.id
-- The modal window has some problems closing when we refresh too early. This is a HACK
void $ setTimeout 400 $ T2.reload reload
_ -> pure unit
ws <- T.read boxes.wsNotification
let action = NT.InsertCallback (NT.UpdateTree p.id) ("tree-" <> show p.id) cb
Notifications.performAction ws action
-- Render
......@@ -384,7 +392,8 @@ doSearch task { boxes: { tasks }, tree: NTree (LNode {id}) _ } = liftEffect $ do
updateNode params p@{ boxes: { errors, tasks }, session, tree: (NTree (LNode {id}) _) } = do
eTask <- updateRequest params session id
handleRESTError (R2.herePrefix here "[updateNode]") errors eTask $ \task -> liftEffect $ do
GAT.insert id task tasks
-- GAT.insert id task tasks
here.log "[updateNode] TODO: IMPLEMENT ME!"
closeBox p
renameNode name p@{ boxes: { errors }, session, tree: (NTree (LNode {id}) _) } = do
......@@ -412,19 +421,22 @@ addNode' name nodeType p@{ boxes: { errors, forestOpen }, session, tree: (NTree
uploadFile' nodeType fileType fileFormat lang mName contents p@{ boxes: { errors, tasks }, session, tree: (NTree (LNode { id }) _) } selection = do
eTask <- uploadFile { contents, fileFormat, fileType, id, lang, mName, nodeType, selection, session }
handleRESTError (R2.herePrefix here "[uploadFile']") errors eTask $ \task -> liftEffect $ do
GAT.insert id task tasks
-- GAT.insert id task tasks
here.log "[uplaodFile'] TODO: IMPLEMENT ME!"
here.log2 "[uploadFile'] UploadFile, uploaded, task:" task
closeBox p
uploadArbitraryFile' fileFormat mName blob { boxes: { errors, tasks }, session, tree: (NTree (LNode { id }) _) } = do
eTask <- uploadArbitraryFile session id { blob, fileFormat, mName }
handleRESTError (R2.herePrefix here "[uploadArbitraryFile']") errors eTask $ \task -> liftEffect $ do
GAT.insert id task tasks
-- GAT.insert id task tasks
here.log "[uplaodArbitraryFile'] TODO: IMPLEMENT ME!"
uploadFrameCalc' lang { boxes: { errors, tasks }, session, tree: (NTree (LNode { id }) _) } selection = do
eTask <- uploadFrameCalc session id lang selection
handleRESTError (R2.herePrefix here "[uploadFrameCalc']") errors eTask $ \task -> liftEffect $ do
GAT.insert id task tasks
-- GAT.insert id task tasks
here.log "[uplaodFrameCalc'] TODO: IMPLEMENT ME!"
moveNode params p@{ boxes: { errors, forestOpen }, session } = traverse_ f params where
f (SubTreeOut { in: in', out }) = do
......@@ -448,7 +460,8 @@ linkNode nodeType params p@{ boxes: { errors }, session } = traverse_ f params w
documentsFromWriteNodes params p@{ boxes: { errors, tasks }, session, tree: NTree (LNode { id }) _ } = do
eTask <- documentsFromWriteNodesReq session params
handleRESTError (R2.herePrefix here "[documentsFromWriteNodes]") errors eTask $ \task -> liftEffect $ do
GAT.insert id task tasks
-- GAT.insert id task tasks
here.log "[documentsFromWriteNodes] TODO: IMPLEMENT ME!"
pure unit
refreshTree p
......
src/Gargantext/Components/Forest/Tree/Node.purs
View file @ 0f9e3220
......@@ -14,6 +14,7 @@ import Data.String.Regex as Regex
import Effect (Effect)
import Effect.Aff (Aff, launchAff)
import Effect.Class (liftEffect)
import Effect.Timer (setTimeout)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.App.Store as AppStore
import Gargantext.Components.Bootstrap as B
......@@ -28,6 +29,8 @@ import Gargantext.Components.Forest.Tree.Node.Tools.Sync (nodeActionsGraph, node
import Gargantext.Components.GraphExplorer.API as GraphAPI
import Gargantext.Components.Lang (Lang(EN))
import Gargantext.Components.Nodes.Corpus.Types (CorpusData)
import Gargantext.Components.Notifications as Notifications
import Gargantext.Components.Notifications.Types as NT
import Gargantext.Context.Progress (asyncContext, asyncProgress)
import Gargantext.Ends (Frontends, url)
import Gargantext.Hooks.Loader (useLoader)
......@@ -174,27 +177,29 @@ nodeSpanCpt = here.component "nodeSpan" cpt
onTaskFinish ::
GT.NodeID
-> GT.AsyncTaskWithType
-> GAT.Task
-> Unit
-> Effect Unit
onTaskFinish id' t _ = do
GAT.finish id' t boxes.tasks
if GAT.asyncTaskTTriggersAppReload t then do
here.log2 "reloading root for task" t
T2.reload boxes.reloadRoot
else do
if GAT.asyncTaskTTriggersTreeReload t then do
here.log2 "reloading tree for task" t
T2.reload reload
else do
here.log2 "task doesn't trigger a tree reload" t
pure unit
if GAT.asyncTaskTTriggersMainPageReload t then do
here.log2 "reloading main page for task" t
T2.reload boxes.reloadMainPage
else do
here.log2 "task doesn't trigger a main page reload" t
pure unit
-- TODO App reload!
here.log "[onTaskFinish] TODO APP/TREE/MAIN PAGE RELOAD"
-- if GAT.asyncTaskTTriggersAppReload t then do
-- here.log2 "reloading root for task" t
-- T2.reload boxes.reloadRoot
-- else do
-- if GAT.asyncTaskTTriggersTreeReload t then do
-- here.log2 "reloading tree for task" t
-- T2.reload reload
-- else do
-- here.log2 "task doesn't trigger a tree reload" t
-- pure unit
-- if GAT.asyncTaskTTriggersMainPageReload t then do
-- here.log2 "reloading main page for task" t
-- T2.reload boxes.reloadMainPage
-- else do
-- here.log2 "task doesn't trigger a main page reload" t
-- pure unit
-- snd tasks $ GAT.Finish id' t
-- mT <- T.read tasks
-- case mT of
......@@ -230,6 +235,26 @@ nodeSpanCpt = here.component "nodeSpan" cpt
else
H.div {} []
-- Notifications
R.useEffectOnce' $ do
let cb n = do
case n of
NT.NUpdateTree _ -> do
here.log2 "[nodeSpan] update tree" props.id
-- The modal window has some problems closing when we refresh too early. This is a HACK
void $ setTimeout 400 $ T2.reload reload
NT.NUpdateWorkerProgress ji atl -> do
-- TODO Fire this only once!
-- here.log3 "[nodeSpan] update job progress" ji atl
if GT.asyncTaskLogIsFinished atl
then pure unit
else
GAT.insert props.id ji boxes.tasks
_ -> pure unit
ws <- T.read boxes.wsNotification
let action = NT.InsertCallback (NT.UpdateTree props.id) ("node-span-" <> show props.id) cb
Notifications.performAction ws action
-- Render
pure $
......
src/Gargantext/Components/Forest/Tree/Node/Action/Add.purs
View file @ 0f9e3220
......@@ -8,6 +8,7 @@ import Data.Newtype (class Newtype)
import Data.String (Pattern(..), indexOf)
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Settings (SettingsBox(..), settingsBox)
import Gargantext.Components.Forest.Tree.Node.Tools as Tools
......@@ -39,10 +40,9 @@ addNode session parentId = post session $ GR.NodeAPI GT.Node (Just parentId) ""
addNodeAsync :: Session
-> GT.ID
-> AddNodeValue
-> AffRESTError GT.AsyncTaskWithType
-> AffRESTError GAT.Task
addNodeAsync session parentId q = do
eTask :: Either RESTError GT.AsyncTask <- post session p q
pure $ (\task -> GT.AsyncTaskWithType { task, typ: GT.AddNode }) <$> eTask
post session p q
where
p = GR.NodeAPI GT.Node (Just parentId) (GT.asyncTaskTypePath GT.AddNode)
......
src/Gargantext/Components/Forest/Tree/Node/Action/Link.purs
View file @ 0f9e3220
......@@ -4,6 +4,7 @@ import Gargantext.Prelude
import Data.Either (Either)
import Data.Maybe (Maybe(..))
import Gargantext.AsyncTasks as GAT
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.Tools as Tools
......@@ -20,11 +21,11 @@ import Toestand as T
here :: R2.Here
here = R2.here "Gargantext.Components.Forest.Tree.Node.Action.Link"
linkNodeReq :: Session -> Maybe GT.NodeType -> GT.ID -> GT.ID -> AffRESTError GT.AsyncTaskWithType
linkNodeReq :: Session -> Maybe GT.NodeType -> GT.ID -> GT.ID -> AffRESTError GAT.Task
linkNodeReq session nt fromId toId = do
eTask :: Either RESTError GT.AsyncTask <- post session (NodeAPI GT.Node (Just fromId) "update")
(LinkNodeReq { nodeType: linkNodeType nt, id: toId })
pure $ (\task -> GT.AsyncTaskWithType { task, typ: GT.UpdateNode }) <$> eTask
post session (NodeAPI GT.Node (Just fromId) "update")
(LinkNodeReq { nodeType: linkNodeType nt, id: toId })
linkNodeType :: Maybe GT.NodeType -> GT.NodeType
linkNodeType (Just GT.Corpus) = GT.Annuaire
......
src/Gargantext/Components/Forest/Tree/Node/Action/Search.purs
View file @ 0f9e3220
......@@ -3,6 +3,7 @@ module Gargantext.Components.Forest.Tree.Node.Action.Search where
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Effect.Aff (Aff, launchAff)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.App.Store as Store
import Gargantext.Components.Forest.Tree.Node.Action.Search.SearchBar (searchBar)
import Gargantext.Components.Forest.Tree.Node.Action.Search.SearchField (defaultSearch)
......@@ -68,7 +69,7 @@ actionSearchWithLangsCpt = here.component "actionSearchWithLangs" cpt
]
where
searchOn :: (Action -> Aff Unit)
-> GT.AsyncTaskWithType
-> GAT.Task
-> Effect Unit
searchOn dispatch' task = do
_ <- launchAff $ dispatch' (DoSearch task)
......
src/Gargantext/Components/Forest/Tree/Node/Action/Search/SearchBar.purs
View file @ 0f9e3220
......@@ -4,6 +4,7 @@ module Gargantext.Components.Forest.Tree.Node.Action.Search.SearchBar
) where
import Effect (Effect)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Forest.Tree.Node.Action.Search.SearchField (searchField)
import Gargantext.Components.Forest.Tree.Node.Action.Search.Types (Search, allDatabases)
import Gargantext.Components.Lang (Lang)
......@@ -21,7 +22,7 @@ here = R2.here "Gargantext.Components.Forest.Tree.Node.Action.Search.SearchBar"
type Props = ( errors :: T.Box (Array FrontendError)
, langs :: Array Lang
, onSearch :: GT.AsyncTaskWithType -> Effect Unit
, onSearch :: GAT.Task -> Effect Unit
, search :: T.Box Search
, session :: Session
)
......
src/Gargantext/Components/Forest/Tree/Node/Action/Search/SearchField.purs
View file @ 0f9e3220
......@@ -13,6 +13,7 @@ import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Aff (launchAff_)
import Effect.Class (liftEffect)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Forest.Tree.Node.Action.Search.Frame (searchIframes)
import Gargantext.Components.Forest.Tree.Node.Action.Search.Types (DataField(..), Database(..), IMT_org(..), Org(..), SearchQuery(..), allOrgs, dataFields, defaultSearchQuery, doc, performSearch, datafield2database, Search, dbFromInputValue, dbToInputValue)
import Gargantext.Components.GraphQL.Endpoints (getIMTSchools, getUser)
......@@ -53,7 +54,7 @@ type Props =
, errors :: T.Box (Array FrontendError)
, langs :: Array Lang
-- State hook for a search, how we get data in and out
, onSearch :: GT.AsyncTaskWithType -> Effect Unit
, onSearch :: GAT.Task -> Effect Unit
, search :: T.Box Search
, session :: Session
)
......@@ -645,7 +646,7 @@ searchInputCpt = here.component "searchInput" cpt
type SubmitButtonProps =
( errors :: T.Box (Array FrontendError)
, onSearch :: GT.AsyncTaskWithType -> Effect Unit
, onSearch :: GAT.Task -> Effect Unit
, search :: T.Box Search
, selection :: T.Box ListSelection.Selection
, session :: Session
......@@ -677,13 +678,13 @@ submitButtonComponent = here.component "submitButton" cpt
type TriggerSearch =
( errors :: T.Box (Array FrontendError)
, onSearch :: GT.AsyncTaskWithType -> Effect Unit
, onSearch :: GAT.Task -> Effect Unit
, search :: T.Box Search
, selection :: T.Box ListSelection.Selection
, session :: Session
)
triggerSearch :: { onSearch :: (GT.AsyncTaskWithType -> Effect Unit)
triggerSearch :: { onSearch :: (GAT.Task -> Effect Unit)
, errors :: T.Box (Array FrontendError)
, session :: Session
, selection :: ListSelection.Selection
......
src/Gargantext/Components/Forest/Tree/Node/Action/Search/Types.purs
View file @ 0f9e3220
......@@ -12,6 +12,7 @@ import Data.Set (Set)
import Data.Set as Set
import Data.Tuple (Tuple)
import Data.Tuple.Nested ((/\))
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.GraphQL.IMT as GQLIMT
import Gargantext.Components.Lang (Lang)
import Gargantext.Components.ListSelection.Types as ListSelection
......@@ -339,9 +340,10 @@ defaultSearchQuery = SearchQuery
, selection : ListSelection.NoList -- MyListsFirst
}
performSearch :: Session -> Int -> SearchQuery -> AffRESTError GT.AsyncTaskWithType
performSearch :: Session -> Int -> SearchQuery -> AffRESTError GAT.Task
performSearch session nodeId q = do
eTask :: Either RESTError GT.AsyncTask <- post session p q
pure $ (\task -> GT.AsyncTaskWithType { task, typ: GT.Query }) <$> eTask
post session p q
-- eTask :: Either RESTError GT.AsyncTask <- post session p q
-- pure $ (\task -> GAT.Task { task, typ: GT.Query }) <$> eTask
where
p = GR.NodeAPI GT.Corpus (Just nodeId) $ GT.asyncTaskTypePath GT.Query
src/Gargantext/Components/Forest/Tree/Node/Action/Types.purs
View file @ 0f9e3220
......@@ -2,6 +2,7 @@ module Gargantext.Components.Forest.Tree.Node.Action.Types where
import Data.Generic.Rep (class Generic)
import Data.Maybe (Maybe)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Forest.Tree.Node.Action.Contact.Types (AddContactParams)
import Gargantext.Components.Forest.Tree.Node.Action.Update.Types (UpdateNodeParams)
import Gargantext.Components.Forest.Tree.Node.Action.Upload.Types (FileFormat, FileType, UploadFileBlob)
......@@ -15,7 +16,7 @@ data Action = AddNode String GT.NodeType
| DeleteNode GT.NodeType
| RenameNode String
| UpdateNode UpdateNodeParams
| DoSearch GT.AsyncTaskWithType
| DoSearch GAT.Task
| UploadFile GT.NodeType FileType FileFormat Lang (Maybe String) String Selection
| UploadArbitraryFile FileFormat (Maybe String) UploadFileBlob
| UploadFrameCalc Lang Selection
......
src/Gargantext/Components/Forest/Tree/Node/Action/Update.purs
View file @ 0f9e3220
......@@ -9,6 +9,7 @@ import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Effect.Aff (Aff, launchAff_)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Bootstrap.Types (ComponentStatus(..))
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Tools as Tools
......@@ -29,14 +30,11 @@ import Toestand as T
here :: R2.Here
here = R2.here "Gargantext.Components.Forest.Tree.Node.Action.Update"
updateRequest :: UpdateNodeParams -> Session -> ID -> AffRESTError GT.AsyncTaskWithType
updateRequest :: UpdateNodeParams -> Session -> ID -> AffRESTError GAT.Task
updateRequest updateNodeParams session nodeId = do
eTask :: Either RESTError GT.AsyncTask <- post session p updateNodeParams
case eTask of
Left err -> pure $ Left err
Right task -> pure $ Right $ GT.AsyncTaskWithType { task, typ: GT.UpdateNode }
where
p = GR.NodeAPI GT.Node (Just nodeId) "update"
post session p updateNodeParams
where
p = GR.NodeAPI GT.Node (Just nodeId) "update"
----------------------------------------------------------------------
type UpdateProps =
......
src/Gargantext/Components/Forest/Tree/Node/Action/Upload.purs
View file @ 0f9e3220
......@@ -14,6 +14,7 @@ import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Effect.Aff (Aff, launchAff)
import Effect.Class (liftEffect)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Bootstrap.Types (ComponentStatus(..))
import Gargantext.Components.Forest.Tree.Node.Action (Props)
......@@ -554,21 +555,10 @@ uploadFile :: { contents :: String
, mName :: Maybe String
, selection :: ListSelection.Selection
, session :: Session }
-> AffRESTError GT.AsyncTaskWithType
{-
uploadFile session NodeList id JSON { mName, contents } = do
let url = GR.NodeAPI NodeList (Just id) $ GT.asyncTaskTypePath GT.ListUpload
-- { input: { data: ..., filetype: "JSON", name: "..." } }
let body = { input: { data: contents
, filetype: "JSON"
, name: fromMaybe "" mName } }
task <- post session url body
pure $ GT.AsyncTaskWithType { task, typ: GT.Form }
-}
-> AffRESTError GAT.Task
uploadFile { contents, fileFormat, lang, fileType, id, nodeType, mName, selection, session } = do
-- contents <- readAsText blob
eTask :: Either RESTError GT.AsyncTask <- postWwwUrlencoded session p body
pure $ (\task -> GT.AsyncTaskWithType { task, typ }) <$> eTask
postWwwUrlencoded session p body
--postMultipartFormData session p fileContents
where
bodyParams = [ Tuple "_wf_data" (Just contents)
......@@ -603,7 +593,7 @@ uploadFile { contents, fileFormat, lang, fileType, id, nodeType, mName, selectio
uploadArbitraryFile :: Session
-> ID
-> {blob :: UploadFileBlob, fileFormat :: FileFormat, mName :: Maybe String}
-> AffRESTError GT.AsyncTaskWithType
-> AffRESTError GAT.Task
uploadArbitraryFile session id { fileFormat, mName, blob: UploadFileBlob blob } = do
contents <- readAsDataURL blob
uploadArbitraryData session id fileFormat mName contents
......@@ -613,12 +603,11 @@ uploadArbitraryData :: Session
-> FileFormat
-> Maybe String
-> String
-> AffRESTError GT.AsyncTaskWithType
-> AffRESTError GAT.Task
uploadArbitraryData session id fileFormat mName contents' = do
let re = fromRight' (\_ -> unsafeCrashWith "Unexpected Left") $ DSR.regex "data:.*;base64," DSRF.noFlags
contents = DSR.replace re "" contents'
eTask :: Either RESTError GT.AsyncTask <- postWwwUrlencoded session p (bodyParams contents)
pure $ (\task -> GT.AsyncTaskWithType { task, typ: GT.UploadFile }) <$> eTask
postWwwUrlencoded session p (bodyParams contents)
where
p = GR.NodeAPI GT.Node (Just id) $ GT.asyncTaskTypePath GT.UploadFile
......@@ -818,10 +807,9 @@ uploadFrameCalc :: Session
-> ID
-> Lang
-> ListSelection.Selection
-> AffRESTError GT.AsyncTaskWithType
-> AffRESTError GAT.Task
uploadFrameCalc session id lang selection = do
let p = GR.NodeAPI GT.Node (Just id) $ GT.asyncTaskTypePath GT.UploadFrameCalc
eTask <- post session p { _wf_lang: Just lang
, _wf_selection: selection }
pure $ (\task -> GT.AsyncTaskWithType { task, typ: GT.UploadFrameCalc }) <$> eTask
post session p { _wf_lang: Just lang
, _wf_selection: selection }
src/Gargantext/Components/Forest/Tree/Node/Action/WriteNodesDocuments.purs
View file @ 0f9e3220
......@@ -4,6 +4,7 @@ import Data.Either (Either)
import Data.Maybe (Maybe(..))
import Data.Tuple.Nested ((/\))
import Effect.Aff (Aff)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.Bootstrap as B
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
import Gargantext.Components.Forest.Tree.Node.Action.Utils (loadLanguages)
......@@ -152,8 +153,6 @@ type Params =
, selection :: ListSelection.Selection
)
documentsFromWriteNodesReq :: Session -> Record Params -> AffRESTError GT.AsyncTaskWithType
documentsFromWriteNodesReq :: Session -> Record Params -> AffRESTError GAT.Task
documentsFromWriteNodesReq session params@{ id } = do
eTask :: Either RESTError GT.AsyncTask <-
post session (NodeAPI GT.Node (Just id) "documents-from-write-nodes") params
pure $ (\task -> GT.AsyncTaskWithType { task, typ: GT.UpdateNode }) <$> eTask
post session (NodeAPI GT.Node (Just id) "documents-from-write-nodes") params
src/Gargantext/Components/Forest/Tree/Node/Tools/FTree.purs
View file @ 0f9e3220
module Gargantext.Components.Forest.Tree.Node.Tools.FTree where
import Data.Generic.Rep (class Generic)
import Data.Eq.Generic (genericEq)
import Data.Generic.Rep (class Generic)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Simple.JSON as JSON
import Gargantext.AsyncTasks as GAT
import Gargantext.Prelude
import Gargantext.Types as GT
import Simple.JSON as JSON
-----------------------------------------------------------------------
type ID = Int
......@@ -26,7 +25,7 @@ instance Eq a => Eq (NTree a) where
eq (NTree a1 as1) (NTree a2 as2) = (eq a1 a2) && (eq as1 as2)
type Tree = { tree :: FTree
, tasks :: Array GT.AsyncTaskWithType
, tasks :: Array GAT.Task
}
fTreeID :: FTree -> ID
......
src/Gargantext/Components/Forest/Tree/Node/Tools/ProgressBar.purs deleted 100644 → 0
View file @ 27d6aa0f
module Gargantext.Components.Forest.Tree.Node.Tools.ProgressBar where
import Data.Int (floor)
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Effect.Aff (launchAff_)
import Effect.Class (liftEffect)
import Effect.Timer (clearInterval, setInterval)
import Gargantext.Components.App.Store as AppStore
import Gargantext.Config.REST (AffRESTError)
import Gargantext.Config.Utils (handleErrorInAsyncProgress, handleRESTError)
import Gargantext.Prelude
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, get)
import Gargantext.Types as GT
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Reactix.DOM.HTML as H
import Record.Extra as RX
import Toestand as T
here :: R2.Here
here = R2.here "Gargantext.Components.Forest.Tree.Node.Tools.ProgressBar"
-- data BarType = Bar | Pie
-- type Props = (
-- asyncTask :: GT.AsyncTaskWithType
-- , barType :: BarType
-- , nodeId :: GT.ID
-- , onFinish :: Unit -> Effect Unit
-- , session :: Session
-- )
-- asyncProgressBar :: R2.Component Props
-- asyncProgressBar = R.createElement asyncProgressBarCpt
-- asyncProgressBarCpt :: R.Component Props
-- asyncProgressBarCpt = R2.hereComponent here "asyncProgressBar" hCpt where
-- hCpt hp props@{ asyncTask: (GT.AsyncTaskWithType {task: GT.AsyncTask {id}})
-- , barType
-- , onFinish
-- } _ = do
-- { errors } <- AppStore.use
-- progress <- T.useBox 0.0
-- intervalIdRef <- R.useRef Nothing
-- R.useEffectOnce' $ do
-- intervalId <- setInterval 1000 $ do
-- launchAff_ $ do
-- let rdata = (RX.pick props :: Record QueryProgressData)
-- eAsyncProgress <- queryProgress rdata
-- handleRESTError hp errors eAsyncProgress $
-- \asyncProgress -> liftEffect $ do
-- let GT.AsyncProgress { status } = asyncProgress
-- T.write_ (min 100.0 $ GT.progressPercent asyncProgress) progress
-- if (status == GT.IsFinished) || (status == GT.IsKilled) || (status == GT.IsFailure) then do
-- _ <- case R.readRef intervalIdRef of
-- Nothing -> pure unit
-- Just iid -> clearInterval iid
-- handleErrorInAsyncProgress errors asyncProgress
-- onFinish unit
-- else
-- pure unit
-- R.setRef intervalIdRef $ Just intervalId
-- pure unit
-- pure $ progressIndicator { barType, label: id, progress }
--------------------------------------------------------------
-- type ProgressIndicatorProps =
-- ( barType :: BarType
-- , label :: String
-- , progress :: T.Box Number
-- )
-- progressIndicator :: Record ProgressIndicatorProps -> R.Element
-- progressIndicator p = R.createElement progressIndicatorCpt p []
-- progressIndicatorCpt :: R.Component ProgressIndicatorProps
-- progressIndicatorCpt = here.component "progressIndicator" cpt
-- where
-- cpt { barType, progress } _ = do
-- progress' <- T.useLive T.unequal progress
-- let progressInt = floor progress'
-- case barType of
-- Bar -> pure $
-- H.div { className: "progress" }
-- [ H.div { className: "progress-bar"
-- , role: "progressbar"
-- , style: { width: (show $ progressInt) <> "%" }
-- } [ ]
-- ]
-- Pie -> pure $
-- H.div { className: "progress-pie" }
-- [ H.div { className: "progress-pie-segment"
-- , style: { "--over50": if progressInt < 50 then "0" else "1"
-- , "--value": show $ progressInt } } [
-- ]
-- ]
--------------------------------------------------------------
type QueryProgressData =
( asyncTask :: GT.AsyncTaskWithType
, nodeId :: GT.ID
, session :: Session
)
queryProgress :: Record QueryProgressData -> AffRESTError GT.AsyncProgress
queryProgress { asyncTask: GT.AsyncTaskWithType { task: GT.AsyncTask {id}
, typ
}
, nodeId
, session
} = get session (p typ)
where
-- TODO refactor path
p GT.ListCSVUpload = NodeAPI GT.NodeList (Just nodeId) $ GT.asyncTaskTypePath GT.ListCSVUpload <> id <> "/poll?limit=1"
p GT.UpdateNgramsCharts = NodeAPI GT.Node (Just nodeId) $ path <> id <> "/poll?limit=1"
p GT.UpdateNode = NodeAPI GT.Node (Just nodeId) $ path <> id <> "/poll?limit=1"
p _ = NodeAPI GT.Corpus (Just nodeId) $ path <> id <> "/poll?limit=1"
path = GT.asyncTaskTypePath typ
-- TODO wait route: take the result if failure then message
src/Gargantext/Components/GraphExplorer/API.purs
View file @ 0f9e3220
......@@ -3,6 +3,7 @@ module Gargantext.Components.GraphExplorer.API where
import Gargantext.Prelude
import Data.Maybe (Maybe(..))
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.GraphExplorer.Types as GET
import Gargantext.Config.REST (AffRESTError)
import Gargantext.Core.NgramsTable.Types as CNT
......@@ -23,10 +24,9 @@ type GraphAsyncUpdateParams =
, version :: CNT.Version
)
graphAsyncUpdate :: Record GraphAsyncUpdateParams -> AffRESTError GT.AsyncTaskWithType
graphAsyncUpdate :: Record GraphAsyncUpdateParams -> AffRESTError GAT.Task
graphAsyncUpdate { graphId, listId, nodes, session, termList, version } = do
eTask <- post session p q
pure $ (\task -> GT.AsyncTaskWithType { task, typ: GT.GraphRecompute }) <$> eTask
post session p q
where
p = GR.GraphAPI graphId $ GT.asyncTaskTypePath GT.GraphRecompute
q = { listId
......@@ -40,24 +40,13 @@ type GraphAsyncRecomputeParams =
, session :: Session
)
graphAsyncRecompute :: Record GraphAsyncRecomputeParams -> AffRESTError GT.AsyncTaskWithType
graphAsyncRecompute :: Record GraphAsyncRecomputeParams -> AffRESTError GAT.Task
graphAsyncRecompute { graphId, session } = do
eTask <- post session p q
pure $ (\task -> GT.AsyncTaskWithType { task, typ: GT.GraphRecompute }) <$> eTask
post session p q
where
p = GR.GraphAPI graphId $ GT.asyncTaskTypePath GT.GraphRecompute
q = {}
type QueryProgressParams =
( graphId :: Int
, session :: Session
, taskId :: String
)
queryProgress :: Record QueryProgressParams -> AffRESTError GT.AsyncProgress
queryProgress { graphId, session, taskId } = do
get session $ GR.GraphAPI graphId $ "async/" <> taskId <> "/poll"
type GraphVersions =
( gv_graph :: Maybe Int
, gv_repo :: Int
......
src/Gargantext/Components/GraphQL/Task.purs deleted 100644 → 0
View file @ 27d6aa0f
module Gargantext.Components.GraphQL.Task where
import Gargantext.Types (AsyncTaskID)
type AsyncTaskStatus = String
type AsyncTaskType = String
type AsyncTask =
{ id :: AsyncTaskID
, status :: AsyncTaskStatus}
type AsyncTaskWithType =
{ task :: AsyncTask
, typ :: AsyncTaskType }
src/Gargantext/Components/Login/PasswordForm.purs
View file @ 0f9e3220
......@@ -19,6 +19,7 @@ import Gargantext.Hooks.FormValidation (VForm, useFormValidation)
import Gargantext.Hooks.FormValidation.Unboxed as FV
import Gargantext.Hooks.StateRecord (useStateRecord)
import Gargantext.Sessions (postForgotPasswordRequest)
import Gargantext.Types as GT
import Gargantext.Utils ((?))
import Gargantext.Utils.Reactix as R2
import Reactix as R
......@@ -195,5 +196,5 @@ formValidation r = foldl append mempty rules
sendEmail ::
Backend
-> FormData
-> Aff (Either String { status :: String })
-> Aff (Either String GT.WorkerTask)
sendEmail backend { email } = postForgotPasswordRequest backend email
src/Gargantext/Components/Notifications.purs
View file @ 0f9e3220
......@@ -51,16 +51,19 @@ removeCallback (State state@{ callbacks }) topic uuid =
-- | Execute all callbacks for a given Notification
callNotification :: State -> Notification -> Effect Unit
callNotification (State { callbacks }) (Notification topic message) = do
callNotification (State { callbacks }) n = do
-- here.log2 "[callTopic] topic" topic
-- here.log2 "[callTopic] callbacks" (HM.values callbacks)
-- here.log2 "[callTopic] topicCallbacks" (HM.values topicCallbacks)
_ <- for (HM.values topicCallbacks) $ \cb -> do
cb message
pure unit
let topics = notificationTopics n
void $ for topics $ \topic -> do
void $ for (HM.values $ topicCallbacks topic) $ \cb -> do
cb n
where
topicCallbacks :: CallbacksHM
topicCallbacks = fromMaybe HM.empty $ HM.lookup topic callbacks
topicCallbacks :: Topic -> CallbacksHM
topicCallbacks topic = fromMaybe HM.empty $ HM.lookup topic callbacks
......@@ -174,7 +177,7 @@ connect ws@(WSNotification ws') url session = do
case parsed of
Left err -> do
here.log2 "[connect] Can't parse message" err
Right n@(Notification topic _message) -> do
Right n -> do
-- here.log2 "[connect] notification" topic
performAction ws (Call n)
-- Right parsed' -> do
......
src/Gargantext/Components/Notifications/Types.purs
View file @ 0f9e3220
......@@ -37,7 +37,7 @@ type NodeId = Int
type UUID = String
data Topic =
UpdateJobProgress GT.AsyncTaskID
UpdateWorkerProgress GT.WorkerTask
| UpdateTree NodeId
derive instance Generic Topic _
instance Eq Topic where eq = genericEq
......@@ -48,16 +48,16 @@ instance JSON.ReadForeign Topic where
readImpl f = do
{ type: type_ } <- JSON.readImpl f :: F.F { type :: String }
case type_ of
"update_job_progress" -> do
{ j_id } <- JSON.readImpl f :: F.F { j_id :: GT.AsyncTaskID }
pure $ UpdateJobProgress j_id
"update_worker_progress" -> do
{ ji } <- JSON.readImpl f :: F.F { ji :: GT.WorkerTask }
pure $ UpdateWorkerProgress ji
"update_tree" -> do
{ node_id } <- JSON.readImpl f :: F.F { node_id :: NodeId }
pure $ UpdateTree node_id
s -> F.fail $ F.ErrorAtProperty "type" $ F.ForeignError $ "unknown Topic type: " <> s
instance JSON.WriteForeign Topic where
writeImpl (UpdateJobProgress j_id) = JSON.writeImpl { "type": "update_job_progress"
, j_id }
writeImpl (UpdateWorkerProgress ji) = JSON.writeImpl { "type": "update_worker_progress"
, ji }
writeImpl (UpdateTree node_id) = JSON.writeImpl { "type": "update_tree"
, node_id }
......@@ -78,42 +78,36 @@ instance JSON.WriteForeign WSRequest where
writeImpl WSDeauthorize = JSON.writeImpl { request: "deauthorize" }
data Message =
-- TODO
-- MJobProgress GT.AsyncProgress
-- MJobProgress GT.AsyncTaskLog
MJobProgress GT.AsyncProgress
| MEmpty
derive instance Generic Message _
instance JSON.ReadForeign Message where
readImpl f = do
{ type: type_ } <- JSON.readImpl f :: F.F { type :: String }
case type_ of
"MJobProgress" -> do
-- TODO
-- { job_progress } <- JSON.readImpl f :: F.F { job_progress :: GT.AsyncProgress }
-- { job_progress } <- JSON.readImpl f :: F.F { job_progress :: GT.AsyncTaskLog }
{ job_status } <- JSON.readImpl f :: F.F { job_status :: GT.AsyncProgress }
pure $ MJobProgress job_status
"MEmpty" -> do
pure MEmpty
s -> do F.fail $ F.ErrorAtProperty "type" $ F.ForeignError $ "unknown Message type: " <> s
data Notification =
Notification Topic Message
NUpdateWorkerProgress GT.WorkerTask GT.AsyncTaskLog
| NUpdateTree NodeId
derive instance Generic Notification _
instance JSON.ReadForeign Notification where
readImpl f = do
let str = JSON.read_ f :: Maybe String
case str of
Nothing -> do
{ notification } <- JSON.readImpl f :: F.F { notification :: { topic :: Topic, message :: Message } }
pure $ Notification notification.topic notification.message
Just s -> F.fail $ F.ErrorAtProperty "_" $ F.ForeignError $ "unkown string: " <> s
type Callback = Message -> Effect Unit
{ type: type_ } <- JSON.readImpl f :: F.F { type :: String }
case type_ of
"update_worker_progress" -> do
{ job_info, job_log } <- JSON.readImpl f :: F.F { job_info :: GT.WorkerTask, job_log :: GT.AsyncTaskLog }
pure $ NUpdateWorkerProgress job_info job_log
"update_tree" -> do
{ node_id } <- JSON.readImpl f :: F.F { node_id :: NodeId }
pure $ NUpdateTree node_id
s -> F.fail $ F.ErrorAtProperty "type" $ F.ForeignError $ "unkown type: " <> s
notificationTopics :: Notification -> Array Topic
notificationTopics (NUpdateWorkerProgress workerTask@(GT.WorkerTask { node_id }) _) =
[ UpdateWorkerProgress workerTask ] <> updateTree
where
-- when receiving a worker progress notification, we are also
-- interested in 'update tree' subscriptions, because there might
-- be a new job that we didn't subscribe to
updateTree = case node_id of
Nothing -> []
Just nId -> [ UpdateTree nId ]
notificationTopics (NUpdateTree nodeId) = [ UpdateTree nodeId ]
type Callback = Notification -> Effect Unit
type CallbacksHM = HM.HashMap UUID Callback
......
src/Gargantext/Components/PhyloExplorer/API.purs
View file @ 0f9e3220
......@@ -5,7 +5,7 @@ module Gargantext.Components.PhyloExplorer.API
, Clique(..), ReflexiveClique(..), CliqueFilter(..)
, toReflexiveTimeUnit, fromReflexiveTimeUnit, extractCriteria
, toReflexiveClique
, update, updateProgress
, update
) where
import Gargantext.Prelude
......@@ -15,6 +15,7 @@ import Data.Generic.Rep (class Generic)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Data.Show.Generic (genericShow)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.PhyloExplorer.JSON (PhyloJSON)
import Gargantext.Components.PhyloExplorer.Types (PhyloSet, parseToPhyloSet)
import Gargantext.Config.REST (AffRESTError)
......@@ -306,37 +307,10 @@ update ::
Session
-> NodeID
-> Unit
-> AffRESTError GT.AsyncTaskWithType
-> AffRESTError GAT.Task
update session nodeId _
= S.post session request {}
>>= case _ of
Left err -> pure $ Left err
Right task -> pure $ Right $ GT.AsyncTaskWithType
{ task
, typ: GT.UpdateNode
}
where
request = GR.NodeAPI GT.Node (Just nodeId)
(GT.asyncTaskTypePath GT.UpdateNode)
updateProgress ::
Session
-> NodeID
-> GT.AsyncTaskWithType
-> AffRESTError GT.AsyncProgress
updateProgress
session
nodeId
(GT.AsyncTaskWithType { task: GT.AsyncTask { id } })
=
S.get session request
where
request = GR.NodeAPI GT.Node (Just nodeId)
(GT.asyncTaskTypePath GT.UpdateNode <> pollParams)
pollParams = "/" <> id <> "/poll?limit1"
src/Gargantext/Config/Utils.purs
View file @ 0f9e3220
......@@ -5,12 +5,12 @@ import Gargantext.Prelude
import Data.Array as A
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, Maybe(..))
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Gargantext.Config.REST (RESTError, logRESTError)
import Gargantext.Types (AsyncEvent(..), AsyncProgress(..), AsyncTaskLog(..), AsyncTaskStatus(..), FrontendError(..))
import Gargantext.Types (AsyncEvent(..), AsyncTaskLog(..), FrontendError(..), asyncTaskLogEventsErrorMessage)
import Gargantext.Utils.Reactix as R2
import Toestand as T
......@@ -29,23 +29,31 @@ handleRESTError herePrefix errors (Left error) _ = liftEffect $ do
-- here.warn2 "[handleTaskError] RESTError" error
handleRESTError _ _ (Right task) handler = handler task
handleErrorInAsyncProgress :: T.Box (Array FrontendError)
-> AsyncProgress
-> Effect Unit
handleErrorInAsyncProgress errors ap@(AsyncProgress { status: IsFailure }) = do
T.modify_ (A.cons $ FStringError { error: concatErrors ap }) errors
handleErrorInAsyncProgress errors ap@(AsyncProgress { log, status: IsFinished }) = do
if countFailed > 0 then
T.modify_ (A.cons $ FStringError { error: concatErrors ap }) errors
else
pure unit
where
countFailed = foldl (+) 0 $ (\(AsyncTaskLog { failed }) -> failed) <$> log
handleErrorInAsyncProgress _ _ = pure unit
concatErrors :: AsyncProgress -> String
concatErrors (AsyncProgress { error, log }) = foldl eventsErrorMessage (fromMaybe "" error) log
where
eventsErrorMessage acc (AsyncTaskLog { events }) = (foldl eventErrorMessage "" events) <> "\n" <> acc
eventErrorMessage acc (AsyncEvent { level: "ERROR", message }) = message <> "\n" <> acc
eventErrorMessage acc _ = acc
-- handleErrorInAsyncProgress :: T.Box (Array FrontendError)
-- -> AsyncProgress
-- -> Effect Unit
-- handleErrorInAsyncProgress errors ap@(AsyncProgress { status: IsFailure }) = do
-- T.modify_ (A.cons $ FStringError { error: concatErrors ap }) errors
-- handleErrorInAsyncProgress errors ap@(AsyncProgress { log, status: IsFinished }) = do
-- if countFailed > 0 then
-- T.modify_ (A.cons $ FStringError { error: concatErrors ap }) errors
-- else
-- pure unit
-- where
-- countFailed = foldl (+) 0 $ (\(AsyncTaskLog { failed }) -> failed) <$> log
-- handleErrorInAsyncProgress _ _ = pure unit
-- concatErrors :: AsyncProgress -> String
-- concatErrors (AsyncProgress { error, log }) = foldl eventsErrorMessage (fromMaybe "" error) log
-- where
-- eventsErrorMessage acc atl = asyncTaskLogEventsErrorMessage atl <> "\n" <> acc
handleErrorInAsyncTaskLog :: T.Box (Array FrontendError)
-> AsyncTaskLog
-> Effect Unit
handleErrorInAsyncTaskLog errors atl =
case asyncTaskLogEventsErrorMessage atl of
Nothing -> pure unit
Just error ->
T.modify_ (A.cons $ FStringError { error }) errors
src/Gargantext/Context/Progress.purs
View file @ 0f9e3220
......@@ -5,6 +5,7 @@ module Gargantext.Context.Progress
) where
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Maybe (Maybe(..))
import Data.Tuple.Nested ((/\))
import Effect (Effect)
......@@ -13,14 +14,12 @@ import Effect.Class (liftEffect)
import Effect.Timer (IntervalId, clearInterval, setInterval)
import Gargantext.AsyncTasks as GAT
import Gargantext.Components.App.Store as AppStore
import Gargantext.Components.Forest.Tree.Node.Tools.ProgressBar (QueryProgressData, queryProgress)
import Gargantext.Components.Notifications as Notifications
import Gargantext.Components.Notifications.Types as NotificationsT
import Gargantext.Config.Utils (handleErrorInAsyncProgress, handleRESTError)
import Gargantext.Components.Notifications.Types as NT
import Gargantext.Config.Utils (handleErrorInAsyncTaskLog, handleRESTError)
import Gargantext.Hooks.FirstEffect (useFirstEffect')
import Gargantext.Prelude
import Gargantext.Sessions (Session)
import Gargantext.Types (AsyncProgress)
import Gargantext.Types as GT
import Gargantext.Utils.Reactix as R2
import Reactix as R
......@@ -29,7 +28,7 @@ import Toestand as T
type AsyncProps =
( asyncTask :: GT.AsyncTaskWithType
( asyncTask :: GAT.Task
, nodeId :: GT.ID
, onFinish :: Unit -> Effect Unit
, session :: Session
......@@ -60,89 +59,52 @@ asyncProgressCpt = R2.hereComponent here "asyncProgress" hCpt where
interval <- T.useBox 1000
-- Methods
let
-- TODO Manage somehow to get the whole job status sent here via
-- websockets, then we can remove the 'Maybe'
fetchJobProgress :: Effect Unit
fetchJobProgress = launchAff_ do
let rdata = (RX.pick props :: Record QueryProgressData)
eAsyncProgress <- queryProgress rdata
-- liftEffect $ here.log2 "[progress] received asyncProgress" eAsyncProgress
-- exponential backoff in case of errors
-- liftEffect $ do
-- case eAsyncProgress of
-- Left _ -> T.modify_ (_ * 2) interval
-- Right _ -> T.write_ 1000 interval
-- interval' <- T.read interval
-- resetInterval intervalIdRef (Just interval') exec
-- Handle removal of task in case of 500 error (e.g. server
-- was restarted and task id is not found anymore).
-- Error logging will be done below, in handleRESTError
case eAsyncProgress of
Right _ -> pure unit
Left err -> do
liftEffect $ do
resetInterval intervalIdRef Nothing (pure unit)
GAT.finish props.nodeId props.asyncTask tasks
handleRESTError hp errors eAsyncProgress onProgress
-- TODO Ideally we should use this function
-- onProgress jobProgress = do
-- launchAff_ $ onProgress jobProgress
onProgress :: AsyncProgress -> Aff Unit
onProgress value@(GT.AsyncProgress { status }) = liftEffect do
T.write_ (min 100.0 $ GT.progressPercent value) progressBox
if (status == GT.IsFinished) ||
(status == GT.IsKilled) ||
(status == GT.IsFailure)
onProgress :: GT.AsyncTaskLog -> Aff Unit
onProgress atl@(GT.AsyncTaskLog log) = liftEffect $ do
T.write_ (min 100.0 $ GT.asyncTaskLogPercent atl) progressBox
here.log "[onProgress] TODO: Implement status killed"
if GT.asyncTaskLogIsFinished atl ||
GT.asyncTaskLogIsError atl
then do
-- resetInterval intervalIdRef Nothing exec
-- case R.readRef intervalIdRef of
-- Nothing -> R.nothing
-- Just iid -> clearInterval iid
handleErrorInAsyncProgress errors value
resetInterval intervalIdRef Nothing (pure unit)
handleErrorInAsyncTaskLog errors atl
-- resetInterval intervalIdRef Nothing (pure unit)
onFinish unit
else
R.nothing
-- if (status == GT.IsFinished) ||
-- (status == GT.IsKilled) ||
-- (status == GT.IsFailure)
-- then do
-- -- resetInterval intervalIdRef Nothing exec
-- -- case R.readRef intervalIdRef of
-- -- Nothing -> R.nothing
-- -- Just iid -> clearInterval iid
-- handleErrorInAsyncProgress errors value
-- resetInterval intervalIdRef Nothing (pure unit)
-- onFinish unit
-- else
-- R.nothing
useFirstEffect' $ do
let (GT.AsyncTaskWithType { task: GT.AsyncTask { id: taskId } }) = props.asyncTask
let cb msg = do
let (GT.WorkerTask { message_id }) = props.asyncTask
let cb n = do
-- here.log2 "callback! for job update" taskId
case msg of
NotificationsT.MJobProgress jobProgress -> launchAff_ $ onProgress jobProgress
NotificationsT.MEmpty -> fetchJobProgress
case n of
NT.NUpdateWorkerProgress _wt jobProgress -> launchAff_ $ onProgress jobProgress
_ -> pure unit
resetInterval intervalIdRef (Just defaultJobPollInterval) fetchJobProgress
-- resetInterval intervalIdRef (Just defaultJobPollInterval) fetchJobProgress
-- The modal window has some problems closing when we refresh too early. This is a HACK
-- void $ setTimeout 400 $ T2.reload reload
let action = NotificationsT.InsertCallback (NotificationsT.UpdateJobProgress taskId) ("task-" <> show taskId) cb
ws <- T.read wsNotification
let action = NT.InsertCallback (NT.UpdateWorkerProgress props.asyncTask) ("task-" <> show message_id) cb
Notifications.performAction ws action
fetchJobProgress
-- Hooks
-- useFirstEffect' do
-- resetInterval intervalIdRef (Just 1000) exec
-- intervalId <- setInterval interval' $ exec unit
-- R.setRef intervalIdRef $ Just intervalId
-- TODO Current backend job implementation is that it cannot, by
-- itself, notify us when a job finished. Hence, we are forced to
-- poll for job still. However, we will keep canceling the timer
-- unless there is no progress report for some time.
useFirstEffect' $ do
resetInterval intervalIdRef (Just defaultJobPollInterval) fetchJobProgress
-- Render
pure $
......
src/Gargantext/Core/NgramsTable/Functions.purs
View file @ 0f9e3220
......@@ -44,7 +44,7 @@ import Gargantext.Config.Utils (handleRESTError)
import Gargantext.Core.NgramsTable.Types
import Gargantext.Routes (SessionRoute(..))
import Gargantext.Sessions (Session, get, post, put)
import Gargantext.Types (AsyncTask, AsyncTaskType(..), AsyncTaskWithType(..), CTabNgramType(..), FrontendError, OrderBy(..), ScoreType(..), TabSubType(..), TabType(..), TermList(..), TermSize(..))
import Gargantext.Types (CTabNgramType(..), FrontendError, OrderBy(..), ScoreType(..), TabSubType(..), TabType(..), TermList(..), TermSize(..))
import Gargantext.Utils.Either (eitherMap)
--import Gargantext.Utils.KarpRabin (indicesOfAny)
import Gargantext.Utils.Reactix as R2
......@@ -584,12 +584,13 @@ chartsAfterSync :: forall props discard.
chartsAfterSync path'@{ nodeId } errors tasks _ = do
eTask <- postNgramsChartsAsync path'
handleRESTError (R2.herePrefix here "[chartsAfterSync]") errors eTask $ \task -> liftEffect $ do
GAT.insert nodeId task tasks
-- GAT.insert nodeId task tasks
here.log "[chartsAfterSync] TODO: IMPLEMENT ME!"
postNgramsChartsAsync :: forall s. CoreParams s -> AffRESTError AsyncTaskWithType
postNgramsChartsAsync :: forall s. CoreParams s -> AffRESTError GAT.Task
postNgramsChartsAsync { listIds, nodeId, session, tabType } = do
eTask :: Either RESTError AsyncTask <- post session putNgramsAsync acu
pure $ (\task -> AsyncTaskWithType { task, typ: UpdateNgramsCharts }) <$> eTask
post session putNgramsAsync acu
where
acu = AsyncNgramsChartsUpdate { listId: head listIds
, tabType }
......
src/Gargantext/Sessions.purs
View file @ 0f9e3220
......@@ -21,6 +21,7 @@ import Gargantext.Config.REST as REST
import Gargantext.Ends (class ToUrl, Backend, toUrl)
import Gargantext.Prelude
import Gargantext.Sessions.Types (Session(..), Sessions(..), OpenNodes, NodeId, mkNodeId, sessionUrl, sessionId, empty, null, unSessions, lookup, cons, tryCons, update, remove, tryRemove)
import Gargantext.Types as GT
import Gargantext.Utils.Reactix as R2
import Reactix as R
import Simple.JSON as JSON
......@@ -118,7 +119,7 @@ postAuthRequest backend ar@(AuthRequest {username}) =
decode (Right (AuthData { token, tree_id, user_id })) =
Right $ Session { backend, caches: Map.empty, token, treeId: tree_id, username, userId: user_id }
postForgotPasswordRequest :: Backend -> String -> Aff (Either String { status :: String })
postForgotPasswordRequest :: Backend -> String -> Aff (Either String GT.WorkerTask)
postForgotPasswordRequest backend email =
decode <$> REST.post Nothing (toUrl backend "async/forgot-password") { email }
where
......
src/Gargantext/Types.purs
View file @ 0f9e3220
......@@ -5,6 +5,7 @@ import Gargantext.Prelude
import Data.Argonaut as Argonaut
import Data.Array as A
import Data.Eq.Generic (genericEq)
import Data.Foldable (foldl)
import Data.Generic.Rep (class Generic)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), maybe)
......@@ -749,64 +750,6 @@ asyncTaskTypePath UploadFile = "async/file/add/"
asyncTaskTypePath UploadFrameCalc = "add/framecalc/async/"
type AsyncTaskID = String
data AsyncTaskStatus = IsRunning
| IsPending
| IsReceived
| IsStarted
| IsFailure
| IsFinished
| IsKilled
derive instance Generic AsyncTaskStatus _
instance JSON.ReadForeign AsyncTaskStatus where
readImpl = JSONG.enumSumRep
instance JSON.WriteForeign AsyncTaskStatus where
writeImpl = JSON.writeImpl <<< show
instance Show AsyncTaskStatus where
show = genericShow
derive instance Eq AsyncTaskStatus
-- instance Read AsyncTaskStatus where
-- read "IsFailure" = Just Failed
-- read "IsFinished" = Just Finished
-- read "IsKilled" = Just Killed
-- read "IsPending" = Just Pending
-- read "IsReceived" = Just Received
-- read "IsRunning" = Just Running
-- read "IsStarted" = Just Started
-- read _ = Nothing
newtype AsyncTask =
AsyncTask { id :: AsyncTaskID
, status :: AsyncTaskStatus
}
derive instance Generic AsyncTask _
derive instance Newtype AsyncTask _
derive newtype instance JSON.ReadForeign AsyncTask
derive newtype instance JSON.WriteForeign AsyncTask
instance Eq AsyncTask where eq = genericEq
newtype AsyncTaskWithType = AsyncTaskWithType
{ task :: AsyncTask
, typ :: AsyncTaskType
}
derive instance Generic AsyncTaskWithType _
derive instance Newtype AsyncTaskWithType _
derive newtype instance JSON.ReadForeign AsyncTaskWithType
derive newtype instance JSON.WriteForeign AsyncTaskWithType
instance Eq AsyncTaskWithType where eq = genericEq
newtype AsyncProgress = AsyncProgress
{ id :: AsyncTaskID
, error :: Maybe String
, log :: Array AsyncTaskLog
, status :: AsyncTaskStatus
}
derive instance Generic AsyncProgress _
derive instance Newtype AsyncProgress _
derive newtype instance JSON.ReadForeign AsyncProgress
newtype AsyncEvent = AsyncEvent
{ level :: String
, message :: String
......@@ -815,6 +758,10 @@ derive instance Generic AsyncEvent _
derive instance Newtype AsyncEvent _
derive newtype instance JSON.ReadForeign AsyncEvent
asyncEventErrorMessage :: AsyncEvent -> Maybe String
asyncEventErrorMessage (AsyncEvent { level: "ERROR", message }) = Just message
asyncEventErrorMessage _ = Nothing
newtype AsyncTaskLog = AsyncTaskLog
{ events :: Array AsyncEvent
, failed :: Int
......@@ -825,15 +772,45 @@ derive instance Generic AsyncTaskLog _
derive instance Newtype AsyncTaskLog _
derive newtype instance JSON.ReadForeign AsyncTaskLog
progressPercent :: AsyncProgress -> Number
progressPercent (AsyncProgress { log }) = perc
asyncTaskLogEventsErrorMessage :: AsyncTaskLog -> Maybe String
asyncTaskLogEventsErrorMessage (AsyncTaskLog { events }) =
foldl eventErrorMessage' Nothing events
where
eventErrorMessage' acc ae =
case asyncEventErrorMessage ae of
Nothing -> acc
Just e' ->
case acc of
Nothing -> Just e'
Just acc' -> Just $ e' <> "\n" <> acc'
asyncTaskLogPercent :: AsyncTaskLog -> Number
asyncTaskLogPercent (AsyncTaskLog { failed, remaining, succeeded }) = 100.0 * nom / denom
where
perc = case A.head log of
Nothing -> 0.0
Just (AsyncTaskLog {failed, remaining, succeeded}) -> 100.0*nom/denom
where
nom = toNumber $ failed + succeeded
denom = toNumber $ failed + succeeded + remaining
nom = toNumber $ failed + succeeded
denom = toNumber $ failed + succeeded + remaining
asyncTaskLogIsFinished :: AsyncTaskLog -> Boolean
asyncTaskLogIsFinished (AsyncTaskLog { remaining }) = remaining == 0
asyncTaskLogIsError :: AsyncTaskLog -> Boolean
asyncTaskLogIsError atl@(AsyncTaskLog { events }) =
asyncTaskLogIsFinished atl &&
(A.length $ A.filter (\(AsyncEvent { level }) -> level == "ERROR") events) > 0
-- New type tasks (async workers)
newtype WorkerTask = WorkerTask { message_id :: Number
, node_id :: Maybe NodeID }
derive instance Generic WorkerTask _
derive instance Newtype WorkerTask _
instance Eq WorkerTask where
eq = genericEq
instance Ord WorkerTask where
compare = genericCompare
instance Show WorkerTask where
show = genericShow
derive newtype instance JSON.ReadForeign WorkerTask
derive newtype instance JSON.WriteForeign WorkerTask
---------------------------------------------------------------------------
-- | GarganText Internal Sugar
......@@ -881,3 +858,76 @@ defaultCacheParams = CacheParams
{ expandTableEdition : false
, showTree : true
}
--- Old-style tasks
-- type AsyncTaskID = String
-- data AsyncTaskStatus = IsRunning
-- | IsPending
-- | IsReceived
-- | IsStarted
-- | IsFailure
-- | IsFinished
-- | IsKilled
-- derive instance Generic AsyncTaskStatus _
-- instance JSON.ReadForeign AsyncTaskStatus where
-- readImpl = JSONG.enumSumRep
-- instance JSON.WriteForeign AsyncTaskStatus where
-- writeImpl = JSON.writeImpl <<< show
-- instance Show AsyncTaskStatus where
-- show = genericShow
-- derive instance Eq AsyncTaskStatus
-- instance Read AsyncTaskStatus where
-- read "IsFailure" = Just Failed
-- read "IsFinished" = Just Finished
-- read "IsKilled" = Just Killed
-- read "IsPending" = Just Pending
-- read "IsReceived" = Just Received
-- read "IsRunning" = Just Running
-- read "IsStarted" = Just Started
-- read _ = Nothing
-- newtype AsyncTask =
-- AsyncTask { id :: AsyncTaskID
-- , status :: AsyncTaskStatus
-- }
-- derive instance Generic AsyncTask _
-- derive instance Newtype AsyncTask _
-- derive newtype instance JSON.ReadForeign AsyncTask
-- derive newtype instance JSON.WriteForeign AsyncTask
-- instance Eq AsyncTask where eq = genericEq
-- newtype AsyncTaskWithType = AsyncTaskWithType
-- { task :: AsyncTask
-- , typ :: AsyncTaskType
-- }
-- derive instance Generic AsyncTaskWithType _
-- derive instance Newtype AsyncTaskWithType _
-- derive newtype instance JSON.ReadForeign AsyncTaskWithType
-- derive newtype instance JSON.WriteForeign AsyncTaskWithType
-- instance Eq AsyncTaskWithType where eq = genericEq
-- newtype AsyncProgress = AsyncProgress
-- { id :: AsyncTaskID
-- , error :: Maybe String
-- , log :: Array AsyncTaskLog
-- , status :: AsyncTaskStatus
-- }
-- derive instance Generic AsyncProgress _
-- derive instance Newtype AsyncProgress _
-- derive newtype instance JSON.ReadForeign AsyncProgress
-- progressPercent :: AsyncProgress -> Number
-- progressPercent (AsyncProgress { log }) = perc
-- where
-- perc = case A.head log of
-- Nothing -> 0.0
-- Just atl -> asyncTaskLogPercent atl
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