[FIX] rdf lib.
[gargantext.git] / src / Gargantext / API / Node.hs
index a8113938fdbba0e865f2c89d85388542d61b5f3b..4688e6bf56c9d67e840e2efa09daccbaa294afc4 100644 (file)
@@ -7,101 +7,114 @@ Maintainer  : team@gargantext.org
 Stability   : experimental
 Portability : POSIX
 
+
+-- TODO-ACCESS: CanGetNode
+-- TODO-EVENTS: No events as this is a read only query.
 Node API
+
+-------------------------------------------------------------------
+-- TODO-ACCESS: access by admin only.
+--              At first let's just have an isAdmin check.
+--              Later: check userId CanDeleteNodes Nothing
+-- TODO-EVENTS: DeletedNodes [NodeId]
+--              {"tag": "DeletedNodes", "nodes": [Int*]}
+
+
 -}
 
-{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE NoImplicitPrelude  #-}
 {-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RankNTypes         #-}
 {-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeOperators      #-}
 
--------------------------------------------------------------------
 module Gargantext.API.Node
-  ( module Gargantext.API.Node
-  , HyperdataAny(..)
-  , HyperdataAnnuaire(..)
-  , HyperdataCorpus(..)
-  , HyperdataResource(..)
-  , HyperdataUser(..)
-  , HyperdataDocument(..)
-  , HyperdataDocumentV3(..)
-  ) where
--------------------------------------------------------------------
+  where
+
 import Control.Lens (prism')
-import Control.Monad.IO.Class (liftIO)
 import Control.Monad ((>>))
---import System.IO (putStrLn, readFile)
-
+import Control.Monad.IO.Class (liftIO)
 import Data.Aeson (FromJSON, ToJSON)
---import Data.Text (Text(), pack)
-import Data.Text (Text())
 import Data.Swagger
+import Data.Text (Text())
 import Data.Time (UTCTime)
-
-import Database.PostgreSQL.Simple (Connection)
-
 import GHC.Generics (Generic)
-import Servant
-
-import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet,tableNgramsPatch, getTableNgrams, NgramsIdPatchsFeed, NgramsIdPatchsBack, NgramsTable)
-import Gargantext.Prelude
-import Gargantext.Database.Types.Node
-import Gargantext.Database.Node ( runCmd
-                                , getNodesWithParentId
-                                , getNode, getNodesWith, CorpusId
-                                , deleteNode, deleteNodes, mk, JSONB)
-import qualified Gargantext.Database.Node.Update as U (update, Update(..))
-import Gargantext.Database.Facet (FacetDoc , runViewDocuments', OrderBy(..)
-                                 ,FacetChart)
-import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
-import Gargantext.Database.NodeNode (nodesToFavorite, nodesToTrash)
--- Graph
---import Gargantext.Text.Flow
-import Gargantext.Viz.Graph (Graph,readGraphFromJson,defaultGraph)
--- import Gargantext.Core (Lang(..))
+import Gargantext.API.Metrics
+import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, QueryParamR)
+import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
+import Gargantext.API.Types
 import Gargantext.Core.Types (Offset, Limit)
-import Gargantext.Core.Types.Main (Tree, NodeTree, ListId)
--- import Gargantext.Text.Terms (TermType(..))
-
+import Gargantext.Core.Types.Main (Tree, NodeTree)
+import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),runViewAuthorsDoc)
+import Gargantext.Database.Node.Children (getChildren)
+import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mkNodeWithParent, JSONB, NodeError(..), HasNodeError(..))
+import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
+import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
+import Gargantext.Database.Types.Node
+import Gargantext.Database.Utils -- (Cmd, CmdM)
+import Gargantext.Prelude
+import Gargantext.Text.Metrics (Scored(..))
+import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
+import Gargantext.Viz.Chart
+import Servant
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+import qualified Data.Map as Map
+import qualified Gargantext.Database.Metrics as Metrics
+import qualified Gargantext.Database.Node.Update as U (update, Update(..))
+
+{-
+import qualified Gargantext.Text.List.Learn as Learn
+import qualified Data.Vector as Vec
+--}
+
 
--------------------------------------------------------------------
--- | TODO : access by admin only
 type NodesAPI  = Delete '[JSON] Int
 
 -- | Delete Nodes
 -- Be careful: really delete nodes
 -- Access by admin only
-nodesAPI :: Connection -> [NodeId] -> Server NodesAPI
-nodesAPI conn ids = deleteNodes' conn ids
+nodesAPI :: [NodeId] -> GargServer NodesAPI
+nodesAPI ids = deleteNodes ids
 
 ------------------------------------------------------------------------
--- | TODO: access by admin only
--- To manager the Users roots
+-- | TODO-ACCESS: access by admin only.
+-- At first let's just have an isAdmin check.
+-- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
+-- To manage the Users roots
+-- TODO-EVENTS:
+--   PutNode ?
+-- TODO needs design discussion.
 type Roots =  Get    '[JSON] [NodeAny]
-         :<|> Post   '[JSON] Int -- TODO
          :<|> Put    '[JSON] Int -- TODO
-         :<|> Delete '[JSON] Int -- TODO
 
 -- | TODO: access by admin only
-roots :: Connection -> Server Roots
-roots conn = liftIO (putStrLn ( "/user" :: Text) >> getNodesWithParentId 0 Nothing conn)
-          :<|> pure (panic "not implemented yet") -- TODO
-          :<|> pure (panic "not implemented yet") -- TODO
-          :<|> pure (panic "not implemented yet") -- TODO
+roots :: GargServer Roots
+roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
+   :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
 
 -------------------------------------------------------------------
 -- | Node API Types management
--- TODO : access by users
+-- TODO-ACCESS : access by users
+-- No ownership check is needed if we strictly follow the capability model.
+--
+-- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
+--             SearchAPI)
+-- CanRenameNode (or part of CanEditNode?)
+-- CanCreateChildren (PostNodeApi)
+-- CanEditNode / CanPutNode TODO not implemented yet
+-- CanDeleteNode
+-- CanPatch (TableNgramsApi)
+-- CanFavorite
+-- CanMoveToTrash
 type NodeAPI a = Get '[JSON] (Node a)
              :<|> "rename" :> RenameApi
-             :<|> PostNodeApi
+             :<|> PostNodeApi -- TODO move to children POST
              :<|> Put    '[JSON] Int
              :<|> Delete '[JSON] Int
              :<|> "children"  :> ChildrenApi a
@@ -110,18 +123,32 @@ type NodeAPI a = Get '[JSON] (Node a)
              :<|> "table"     :> TableApi
              :<|> "list"      :> TableNgramsApi
              :<|> "listGet"   :> TableNgramsApiGet
-
-             :<|> "chart"     :> ChartApi
+             :<|> "pairing"   :> PairingApi
+             
+             
              :<|> "favorites" :> FavApi
              :<|> "documents" :> DocsApi
+             :<|> "search":> Summary "Node Search"
+                        :> ReqBody '[JSON] SearchInQuery
+                        :> QueryParam "offset" Int
+                        :> QueryParam "limit"  Int
+                        :> QueryParam "order"  OrderBy
+                        :> SearchAPI
+             
+             -- VIZ
+             :<|> "metrics" :> MetricsAPI
+             :<|> "chart"     :> ChartApi
+             :<|> "phylo"     :> PhyloAPI
 
-type RenameApi = Summary " RenameNode Node"
+-- TODO-ACCESS: check userId CanRenameNode nodeId
+-- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
+type RenameApi = Summary " Rename Node"
                :> ReqBody '[JSON] RenameNode
                :> Put     '[JSON] [Int]
 
 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
                  :> ReqBody '[JSON] PostNode
-                 :> Post    '[JSON] [Int]
+                 :> Post    '[JSON] [NodeId]
 
 type ChildrenApi a = Summary " Summary children"
                  :> QueryParam "type"   NodeType
@@ -130,26 +157,32 @@ type ChildrenApi a = Summary " Summary children"
                  :> Get '[JSON] [Node a]
 ------------------------------------------------------------------------
 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
-nodeAPI :: JSONB a => Connection -> proxy a -> NodeId -> Server (NodeAPI a)
-nodeAPI conn p id
-                =  liftIO (getNode conn id p)
-              :<|> rename        conn id
-              :<|> postNode      conn id
-              :<|> putNode       conn id
-              :<|> deleteNode'   conn id
-              :<|> getNodesWith' conn id p
-              
-              -- TODO gather it
-              :<|> getTable      conn id
-              :<|> tableNgramsPatch'  conn id
-              :<|> getTableNgrams' conn id
-
-              :<|> getChart      conn id
-              :<|> favApi        conn id
-              :<|> delDocs       conn id
-              -- Annuaire
-              -- :<|> upload
-              -- :<|> query
+nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
+nodeAPI p uId id
+             =  getNode     id p
+           :<|> rename      id
+           :<|> postNode    uId id
+           :<|> putNode     id
+           :<|> deleteNode  id
+           :<|> getChildren id p
+
+           -- TODO gather it
+           :<|> getTable         id
+           :<|> tableNgramsPatch id
+           :<|> getTableNgrams   id
+           :<|> getPairing       id
+           
+           :<|> favApi   id
+           :<|> delDocs  id
+           :<|> searchIn id
+           
+           :<|> getMetrics id
+           :<|> getChart id
+           :<|> phyloAPI id
+           -- Annuaire
+           -- :<|> upload
+           -- :<|> query
+
 ------------------------------------------------------------------------
 data RenameNode = RenameNode { r_name :: Text }
   deriving (Generic)
@@ -182,9 +215,8 @@ instance FromJSON  Documents
 instance ToJSON    Documents
 instance ToSchema  Documents
 
-delDocs :: Connection -> CorpusId -> Documents -> Handler [Int]
-delDocs c cId ds = liftIO $ nodesToTrash c
-                $ map (\n -> (cId, n, True)) $ documents ds
+delDocs :: CorpusId -> Documents -> Cmd err [Int]
+delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 
 ------------------------------------------------------------------------
 type FavApi =  Summary " Favorites label"
@@ -201,17 +233,14 @@ instance FromJSON  Favorites
 instance ToJSON    Favorites
 instance ToSchema  Favorites
 
-putFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
-putFav c cId fs = liftIO $ nodesToFavorite c
-                $ map (\n -> (cId, n, True)) $ favorites fs
+putFav :: CorpusId -> Favorites -> Cmd err [Int]
+putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 
-delFav :: Connection -> CorpusId -> Favorites -> Handler [Int]
-delFav c cId fs = liftIO $ nodesToFavorite c
-                $ map (\n -> (cId, n, False)) $ favorites fs
+delFav :: CorpusId -> Favorites -> Cmd err [Int]
+delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 
-favApi :: Connection -> CorpusId -> (Favorites -> Handler [Int])
-                               :<|> (Favorites -> Handler [Int])
-favApi c cId = putFav c cId :<|> delFav c cId
+favApi :: CorpusId -> GargServer FavApi
+favApi cId = putFav cId :<|> delFav cId
 
 ------------------------------------------------------------------------
 type TableApi = Summary " Table API"
@@ -221,11 +250,19 @@ type TableApi = Summary " Table API"
               :> QueryParam "order"  OrderBy
               :> Get '[JSON] [FacetDoc]
 
+-- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
+type PairingApi = Summary " Pairing API"
+              :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
+              :> QueryParam "offset" Int
+              :> QueryParam "limit"  Int
+              :> QueryParam "order"  OrderBy
+              :> Get '[JSON] [FacetDoc]
+
 ------------------------------------------------------------------------
 type ChartApi = Summary " Chart API"
               :> QueryParam "from" UTCTime
               :> QueryParam "to"   UTCTime
-              :> Get '[JSON] [FacetChart]
+              :> Get '[JSON] (ChartMetrics Histo)
 
                 -- Depending on the Type of the Node, we could post
                 -- New documents for a corpus
@@ -236,66 +273,70 @@ type ChartApi = Summary " Chart API"
              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 
 ------------------------------------------------------------------------
-type GraphAPI   = Get '[JSON] Graph
-graphAPI :: Connection -> NodeId -> Server GraphAPI
-graphAPI _ _ = do
-  liftIO $ maybe defaultGraph identity <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
-  -- t <- textFlow (Mono EN) (Contexts contextText)
-  -- liftIO $ liftIO $ pure $  maybe t identity maybeGraph
-  -- TODO what do we get about the node? to replace contextText
+
+
+instance HasNodeError ServantErr where
+  _NodeError = prism' mk (const Nothing) -- $ panic "HasNodeError ServantErr: not a prism")
+    where
+      e = "Gargantext NodeError: "
+      mk NoListFound   = err404 { errBody = e <> "No list found"         }
+      mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
+      mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
+      mk NoUserFound   = err404 { errBody = e <> "No User found"         }
+
+      mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
+      mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
+      mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
+      mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
+      mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
+      mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
+      mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 
 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 instance HasTreeError ServantErr where
-  _TreeError = prism' mk (const Nothing) -- Note a prism
+  _TreeError = prism' mk (const Nothing) -- $ panic "HasTreeError ServantErr: not a prism")
     where
-      mk NoRoot       = err404 { errBody = "Root node not found"           }
-      mk EmptyRoot    = err500 { errBody = "Root node should not be empty" }
-      mk TooManyRoots = err500 { errBody = "Too many root nodes"           }
+      e = "TreeError: "
+      mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
+      mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
+      mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 
 type TreeAPI   = Get '[JSON] (Tree NodeTree)
-treeAPI :: Connection -> NodeId -> Server TreeAPI
+-- TODO-ACCESS: CanTree or CanGetNode
+-- TODO-EVENTS: No events as this is a read only query.
+treeAPI :: NodeId -> GargServer TreeAPI
 treeAPI = treeDB
 
 ------------------------------------------------------------------------
 -- | Check if the name is less than 255 char
-rename :: Connection -> NodeId -> RenameNode -> Handler [Int]
-rename c nId (RenameNode name) = liftIO $ U.update (U.Rename nId name) c
+rename :: NodeId -> RenameNode -> Cmd err [Int]
+rename nId (RenameNode name') = U.update (U.Rename nId name')
 
-getTable :: Connection -> NodeId -> Maybe TabType
+getTable :: NodeId -> Maybe TabType
          -> Maybe Offset  -> Maybe Limit
-         -> Maybe OrderBy -> Handler [FacetDoc]
-getTable c cId ft o l order = liftIO $ case ft of
-                                (Just Docs)  -> runViewDocuments' c cId False o l order
-                                (Just Trash) -> runViewDocuments' c cId True  o l order
-                                _     -> panic "not implemented"
-
-getChart :: Connection -> NodeId -> Maybe UTCTime -> Maybe UTCTime
-                        -> Handler [FacetChart]
-getChart _ _ _ _ = undefined -- TODO
+         -> Maybe OrderBy -> Cmd err [FacetDoc]
+getTable cId ft o l order =
+  case ft of
+    (Just Docs)  -> runViewDocuments cId False o l order
+    (Just Trash) -> runViewDocuments cId True  o l order
+    _     -> panic "not implemented"
+
+getPairing :: ContactId -> Maybe TabType
+         -> Maybe Offset  -> Maybe Limit
+         -> Maybe OrderBy -> Cmd err [FacetDoc]
+getPairing cId ft o l order =
+  case ft of
+    (Just Docs)  -> runViewAuthorsDoc cId False o l order
+    (Just Trash) -> runViewAuthorsDoc cId True  o l order
+    _     -> panic "not implemented"
 
-postNode :: Connection -> NodeId -> PostNode -> Handler [Int]
-postNode c pId (PostNode name nt) = liftIO $ mk c nt (Just pId) name
+postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
+postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 
-putNode :: Connection -> NodeId -> Handler Int
+putNode :: NodeId -> Cmd err Int
 putNode = undefined -- TODO
 
-deleteNodes' :: Connection -> [NodeId] -> Handler Int
-deleteNodes' conn ids = liftIO (runCmd conn $ deleteNodes ids)
-
-deleteNode' :: Connection -> NodeId -> Handler Int
-deleteNode' conn id = liftIO (runCmd conn $ deleteNode id)
-
-getNodesWith' :: JSONB a => Connection -> NodeId -> proxy a -> Maybe NodeType
-              -> Maybe Int -> Maybe Int -> Handler [Node a]
-getNodesWith' conn id p nodeType offset limit  = liftIO (getNodesWith conn id p nodeType offset limit)
-
-tableNgramsPatch' :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> Handler NgramsIdPatchsBack
-tableNgramsPatch' c cId mL ns = liftIO $ tableNgramsPatch c cId mL ns
-
-getTableNgrams' :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> Handler NgramsTable
-getTableNgrams' c cId nType mL = liftIO $ getTableNgrams c cId nType mL
-
-query :: Text -> Handler Text
+query :: Monad m => Text -> m Text
 query s = pure s
 
 
@@ -316,3 +357,25 @@ query s = pure s
 --      putStrLn content
 --  pure (pack "Data loaded")
 
+-------------------------------------------------------------------------------
+
+type MetricsAPI = Summary "SepGen IncExc metrics"
+                :> QueryParam  "list"       ListId
+                :> QueryParamR "ngramsType" TabType
+                :> QueryParam  "limit"      Int
+                :> Get '[JSON] Metrics
+
+getMetrics :: NodeId -> GargServer MetricsAPI
+getMetrics cId maybeListId tabType maybeLimit = do
+  (ngs', scores) <- Metrics.getMetrics' cId maybeListId tabType maybeLimit
+
+  let
+    metrics      = map (\(Scored t s1 s2) -> Metric t s1 s2 (listType t ngs')) scores
+    listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
+    errorMsg     = "API.Node.metrics: key absent"
+  
+  pure $ Metrics metrics
+
+
+
+