src/Gargantext/API/Node.hs

   1 {-|
   2 Module      : Gargantext.API.Node
   3 Description : Server API
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Node API
  11 -}
  12
  13 {-# OPTIONS_GHC -fno-warn-orphans #-}
  14
  15 {-# LANGUAGE DataKinds          #-}
  16 {-# LANGUAGE DeriveGeneric      #-}
  17 {-# LANGUAGE FlexibleContexts   #-}
  18 {-# LANGUAGE NoImplicitPrelude  #-}
  19 {-# LANGUAGE OverloadedStrings  #-}
  20 {-# LANGUAGE RankNTypes         #-}
  21 {-# LANGUAGE TemplateHaskell    #-}
  22 {-# LANGUAGE TypeOperators      #-}
  23
  24 module Gargantext.API.Node
  25   ( module Gargantext.API.Node
  26   , HyperdataAny(..)
  27   , HyperdataAnnuaire(..)
  28   , HyperdataCorpus(..)
  29   , HyperdataResource(..)
  30   , HyperdataUser(..)
  31   , HyperdataDocument(..)
  32   , HyperdataDocumentV3(..)
  33   ) where
  34
  35 import Control.Lens (prism', set)
  36 import Control.Monad ((>>))
  37 import Control.Monad.IO.Class (liftIO)
  38 import Data.Aeson (FromJSON, ToJSON)
  39 import Data.Swagger
  40 import Data.Text (Text())
  41 import Data.Time (UTCTime)
  42 import GHC.Generics (Generic)
  43 import Gargantext.API.Metrics
  44 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, HasRepo, QueryParamR)
  45 import Gargantext.API.Ngrams.Tools
  46 import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
  47 import Gargantext.Core.Types (Offset, Limit, ListType(..), HasInvalidError)
  48 import Gargantext.Core.Types.Main (Tree, NodeTree)
  49 import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),FacetChart,runViewAuthorsDoc)
  50 import qualified Gargantext.Database.Metrics as Metrics
  51 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
  52 import Gargantext.Database.Node.Children (getChildren)
  53 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
  54 import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mkNodeWithParent, JSONB, NodeError(..), HasNodeError(..))
  55 import Gargantext.Database.Schema.Node (defaultList)
  56 import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
  57 import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
  58 import Gargantext.Database.Types.Node
  59 import Gargantext.Database.Types.Node (CorpusId, ContactId)
  60 import Gargantext.Database.Utils -- (Cmd, CmdM)
  61 import Gargantext.Prelude
  62 import Gargantext.API.Settings
  63 import Gargantext.Text.Metrics (Scored(..))
  64 import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
  65 import Gargantext.Viz.Graph.Tools (cooc2graph)
  66 import Gargantext.Viz.Phylo.API (getPhylo)
  67 import Gargantext.Viz.Phylo hiding (Tree)
  68 import Servant
  69 import Test.QuickCheck (elements)
  70 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  71 import qualified Data.Map as Map
  72 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  73
  74 {-
  75 import qualified Gargantext.Text.List.Learn as Learn
  76 import qualified Data.Vector as Vec
  77 --}
  78
  79 type GargServer api =
  80   forall env err m.
  81     ( CmdM env err m
  82     , HasNodeError err
  83     , HasInvalidError err
  84     , HasTreeError err
  85     , HasRepo env
  86     , HasSettings env
  87     )
  88     => ServerT api m
  89
  90 -------------------------------------------------------------------
  91 -- TODO-ACCESS: access by admin only.
  92 --              At first let's just have an isAdmin check.
  93 --              Later: check userId CanDeleteNodes Nothing
  94 -- TODO-EVENTS: DeletedNodes [NodeId]
  95 --              {"tag": "DeletedNodes", "nodes": [Int*]}
  96 type NodesAPI  = Delete '[JSON] Int
  97
  98 -- | Delete Nodes
  99 -- Be careful: really delete nodes
 100 -- Access by admin only
 101 nodesAPI :: [NodeId] -> GargServer NodesAPI
 102 nodesAPI ids = deleteNodes ids
 103
 104 ------------------------------------------------------------------------
 105 -- | TODO-ACCESS: access by admin only.
 106 -- At first let's just have an isAdmin check.
 107 -- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
 108 -- To manage the Users roots
 109 -- TODO-EVENTS:
 110 --   PutNode ?
 111 -- TODO needs design discussion.
 112 type Roots =  Get    '[JSON] [NodeAny]
 113          :<|> Put    '[JSON] Int -- TODO
 114
 115 -- | TODO: access by admin only
 116 roots :: GargServer Roots
 117 roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
 118    :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
 119
 120 -------------------------------------------------------------------
 121 -- | Node API Types management
 122 -- TODO-ACCESS : access by users
 123 -- No ownership check is needed if we strictly follow the capability model.
 124 --
 125 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
 126 --             SearchAPI)
 127 -- CanRenameNode (or part of CanEditNode?)
 128 -- CanCreateChildren (PostNodeApi)
 129 -- CanEditNode / CanPutNode TODO not implemented yet
 130 -- CanDeleteNode
 131 -- CanPatch (TableNgramsApi)
 132 -- CanFavorite
 133 -- CanMoveToTrash
 134 type NodeAPI a = Get '[JSON] (Node a)
 135              :<|> "rename" :> RenameApi
 136              :<|> PostNodeApi -- TODO move to children POST
 137              :<|> Put    '[JSON] Int
 138              :<|> Delete '[JSON] Int
 139              :<|> "children"  :> ChildrenApi a
 140
 141              -- TODO gather it
 142              :<|> "table"     :> TableApi
 143              :<|> "list"      :> TableNgramsApi
 144              :<|> "listGet"   :> TableNgramsApiGet
 145              :<|> "pairing"   :> PairingApi
 146
 147              -- VIZ
 148              :<|> "chart"     :> ChartApi
 149              :<|> "phylo"     :> PhyloAPI
 150
 151              :<|> "favorites" :> FavApi
 152              :<|> "documents" :> DocsApi
 153              :<|> "search":> Summary "Node Search"
 154                         :> ReqBody '[JSON] SearchInQuery
 155                         :> QueryParam "offset" Int
 156                         :> QueryParam "limit"  Int
 157                         :> QueryParam "order"  OrderBy
 158                         :> SearchAPI
 159             :<|> "metrics" :> MetricsAPI
 160
 161 -- TODO-ACCESS: check userId CanRenameNode nodeId
 162 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 163 type RenameApi = Summary " Rename Node"
 164                :> ReqBody '[JSON] RenameNode
 165                :> Put     '[JSON] [Int]
 166
 167 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 168                  :> ReqBody '[JSON] PostNode
 169                  :> Post    '[JSON] [NodeId]
 170
 171 type ChildrenApi a = Summary " Summary children"
 172                  :> QueryParam "type"   NodeType
 173                  :> QueryParam "offset" Int
 174                  :> QueryParam "limit"  Int
 175                  :> Get '[JSON] [Node a]
 176 ------------------------------------------------------------------------
 177 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 178 nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 179 nodeAPI p uId id
 180              =  getNode     id p
 181            :<|> rename      id
 182            :<|> postNode    uId id
 183            :<|> putNode     id
 184            :<|> deleteNode  id
 185            :<|> getChildren id p
 186
 187            -- TODO gather it
 188            :<|> getTable         id
 189            :<|> tableNgramsPatch id
 190            :<|> getTableNgrams   id
 191            :<|> getPairing       id
 192
 193            :<|> getChart id
 194            :<|> phyloAPI id
 195
 196            :<|> favApi   id
 197            :<|> delDocs  id
 198            :<|> searchIn id
 199            :<|> getMetrics id
 200            -- Annuaire
 201            -- :<|> upload
 202            -- :<|> query
 203
 204 ------------------------------------------------------------------------
 205 data RenameNode = RenameNode { r_name :: Text }
 206   deriving (Generic)
 207
 208 instance FromJSON  RenameNode
 209 instance ToJSON    RenameNode
 210 instance ToSchema  RenameNode
 211 instance Arbitrary RenameNode where
 212   arbitrary = elements [RenameNode "test"]
 213 ------------------------------------------------------------------------
 214 data PostNode = PostNode { pn_name :: Text
 215                          , pn_typename :: NodeType}
 216   deriving (Generic)
 217
 218 instance FromJSON  PostNode
 219 instance ToJSON    PostNode
 220 instance ToSchema  PostNode
 221 instance Arbitrary PostNode where
 222   arbitrary = elements [PostNode "Node test" NodeCorpus]
 223
 224 ------------------------------------------------------------------------
 225 type DocsApi = Summary "Docs : Move to trash"
 226              :> ReqBody '[JSON] Documents
 227              :> Delete  '[JSON] [Int]
 228
 229 data Documents = Documents { documents :: [NodeId]}
 230   deriving (Generic)
 231
 232 instance FromJSON  Documents
 233 instance ToJSON    Documents
 234 instance ToSchema  Documents
 235
 236 delDocs :: CorpusId -> Documents -> Cmd err [Int]
 237 delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 238
 239 ------------------------------------------------------------------------
 240 type FavApi =  Summary " Favorites label"
 241             :> ReqBody '[JSON] Favorites
 242             :> Put     '[JSON] [Int]
 243           :<|> Summary " Favorites unlabel"
 244             :> ReqBody '[JSON] Favorites
 245             :> Delete  '[JSON] [Int]
 246
 247 data Favorites = Favorites { favorites :: [NodeId]}
 248   deriving (Generic)
 249
 250 instance FromJSON  Favorites
 251 instance ToJSON    Favorites
 252 instance ToSchema  Favorites
 253
 254 putFav :: CorpusId -> Favorites -> Cmd err [Int]
 255 putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 256
 257 delFav :: CorpusId -> Favorites -> Cmd err [Int]
 258 delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 259
 260 favApi :: CorpusId -> GargServer FavApi
 261 favApi cId = putFav cId :<|> delFav cId
 262
 263 ------------------------------------------------------------------------
 264 type TableApi = Summary " Table API"
 265               :> QueryParam "view"   TabType
 266               :> QueryParam "offset" Int
 267               :> QueryParam "limit"  Int
 268               :> QueryParam "order"  OrderBy
 269               :> Get '[JSON] [FacetDoc]
 270
 271 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 272 type PairingApi = Summary " Pairing API"
 273               :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
 274               :> QueryParam "offset" Int
 275               :> QueryParam "limit"  Int
 276               :> QueryParam "order"  OrderBy
 277               :> Get '[JSON] [FacetDoc]
 278
 279 ------------------------------------------------------------------------
 280 type ChartApi = Summary " Chart API"
 281               :> QueryParam "from" UTCTime
 282               :> QueryParam "to"   UTCTime
 283               :> Get '[JSON] [FacetChart]
 284
 285                 -- Depending on the Type of the Node, we could post
 286                 -- New documents for a corpus
 287                 -- New map list terms
 288              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 289
 290                 -- To launch a query and update the corpus
 291              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 292
 293 ------------------------------------------------------------------------
 294 -- TODO-ACCESS: CanGetNode
 295 -- TODO-EVENTS: No events as this is a read only query.
 296 type GraphAPI   = Get '[JSON] Graph
 297
 298 graphAPI :: NodeId -> GargServer GraphAPI
 299 graphAPI nId = do
 300   nodeGraph <- getNode nId HyperdataGraph
 301
 302   let metadata = GraphMetadata "Title" [maybe 0 identity $ _node_parentId nodeGraph]
 303                                      [ LegendField 1 "#FFF" "Cluster"
 304                                      , LegendField 2 "#FFF" "Cluster"
 305                                      ]
 306                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 307   let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
 308
 309   lId <- defaultList cId
 310   ngs    <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] NgramsTerms
 311
 312   myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal False)
 313                             <$> groupNodesByNgrams ngs
 314                             <$> getNodesByNgramsOnlyUser cId NgramsTerms (Map.keys ngs)
 315
 316   liftIO $ set graph_metadata (Just metadata) <$> cooc2graph myCooc
 317
 318
 319 type PhyloAPI = Summary "Phylo API"
 320      --         :> QueryParam "param" PhyloQueryView
 321               :> Get '[JSON] PhyloView
 322
 323 phyloAPI :: NodeId -> GargServer PhyloAPI
 324 phyloAPI n = pure $ getPhylo n
 325
 326
 327
 328 instance HasNodeError ServantErr where
 329   _NodeError = prism' mk (const Nothing) -- $ panic "HasNodeError ServantErr: not a prism")
 330     where
 331       e = "Gargantext NodeError: "
 332       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 333       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 334       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 335       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 336
 337       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 338       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 339       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 340       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 341       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 342       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 343       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 344
 345 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 346 instance HasTreeError ServantErr where
 347   _TreeError = prism' mk (const Nothing) -- $ panic "HasTreeError ServantErr: not a prism")
 348     where
 349       e = "TreeError: "
 350       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 351       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 352       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 353
 354 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 355 -- TODO-ACCESS: CanTree or CanGetNode
 356 -- TODO-EVENTS: No events as this is a read only query.
 357 treeAPI :: NodeId -> GargServer TreeAPI
 358 treeAPI = treeDB
 359
 360 ------------------------------------------------------------------------
 361 -- | Check if the name is less than 255 char
 362 rename :: NodeId -> RenameNode -> Cmd err [Int]
 363 rename nId (RenameNode name') = U.update (U.Rename nId name')
 364
 365 getTable :: NodeId -> Maybe TabType
 366          -> Maybe Offset  -> Maybe Limit
 367          -> Maybe OrderBy -> Cmd err [FacetDoc]
 368 getTable cId ft o l order =
 369   case ft of
 370     (Just Docs)  -> runViewDocuments cId False o l order
 371     (Just Trash) -> runViewDocuments cId True  o l order
 372     _     -> panic "not implemented"
 373
 374 getPairing :: ContactId -> Maybe TabType
 375          -> Maybe Offset  -> Maybe Limit
 376          -> Maybe OrderBy -> Cmd err [FacetDoc]
 377 getPairing cId ft o l order =
 378   case ft of
 379     (Just Docs)  -> runViewAuthorsDoc cId False o l order
 380     (Just Trash) -> runViewAuthorsDoc cId True  o l order
 381     _     -> panic "not implemented"
 382
 383
 384 getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
 385                    -> Cmd err [FacetChart]
 386 getChart _ _ _ = undefined -- TODO
 387
 388 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 389 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 390
 391 putNode :: NodeId -> Cmd err Int
 392 putNode = undefined -- TODO
 393
 394 query :: Monad m => Text -> m Text
 395 query s = pure s
 396
 397
 398 -- | Upload files
 399 -- TODO Is it possible to adapt the function according to iValue input ?
 400 --upload :: MultipartData -> Handler Text
 401 --upload multipartData = do
 402 --  liftIO $ do
 403 --    putStrLn "Inputs:"
 404 --    forM_ (inputs multipartData) $ \input ->
 405 --      putStrLn $ "  " <> show (iName input)
 406 --            <> " -> " <> show (iValue input)
 407 --
 408 --    forM_ (files multipartData) $ \file -> do
 409 --      content <- readFile (fdFilePath file)
 410 --      putStrLn $ "Content of " <> show (fdFileName file)
 411 --              <> " at " <> fdFilePath file
 412 --      putStrLn content
 413 --  pure (pack "Data loaded")
 414
 415 -------------------------------------------------------------------------------
 416
 417 type MetricsAPI = Summary "SepGen IncExc metrics"
 418                 :> QueryParam  "list"       ListId
 419                 :> QueryParamR "ngramsType" TabType
 420                 :> QueryParam  "limit"      Int
 421                 :> Get '[JSON] Metrics
 422
 423 getMetrics :: NodeId -> GargServer MetricsAPI
 424 getMetrics cId maybeListId tabType maybeLimit = do
 425   (ngs', scores) <- Metrics.getMetrics' cId maybeListId tabType maybeLimit
 426
 427   let
 428     metrics      = map (\(Scored t s1 s2) -> Metric t s1 s2 (listType t ngs')) scores
 429     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
 430     errorMsg     = "API.Node.metrics: key absent"
 431
 432   pure $ Metrics metrics
 433
 434
 435
 436