Node.hs

{-|
Module      : Gargantext.API.Node
Description : Server API
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-- TODO-SECURITY: Critical

-- TODO-ACCESS: CanGetNode
-- TODO-EVENTS: No events as this is a read only query.
Node API
-------------------------------------------------------------------
-- 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*]}

-}

{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeOperators        #-}

module Gargantext.API.Node
  where

import Gargantext.API.Admin.Auth (withNamedAccess, withNamedPolicyT)
import Gargantext.API.Admin.Auth.Types (PathId(..), AuthenticatedUser (..), auth_node_id)
import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Auth.PolicyCheck ( nodeChecks, AccessPolicyManager )
import Gargantext.API.Errors.Types (BackendInternalError)
import Gargantext.API.Metrics
import Gargantext.API.Ngrams.Types (TabType(..))
import Gargantext.API.Node.DocumentUpload qualified as DocumentUpload
import Gargantext.API.Node.DocumentsFromWriteNodes qualified as DFWN
import Gargantext.API.Node.File ( fileApi, fileAsyncApi )
import Gargantext.API.Node.FrameCalcUpload qualified as FrameCalcUpload
import Gargantext.API.Node.New ( postNode, postNodeAsyncAPI )
import Gargantext.API.Node.Share qualified as Share
import Gargantext.API.Node.Types
import Gargantext.API.Node.Update qualified as Update
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
import Gargantext.API.Search qualified as Search
import Gargantext.API.Server.Named.Ngrams (apiNgramsTableCorpus)
import Gargantext.API.Table ( tableApi, getPair )
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Viz.Phylo.API (phyloAPI)
import Gargantext.Database.Action.Delete qualified as Action (deleteNode)
import Gargantext.Database.Action.Flow.Pairing (pairing)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny, HyperdataCorpus, HyperdataAnnuaire)
import Gargantext.Database.Admin.Types.Hyperdata.Prelude ( HyperdataC )
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (Cmd, JSONB)
import Gargantext.Database.Query.Table.Node
import Gargantext.Database.Query.Table.Node.Children (getChildren)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
import Gargantext.Database.Query.Table.Node.Update qualified as U (update, Update(..))
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Query.Table.NodeContext (nodeContextsCategory, nodeContextsScore)
import Gargantext.Database.Query.Table.NodeNode
import Gargantext.Database.Query.Tree (tree, tree_flat, TreeMode(..))
import Gargantext.Prelude
import Servant
import Servant.Server.Generic (AsServerT)
import Gargantext.API.Routes.Named.Tree qualified as Named


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

------------------------------------------------------------------------
-- | 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.
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
  }

-------------------------------------------------------------------
-- | Node API Types management
-- 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

nodeNodeAPI :: forall proxy a env err m. (JSONB a, ToJSON a, IsGargServer env err m)
            => proxy a
            -> AuthenticatedUser
            -> CorpusId
            -> NodeId
            -> Named.NodeNodeAPI a (AsServerT m)
nodeNodeAPI p uId cId nId =
  withNamedAccess uId (PathNodeNode cId nId) nodeNodeAPI'
  where
    nodeNodeAPI' :: Named.NodeNodeAPI a (AsServerT m)
    nodeNodeAPI' = Named.NodeNodeAPI $ getNodeWith nId p

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

catApi :: CorpusId -> GargServer CatApi
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

------------------------------------------------------------------------
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]
    putScore cId cs' = nodeContextsScore $ map (\n -> (cId, n, nts_score cs')) (nts_nodesId cs')

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

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


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

treeFlatAPI :: IsGargServer env err m
            => AuthenticatedUser
            -> RootId
            -> Named.TreeFlatAPI (AsServerT m)
treeFlatAPI authenticatedUser rootId =
  withNamedAccess authenticatedUser (PathNode rootId) $
    Named.TreeFlatAPI { getNodesEp = tree_flat rootId }

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

putNode :: forall err a. (HasNodeError err, HyperdataC a)
        => NodeId
        -> a
        -> Cmd err Int
putNode n h = fromIntegral <$> updateHyperdata n h

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

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

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

------------------------------------------------------------------------
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
  , frameCalcUploadAPI = FrameCalcUpload.api authenticatedUser targetNode
  , putEp              = putNode targetNode
  , updateAPI          = Update.api targetNode
  , 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
  , unpublishEp        = Share.unPublish targetNode
  , fileAPI            = Named.FileAPI $ fileApi targetNode
  , fileAsyncAPI       = fileAsyncApi authenticatedUser targetNode
  , dfwnAPI            = DFWN.api authenticatedUser targetNode
  , documentUploadAPI  = DocumentUpload.api targetNode
  }
  where
    userRootId = RootId $ authenticatedUser ^. auth_node_id