Tree.purs 14.2 KB
Newer Older
1 2
module Gargantext.Components.Forest.Tree where

James Laver's avatar
James Laver committed
3
import Gargantext.Prelude
4

5
import Data.Array as A
6
import Data.Maybe (Maybe(..))
7
import Data.Traversable (traverse_, traverse)
8
import Effect (Effect)
9
import Effect.Aff (Aff)
10
import Effect.Class (liftEffect)
11
import Gargantext.AsyncTasks as GAT
12
import Gargantext.Components.App.Data (Boxes)
13
import Gargantext.Components.Forest.Tree.Node (nodeSpan)
Alexandre Delanoë's avatar
Alexandre Delanoë committed
14
import Gargantext.Components.Forest.Tree.Node.Action.Add (AddNodeValue(..), addNode)
15
import Gargantext.Components.Forest.Tree.Node.Action.Contact as Contact
16
import Gargantext.Components.Forest.Tree.Node.Action.Delete (deleteNode, unpublishNode)
17 18 19
import Gargantext.Components.Forest.Tree.Node.Action.Link (linkNodeReq)
import Gargantext.Components.Forest.Tree.Node.Action.Merge (mergeNodeReq)
import Gargantext.Components.Forest.Tree.Node.Action.Move (moveNodeReq)
20
import Gargantext.Components.Forest.Tree.Node.Action.Rename (RenameValue(..), rename)
21
import Gargantext.Components.Forest.Tree.Node.Action.Share as Share
22
import Gargantext.Components.Forest.Tree.Node.Action.Types (Action(..))
23
import Gargantext.Components.Forest.Tree.Node.Action.Update (updateRequest)
24
import Gargantext.Components.Forest.Tree.Node.Action.Upload (uploadFile, uploadArbitraryFile, uploadFrameCalc)
25
import Gargantext.Components.Forest.Tree.Node.Action.WriteNodesDocuments (documentsFromWriteNodesReq)
26 27
import Gargantext.Components.Forest.Tree.Node.Tools.FTree (FTree, LNode(..), NTree(..), fTreeID)
import Gargantext.Components.Forest.Tree.Node.Tools.SubTree.Types (SubTreeOut(..))
28
import Gargantext.Config.REST (AffRESTError, logRESTError)
29
import Gargantext.Config.Utils (handleRESTError)
30
import Gargantext.Ends (Frontends)
31
import Gargantext.Hooks.Loader (useLoader)
32
import Gargantext.Routes as GR
33
import Gargantext.Sessions (Session, get, mkNodeId)
34
import Gargantext.Sessions.Types (useOpenNodesMemberBox, openNodesInsert, openNodesDelete)
35
import Gargantext.Types (Handed, ID, isPublic, publicize, switchHanded)
36
import Gargantext.Types as GT
37
import Gargantext.Utils.Reactix as R2
James Laver's avatar
James Laver committed
38
import Gargantext.Utils.Toestand as T2
39 40 41 42 43
import Reactix as R
import Reactix.DOM.HTML as H
import Record as Record
import Record.Extra as RecordE
import Toestand as T
44

James Laver's avatar
James Laver committed
45 46 47
here :: R2.Here
here = R2.here "Gargantext.Components.Forest.Tree"

48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
-- Shared by every component here
type Common =
  ( boxes     :: Boxes
  , frontends :: Frontends
  , handed    :: Handed
  , reload    :: T2.ReloadS
  )

type LoaderProps =
 ( root    :: ID
 , session :: Session
 | Common )

type NodeProps =
 ( reloadTree :: T2.ReloadS
 , session :: Session
 | Common )
James Laver's avatar
James Laver committed
65

66
type TreeProps =
67 68
 ( root :: ID
 , tree :: FTree
69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
 | NodeProps )

type ChildrenTreeProps =
  ( childProps :: { children'  :: Array FTree
                  , folderOpen :: T.Box Boolean
                  , render     :: R2.Leaf TreeProps }
  | TreeProps )

--- The properties tree shares in common with performAction
type PACommon =
  ( boxes      :: Boxes
  , reloadTree :: T2.ReloadS
  , session    :: Session
  , tree       :: FTree
  )
James Laver's avatar
James Laver committed
84

85 86
-- The properties tree shares in common with nodeSpan
type NSCommon =
87 88
  ( frontends :: Frontends
  , handed    :: Handed
89
  , session   :: Session  )
James Laver's avatar
James Laver committed
90

91 92 93 94
-- The annoying 'render' here is busting a cycle in the low tech
-- way. This function is only called by functions in this module, so
-- we just have to careful in what we pass.
type ChildLoaderProps =
95
  ( id     :: ID
96
  , render :: R2.Leaf TreeProps
97
  , root   :: ID
98
  | NodeProps )
James Laver's avatar
James Laver committed
99

100 101 102
type PerformActionProps =
  ( setPopoverRef :: R.Ref (Maybe (Boolean -> Effect Unit))
  | PACommon )
James Laver's avatar
James Laver committed
103 104 105 106 107 108

-- | Loads and renders the tree starting at the given root node id.
treeLoader :: R2.Component LoaderProps
treeLoader = R.createElement treeLoaderCpt
treeLoaderCpt :: R.Component LoaderProps
treeLoaderCpt = here.component "treeLoader" cpt where
109 110 111
-- treeLoaderCpt :: R.Memo LoaderProps
-- treeLoaderCpt = R.memo (here.component "treeLoader" cpt) memoCmp where
--   memoCmp ({ root: t1 }) ({ root: t2 }) = t1 == t2
112
  cpt p@{ root, session } _ = do
113
    -- app     <- T.useLive T.unequal p.reloadRoot
114
    let fetch { root: r } = getNodeTree session r
115 116 117 118 119 120 121 122
    useLoader { errorHandler
              , loader: fetch
              , path: { root }
              , render: loaded }
      where
        loaded tree' = tree props where
          props = Record.merge common extra where
            common = RecordE.pick p :: Record Common
123
            extra = { reloadTree: p.reload, root, session, tree: tree' }
124
        errorHandler = logRESTError here "[treeLoader]"
James Laver's avatar
James Laver committed
125

126
getNodeTree :: Session -> ID -> AffRESTError FTree
127
getNodeTree session nodeId = get session $ GR.NodeAPI GT.Tree (Just nodeId) ""
128

129
getNodeTreeFirstLevel :: Session -> ID -> AffRESTError FTree
James Laver's avatar
James Laver committed
130
getNodeTreeFirstLevel session nodeId = get session $ GR.TreeFirstLevel (Just nodeId) ""
131

James Laver's avatar
James Laver committed
132 133 134 135
tree :: R2.Leaf TreeProps
tree props = R.createElement treeCpt props []
treeCpt :: R.Component TreeProps
treeCpt = here.component "tree" cpt where
136 137 138 139
  cpt p@{ boxes: boxes@{ forestOpen }
        , frontends
        , handed
        , reload
140
        , root
141 142
        , session
        , tree: NTree (LNode { id, name, nodeType }) children } _ = do
James Laver's avatar
James Laver committed
143
    setPopoverRef <- R.useRef Nothing
144
    folderOpen <- useOpenNodesMemberBox nodeId forestOpen
145 146
    pure $ H.ul { className: ulClass }
      [ H.li { className: childrenClass children' }
147 148 149 150 151 152 153 154 155
        [ nodeSpan { boxes
                   , dispatch: dispatch setPopoverRef
                   , folderOpen
                   , frontends
                   , id
                   , isLeaf
                   , name
                   , nodeType
                   , reload
156
                   , root
157 158
                   , session
                   , setPopoverRef }
159
          [ renderChildren (Record.merge p { childProps: { children', folderOpen, render: tree } } ) [] ]
160 161
        ]
      ]
James Laver's avatar
James Laver committed
162 163 164
    where
      isLeaf = A.null children
      nodeId = mkNodeId session id
165
      ulClass  = switchHanded "ml left" "mr right" handed <> "-auto tree handed"
166 167
      children' = A.sortWith fTreeID pubChildren
      pubChildren = if isPublic nodeType then map (map pub) children else children
168 169 170
      dispatch setPopoverRef a = performAction a (Record.merge common' spr) where
        common' = RecordE.pick p :: Record PACommon
        spr = { setPopoverRef }
James Laver's avatar
James Laver committed
171 172
  pub (LNode n@{ nodeType: t }) = LNode (n { nodeType = publicize t })
  childrenClass [] = "no-children"
173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192
  childrenClass _  = "with-children"


renderChildren :: R2.Component ChildrenTreeProps
renderChildren = R.createElement renderChildrenCpt
renderChildrenCpt :: R.Component ChildrenTreeProps
renderChildrenCpt = here.component "renderChildren" cpt where
  cpt p@{ childProps: { folderOpen } } _ = do
    folderOpen' <- T.useLive T.unequal folderOpen

    if folderOpen' then
      pure $ renderTreeChildren p []
    else
      pure $ H.div {} []

renderTreeChildren :: R2.Component ChildrenTreeProps
renderTreeChildren = R.createElement renderTreeChildrenCpt
renderTreeChildrenCpt :: R.Component ChildrenTreeProps
renderTreeChildrenCpt = here.component "renderTreeChildren" cpt where
  cpt p@{ childProps: { children'
193 194
                      , render }
        , root } _ = do
195 196 197 198 199
    pure $ R.fragment (map renderChild children')

    where
      nodeProps = RecordE.pick p :: Record NodeProps
      renderChild (NTree (LNode {id: cId}) _) = childLoader props [] where
200
        props = Record.merge nodeProps { id: cId, render, root }
201

James Laver's avatar
James Laver committed
202 203 204 205
childLoader :: R2.Component ChildLoaderProps
childLoader = R.createElement childLoaderCpt
childLoaderCpt :: R.Component ChildLoaderProps
childLoaderCpt = here.component "childLoader" cpt where
206 207
  cpt p@{ boxes: { reloadRoot }
        , reloadTree
208 209
        , render
        , root } _ = do
210
    reload <- T.useBox T2.newReload
211
    let reloads = [ reload, reloadRoot, reloadTree ]
James Laver's avatar
James Laver committed
212
    cache <- (A.cons p.id) <$> traverse (T.useLive T.unequal) reloads
213 214 215 216
    useLoader { errorHandler
              , loader: fetch
              , path: cache
              , render: paint reload }
James Laver's avatar
James Laver committed
217
    where
218
      errorHandler = logRESTError here "[childLoader]"
James Laver's avatar
James Laver committed
219
      fetch _ = getNodeTreeFirstLevel p.session p.id
220 221
      paint reload tree' = render (Record.merge base extra) where
        base = nodeProps { reload = reload }
222
        extra = { root, tree: tree' }
223
        nodeProps = RecordE.pick p :: Record NodeProps
James Laver's avatar
James Laver committed
224

225 226 227
closePopover { setPopoverRef } =
   liftEffect $ traverse_ (\set -> set false) (R.readRef setPopoverRef)

228
refreshTree p@{ reloadTree } = liftEffect $ T2.reload reloadTree *> closePopover p
229

230
deleteNode' nt p@{ boxes: { forestOpen }, session, tree: (NTree (LNode {id, parent_id}) _) } = do
James Laver's avatar
James Laver committed
231
  case nt of
232
    GT.NodePublic GT.FolderPublic -> void $ deleteNode session id
233
    GT.NodePublic _               -> void $ unpublishNode session parent_id id
234
    _                             -> void $ deleteNode session id
235
  liftEffect $ T.modify_ (openNodesDelete (mkNodeId session id)) forestOpen
236 237
  refreshTree p

238
doSearch task { boxes: { tasks }, tree: NTree (LNode {id}) _ } = liftEffect $ do
239
  GAT.insert id task tasks
240 241
  here.log2 "[doSearch] DoSearch task:" task

242 243
updateNode params { boxes: { errors, tasks }, session, tree: (NTree (LNode {id}) _) } = do
  eTask <- updateRequest params session id
244
  handleRESTError errors eTask $ \task -> liftEffect $ do
245
    GAT.insert id task tasks
246
    here.log2 "[updateNode] UpdateNode task:" task
247

248 249
renameNode name p@{ boxes: { errors }, session, tree: (NTree (LNode {id}) _) } = do
  eTask <- rename session id $ RenameValue { text: name }
250
  handleRESTError errors eTask $ \_task -> pure unit
251 252
  refreshTree p

253
shareTeam username { boxes: { errors }, session, tree: (NTree (LNode {id}) _)} = do
254
  eTask <- Share.shareReq session id $ Share.ShareTeamParams { username }
255
  handleRESTError errors eTask $ \_task -> pure unit
256

257
sharePublic params p@{ boxes: { errors, forestOpen }, session } = traverse_ f params where
James Laver's avatar
James Laver committed
258
  f (SubTreeOut { in: inId, out }) = do
259
    eTask <- Share.shareReq session inId $ Share.SharePublicParams { node_id: out }
260 261 262 263
    handleRESTError errors eTask $ \_task -> do
      liftEffect $ T.modify_ (openNodesInsert (mkNodeId p.session out)) forestOpen
      refreshTree p

264
addContact params { boxes: { errors }, session, tree: (NTree (LNode {id}) _) } = do
265
  eTask <- Contact.contactReq session id params
266 267
  handleRESTError errors eTask $ \_task -> pure unit

268 269
addNode' name nodeType p@{ boxes: { errors, forestOpen }, session, tree: (NTree (LNode { id }) _) } = do
  eId <- addNode session id $ AddNodeValue { name, nodeType }
270
  handleRESTError errors eId $ \_id -> liftEffect $ do
271
    liftEffect $ T.modify_ (openNodesInsert (mkNodeId session id)) forestOpen
272 273
    refreshTree p

274 275
uploadFile' nodeType fileType mName contents p@{ boxes: { errors, tasks }, session, tree: (NTree (LNode { id }) _) } selection = do
  eTask <- uploadFile { contents, fileType, id, mName, nodeType, selection, session }
276
  handleRESTError errors eTask $ \task -> liftEffect $ do
277
    GAT.insert id task tasks
278
    here.log2 "[uploadFile'] UploadFile, uploaded, task:" task
279

280 281
uploadArbitraryFile' mName blob p@{ boxes: { errors, tasks }, session, tree: (NTree (LNode { id }) _) } selection = do
  eTask <- uploadArbitraryFile session id { blob, mName } selection
282
  handleRESTError errors eTask $ \task -> liftEffect $ do
283
    GAT.insert id task tasks
284
    here.log2 "[uploadArbitraryFile'] UploadArbitraryFile, uploaded, task:" task
285

286 287 288
uploadFrameCalc' p@{ boxes: { errors, tasks }, session, tree: (NTree (LNode { id }) _) } = do
  eTask <- uploadFrameCalc session id
  handleRESTError errors eTask $ \task -> liftEffect $ do
289
    GAT.insert id task tasks
290
    here.log2 "[performAction] UploadFrameCalc, uploaded, task:" task
291

292
moveNode params p@{ boxes: { errors, forestOpen }, session } = traverse_ f params where
293
  f (SubTreeOut { in: in', out }) = do
294
    eTask <- moveNodeReq session in' out
295
    handleRESTError errors eTask $ \_task -> pure unit
296
    liftEffect $ T.modify_ (openNodesInsert (mkNodeId session out)) forestOpen
297 298
    refreshTree p

299
mergeNode params p@{ boxes: { errors }, session } = traverse_ f params where
James Laver's avatar
James Laver committed
300
  f (SubTreeOut { in: in', out }) = do
301
    eTask <- mergeNodeReq session in' out
302
    handleRESTError errors eTask $ \_task -> pure unit
303 304
    refreshTree p

305
linkNode nodeType params p@{ boxes: { errors }, session } = traverse_ f params where
James Laver's avatar
James Laver committed
306
  f (SubTreeOut { in: in', out }) = do
307
    eTask <- linkNodeReq session nodeType in' out
308
    handleRESTError errors eTask $ \_task -> pure unit
309 310
    refreshTree p

311 312 313 314 315
documentsFromWriteNodes id p@{ boxes: { errors }, session } = do
  eTask <- documentsFromWriteNodesReq session id
  handleRESTError errors eTask $ \_task -> pure unit
  refreshTree p

316 317 318
-- | This thing is basically a hangover from when garg was a thermite
-- | application. we should slowly get rid of it.
performAction :: Action -> Record PerformActionProps -> Aff Unit
319 320 321 322 323 324 325 326
performAction (DeleteNode nt) p                               = deleteNode' nt p
performAction (DoSearch task) p                               = doSearch task p
performAction (UpdateNode params) p                           = updateNode params p
performAction (RenameNode name) p                             = renameNode name p
performAction (ShareTeam username) p                          = shareTeam username p
performAction (SharePublic { params }) p                      = sharePublic params p
performAction (AddContact params) p                           = addContact params p
performAction (AddNode name nodeType) p                       = addNode' name nodeType p
327
performAction UploadFrameCalc p                               = uploadFrameCalc' p
328 329 330 331
performAction (UploadFile nodeType fileType mName contents selection) p =
  uploadFile' nodeType fileType mName contents p selection
performAction (UploadArbitraryFile mName blob selection) p              =
  uploadArbitraryFile' mName blob p selection
332 333 334 335 336 337
performAction DownloadNode _                                  = liftEffect $ here.log "[performAction] DownloadNode"
performAction (MoveNode {params}) p                           = moveNode params p
performAction (MergeNode {params}) p                          = mergeNode params p
performAction (LinkNode { nodeType, params }) p               = linkNode nodeType params p
performAction RefreshTree p                                   = refreshTree p
performAction ClosePopover p                                  = closePopover p
338 339
performAction (DocumentsFromWriteNodes { id }) p              = documentsFromWriteNodes id p
performAction NoAction _                                      = liftEffect $ here.log "[performAction] NoAction"