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              :<|> "chart"     :> ChartApi
 148              :<|> "favorites" :> FavApi
 149              :<|> "documents" :> DocsApi
 150              :<|> "search":> Summary "Node Search"
 151                         :> ReqBody '[JSON] SearchInQuery
 152                         :> QueryParam "offset" Int
 153                         :> QueryParam "limit"  Int
 154                         :> QueryParam "order"  OrderBy
 155                         :> SearchAPI
 156             :<|> "metrics" :> MetricsAPI
 157
 158 -- TODO-ACCESS: check userId CanRenameNode nodeId
 159 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 160 type RenameApi = Summary " Rename Node"
 161                :> ReqBody '[JSON] RenameNode
 162                :> Put     '[JSON] [Int]
 163
 164 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 165                  :> ReqBody '[JSON] PostNode
 166                  :> Post    '[JSON] [NodeId]
 167
 168 type ChildrenApi a = Summary " Summary children"
 169                  :> QueryParam "type"   NodeType
 170                  :> QueryParam "offset" Int
 171                  :> QueryParam "limit"  Int
 172                  :> Get '[JSON] [Node a]
 173 ------------------------------------------------------------------------
 174 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 175 nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 176 nodeAPI p uId id
 177              =  getNode     id p
 178            :<|> rename      id
 179            :<|> postNode    uId id
 180            :<|> putNode     id
 181            :<|> deleteNode  id
 182            :<|> getChildren id p
 183
 184            -- TODO gather it
 185            :<|> getTable         id
 186            :<|> tableNgramsPatch id
 187            :<|> getTableNgrams   id
 188            :<|> getPairing       id
 189
 190            :<|> getChart id
 191            :<|> favApi   id
 192            :<|> delDocs  id
 193            :<|> searchIn id
 194            :<|> getMetrics id
 195            -- Annuaire
 196            -- :<|> upload
 197            -- :<|> query
 198
 199 ------------------------------------------------------------------------
 200 data RenameNode = RenameNode { r_name :: Text }
 201   deriving (Generic)
 202
 203 instance FromJSON  RenameNode
 204 instance ToJSON    RenameNode
 205 instance ToSchema  RenameNode
 206 instance Arbitrary RenameNode where
 207   arbitrary = elements [RenameNode "test"]
 208 ------------------------------------------------------------------------
 209 data PostNode = PostNode { pn_name :: Text
 210                          , pn_typename :: NodeType}
 211   deriving (Generic)
 212
 213 instance FromJSON  PostNode
 214 instance ToJSON    PostNode
 215 instance ToSchema  PostNode
 216 instance Arbitrary PostNode where
 217   arbitrary = elements [PostNode "Node test" NodeCorpus]
 218
 219 ------------------------------------------------------------------------
 220 type DocsApi = Summary "Docs : Move to trash"
 221              :> ReqBody '[JSON] Documents
 222              :> Delete  '[JSON] [Int]
 223
 224 data Documents = Documents { documents :: [NodeId]}
 225   deriving (Generic)
 226
 227 instance FromJSON  Documents
 228 instance ToJSON    Documents
 229 instance ToSchema  Documents
 230
 231 delDocs :: CorpusId -> Documents -> Cmd err [Int]
 232 delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 233
 234 ------------------------------------------------------------------------
 235 type FavApi =  Summary " Favorites label"
 236             :> ReqBody '[JSON] Favorites
 237             :> Put     '[JSON] [Int]
 238           :<|> Summary " Favorites unlabel"
 239             :> ReqBody '[JSON] Favorites
 240             :> Delete  '[JSON] [Int]
 241
 242 data Favorites = Favorites { favorites :: [NodeId]}
 243   deriving (Generic)
 244
 245 instance FromJSON  Favorites
 246 instance ToJSON    Favorites
 247 instance ToSchema  Favorites
 248
 249 putFav :: CorpusId -> Favorites -> Cmd err [Int]
 250 putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 251
 252 delFav :: CorpusId -> Favorites -> Cmd err [Int]
 253 delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 254
 255 favApi :: CorpusId -> GargServer FavApi
 256 favApi cId = putFav cId :<|> delFav cId
 257
 258 ------------------------------------------------------------------------
 259 type TableApi = Summary " Table API"
 260               :> QueryParam "view"   TabType
 261               :> QueryParam "offset" Int
 262               :> QueryParam "limit"  Int
 263               :> QueryParam "order"  OrderBy
 264               :> Get '[JSON] [FacetDoc]
 265
 266 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 267 type PairingApi = Summary " Pairing API"
 268               :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
 269               :> QueryParam "offset" Int
 270               :> QueryParam "limit"  Int
 271               :> QueryParam "order"  OrderBy
 272               :> Get '[JSON] [FacetDoc]
 273
 274 ------------------------------------------------------------------------
 275 type ChartApi = Summary " Chart API"
 276               :> QueryParam "from" UTCTime
 277               :> QueryParam "to"   UTCTime
 278               :> Get '[JSON] [FacetChart]
 279
 280                 -- Depending on the Type of the Node, we could post
 281                 -- New documents for a corpus
 282                 -- New map list terms
 283              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 284
 285                 -- To launch a query and update the corpus
 286              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 287
 288 ------------------------------------------------------------------------
 289 -- TODO-ACCESS: CanGetNode
 290 -- TODO-EVENTS: No events as this is a read only query.
 291 type GraphAPI   = Get '[JSON] Graph
 292
 293 graphAPI :: NodeId -> GargServer GraphAPI
 294 graphAPI nId = do
 295   nodeGraph <- getNode nId HyperdataGraph
 296
 297   let metadata = GraphMetadata "Title" [maybe 0 identity $ _node_parentId nodeGraph]
 298                                      [ LegendField 1 "#FFF" "Cluster"
 299                                      , LegendField 2 "#FFF" "Cluster"
 300                                      ]
 301                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 302   let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
 303
 304   lId <- defaultList cId
 305   ngs    <- filterListWithRoot GraphTerm <$> mapTermListRoot [lId] NgramsTerms
 306
 307   myCooc <- Map.filter (>1) <$> getCoocByNgrams (Diagonal False)
 308                             <$> groupNodesByNgrams ngs
 309                             <$> getNodesByNgramsOnlyUser cId NgramsTerms (Map.keys ngs)
 310
 311   liftIO $ set graph_metadata (Just metadata) <$> cooc2graph myCooc
 312
 313
 314 instance HasNodeError ServantErr where
 315   _NodeError = prism' mk (const Nothing) -- $ panic "HasNodeError ServantErr: not a prism")
 316     where
 317       e = "Gargantext NodeError: "
 318       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 319       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 320       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 321       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 322
 323       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 324       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 325       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 326       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 327       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 328       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 329       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 330
 331 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 332 instance HasTreeError ServantErr where
 333   _TreeError = prism' mk (const Nothing) -- $ panic "HasTreeError ServantErr: not a prism")
 334     where
 335       e = "TreeError: "
 336       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 337       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 338       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 339
 340 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 341 -- TODO-ACCESS: CanTree or CanGetNode
 342 -- TODO-EVENTS: No events as this is a read only query.
 343 treeAPI :: NodeId -> GargServer TreeAPI
 344 treeAPI = treeDB
 345
 346 ------------------------------------------------------------------------
 347 -- | Check if the name is less than 255 char
 348 rename :: NodeId -> RenameNode -> Cmd err [Int]
 349 rename nId (RenameNode name') = U.update (U.Rename nId name')
 350
 351 getTable :: NodeId -> Maybe TabType
 352          -> Maybe Offset  -> Maybe Limit
 353          -> Maybe OrderBy -> Cmd err [FacetDoc]
 354 getTable cId ft o l order =
 355   case ft of
 356     (Just Docs)  -> runViewDocuments cId False o l order
 357     (Just Trash) -> runViewDocuments cId True  o l order
 358     _     -> panic "not implemented"
 359
 360 getPairing :: ContactId -> Maybe TabType
 361          -> Maybe Offset  -> Maybe Limit
 362          -> Maybe OrderBy -> Cmd err [FacetDoc]
 363 getPairing cId ft o l order =
 364   case ft of
 365     (Just Docs)  -> runViewAuthorsDoc cId False o l order
 366     (Just Trash) -> runViewAuthorsDoc cId True  o l order
 367     _     -> panic "not implemented"
 368
 369
 370 getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
 371                    -> Cmd err [FacetChart]
 372 getChart _ _ _ = undefined -- TODO
 373
 374 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 375 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 376
 377 putNode :: NodeId -> Cmd err Int
 378 putNode = undefined -- TODO
 379
 380 query :: Monad m => Text -> m Text
 381 query s = pure s
 382
 383
 384 -- | Upload files
 385 -- TODO Is it possible to adapt the function according to iValue input ?
 386 --upload :: MultipartData -> Handler Text
 387 --upload multipartData = do
 388 --  liftIO $ do
 389 --    putStrLn "Inputs:"
 390 --    forM_ (inputs multipartData) $ \input ->
 391 --      putStrLn $ "  " <> show (iName input)
 392 --            <> " -> " <> show (iValue input)
 393 --
 394 --    forM_ (files multipartData) $ \file -> do
 395 --      content <- readFile (fdFilePath file)
 396 --      putStrLn $ "Content of " <> show (fdFileName file)
 397 --              <> " at " <> fdFilePath file
 398 --      putStrLn content
 399 --  pure (pack "Data loaded")
 400
 401 -------------------------------------------------------------------------------
 402
 403 type MetricsAPI = Summary "SepGen IncExc metrics"
 404                 :> QueryParam  "list"       ListId
 405                 :> QueryParamR "ngramsType" TabType
 406                 :> QueryParam  "limit"      Int
 407                 :> Get '[JSON] Metrics
 408
 409 getMetrics :: NodeId -> GargServer MetricsAPI
 410 getMetrics cId maybeListId tabType maybeLimit = do
 411   (ngs', scores) <- Metrics.getMetrics' cId maybeListId tabType maybeLimit
 412
 413   let
 414     metrics      = map (\(Scored t s1 s2) -> Metric t s1 s2 (listType t ngs')) scores
 415     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
 416     errorMsg     = "API.Node.metrics: key absent"
 417
 418   pure $ Metrics metrics
 419
 420
 421
 422