[FIX] Annuaire / Team Node creation

src/Gargantext/API.hs

@@ -94,6 +94,7 @@ import Gargantext.API.Ngrams (HasRepo(..), HasRepoSaver(..), saveRepo, TableNgra
 import Gargantext.API.Node
 import Gargantext.API.Search (SearchPairsAPI, searchPairs)
 import Gargantext.API.Types
+import qualified Gargantext.API.Annuaire as Annuaire
 import qualified Gargantext.API.Export as Export
 import qualified Gargantext.API.Corpus.New as New
 import Gargantext.Database.Types.Node
@@ -304,6 +305,8 @@ type GargPrivateAPI' =
            -- :<|> New.Upload
            :<|> New.AddWithForm
            :<|> New.AddWithQuery
+
+           :<|> Annuaire.AddWithForm
            -- :<|> New.AddWithFile
        --  :<|> "scraper" :> WithCallbacks ScraperAPI
        --  :<|> "new"  :> New.Api
@@ -390,8 +393,10 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
      -- TODO access
      -- :<|> addUpload
      -- :<|> (\corpus -> addWithQuery corpus :<|> addWithFile corpus)
-     :<|> addWithForm
-     :<|> addWithQuery
+     :<|> addCorpusWithForm
+     :<|> addCorpusWithQuery
+
+     :<|> addAnnuaireWithForm
      -- :<|> New.api  uid -- TODO-SECURITY
      -- :<|> New.info uid -- TODO-SECURITY
 
@@ -401,8 +406,8 @@ addUpload cId = (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusJobFunctio
            :<|> (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusWithForm    cid i (liftIO . log)))
 --}
 
-addWithQuery :: GargServer New.AddWithQuery
-addWithQuery cid =
+addCorpusWithQuery :: GargServer New.AddWithQuery
+addCorpusWithQuery cid =
   serveJobsAPI $
     JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftIO . log))
 
@@ -411,11 +416,16 @@ addWithFile cid i f =
   serveJobsAPI $
     JobFunction (\_i log -> New.addToCorpusWithFile cid i f (liftIO . log))
 
-addWithForm :: GargServer New.AddWithForm
-addWithForm cid =
+addCorpusWithForm :: GargServer New.AddWithForm
+addCorpusWithForm cid =
   serveJobsAPI $
     JobFunction (\i log -> New.addToCorpusWithForm cid i (liftIO . log))
 
+addAnnuaireWithForm :: GargServer Annuaire.AddWithForm
+addAnnuaireWithForm cid =
+  serveJobsAPI $
+    JobFunction (\i log -> Annuaire.addToAnnuaireWithForm cid i (liftIO . log))
+
 serverStatic :: Server (Get '[HTML] Html)
 serverStatic = $(do
                   let path = "purescript-gargantext/dist/index.html"

src/Gargantext/API/Annuaire.hs

+{-|
+Module      : Gargantext.API.Annuaire
+Description : New annuaire API
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+-}
+
+{-# LANGUAGE NoImplicitPrelude  #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE TypeOperators      #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE RankNTypes         #-}
+
+module Gargantext.API.Annuaire
+      where
+
+import Control.Lens hiding (elements)
+import Data.Aeson
+import Data.Swagger
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import qualified Gargantext.API.Corpus.New.File as NewFile
+import Gargantext.API.Orchestrator.Types
+import Gargantext.Core (Lang(..))
+import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
+import Gargantext.Database.Flow (FlowCmdM)  -- flowAnnuaire
+import Gargantext.Database.Types.Node (AnnuaireId)
+import Gargantext.Prelude
+import Servant
+import Servant.API.Flatten (Flat)
+import Servant.Job.Core
+import Servant.Job.Types
+import Servant.Job.Utils (jsonOptions)
+import Web.FormUrlEncoded          (FromForm)
+
+
+type Api = Summary "New Annuaire endpoint"
+         :> Post '[JSON] AnnuaireId
+
+------------------------------------------------------------------------
+------------------------------------------------------------------------
+data WithForm = WithForm
+  { _wf_filetype :: !NewFile.FileType
+  , _wf_data     :: !Text
+  , _wf_lang     :: !(Maybe Lang)
+  } deriving (Eq, Show, Generic)
+
+makeLenses ''WithForm
+instance FromForm WithForm
+instance FromJSON WithForm where
+  parseJSON = genericParseJSON $ jsonOptions "_wf_"
+instance ToSchema WithForm where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_")
+
+------------------------------------------------------------------------
+type AsyncJobs event ctI input output =
+  Flat (AsyncJobsAPI' 'Unsafe 'Safe ctI '[JSON] Maybe event input output)
+------------------------------------------------------------------------
+
+type AddWithForm = Summary "Add with FormUrlEncoded to annuaire endpoint"
+   :> "annuaire"
+   :> Capture "annuaire_id" AnnuaireId
+   :> "add"
+   :> "form"
+   :> "async"
+   :> AsyncJobs ScraperStatus '[FormUrlEncoded] WithForm ScraperStatus
+
+------------------------------------------------------------------------
+addToAnnuaireWithForm :: FlowCmdM env err m
+                    => AnnuaireId
+                    -> WithForm
+                    -> (ScraperStatus -> m ())
+                    -> m ScraperStatus
+addToAnnuaireWithForm _cid (WithForm ft _d _l) logStatus = do
+
+  printDebug "ft" ft
+
+  -- let
+    -- parse = case ft of
+    --   CSV_HAL   -> Parser.parseFormat Parser.CsvHal
+    --   CSV       -> Parser.parseFormat Parser.CsvGargV3
+    --   WOS       -> Parser.parseFormat Parser.WOS
+    --   PresseRIS -> Parser.parseFormat Parser.RisPresse
+
+  -- docs <- liftIO
+  --       $ splitEvery 500
+  --      <$> take 1000000
+  --      <$> parse (cs d)
+
+  logStatus ScraperStatus { _scst_succeeded = Just 1
+                          , _scst_failed    = Just 0
+                          , _scst_remaining = Just 1
+                          , _scst_events    = Just []
+                          }
+  -- cid' <- flowCorpus "user1"
+  --                    (Right [cid])
+  --                    (Multi $ fromMaybe EN l)
+  --                    (map (map toHyperdataDocument) docs)
+
+  -- printDebug "cid'" cid'
+
+  pure      ScraperStatus { _scst_succeeded = Just 2
+                          , _scst_failed    = Just 0
+                          , _scst_remaining = Just 0
+                          , _scst_events    = Just []
+                          }
+

src/Gargantext/Database/Schema/Node.hs

@@ -620,15 +620,18 @@ childWith uId pId (Node' NodeContact  txt v []) = node2table uId (Just pId) (Nod
 childWith _   _   (Node' _        _   _ _) = panic "This NodeType can not be a child"
 
 
+-- =================================================================== --
+------------------------------------------------------------------------
 -- | TODO mk all others nodes
 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
+
+------------------------------------------------------------------------
 mkNodeWithParent NodeUser Nothing  uId name =
   insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
     where
       hd = HyperdataUser . Just . pack $ show EN
 mkNodeWithParent _ Nothing _ _ = nodeError HasParent
-
 ------------------------------------------------------------------------
 mkNodeWithParent NodeFolder (Just i) uId name = 
    insertNodesWithParentR (Just i) [node NodeFolder name hd Nothing uId]
@@ -654,18 +657,20 @@ mkNodeWithParent NodeTeam (Just i) uId _ =
    insertNodesWithParentR (Just i) [node NodeTeam "Team" hd Nothing uId]
     where
       hd = defaultFolder
-
-
 ------------------------------------------------------------------------
-
-
-
 mkNodeWithParent NodeCorpus (Just i) uId name =
    insertNodesWithParentR (Just i) [node NodeCorpus name hd Nothing uId]
     where
       hd = defaultCorpus
 
+mkNodeWithParent NodeAnnuaire (Just i) uId name =
+   insertNodesWithParentR (Just i) [node NodeAnnuaire name hd Nothing uId]
+    where
+      hd = defaultAnnuaire
+
 mkNodeWithParent _ _ _ _       = nodeError NotImplYet
+------------------------------------------------------------------------
+-- =================================================================== --
 
 
 

src/Gargantext/Database/Tree.hs

@@ -108,7 +108,7 @@ dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
           FROM nodes AS c
 
           INNER JOIN tree AS s ON c.parent_id = s.id
-           WHERE c.typename IN (2,20,21,22,3,5,30,31,40,7,9,90,71)
+           -- WHERE c.typename IN (2,20,21,22,3,5,30,31,40,7,9,90,71)
         )
     SELECT * from tree;
     |] (Only rootId)

stack.yaml

@@ -7,7 +7,9 @@ packages:
 
 docker:
   enable: false
-  repo: 'fpco/stack-build:lts-14.22-garg'
+  repo: 'fpco/stack-build:lts-14.6-garg'
+  run-args:
+    - '--publish=8008:8008'
 
 nix:
   enable: false