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