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