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            -- :<|> upload
 190            -- :<|> query
 191
 192 ------------------------------------------------------------------------
 193 data RenameNode = RenameNode { r_name :: Text }
 194   deriving (Generic)
 195
 196 instance FromJSON  RenameNode
 197 instance ToJSON    RenameNode
 198 instance ToSchema  RenameNode
 199 instance Arbitrary RenameNode where
 200   arbitrary = elements [RenameNode "test"]
 201 ------------------------------------------------------------------------
 202 data PostNode = PostNode { pn_name :: Text
 203                          , pn_typename :: NodeType}
 204   deriving (Generic)
 205
 206 instance FromJSON  PostNode
 207 instance ToJSON    PostNode
 208 instance ToSchema  PostNode
 209 instance Arbitrary PostNode where
 210   arbitrary = elements [PostNode "Node test" NodeCorpus]
 211
 212 ------------------------------------------------------------------------
 213 type DocsApi = Summary "Docs : Move to trash"
 214              :> ReqBody '[JSON] Documents
 215              :> Delete  '[JSON] [Int]
 216
 217 data Documents = Documents { documents :: [NodeId]}
 218   deriving (Generic)
 219
 220 instance FromJSON  Documents
 221 instance ToJSON    Documents
 222 instance ToSchema  Documents
 223
 224 delDocs :: CorpusId -> Documents -> Cmd err [Int]
 225 delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 226
 227 ------------------------------------------------------------------------
 228 type FavApi =  Summary " Favorites label"
 229             :> ReqBody '[JSON] Favorites
 230             :> Put     '[JSON] [Int]
 231           :<|> Summary " Favorites unlabel"
 232             :> ReqBody '[JSON] Favorites
 233             :> Delete  '[JSON] [Int]
 234
 235 data Favorites = Favorites { favorites :: [NodeId]}
 236   deriving (Generic)
 237
 238 instance FromJSON  Favorites
 239 instance ToJSON    Favorites
 240 instance ToSchema  Favorites
 241
 242 putFav :: CorpusId -> Favorites -> Cmd err [Int]
 243 putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 244
 245 delFav :: CorpusId -> Favorites -> Cmd err [Int]
 246 delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 247
 248 favApi :: CorpusId -> GargServer FavApi
 249 favApi cId = putFav cId :<|> delFav cId
 250
 251 ------------------------------------------------------------------------
 252 type TableApi = Summary " Table API"
 253               :> QueryParam "view"   TabType
 254               :> QueryParam "offset" Int
 255               :> QueryParam "limit"  Int
 256               :> QueryParam "order"  OrderBy
 257               :> Get '[JSON] [FacetDoc]
 258
 259 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 260 type PairingApi = Summary " Pairing API"
 261               :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
 262               :> QueryParam "offset" Int
 263               :> QueryParam "limit"  Int
 264               :> QueryParam "order"  OrderBy
 265               :> Get '[JSON] [FacetDoc]
 266
 267 ------------------------------------------------------------------------
 268 type ChartApi = Summary " Chart API"
 269               :> QueryParam "from" UTCTime
 270               :> QueryParam "to"   UTCTime
 271               :> Get '[JSON] (ChartMetrics Histo)
 272
 273 type PieApi = Summary " Chart API"
 274            :> QueryParam "from" UTCTime
 275            :> QueryParam "to"   UTCTime
 276            :> QueryParamR "ngramsType" TabType
 277            :> Get '[JSON] (ChartMetrics Histo)
 278
 279 type TreeApi = Summary " Tree API"
 280            :> QueryParam "from" UTCTime
 281            :> QueryParam "to"   UTCTime
 282            :> QueryParamR "ngramsType" TabType
 283            :> QueryParamR "listType"   ListType
 284            :> Get '[JSON] (ChartMetrics [MyTree])
 285
 286
 287
 288                 -- Depending on the Type of the Node, we could post
 289                 -- New documents for a corpus
 290                 -- New map list terms
 291              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 292
 293                 -- To launch a query and update the corpus
 294              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 295
 296 ------------------------------------------------------------------------
 297
 298
 299 instance HasNodeError ServantErr where
 300   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 301     where
 302       e = "Gargantext NodeError: "
 303       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 304       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 305       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 306       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 307
 308       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 309       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 310       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 311       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 312       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 313       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 314       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 315
 316 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 317 instance HasTreeError ServantErr where
 318   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 319     where
 320       e = "TreeError: "
 321       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 322       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 323       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 324
 325 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 326 -- TODO-ACCESS: CanTree or CanGetNode
 327 -- TODO-EVENTS: No events as this is a read only query.
 328 treeAPI :: NodeId -> GargServer TreeAPI
 329 treeAPI = treeDB
 330
 331 ------------------------------------------------------------------------
 332 -- | Check if the name is less than 255 char
 333 rename :: NodeId -> RenameNode -> Cmd err [Int]
 334 rename nId (RenameNode name') = U.update (U.Rename nId name')
 335
 336 getTable :: NodeId -> Maybe TabType
 337          -> Maybe Offset  -> Maybe Limit
 338          -> Maybe OrderBy -> Cmd err [FacetDoc]
 339 getTable cId ft o l order =
 340   case ft of
 341     (Just Docs)  -> runViewDocuments cId False o l order
 342     (Just Trash) -> runViewDocuments cId True  o l order
 343     _     -> panic "not implemented"
 344
 345 getPairing :: ContactId -> Maybe TabType
 346          -> Maybe Offset  -> Maybe Limit
 347          -> Maybe OrderBy -> Cmd err [FacetDoc]
 348 getPairing cId ft o l order =
 349   case ft of
 350     (Just Docs)  -> runViewAuthorsDoc cId False o l order
 351     (Just Trash) -> runViewAuthorsDoc cId True  o l order
 352     _     -> panic "not implemented"
 353
 354 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 355 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 356
 357 putNode :: NodeId -> Cmd err Int
 358 putNode = undefined -- TODO
 359
 360 query :: Monad m => Text -> m Text
 361 query s = pure s
 362
 363
 364 -- | Upload files
 365 -- TODO Is it possible to adapt the function according to iValue input ?
 366 --upload :: MultipartData -> Handler Text
 367 --upload multipartData = do
 368 --  liftIO $ do
 369 --    putStrLn "Inputs:"
 370 --    forM_ (inputs multipartData) $ \input ->
 371 --      putStrLn $ "  " <> show (iName input)
 372 --            <> " -> " <> show (iValue input)
 373 --
 374 --    forM_ (files multipartData) $ \file -> do
 375 --      content <- readFile (fdFilePath file)
 376 --      putStrLn $ "Content of " <> show (fdFileName file)
 377 --              <> " at " <> fdFilePath file
 378 --      putStrLn content
 379 --  pure (pack "Data loaded")
 380
 381 -------------------------------------------------------------------------------
 382
 383 type MetricsAPI = Summary "SepGen IncExc metrics"
 384                 :> QueryParam  "list"       ListId
 385                 :> QueryParamR "ngramsType" TabType
 386                 :> QueryParam  "limit"      Int
 387                 :> Get '[JSON] Metrics
 388
 389 getMetrics :: NodeId -> GargServer MetricsAPI
 390 getMetrics cId maybeListId tabType maybeLimit = do
 391   (ngs', scores) <- Metrics.getMetrics' cId maybeListId tabType maybeLimit
 392
 393   let
 394     metrics      = map (\(Scored t s1 s2) -> Metric t (log' 5 s1) (log' 2 s2) (listType t ngs')) scores
 395     log' n x     = 1 + (if x <= 0 then 0 else (log $ (10^(n::Int)) * x))
 396     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
 397     errorMsg     = "API.Node.metrics: key absent"
 398
 399   pure $ Metrics metrics
 400
 401