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, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, 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)
  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 Servant
  65 import Test.QuickCheck (elements)
  66 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  67 import qualified Data.Map as Map
  68 import qualified Gargantext.Database.Metrics as Metrics
  69 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  70
  71 {-
  72 import qualified Gargantext.Text.List.Learn as Learn
  73 import qualified Data.Vector as Vec
  74 --}
  75
  76
  77 type NodesAPI  = Delete '[JSON] Int
  78
  79 -- | Delete Nodes
  80 -- Be careful: really delete nodes
  81 -- Access by admin only
  82 nodesAPI :: [NodeId] -> GargServer NodesAPI
  83 nodesAPI ids = deleteNodes ids
  84
  85 ------------------------------------------------------------------------
  86 -- | TODO-ACCESS: access by admin only.
  87 -- At first let's just have an isAdmin check.
  88 -- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
  89 -- To manage the Users roots
  90 -- TODO-EVENTS:
  91 --   PutNode ?
  92 -- TODO needs design discussion.
  93 type Roots =  Get    '[JSON] [NodeAny]
  94          :<|> Put    '[JSON] Int -- TODO
  95
  96 -- | TODO: access by admin only
  97 roots :: GargServer Roots
  98 roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
  99    :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
 100
 101 -------------------------------------------------------------------
 102 -- | Node API Types management
 103 -- TODO-ACCESS : access by users
 104 -- No ownership check is needed if we strictly follow the capability model.
 105 --
 106 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
 107 --             SearchAPI)
 108 -- CanRenameNode (or part of CanEditNode?)
 109 -- CanCreateChildren (PostNodeApi)
 110 -- CanEditNode / CanPutNode TODO not implemented yet
 111 -- CanDeleteNode
 112 -- CanPatch (TableNgramsApi)
 113 -- CanFavorite
 114 -- CanMoveToTrash
 115 type NodeAPI a = Get '[JSON] (Node a)
 116              :<|> "rename" :> RenameApi
 117              :<|> PostNodeApi -- TODO move to children POST
 118              :<|> Put    '[JSON] Int
 119              :<|> Delete '[JSON] Int
 120              :<|> "children"  :> ChildrenApi a
 121
 122              -- TODO gather it
 123              :<|> "table"     :> TableApi
 124              :<|> "list"      :> TableNgramsApi
 125              :<|> "listGet"   :> TableNgramsApiGet
 126              :<|> "pairing"   :> PairingApi
 127
 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              :<|> "phylo"     :> PhyloAPI
 142
 143 -- TODO-ACCESS: check userId CanRenameNode nodeId
 144 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 145 type RenameApi = Summary " Rename Node"
 146                :> ReqBody '[JSON] RenameNode
 147                :> Put     '[JSON] [Int]
 148
 149 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 150                  :> ReqBody '[JSON] PostNode
 151                  :> Post    '[JSON] [NodeId]
 152
 153 type ChildrenApi a = Summary " Summary children"
 154                  :> QueryParam "type"   NodeType
 155                  :> QueryParam "offset" Int
 156                  :> QueryParam "limit"  Int
 157                  :> Get '[JSON] [Node a]
 158 ------------------------------------------------------------------------
 159 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 160 nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 161 nodeAPI p uId id
 162              =  getNode     id p
 163            :<|> rename      id
 164            :<|> postNode    uId id
 165            :<|> putNode     id
 166            :<|> deleteNode  id
 167            :<|> getChildren id p
 168
 169            -- TODO gather it
 170            :<|> getTable         id
 171            :<|> tableNgramsPatch id
 172            :<|> getTableNgrams   id
 173            :<|> getPairing       id
 174
 175            :<|> favApi   id
 176            :<|> delDocs  id
 177            :<|> searchIn id
 178
 179            :<|> getMetrics id
 180            :<|> getChart id
 181            :<|> phyloAPI id
 182            -- Annuaire
 183            -- :<|> upload
 184            -- :<|> query
 185
 186 ------------------------------------------------------------------------
 187 data RenameNode = RenameNode { r_name :: Text }
 188   deriving (Generic)
 189
 190 instance FromJSON  RenameNode
 191 instance ToJSON    RenameNode
 192 instance ToSchema  RenameNode
 193 instance Arbitrary RenameNode where
 194   arbitrary = elements [RenameNode "test"]
 195 ------------------------------------------------------------------------
 196 data PostNode = PostNode { pn_name :: Text
 197                          , pn_typename :: NodeType}
 198   deriving (Generic)
 199
 200 instance FromJSON  PostNode
 201 instance ToJSON    PostNode
 202 instance ToSchema  PostNode
 203 instance Arbitrary PostNode where
 204   arbitrary = elements [PostNode "Node test" NodeCorpus]
 205
 206 ------------------------------------------------------------------------
 207 type DocsApi = Summary "Docs : Move to trash"
 208              :> ReqBody '[JSON] Documents
 209              :> Delete  '[JSON] [Int]
 210
 211 data Documents = Documents { documents :: [NodeId]}
 212   deriving (Generic)
 213
 214 instance FromJSON  Documents
 215 instance ToJSON    Documents
 216 instance ToSchema  Documents
 217
 218 delDocs :: CorpusId -> Documents -> Cmd err [Int]
 219 delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 220
 221 ------------------------------------------------------------------------
 222 type FavApi =  Summary " Favorites label"
 223             :> ReqBody '[JSON] Favorites
 224             :> Put     '[JSON] [Int]
 225           :<|> Summary " Favorites unlabel"
 226             :> ReqBody '[JSON] Favorites
 227             :> Delete  '[JSON] [Int]
 228
 229 data Favorites = Favorites { favorites :: [NodeId]}
 230   deriving (Generic)
 231
 232 instance FromJSON  Favorites
 233 instance ToJSON    Favorites
 234 instance ToSchema  Favorites
 235
 236 putFav :: CorpusId -> Favorites -> Cmd err [Int]
 237 putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 238
 239 delFav :: CorpusId -> Favorites -> Cmd err [Int]
 240 delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 241
 242 favApi :: CorpusId -> GargServer FavApi
 243 favApi cId = putFav cId :<|> delFav cId
 244
 245 ------------------------------------------------------------------------
 246 type TableApi = Summary " Table API"
 247               :> QueryParam "view"   TabType
 248               :> QueryParam "offset" Int
 249               :> QueryParam "limit"  Int
 250               :> QueryParam "order"  OrderBy
 251               :> Get '[JSON] [FacetDoc]
 252
 253 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 254 type PairingApi = Summary " Pairing API"
 255               :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
 256               :> QueryParam "offset" Int
 257               :> QueryParam "limit"  Int
 258               :> QueryParam "order"  OrderBy
 259               :> Get '[JSON] [FacetDoc]
 260
 261 ------------------------------------------------------------------------
 262 type ChartApi = Summary " Chart API"
 263               :> QueryParam "from" UTCTime
 264               :> QueryParam "to"   UTCTime
 265               :> Get '[JSON] (ChartMetrics Histo)
 266
 267                 -- Depending on the Type of the Node, we could post
 268                 -- New documents for a corpus
 269                 -- New map list terms
 270              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 271
 272                 -- To launch a query and update the corpus
 273              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 274
 275 ------------------------------------------------------------------------
 276
 277
 278 instance HasNodeError ServantErr where
 279   _NodeError = prism' mk (const Nothing) -- $ panic "HasNodeError ServantErr: not a prism")
 280     where
 281       e = "Gargantext NodeError: "
 282       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 283       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 284       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 285       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 286
 287       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 288       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 289       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 290       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 291       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 292       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 293       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 294
 295 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 296 instance HasTreeError ServantErr where
 297   _TreeError = prism' mk (const Nothing) -- $ panic "HasTreeError ServantErr: not a prism")
 298     where
 299       e = "TreeError: "
 300       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 301       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 302       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 303
 304 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 305 -- TODO-ACCESS: CanTree or CanGetNode
 306 -- TODO-EVENTS: No events as this is a read only query.
 307 treeAPI :: NodeId -> GargServer TreeAPI
 308 treeAPI = treeDB
 309
 310 ------------------------------------------------------------------------
 311 -- | Check if the name is less than 255 char
 312 rename :: NodeId -> RenameNode -> Cmd err [Int]
 313 rename nId (RenameNode name') = U.update (U.Rename nId name')
 314
 315 getTable :: NodeId -> Maybe TabType
 316          -> Maybe Offset  -> Maybe Limit
 317          -> Maybe OrderBy -> Cmd err [FacetDoc]
 318 getTable cId ft o l order =
 319   case ft of
 320     (Just Docs)  -> runViewDocuments cId False o l order
 321     (Just Trash) -> runViewDocuments cId True  o l order
 322     _     -> panic "not implemented"
 323
 324 getPairing :: ContactId -> Maybe TabType
 325          -> Maybe Offset  -> Maybe Limit
 326          -> Maybe OrderBy -> Cmd err [FacetDoc]
 327 getPairing cId ft o l order =
 328   case ft of
 329     (Just Docs)  -> runViewAuthorsDoc cId False o l order
 330     (Just Trash) -> runViewAuthorsDoc cId True  o l order
 331     _     -> panic "not implemented"
 332
 333 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 334 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 335
 336 putNode :: NodeId -> Cmd err Int
 337 putNode = undefined -- TODO
 338
 339 query :: Monad m => Text -> m Text
 340 query s = pure s
 341
 342
 343 -- | Upload files
 344 -- TODO Is it possible to adapt the function according to iValue input ?
 345 --upload :: MultipartData -> Handler Text
 346 --upload multipartData = do
 347 --  liftIO $ do
 348 --    putStrLn "Inputs:"
 349 --    forM_ (inputs multipartData) $ \input ->
 350 --      putStrLn $ "  " <> show (iName input)
 351 --            <> " -> " <> show (iValue input)
 352 --
 353 --    forM_ (files multipartData) $ \file -> do
 354 --      content <- readFile (fdFilePath file)
 355 --      putStrLn $ "Content of " <> show (fdFileName file)
 356 --              <> " at " <> fdFilePath file
 357 --      putStrLn content
 358 --  pure (pack "Data loaded")
 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 s1 s2 (listType t ngs')) scores
 374     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
 375     errorMsg     = "API.Node.metrics: key absent"
 376
 377   pure $ Metrics metrics
 378
 379
 380
 381