Node.hs 11.4 KB
Newer Older
1 2 3 4 5 6 7 8 9
{-|
Module      : Gargantext.API.Node
Description : Server API
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

10 11
-- TODO-SECURITY: Critical

Alexandre Delanoë's avatar
Alexandre Delanoë committed
12 13
-- TODO-ACCESS: CanGetNode
-- TODO-EVENTS: No events as this is a read only query.
14
Node API
Alexandre Delanoë's avatar
Alexandre Delanoë committed
15 16 17 18 19 20 21
-------------------------------------------------------------------
-- TODO-ACCESS: access by admin only.
--              At first let's just have an isAdmin check.
--              Later: check userId CanDeleteNodes Nothing
-- TODO-EVENTS: DeletedNodes [NodeId]
--              {"tag": "DeletedNodes", "nodes": [Int*]}

22 23
-}

24 25 26
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeOperators        #-}
27 28

module Gargantext.API.Node
Alexandre Delanoë's avatar
Alexandre Delanoë committed
29 30
  where

31
import Gargantext.API.Admin.Auth (withNamedAccess, withNamedPolicyT)
32
import Gargantext.API.Admin.Auth.Types (PathId(..), AuthenticatedUser (..), auth_node_id)
33
import Gargantext.API.Admin.EnvTypes (Env)
34
import Gargantext.API.Auth.PolicyCheck ( nodeChecks, AccessPolicyManager )
35
import Gargantext.API.Errors.Types (BackendInternalError)
36
import Gargantext.API.Metrics
37
import Gargantext.API.Ngrams.Types (TabType(..))
38
import Gargantext.API.Node.DocumentUpload qualified as DocumentUpload
39
import Gargantext.API.Node.DocumentsFromWriteNodes qualified as DFWN
40
import Gargantext.API.Node.File ( fileApi, fileAsyncApi )
41
import Gargantext.API.Node.FrameCalcUpload qualified as FrameCalcUpload
42
import Gargantext.API.Node.New ( postNode, postNodeAsyncAPI )
43
import Gargantext.API.Node.Share qualified as Share
44
import Gargantext.API.Node.Types
45
import Gargantext.API.Node.Update qualified as Update
46 47 48 49 50
import Gargantext.API.Prelude ( GargM, GargServer, IsGargServer )
import Gargantext.API.Routes.Named.File qualified as Named
import Gargantext.API.Routes.Named.Node qualified as Named
import Gargantext.API.Routes.Named.Private qualified as Named
import Gargantext.API.Routes.Named.Share qualified as Named
51
import Gargantext.API.Search qualified as Search
52
import Gargantext.API.Server.Named.Ngrams (apiNgramsTableCorpus)
53
import Gargantext.API.Table ( tableApi, getPair )
54
import Gargantext.Core.Types.Individu (User(..))
55
import Gargantext.Core.Viz.Phylo.API (phyloAPI)
56
import Gargantext.Database.Action.Delete qualified as Action (deleteNode)
57
import Gargantext.Database.Action.Flow.Pairing (pairing)
58
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny, HyperdataCorpus, HyperdataAnnuaire)
59
import Gargantext.Database.Admin.Types.Hyperdata.Prelude ( HyperdataC )
60
import Gargantext.Database.Admin.Types.Node
61
import Gargantext.Database.Prelude (Cmd, JSONB)
62
import Gargantext.Database.Query.Table.Node
63
import Gargantext.Database.Query.Table.Node.Children (getChildren)
64 65
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
66
import Gargantext.Database.Query.Table.Node.Update qualified as U (update, Update(..))
67
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
68
import Gargantext.Database.Query.Table.NodeContext (nodeContextsCategory, nodeContextsScore)
69
import Gargantext.Database.Query.Table.NodeNode
70
import Gargantext.Database.Query.Tree (tree, tree_flat, TreeMode(..))
71
import Gargantext.Prelude
72
import Servant
73 74
import Servant.Server.Generic (AsServerT)
import Gargantext.API.Routes.Named.Tree qualified as Named
75

76 77 78 79

-- | Delete Nodes
-- Be careful: really delete nodes
-- Access by admin only
80 81
nodesAPI :: IsGargServer err env m => [NodeId] -> Named.NodesAPI (AsServerT m)
nodesAPI nodes = Named.NodesAPI { deleteNodeEp = deleteNodes nodes }
82 83

------------------------------------------------------------------------
84 85 86 87 88 89 90
-- | TODO-ACCESS: access by admin only.
-- At first let's just have an isAdmin check.
-- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
-- To manage the Users roots
-- TODO-EVENTS:
--   PutNode ?
-- TODO needs design discussion.
91 92 93 94 95
roots :: IsGargServer err env m => Named.Roots (AsServerT m)
roots = Named.Roots
  { getRootsEp = getNodesWithParentId Nothing
  , putRootsEp = pure (panicTrace "not implemented yet") -- TODO use patch map to update what we need
  }
96

97 98
-------------------------------------------------------------------
-- | Node API Types management
99 100 101 102 103 104 105 106 107 108 109 110
-- TODO-ACCESS : access by users
-- No ownership check is needed if we strictly follow the capability model.
--
-- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
--             SearchAPI)
-- CanRenameNode (or part of CanEditNode?)
-- CanCreateChildren (PostNodeApi)
-- CanEditNode / CanPutNode TODO not implemented yet
-- CanDeleteNode
-- CanPatch (TableNgramsApi)
-- CanFavorite
-- CanMoveToTrash
111

112
nodeNodeAPI :: forall proxy a env err m. (JSONB a, ToJSON a, IsGargServer env err m)
113
            => proxy a
114
            -> AuthenticatedUser
115 116
            -> CorpusId
            -> NodeId
117 118 119
            -> Named.NodeNodeAPI a (AsServerT m)
nodeNodeAPI p uId cId nId =
  withNamedAccess uId (PathNodeNode cId nId) nodeNodeAPI'
120
  where
121 122
    nodeNodeAPI' :: Named.NodeNodeAPI a (AsServerT m)
    nodeNodeAPI' = Named.NodeNodeAPI $ getNodeWith nId p
123 124 125

------------------------------------------------------------------------
------------------------------------------------------------------------
126
type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
127
            :> ReqBody '[JSON] NodesToCategory
128
            :> Put     '[JSON] [Int]
129

130
catApi :: CorpusId -> GargServer CatApi
131 132 133 134 135
catApi cId cs' = do
  ret <- nodeContextsCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
  lId <- defaultList cId
  _ <- updateChart cId (Just lId) Docs Nothing
  pure ret
136

137 138 139 140 141 142 143 144 145
------------------------------------------------------------------------
type ScoreApi =  Summary " To Score NodeNodes"
            :> ReqBody '[JSON] NodesToScore
            :> Put     '[JSON] [Int]

scoreApi :: CorpusId -> GargServer ScoreApi
scoreApi = putScore
  where
    putScore :: CorpusId -> NodesToScore -> Cmd err [Int]
146
    putScore cId cs' = nodeContextsScore $ map (\n -> (cId, n, nts_score cs')) (nts_nodesId cs')
147

148
------------------------------------------------------------------------
149
-- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
150
-- Pairing utilities to move elsewhere
151 152
pairs :: IsGargServer err env m => CorpusId -> Named.Pairs (AsServerT m)
pairs cId = Named.Pairs $ do
153 154
  ns <- getNodeNode cId
  pure $ map _nn_node2_id ns
155

156 157
pairWith :: IsGargServer err env m => CorpusId -> Named.PairWith (AsServerT m)
pairWith cId = Named.PairWith $ \ aId lId -> do
158
  r <- pairing cId aId lId
159 160 161 162
  _ <- insertNodeNode [ NodeNode { _nn_node1_id = cId
                                 , _nn_node2_id = aId
                                 , _nn_score = Nothing
                                 , _nn_category = Nothing }]
163 164
  pure r

165

166 167 168 169 170 171 172 173 174 175
treeAPI :: IsGargServer env BackendInternalError m
        => AuthenticatedUser
        -> NodeId
        -> AccessPolicyManager
        -> Named.NodeTreeAPI (AsServerT m)
treeAPI authenticatedUser nodeId mgr =
  withNamedPolicyT authenticatedUser (nodeChecks nodeId) (Named.NodeTreeAPI
    { nodeTreeEp   = tree TreeAdvanced nodeId
    , firstLevelEp = tree TreeFirstLevel nodeId
    }) mgr
176

177 178 179 180 181 182 183
treeFlatAPI :: IsGargServer env err m
            => AuthenticatedUser
            -> RootId
            -> Named.TreeFlatAPI (AsServerT m)
treeFlatAPI authenticatedUser rootId =
  withNamedAccess authenticatedUser (PathNode rootId) $
    Named.TreeFlatAPI { getNodesEp = tree_flat rootId }
184

185
------------------------------------------------------------------------
186
-- | TODO Check if the name is less than 255 char
187
rename :: NodeId -> RenameNode -> Cmd err [Int]
188
rename nId (RenameNode name') = U.update (U.Rename nId name')
189

190
putNode :: forall err a. (HasNodeError err, HyperdataC a)
191
        => NodeId
192
        -> a
193
        -> Cmd err Int
194
putNode n h = fromIntegral <$> updateHyperdata n h
195 196 197 198 199 200

moveNode :: User
         -> NodeId
         -> ParentId
         -> Cmd err [Int]
moveNode _u n p = update (Move n p)
201
-------------------------------------------------------------
202

203 204 205 206 207 208
annuaireNodeAPI :: AuthenticatedUser
                -> Named.NodeAPIEndpoint HyperdataAnnuaire (AsServerT (GargM Env BackendInternalError))
annuaireNodeAPI authenticatedUser = Named.NodeAPIEndpoint $ \targetNode ->
  withNamedAccess authenticatedUser (PathNode targetNode) (concreteAPI targetNode)
  where
    concreteAPI = genericNodeAPI' (Proxy :: Proxy HyperdataAnnuaire) authenticatedUser
209

210 211 212 213 214 215
corpusNodeAPI :: AuthenticatedUser
              -> Named.NodeAPIEndpoint HyperdataCorpus (AsServerT (GargM Env BackendInternalError))
corpusNodeAPI authenticatedUser = Named.NodeAPIEndpoint $ \targetNode ->
  withNamedAccess authenticatedUser (PathNode targetNode) (concreteAPI targetNode)
  where
    concreteAPI = genericNodeAPI' (Proxy :: Proxy HyperdataCorpus) authenticatedUser
216

217
------------------------------------------------------------------------
218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236
nodeAPI :: AuthenticatedUser
        -> Named.NodeAPIEndpoint HyperdataAny (AsServerT (GargM Env BackendInternalError))
nodeAPI authenticatedUser = Named.NodeAPIEndpoint $ \targetNode ->
  withNamedAccess authenticatedUser (PathNode targetNode) (concreteAPI targetNode)
  where
    concreteAPI = genericNodeAPI' (Proxy :: Proxy HyperdataAny) authenticatedUser

-- | The /actual/ (generic) node API, instantiated depending on the concrete type of node.
genericNodeAPI' :: forall a proxy. ( HyperdataC a, Show a, MimeUnrender JSON a, Named.IsGenericNodeRoute a )
                => proxy a
                -> AuthenticatedUser
                -> NodeId
                -> Named.NodeAPI a (AsServerT (GargM Env BackendInternalError))
genericNodeAPI' _ authenticatedUser targetNode =  Named.NodeAPI
  { nodeNodeAPI        = withNamedPolicyT authenticatedUser (nodeChecks targetNode) $
                           Named.NodeNodeAPI $ getNodeWith targetNode (Proxy :: Proxy a)
  , renameAPI          = Named.RenameAPI   $ rename targetNode
  , postNodeAPI        = Named.PostNodeAPI $ postNode authenticatedUser targetNode
  , postNodeAsyncAPI   = postNodeAsyncAPI authenticatedUser targetNode
237
  , frameCalcUploadAPI = FrameCalcUpload.api authenticatedUser targetNode
238
  , putEp              = putNode targetNode
239
  , updateAPI          = Update.api targetNode
240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258
  , deleteEp           = Action.deleteNode userRootId targetNode
  , childrenAPI        = Named.ChildrenAPI $ getChildren targetNode (Proxy :: Proxy a)
  , tableAPI           = tableApi targetNode
  , tableNgramsAPI     = apiNgramsTableCorpus targetNode
  , catAPI             = Named.CatAPI $ catApi targetNode
  , scoreAPI           = Named.ScoreAPI $ scoreApi targetNode
  , searchAPI          = Search.api targetNode
  , shareAPI           = Named.ShareNode $ Share.api userRootId targetNode
  ---- Pairing utilities
  , pairWithEp         = pairWith targetNode
  , pairsEp            = pairs targetNode
  , pairingEp          = Named.PairingAPI $ getPair targetNode
  ---- VIZ
  , scatterAPI         = scatterApi targetNode
  , chartAPI           = chartApi targetNode
  , pieAPI             = pieApi targetNode
  , treeAPI            = treeApi targetNode
  , phyloAPI           = phyloAPI targetNode
  , moveAPI            = Named.MoveAPI $ moveNode userRootId targetNode
259
  , unpublishEp        = Share.unPublish targetNode
260
  , fileAPI            = Named.FileAPI $ fileApi targetNode
261
  , fileAsyncAPI       = fileAsyncApi authenticatedUser targetNode
262 263
  , dfwnAPI            = DFWN.api authenticatedUser targetNode
  , documentUploadAPI  = DocumentUpload.api targetNode
264
  }
265 266
  where
    userRootId = RootId $ authenticatedUser ^. auth_node_id