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(..), TableNgramsApi, apiNgramsTableCorpus, 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              :<|> "ngrams"    :> TableNgramsApi
 126              :<|> "pairing"   :> PairingApi
 127
 128              :<|> "favorites" :> FavApi
 129              :<|> "documents" :> DocsApi
 130              :<|> "search":> Summary "Node Search"
 131                         :> ReqBody '[JSON] SearchInQuery
 132                         :> QueryParam "offset" Int
 133                         :> QueryParam "limit"  Int
 134                         :> QueryParam "order"  OrderBy
 135                         :> SearchAPI
 136
 137              -- VIZ
 138              :<|> "metrics" :> MetricsAPI
 139              :<|> "chart"     :> ChartApi
 140              :<|> "pie"       :> PieApi
 141              :<|> "tree"      :> TreeApi
 142              :<|> "phylo"     :> PhyloAPI
 143
 144 -- TODO-ACCESS: check userId CanRenameNode nodeId
 145 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 146 type RenameApi = Summary " Rename Node"
 147                :> ReqBody '[JSON] RenameNode
 148                :> Put     '[JSON] [Int]
 149
 150 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 151                  :> ReqBody '[JSON] PostNode
 152                  :> Post    '[JSON] [NodeId]
 153
 154 type ChildrenApi a = Summary " Summary children"
 155                  :> QueryParam "type"   NodeType
 156                  :> QueryParam "offset" Int
 157                  :> QueryParam "limit"  Int
 158                  :> Get '[JSON] [Node a]
 159 ------------------------------------------------------------------------
 160 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 161 nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 162 nodeAPI p uId id
 163              =  getNode     id p
 164            :<|> rename      id
 165            :<|> postNode    uId id
 166            :<|> putNode     id
 167            :<|> deleteNode  id
 168            :<|> getChildren id p
 169
 170            -- TODO gather it
 171            :<|> getTable         id
 172            :<|> apiNgramsTableCorpus id
 173            :<|> getPairing       id
 174            -- :<|> getTableNgramsDoc id
 175
 176            :<|> favApi   id
 177            :<|> delDocs  id
 178            :<|> searchIn id
 179
 180            :<|> getMetrics id
 181            :<|> getChart id
 182            :<|> getPie   id
 183            :<|> getTree  id
 184            :<|> phyloAPI id
 185
 186            -- Annuaire
 187            -- :<|> query
 188
 189 ------------------------------------------------------------------------
 190 data RenameNode = RenameNode { r_name :: Text }
 191   deriving (Generic)
 192
 193 instance FromJSON  RenameNode
 194 instance ToJSON    RenameNode
 195 instance ToSchema  RenameNode
 196 instance Arbitrary RenameNode where
 197   arbitrary = elements [RenameNode "test"]
 198 ------------------------------------------------------------------------
 199 data PostNode = PostNode { pn_name :: Text
 200                          , pn_typename :: NodeType}
 201   deriving (Generic)
 202
 203 instance FromJSON  PostNode
 204 instance ToJSON    PostNode
 205 instance ToSchema  PostNode
 206 instance Arbitrary PostNode where
 207   arbitrary = elements [PostNode "Node test" NodeCorpus]
 208
 209 ------------------------------------------------------------------------
 210 type DocsApi = Summary "Docs : Move to trash"
 211              :> ReqBody '[JSON] Documents
 212              :> Delete  '[JSON] [Int]
 213
 214 data Documents = Documents { documents :: [NodeId]}
 215   deriving (Generic)
 216
 217 instance FromJSON  Documents
 218 instance ToJSON    Documents
 219 instance ToSchema  Documents
 220
 221 delDocs :: CorpusId -> Documents -> Cmd err [Int]
 222 delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 223
 224 ------------------------------------------------------------------------
 225 type FavApi =  Summary " Favorites label"
 226             :> ReqBody '[JSON] Favorites
 227             :> Put     '[JSON] [Int]
 228           :<|> Summary " Favorites unlabel"
 229             :> ReqBody '[JSON] Favorites
 230             :> Delete  '[JSON] [Int]
 231
 232 data Favorites = Favorites { favorites :: [NodeId]}
 233   deriving (Generic)
 234
 235 instance FromJSON  Favorites
 236 instance ToJSON    Favorites
 237 instance ToSchema  Favorites
 238
 239 putFav :: CorpusId -> Favorites -> Cmd err [Int]
 240 putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 241
 242 delFav :: CorpusId -> Favorites -> Cmd err [Int]
 243 delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 244
 245 favApi :: CorpusId -> GargServer FavApi
 246 favApi cId = putFav cId :<|> delFav cId
 247
 248 ------------------------------------------------------------------------
 249 type TableApi = Summary " Table API"
 250               :> QueryParam "view"   TabType
 251               :> QueryParam "offset" Int
 252               :> QueryParam "limit"  Int
 253               :> QueryParam "order"  OrderBy
 254               :> Get '[JSON] [FacetDoc]
 255
 256 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 257 type PairingApi = Summary " Pairing API"
 258               :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
 259               :> QueryParam "offset" Int
 260               :> QueryParam "limit"  Int
 261               :> QueryParam "order"  OrderBy
 262               :> Get '[JSON] [FacetDoc]
 263
 264 ------------------------------------------------------------------------
 265 type ChartApi = Summary " Chart API"
 266               :> QueryParam "from" UTCTime
 267               :> QueryParam "to"   UTCTime
 268               :> Get '[JSON] (ChartMetrics Histo)
 269
 270 type PieApi = Summary " Chart API"
 271            :> QueryParam "from" UTCTime
 272            :> QueryParam "to"   UTCTime
 273            :> QueryParamR "ngramsType" TabType
 274            :> Get '[JSON] (ChartMetrics Histo)
 275
 276 type TreeApi = Summary " Tree API"
 277            :> QueryParam "from" UTCTime
 278            :> QueryParam "to"   UTCTime
 279            :> QueryParamR "ngramsType" TabType
 280            :> QueryParamR "listType"   ListType
 281            :> Get '[JSON] (ChartMetrics [MyTree])
 282
 283
 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
 295
 296 instance HasNodeError ServantErr where
 297   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 298     where
 299       e = "Gargantext NodeError: "
 300       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 301       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 302       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 303       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 304
 305       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 306       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 307       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 308       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 309       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 310       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 311       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 312
 313 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 314 instance HasTreeError ServantErr where
 315   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 316     where
 317       e = "TreeError: "
 318       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 319       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 320       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 321
 322 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 323 -- TODO-ACCESS: CanTree or CanGetNode
 324 -- TODO-EVENTS: No events as this is a read only query.
 325 treeAPI :: NodeId -> GargServer TreeAPI
 326 treeAPI = treeDB
 327
 328 ------------------------------------------------------------------------
 329 -- | Check if the name is less than 255 char
 330 rename :: NodeId -> RenameNode -> Cmd err [Int]
 331 rename nId (RenameNode name') = U.update (U.Rename nId name')
 332
 333 getTable :: NodeId -> Maybe TabType
 334          -> Maybe Offset  -> Maybe Limit
 335          -> Maybe OrderBy -> Cmd err [FacetDoc]
 336 getTable cId ft o l order =
 337   case ft of
 338     (Just Docs)  -> runViewDocuments cId False o l order
 339     (Just Trash) -> runViewDocuments cId True  o l order
 340     _     -> panic "not implemented"
 341
 342 getPairing :: ContactId -> Maybe TabType
 343          -> Maybe Offset  -> Maybe Limit
 344          -> Maybe OrderBy -> Cmd err [FacetDoc]
 345 getPairing cId ft o l order =
 346   case ft of
 347     (Just Docs)  -> runViewAuthorsDoc cId False o l order
 348     (Just Trash) -> runViewAuthorsDoc cId True  o l order
 349     _     -> panic "not implemented"
 350
 351 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 352 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 353
 354 putNode :: NodeId -> Cmd err Int
 355 putNode = undefined -- TODO
 356
 357 query :: Monad m => Text -> m Text
 358 query s = pure s
 359
 360
 361 -------------------------------------------------------------
 362 type MetricsAPI = Summary "SepGen IncExc metrics"
 363                 :> QueryParam  "list"       ListId
 364                 :> QueryParamR "ngramsType" TabType
 365                 :> QueryParam  "limit"      Int
 366                 :> Get '[JSON] Metrics
 367
 368 getMetrics :: NodeId -> GargServer MetricsAPI
 369 getMetrics cId maybeListId tabType maybeLimit = do
 370   (ngs', scores) <- Metrics.getMetrics' cId maybeListId tabType maybeLimit
 371
 372   let
 373     metrics      = map (\(Scored t s1 s2) -> Metric t (log' 5 s1) (log' 2 s2) (listType t ngs')) scores
 374     log' n x     = 1 + (if x <= 0 then 0 else (log $ (10^(n::Int)) * x))
 375     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
 376     errorMsg     = "API.Node.metrics: key absent"
 377
 378   pure $ Metrics metrics
 379
 380