[OPTIM + FIX] TFICF
[gargantext.git] / src / Gargantext / API / Node.hs
index 1e21f31a0a0f2b7576212a63a113a38b53a4f631..d0ab8533e0ee1b975e8b19a89618363b826decce 100644 (file)
@@ -12,7 +12,6 @@ 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.
@@ -24,13 +23,6 @@ Node API
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-{-# LANGUAGE DataKinds            #-}
-{-# LANGUAGE DeriveGeneric        #-}
-{-# LANGUAGE FlexibleContexts     #-}
-{-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE NoImplicitPrelude    #-}
-{-# LANGUAGE OverloadedStrings    #-}
-{-# LANGUAGE RankNTypes           #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TemplateHaskell      #-}
 {-# LANGUAGE TypeOperators        #-}
@@ -38,57 +30,61 @@ Node API
 module Gargantext.API.Node
   where
 
-import Control.Lens ((.~), (?~))
-import Control.Monad ((>>), forM)
-import Control.Monad.IO.Class (liftIO)
 import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson.TH (deriveJSON)
 import Data.Maybe
-import Data.Monoid (mempty)
 import Data.Swagger
 import Data.Text (Text())
-import Data.Time (UTCTime)
 import GHC.Generics (Generic)
-import Gargantext.API.Auth (withAccess)
-import Gargantext.API.Metrics
-import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO)
-import Gargantext.API.Ngrams.NTree (MyTree)
-import Gargantext.API.Search (SearchDocsAPI, searchDocs)
-import Gargantext.API.Table
-import Gargantext.API.Types
-import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
-import Gargantext.Database.Config (nodeTypeId)
-import Gargantext.Database.Facet (FacetDoc, OrderBy(..))
-import Gargantext.Database.Node.Children (getChildren)
-import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, getNode', deleteNode, deleteNodes, mkNodeWithParent, JSONB, HasNodeError(..))
-import Gargantext.Database.Schema.NodeNode (nodeNodesCategory)
-import Gargantext.Database.Tree (treeDB)
-import Gargantext.Database.Types.Node
-import Gargantext.Database.Utils -- (Cmd, CmdM)
-import Gargantext.Prelude
-import Gargantext.Prelude.Utils (hash)
-import Gargantext.Viz.Chart
-import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
 import Servant
-import Servant.Multipart
-import Servant.Swagger (HasSwagger(toSwagger))
-import Servant.Swagger.Internal
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-import qualified Gargantext.Database.Node.Update as U (update, Update(..))
+
+import Gargantext.API.Admin.Auth (withAccess, PathId(..))
+import Gargantext.API.Metrics
+import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus)
+import Gargantext.API.Node.File
+import Gargantext.API.Node.New
+import Gargantext.API.Prelude
+import Gargantext.API.Table
+import Gargantext.Core.Types (NodeTableResult)
+import Gargantext.Core.Types.Individu (User(..))
+import Gargantext.Core.Types.Main (Tree, NodeTree)
+import Gargantext.Core.Utils.Prefix (unPrefix)
+import Gargantext.Database.Action.Flow.Pairing (pairing)
+import Gargantext.Database.Admin.Types.Hyperdata
+import Gargantext.Database.Admin.Types.Node
+import Gargantext.Database.Prelude -- (Cmd, CmdM)
+import Gargantext.Database.Query.Facet (FacetDoc, OrderBy(..))
+import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Table.Node.Children (getChildren)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
+import Gargantext.Database.Query.Table.Node.Update (Update(..), update)
+import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
+import Gargantext.Database.Query.Table.NodeNode
+import Gargantext.Database.Query.Tree (tree, TreeMode(..))
+import Gargantext.Prelude
+import Gargantext.Core.Viz.Phylo.API (PhyloAPI, phyloAPI)
+import qualified Gargantext.API.Node.Share  as Share
+import qualified Gargantext.API.Node.Update as Update
+import qualified Gargantext.API.Search as Search
+import qualified Gargantext.Database.Action.Delete as Action (deleteNode)
+import qualified Gargantext.Database.Query.Table.Node.Update as U (update, Update(..))
 
 {-
-import qualified Gargantext.Text.List.Learn as Learn
+import qualified Gargantext.Core.Text.List.Learn as Learn
 import qualified Data.Vector as Vec
 --}
 
-
+-- | Admin NodesAPI
+-- TODO
 type NodesAPI  = Delete '[JSON] Int
 
 -- | Delete Nodes
 -- Be careful: really delete nodes
 -- Access by admin only
 nodesAPI :: [NodeId] -> GargServer NodesAPI
-nodesAPI ids = deleteNodes ids
+nodesAPI = deleteNodes
 
 ------------------------------------------------------------------------
 -- | TODO-ACCESS: access by admin only.
@@ -98,13 +94,13 @@ nodesAPI ids = deleteNodes ids
 -- TODO-EVENTS:
 --   PutNode ?
 -- TODO needs design discussion.
-type Roots =  Get    '[JSON] [Node HyperdataAny]
+type Roots =  Get    '[JSON] [Node HyperdataUser]
          :<|> Put    '[JSON] Int -- TODO
 
 -- | TODO: access by admin only
 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
+roots = getNodesWithParentId Nothing
+    :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
 
 -------------------------------------------------------------------
 -- | Node API Types management
@@ -124,25 +120,36 @@ roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
 type NodeAPI a = Get '[JSON] (Node a)
              :<|> "rename" :> RenameApi
              :<|> PostNodeApi -- TODO move to children POST
-             :<|> Put    '[JSON] Int
+             :<|> PostNodeAsync
+             :<|> ReqBody '[JSON] a :> Put    '[JSON] Int
+             :<|> "update"     :> Update.API
              :<|> Delete '[JSON] Int
              :<|> "children"  :> ChildrenApi a
 
              -- TODO gather it
-             :<|> "table"     :> TableApi
-             :<|> "ngrams"    :> TableNgramsApi
-             :<|> "pairing"   :> PairingApi
+             :<|> "table"      :> TableApi
+             :<|> "ngrams"     :> TableNgramsApi
+
+             :<|> "category"   :> CatApi
+             :<|> "search"     :> (Search.API Search.SearchResult)
+             :<|> "share"      :> Share.API
 
-             :<|> "category"  :> CatApi
-             :<|> "search"    :> SearchDocsAPI
+             -- Pairing utilities
+             :<|> "pairwith"   :> PairWith
+             :<|> "pairs"      :> Pairs
+             :<|> "pairing"    :> PairingApi
 
              -- VIZ
-             :<|> "metrics" :> ScatterAPI
+             :<|> "metrics"   :> ScatterAPI
              :<|> "chart"     :> ChartApi
              :<|> "pie"       :> PieApi
              :<|> "tree"      :> TreeApi
              :<|> "phylo"     :> PhyloAPI
-             :<|> "upload"    :> UploadAPI
+             -- :<|> "add"       :> NodeAddAPI
+             :<|> "move"      :> MoveAPI
+             :<|> "unpublish" :> Share.Unpublish
+
+             :<|> "file"      :> FileApi
 
 -- TODO-ACCESS: check userId CanRenameNode nodeId
 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
@@ -158,68 +165,76 @@ type ChildrenApi a = Summary " Summary children"
                  :> QueryParam "type"   NodeType
                  :> QueryParam "offset" Int
                  :> QueryParam "limit"  Int
-                 :> Get '[JSON] [Node a]
+                 -- :> Get '[JSON] [Node a]
+                 :> Get '[JSON] (NodeTableResult a)
+
+------------------------------------------------------------------------
+type NodeNodeAPI a = Get '[JSON] (Node a)
+
+nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a)
+            => proxy a
+            -> UserId
+            -> CorpusId
+            -> NodeId
+            -> GargServer (NodeNodeAPI a)
+nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
+  where
+    nodeNodeAPI' :: GargServer (NodeNodeAPI a)
+    nodeNodeAPI' = getNodeWith nId p
 
 ------------------------------------------------------------------------
 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
-nodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
-nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId id nodeAPI'
+nodeAPI :: forall proxy a.
+       ( JSONB a
+       , FromJSON a
+       , ToJSON a
+       ) => proxy a
+         -> UserId
+         -> NodeId
+         -> GargServer (NodeAPI a)
+nodeAPI p uId id' = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id') nodeAPI'
   where
     nodeAPI' :: GargServer (NodeAPI a)
-    nodeAPI' =  getNode       id p
-           :<|> rename        id
-           :<|> postNode  uId id
-           :<|> putNode       id
-           :<|> deleteNodeApi id
-           :<|> getChildren   id p
+    nodeAPI' =  getNodeWith   id' p
+           :<|> rename        id'
+           :<|> postNode  uId id'
+           :<|> postNodeAsyncAPI  uId id'
+           :<|> putNode       id'
+           :<|> Update.api  uId id'
+           :<|> Action.deleteNode (RootId $ NodeId uId) id'
+           :<|> getChildren   id' p
 
            -- TODO gather it
-           :<|> tableApi             id
-           :<|> apiNgramsTableCorpus id
-           :<|> getPairing           id
-           -- :<|> getTableNgramsDoc id
-
-           :<|> catApi     id
-
-           :<|> searchDocs id
-
-           :<|> getScatter id
-           :<|> getChart   id
-           :<|> getPie     id
-           :<|> getTree    id
-           :<|> phyloAPI   id uId
-           :<|> postUpload id
-
-    deleteNodeApi id' = do
-      node <- getNode' id'
-      if _node_typename node == nodeTypeId NodeUser
-         then panic "not allowed"  -- TODO add proper Right Management Type
-         else deleteNode id'
-           
-           -- Annuaire
-           -- :<|> query
+           :<|> tableApi             id'
+           :<|> apiNgramsTableCorpus id'
+            
+           :<|> catApi      id'
+           :<|> Search.api  id'
+           :<|> Share.api   id'
+           -- Pairing Tools
+           :<|> pairWith    id'
+           :<|> pairs       id'
+           :<|> getPair     id'
+
+           -- VIZ
+           :<|> scatterApi id'
+           :<|> chartApi   id'
+           :<|> pieApi     id'
+           :<|> treeApi    id'
+           :<|> phyloAPI   id' uId
+           :<|> moveNode   (RootId $ NodeId uId) id'
+           -- :<|> nodeAddAPI id'
+           -- :<|> postUpload id'
+           :<|> Share.unPublish id'
+
+           :<|> fileApi uId id'
+
+
 ------------------------------------------------------------------------
 data RenameNode = RenameNode { r_name :: Text }
   deriving (Generic)
 
--- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
-instance FromJSON  RenameNode
-instance ToJSON    RenameNode
-instance ToSchema  RenameNode
-instance Arbitrary RenameNode where
-  arbitrary = elements [RenameNode "test"]
 ------------------------------------------------------------------------
-data PostNode = PostNode { pn_name :: Text
-                         , pn_typename :: NodeType}
-  deriving (Generic)
-
--- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
-instance FromJSON  PostNode
-instance ToJSON    PostNode
-instance ToSchema  PostNode
-instance Arbitrary PostNode where
-  arbitrary = elements [PostNode "Node test" NodeCorpus]
-
 ------------------------------------------------------------------------
 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
             :> ReqBody '[JSON] NodesToCategory
@@ -243,148 +258,69 @@ catApi = putCat
 
 ------------------------------------------------------------------------
 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
+-- Pairing utilities to move elsewhere
 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]
+                :> QueryParam "view"   TabType
+                -- TODO change TabType -> DocType (CorpusId for pairing)
+                :> QueryParam "offset" Int
+                :> QueryParam "limit"  Int
+                :> QueryParam "order"  OrderBy
+                :> Get '[JSON] [FacetDoc]
+
+----------
+type Pairs    = Summary "List of Pairs"
+              :> Get '[JSON] [AnnuaireId]
+pairs :: CorpusId -> GargServer Pairs
+pairs cId = do
+  ns <- getNodeNode cId
+  pure $ map _nn_node2_id ns
+
+type PairWith = Summary "Pair a Corpus with an Annuaire"
+              :> "annuaire" :> Capture "annuaire_id" AnnuaireId
+              :> QueryParam "list_id"     ListId
+              :> Post '[JSON] Int
+
+pairWith :: CorpusId -> GargServer PairWith
+pairWith cId aId lId = do
+  r <- pairing cId aId lId
+  _ <- insertNodeNode [ NodeNode cId aId Nothing Nothing]
+  pure r
 
-------------------------------------------------------------------------
-type ChartApi = Summary " Chart API"
-              :> QueryParam "from" UTCTime
-              :> QueryParam "to"   UTCTime
-              :> Get '[JSON] (ChartMetrics Histo)
-
-type PieApi = Summary " Chart API"
-           :> QueryParam "from" UTCTime
-           :> QueryParam "to"   UTCTime
-           :> QueryParamR "ngramsType" TabType
-           :> Get '[JSON] (ChartMetrics Histo)
-
-type TreeApi = Summary " Tree API"
-           :> QueryParam "from" UTCTime
-           :> QueryParam "to"   UTCTime
-           :> QueryParamR "ngramsType" TabType
-           :> QueryParamR "listType"   ListType
-           :> Get '[JSON] (ChartMetrics [MyTree])
-
-                -- Depending on the Type of the Node, we could post
-                -- New documents for a corpus
-                -- New map list terms
-             -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
-                
-                -- To launch a query and update the corpus
-             -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 
 ------------------------------------------------------------------------
-
-{-
-NOTE: These instances are not necessary. However, these messages could be part
-      of a display function for NodeError/TreeError.
-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"    }
-
-instance HasTreeError ServantErr where
-  _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
-    where
-      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)
+type TreeAPI   = QueryParams "type" NodeType :> Get '[JSON] (Tree NodeTree)
 
 treeAPI :: NodeId -> GargServer TreeAPI
-treeAPI = treeDB
+treeAPI = tree Advanced
 
 ------------------------------------------------------------------------
--- | Check if the name is less than 255 char
+-- | TODO Check if the name is less than 255 char
 rename :: NodeId -> RenameNode -> Cmd err [Int]
 rename nId (RenameNode name') = U.update (U.Rename nId name')
 
-postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
-postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
-
-putNode :: NodeId -> Cmd err Int
-putNode = undefined -- TODO
-
-query :: Monad m => Text -> m Text
-query s = pure s
+putNode :: forall err a. (HasNodeError err, JSONB a, ToJSON a)
+        => NodeId
+        -> a
+        -> Cmd err Int
+putNode n h = fromIntegral <$> updateHyperdata n h
 
 -------------------------------------------------------------
-type Hash = Text
-data FileType = CSV | PresseRIS
-  deriving (Eq, Show, Generic)
+type MoveAPI  = Summary "Move Node endpoint"
+              :> Capture "parent_id" ParentId
+              :> Put '[JSON] [Int]
+
+moveNode :: User
+         -> NodeId
+         -> ParentId
+         -> Cmd err [Int]
+moveNode _u n p = update (Move n p)
+-------------------------------------------------------------
 
-instance ToSchema FileType
-instance Arbitrary FileType
-  where
-    arbitrary = elements [CSV, PresseRIS]
-instance ToParamSchema FileType
 
-instance ToParamSchema (MultipartData Mem) where
-  toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
+$(deriveJSON (unPrefix "r_"       ) ''RenameNode )
+instance ToSchema  RenameNode
+instance Arbitrary RenameNode where
+  arbitrary = elements [RenameNode "test"]
 
-instance FromHttpApiData FileType
-  where
-    parseUrlPiece "CSV"       = pure CSV
-    parseUrlPiece "PresseRis" = pure PresseRIS
-    parseUrlPiece _           = pure CSV -- TODO error here
-
-
-instance (ToParamSchema a, HasSwagger sub) =>
-         HasSwagger (MultipartForm tag a :> sub) where
-  -- TODO
-  toSwagger _ = toSwagger (Proxy :: Proxy sub)
-    & addParam param
-    where
-      param = mempty
-        & required ?~ True
-        & schema   .~ ParamOther sch
-      sch = mempty
-        & in_         .~ ParamFormData
-        & paramSchema .~ toParamSchema (Proxy :: Proxy a)
-
-type UploadAPI = Summary "Upload file(s) to a corpus"
-                :> MultipartForm Mem (MultipartData Mem)
-                :> QueryParam "fileType"  FileType
-                :> Post '[JSON] [Hash]
-
---postUpload :: NodeId -> Maybe FileType ->  GargServer UploadAPI
---postUpload :: NodeId -> GargServer UploadAPI
-postUpload :: NodeId -> MultipartData Mem -> Maybe FileType -> Cmd err [Hash]
-postUpload _ _ Nothing = panic "fileType is a required parameter"
-postUpload _ multipartData (Just fileType) = do
-  putStrLn $ "File Type: " <> (show fileType)
-  is <- liftIO $ do
-    putStrLn ("Inputs:" :: Text)
-    forM (inputs multipartData) $ \input -> do
-      putStrLn $ ("iName  " :: Text) <> (iName input)
-            <> ("iValue " :: Text) <> (iValue input)
-      pure $ iName input
-
-  _ <- forM (files multipartData) $ \file -> do
-    let content = fdPayload file
-    putStrLn $ ("XXX " :: Text) <> (fdFileName file)
-    putStrLn $ ("YYY " :: Text) <>  cs content
-    --pure $ cs content
-  -- is <- inputs multipartData
-
-  pure $ map (hash . cs) is
+
+-------------------------------------------------------------