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