[docker] update image, add README info
[gargantext.git] / src / Gargantext / API / Node.hs
index bd66327a3ff82f75d3c36a2317a083e843ef33db..438747b0c2cedb1f0b22ed3329c5212960f6174b 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.
@@ -38,41 +37,37 @@ Node API
 module Gargantext.API.Node
   where
 
-import Control.Lens ((.~), (?~))
-import Control.Monad ((>>), forM)
-import Control.Monad.IO.Class (liftIO)
+import Control.Lens ((^.))
 import Data.Aeson (FromJSON, ToJSON)
 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, PathId(..))
 import Gargantext.API.Metrics
-import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO)
+import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR)
 import Gargantext.API.Ngrams.NTree (MyTree)
-import Gargantext.API.Search (SearchDocsAPI, searchDocs)
+import Gargantext.API.Search (SearchDocsAPI, searchDocs, SearchPairsAPI, searchPairs)
 import Gargantext.API.Table
 import Gargantext.API.Types
-import Gargantext.Core.Types (NodeTableResult(..))
+import Gargantext.Core.Types (NodeTableResult)
 import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
 import Gargantext.Database.Config (nodeTypeId)
+import Gargantext.Database.Flow.Pairing (pairing)
 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.Node.User (NodeUser)
+import Gargantext.Database.Schema.Node (getNodesWithParentId, getNodeWith, getNode, deleteNode, deleteNodes, mkNodeWithParent, JSONB, HasNodeError(..), getNodeUser)
+import Gargantext.Database.Schema.NodeNode -- (nodeNodesCategory, insertNodeNode, NodeNode(..))
+import Gargantext.Database.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Tree (treeDB)
 import Gargantext.Database.Types.Node
 import Gargantext.Database.Utils -- (Cmd, CmdM)
 import Gargantext.Prelude
-import Gargantext.Prelude.Utils (sha)
 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(..))
@@ -82,7 +77,6 @@ import qualified Gargantext.Text.List.Learn as Learn
 import qualified Data.Vector as Vec
 --}
 
-
 type NodesAPI  = Delete '[JSON] Int
 
 -- | Delete Nodes
@@ -99,13 +93,13 @@ nodesAPI ids = deleteNodes ids
 -- TODO-EVENTS:
 --   PutNode ?
 -- TODO needs design discussion.
-type Roots =  Get    '[JSON] [Node HyperdataAny]
+type Roots =  Get    '[JSON] [NodeUser]
          :<|> 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
@@ -125,17 +119,22 @@ 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
+             :<|> ReqBody '[JSON] a :> Put    '[JSON] Int
              :<|> Delete '[JSON] Int
              :<|> "children"  :> ChildrenApi a
 
              -- TODO gather it
              :<|> "table"     :> TableApi
              :<|> "ngrams"    :> TableNgramsApi
-             -- :<|> "pairing"   :> PairingApi
 
              :<|> "category"  :> CatApi
-             :<|> "search"    :> SearchDocsAPI
+             :<|> "search"     :> SearchDocsAPI
+
+             -- Pairing utilities
+             :<|> "pairwith"   :> PairWith
+             :<|> "pairs"      :> Pairs
+             :<|> "pairing"    :> PairingApi
+             :<|> "searchPair" :> SearchPairsAPI
 
              -- VIZ
              :<|> "metrics" :> ScatterAPI
@@ -143,7 +142,7 @@ type NodeAPI a = Get '[JSON] (Node a)
              :<|> "pie"       :> PieApi
              :<|> "tree"      :> TreeApi
              :<|> "phylo"     :> PhyloAPI
-             :<|> "add"       :> NodeAddAPI
+             -- :<|> "add"       :> NodeAddAPI
 
 -- TODO-ACCESS: check userId CanRenameNode nodeId
 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
@@ -160,26 +159,29 @@ type ChildrenApi a = Summary " Summary children"
                  :> QueryParam "offset" Int
                  :> QueryParam "limit"  Int
                  -- :> Get '[JSON] [Node a]
-                 :> Get '[JSON] (NodeTableResult (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 :: 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' = getNode nId p
-
-
+    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 :: 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
+    nodeAPI' =  getNodeWith   id p
            :<|> rename        id
            :<|> postNode  uId id
            :<|> putNode       id
@@ -189,31 +191,30 @@ nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode i
            -- TODO gather it
            :<|> tableApi             id
            :<|> apiNgramsTableCorpus id
-           -- :<|> getPairing           id
-           -- :<|> getTableNgramsDoc id
 
-           :<|> catApi     id
+           :<|> catApi      id
 
-           :<|> searchDocs id
+           :<|> searchDocs  id
+           -- Pairing Tools
+           :<|> pairWith    id
+           :<|> pairs       id
+           :<|> getPair     id
+           :<|> searchPairs id
 
            :<|> getScatter id
            :<|> getChart   id
            :<|> getPie     id
            :<|> getTree    id
            :<|> phyloAPI   id uId
-           :<|> nodeAddAPI id
+           -- :<|> nodeAddAPI id
            -- :<|> postUpload id
 
     deleteNodeApi id' = do
-      node <- getNode' id'
+      node <- getNode id'
       if _node_typename node == nodeTypeId NodeUser
          then panic "not allowed"  -- TODO add proper Right Management Type
          else deleteNode id'
 
-           -- Annuaire
-           -- :<|> query
-
-
 ------------------------------------------------------------------------
 data RenameNode = RenameNode { r_name :: Text }
   deriving (Generic)
@@ -259,6 +260,7 @@ 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)
@@ -267,6 +269,25 @@ type PairingApi = Summary " Pairing API"
               :> 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
+              :> "list"     :> Capture "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
@@ -290,9 +311,6 @@ type TreeApi = Summary " Tree API"
                 -- 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
 
 ------------------------------------------------------------------------
 
@@ -325,7 +343,7 @@ instance HasTreeError ServantErr where
       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
@@ -335,78 +353,20 @@ treeAPI = treeDB
 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
-
+postNode :: HasNodeError err
+         => UserId
+         -> NodeId
+         -> PostNode
+         -> Cmd err [NodeId]
+postNode uId pId (PostNode nodeName nt) = do
+  nodeUser <- getNodeUser (NodeId uId)
+  let uId' = nodeUser ^. node_userId
+  mkNodeWithParent nt (Just pId) uId' nodeName
+
+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)
-
-instance ToSchema FileType
-instance Arbitrary FileType
-  where
-    arbitrary = elements [CSV, PresseRIS]
-instance ToParamSchema FileType
-
-instance ToParamSchema (MultipartData Mem) where
-  toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 
-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 NodeAddAPI = "file" :> Summary "Node add API"
-                         :> UploadAPI
-
-nodeAddAPI :: NodeId -> GargServer NodeAddAPI
-nodeAddAPI id =  postUpload       id
-
-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 (sha . cs) is