Tree.purs 13.3 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.Either (Either)
7
import Data.Maybe (Maybe(..))
8
import Data.Traversable (traverse_, traverse)
9
import Effect (Effect)
10
import Effect.Aff (Aff)
11
import Effect.Class (liftEffect)
12
import Gargantext.AsyncTasks as GAT
13
import Gargantext.Components.App.Data (Boxes)
14
import Gargantext.Components.Forest.Tree.Node (nodeSpan)
15
import Gargantext.Components.Forest.Tree.Node.Action (Action(..))
Alexandre Delanoë's avatar
Alexandre Delanoë committed
16
import Gargantext.Components.Forest.Tree.Node.Action.Add (AddNodeValue(..), addNode)
17
import Gargantext.Components.Forest.Tree.Node.Action.Contact as Contact
18
import Gargantext.Components.Forest.Tree.Node.Action.Delete (deleteNode, unpublishNode)
19 20 21
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)
22
import Gargantext.Components.Forest.Tree.Node.Action.Rename (RenameValue(..), rename)
23
import Gargantext.Components.Forest.Tree.Node.Action.Share as Share
24
import Gargantext.Components.Forest.Tree.Node.Action.Update (updateRequest)
25
import Gargantext.Components.Forest.Tree.Node.Action.Upload (uploadFile, uploadArbitraryFile)
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 (RESTError)
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 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82
-- 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 )

type TreeProps =
 ( tree :: FTree
 | 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
83

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

90 91 92 93 94 95 96
-- 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 =
  ( id :: ID
  , render :: R2.Leaf TreeProps
  | NodeProps )
James Laver's avatar
James Laver committed
97

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

-- | 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
107 108 109
-- treeLoaderCpt :: R.Memo LoaderProps
-- treeLoaderCpt = R.memo (here.component "treeLoader" cpt) memoCmp where
--   memoCmp ({ root: t1 }) ({ root: t2 }) = t1 == t2
110
  cpt p@{ root, session } _ = do
111
    -- app     <- T.useLive T.unequal p.reloadRoot
112
    let fetch { root: r } = getNodeTree session r
113 114 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
            extra = { tree: tree', reloadTree: p.reload, session }
        errorHandler err = here.log2 "[treeLoader] RESTError" err
James Laver's avatar
James Laver committed
123

124
getNodeTree :: Session -> ID -> Aff (Either RESTError FTree)
125
getNodeTree session nodeId = get session $ GR.NodeAPI GT.Tree (Just nodeId) ""
126

127
getNodeTreeFirstLevel :: Session -> ID -> Aff (Either RESTError FTree)
James Laver's avatar
James Laver committed
128
getNodeTreeFirstLevel session nodeId = get session $ GR.TreeFirstLevel (Just nodeId) ""
129

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

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

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

219 220 221
closePopover { setPopoverRef } =
   liftEffect $ traverse_ (\set -> set false) (R.readRef setPopoverRef)

222
refreshTree p@{ reloadTree } = liftEffect $ T2.reload reloadTree *> closePopover p
223

224
deleteNode' nt p@{ boxes: { forestOpen }, session, tree: (NTree (LNode {id, parent_id}) _) } = do
James Laver's avatar
James Laver committed
225
  case nt of
226 227 228 229
    GT.NodePublic GT.FolderPublic -> void $ deleteNode session nt id
    GT.NodePublic _               -> void $ unpublishNode session parent_id id
    _                             -> void $ deleteNode session nt id
  liftEffect $ T.modify_ (openNodesDelete (mkNodeId session id)) forestOpen
230 231
  refreshTree p

232
doSearch task p@{ boxes: { tasks }, tree: NTree (LNode {id}) _ } = liftEffect $ do
233
  GAT.insert id task tasks
234 235
  here.log2 "[doSearch] DoSearch task:" task

236 237
updateNode params { boxes: { errors, tasks }, session, tree: (NTree (LNode {id}) _) } = do
  eTask <- updateRequest params session id
238
  handleRESTError errors eTask $ \task -> liftEffect $ do
239
    GAT.insert id task tasks
240
    here.log2 "[updateNode] UpdateNode task:" task
241

242 243
renameNode name p@{ boxes: { errors }, session, tree: (NTree (LNode {id}) _) } = do
  eTask <- rename session id $ RenameValue { text: name }
244
  handleRESTError errors eTask $ \_task -> pure unit
245 246
  refreshTree p

247 248
shareTeam username p@{ boxes: { errors }, session, tree: (NTree (LNode {id}) _)} = do
  eTask <- Share.shareReq session id $ Share.ShareTeamParams { username }
249
  handleRESTError errors eTask $ \_task -> pure unit
250

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

258 259
addContact params p@{ boxes: { errors }, session, tree: (NTree (LNode {id}) _) } = do
  eTask <- Contact.contactReq session id params
260 261
  handleRESTError errors eTask $ \_task -> pure unit

262 263
addNode' name nodeType p@{ boxes: { errors, forestOpen }, session, tree: (NTree (LNode { id }) _) } = do
  eId <- addNode session id $ AddNodeValue { name, nodeType }
264
  handleRESTError errors eId $ \_id -> liftEffect $ do
265
    liftEffect $ T.modify_ (openNodesInsert (mkNodeId session id)) forestOpen
266 267
    refreshTree p

268 269
uploadFile' nodeType fileType mName contents p@{ boxes: { errors, tasks }, session, tree: (NTree (LNode { id }) _) } = do
  eTask <- uploadFile { contents, fileType, id, mName, nodeType, session }
270
  handleRESTError errors eTask $ \task -> liftEffect $ do
271
    GAT.insert id task tasks
272
    here.log2 "[uploadFile'] UploadFile, uploaded, task:" task
273

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

280
moveNode params p@{ boxes: { errors, forestOpen }, session } = traverse_ f params where
281
  f (SubTreeOut { in: in', out }) = do
282
    eTask <- moveNodeReq session in' out
283
    handleRESTError errors eTask $ \_task -> pure unit
284
    liftEffect $ T.modify_ (openNodesInsert (mkNodeId session out)) forestOpen
285 286
    refreshTree p

287
mergeNode params p@{ boxes: { errors }, session } = traverse_ f params where
James Laver's avatar
James Laver committed
288
  f (SubTreeOut { in: in', out }) = do
289
    eTask <- mergeNodeReq session in' out
290
    handleRESTError errors eTask $ \_task -> pure unit
291 292
    refreshTree p

293
linkNode nodeType params p@{ boxes: { errors }, session } = traverse_ f params where
James Laver's avatar
James Laver committed
294
  f (SubTreeOut { in: in', out }) = do
295
    eTask <- linkNodeReq session nodeType in' out
296
    handleRESTError errors eTask $ \_task -> pure unit
297 298 299 300 301
    refreshTree p

-- | 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
302 303 304 305 306 307 308 309
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
310
performAction (UploadFile nodeType fileType mName contents) p = uploadFile' nodeType fileType mName contents p
311 312 313 314 315 316 317 318
performAction (UploadArbitraryFile mName blob) p              = uploadArbitraryFile' mName blob p
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 NoAction _                                      = liftEffect $ here.log "[performAction] NoAction"
performAction ClosePopover p                                  = closePopover p