[FACTO] Types Class for flow CorpusDoc and CorpusContact.

src/Gargantext/Database/Flow.hs

@@ -30,10 +30,10 @@ module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
 --import Gargantext.Database.Schema.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
 --import Gargantext.Database.Schema.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
 --import Gargantext.Database.Schema.User (insertUsers, simpleUser, gargantuaUser)
---import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
+import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
 --import Gargantext.Text.Metrics.TFICF (Tficf(..))
 --import Debug.Trace (trace)
-import Control.Lens ((^.), view, Lens')
+import Control.Lens ((^.), view, Lens', _Just)
 import Control.Monad (mapM_)
 import Control.Monad.IO.Class (liftIO)
 import Data.List (concat)
@@ -52,6 +52,7 @@ import Gargantext.Database.TextSearch (searchInDatabase)
 import Gargantext.Database.Config (userMaster, corpusMasterName)
 import Gargantext.Database.Flow.Utils (insertToNodeNgrams)
 import Gargantext.Database.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
+import Gargantext.Database.Node.Contact -- (HyperdataContact(..), ContactWho(..))
 import Gargantext.Database.Root (getRoot)
 import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams,  NgramsType(..), text2ngrams, ngramsTypeId)
 import Gargantext.Database.Schema.Node -- (mkRoot, mkCorpus, getOrMkList, mkGraph, mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError, NodeError(..), nodeError)
@@ -79,18 +80,33 @@ type FlowCmdM env err m =
   , HasRepoVar env
   )
 
+type FlowCorpus a = ( AddUniqId a
+                    , UniqId a
+                    , InsertDb a
+                    , ExtractNgramsT a
+                    )
 
 ------------------------------------------------------------------------
 
+--{-
+flowAnnuaire' :: FlowCmdM env ServantErr m 
+             => Username -> CorpusName -> (TermType Lang) -> FilePath -> m AnnuaireId
+flowAnnuaire' u n l filePath = do
+  docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
+  flowAnnuaire u n (Multi FR) docs
+--}
+
 flowCorpusDebat :: FlowCmdM env ServantErr m
-            => Username -> CorpusName -> Limit -> FilePath -> m CorpusId
+            => Username -> CorpusName
+            -> Limit -> FilePath
+            -> m CorpusId
 flowCorpusDebat u n l fp = do
   docs <- liftIO ( splitEvery 500
                  <$> take l
                  <$> GD.readFile fp
                  :: IO [[GD.GrandDebatReference ]]
                  )
-  flowCorpus u n (Multi FR) docs
+  flowCorpus u n (Multi FR) (map (map toHyperdataDocument) docs)
 
 
 flowCorpusFile :: FlowCmdM env ServantErr m
@@ -103,43 +119,54 @@ flowCorpusFile u n l la ff fp = do
                  <$> take l
                  <$> parseDocs ff fp
                  )
-  flowCorpus u n la docs
+  flowCorpus u n la (map (map toHyperdataDocument) docs)
 
 -- TODO query with complex query
 flowCorpusSearchInDatabase :: FlowCmdM env ServantErr m
           => Username -> Lang -> Text -> m CorpusId
 flowCorpusSearchInDatabase u la q = do
-  (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster ""
+  (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster "" (Nothing :: Maybe HyperdataCorpus)
   ids <-  map fst <$> searchInDatabase cId (stemIt q)
-  flowCorpusUser la u q ids
+  flowCorpusUser la u q (Nothing :: Maybe HyperdataCorpus) ids
 
 ------------------------------------------------------------------------
 
 -- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
 -- TODO-EVENTS: InsertedNodes
-flowCorpus :: (FlowCmdM env ServantErr m, ToHyperdataDocument a)
-           => Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId
-flowCorpus u cn la docs = do
-  ids <- mapM ((insertMasterDocs la) . (map toHyperdataDocument)) docs
-  flowCorpusUser (la ^. tt_lang) u cn (concat ids)
 
 
-flowCorpusUser :: FlowCmdM env ServantErr m
-               => Lang -> Username -> CorpusName -> [NodeId] -> m CorpusId
-flowCorpusUser l userName corpusName ids = do
+flow :: (FlowCmdM env ServantErr m, FlowCorpus a, MkCorpus c)
+     => Maybe c -> Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId
+flow c u cn la docs = do
+  ids <- mapM (insertMasterDocs c la ) docs
+  flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
+
+flowCorpus :: (FlowCmdM env ServantErr m, FlowCorpus a)
+     => Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId
+flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
+
+flowAnnuaire :: (FlowCmdM env ServantErr m, FlowCorpus a)
+     => Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId
+flowAnnuaire = flow (Nothing :: Maybe HyperdataAnnuaire)
+
+
+flowCorpusUser :: (FlowCmdM env ServantErr m, MkCorpus c)
+               => Lang -> Username -> CorpusName -> Maybe c -> [NodeId] -> m CorpusId
+flowCorpusUser l userName corpusName ctype ids = do
   -- User Flow
-  (userId, _rootId, userCorpusId) <- getOrMkRootWithCorpus userName corpusName
+  (userId, _rootId, userCorpusId) <- getOrMkRootWithCorpus userName corpusName ctype
   -- TODO: check if present already, ignore
   _ <- Doc.add userCorpusId ids
 
   -- User List Flow
+  {-
   (_masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster ""
   ngs         <- buildNgramsLists l 2 3 (StopSize 3) userCorpusId masterCorpusId
   userListId  <- flowList userId userCorpusId ngs
   printDebug "userListId" userListId
-
   -- User Graph Flow
   _ <- mkGraph     userCorpusId userId
+  -}
 
   -- User Dashboard Flow
   -- _ <- mkDashboard userCorpusId userId
@@ -150,20 +177,18 @@ flowCorpusUser l userName corpusName ids = do
 
 
 insertMasterDocs :: ( FlowCmdM env ServantErr m
-                    , AddUniqId a -- Maybe use a Setter her
-                    , UniqId a    -- That is a lens
-                    , InsertDb a
-                    , ExtractNgramsT a
+                    , FlowCorpus a
+                    , MkCorpus   c
                     )
-                => TermType Lang -> [a] -> m [DocId]
-insertMasterDocs lang hs  =  do
-  (masterUserId, _, masterCorpusId) <- getOrMkRootWithCorpus userMaster corpusMasterName
+                 => Maybe c -> TermType Lang -> [a] -> m [DocId]
+insertMasterDocs c lang hs  =  do
+  (masterUserId, _, masterCorpusId) <- getOrMkRootWithCorpus userMaster corpusMasterName c
 
   -- TODO Type NodeDocumentUnicised
   let hs' = map addUniqId hs
   ids <- insertDb masterUserId masterCorpusId hs'
-
   let documentsWithId = mergeData (toInserted ids) (DM.fromList $ map viewUniqId' hs')
+  
   docsWithNgrams     <- documentIdWithNgrams (extractNgramsT lang) documentsWithId
 
   let maps            = mapNodeIdNgrams docsWithNgrams
@@ -177,10 +202,10 @@ insertMasterDocs lang hs  =  do
 
 type CorpusName = Text
 
-getOrMkRootWithCorpus :: HasNodeError err
-              => Username -> CorpusName
+getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a)
+              => Username -> CorpusName -> Maybe a
               -> Cmd err (UserId, RootId, CorpusId)
-getOrMkRootWithCorpus username cName = do
+getOrMkRootWithCorpus username cName c = do
   maybeUserId <- getUser username
   userId <- case maybeUserId of
         Nothing   -> nodeError NoUserFound
@@ -202,17 +227,16 @@ getOrMkRootWithCorpus username cName = do
                     pure $ map _node_id ns
                   else
                     pure []
-
+  
   corpusId' <- if corpusId'' /= []
                   then pure corpusId''
-                  else mkCorpus (Just cName) Nothing rootId userId
+                  else mk (Just cName) c rootId userId
 
   corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
 
   pure (userId, rootId, corpusId)
 
 
-
 ------------------------------------------------------------------------
 
 class UniqId a
@@ -224,6 +248,9 @@ instance UniqId HyperdataDocument
   where
     uniqId = hyperdataDocument_uniqId
 
+instance UniqId HyperdataContact
+  where
+    uniqId = hc_uniqId
 
 viewUniqId' :: UniqId a => a -> (HashId, a)
 viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
@@ -261,6 +288,23 @@ class ExtractNgramsT h
   where
     extractNgramsT :: TermType Lang -> h -> Cmd err (Map Ngrams (Map NgramsType Int))
 
+
+instance ExtractNgramsT HyperdataContact
+  where
+    extractNgramsT l hc = filterNgramsT 255 <$> extract l hc
+      where
+        extract :: TermType Lang -> HyperdataContact
+                -> Cmd err (Map Ngrams (Map NgramsType Int))
+        extract _l hc' = do
+          let authors = map text2ngrams
+                     $ maybe ["Nothing"] (\a -> [a])
+                     $ view (hc_who . _Just . cw_lastName) hc'
+        
+          pure $ DM.fromList $ [(a', DM.singleton Authors     1) | a' <- authors    ]
+
+
+
+
 instance ExtractNgramsT HyperdataDocument
   where
     extractNgramsT = extractNgramsT'
@@ -299,13 +343,13 @@ extractNgramsT' lang hd = filterNgramsT 255 <$> extractNgramsT'' lang hd
                          <> [(t', DM.singleton NgramsTerms 1) | t' <- terms'     ]
 
 
-    filterNgramsT :: Int -> Map Ngrams (Map NgramsType Int)
-                         -> Map Ngrams (Map NgramsType Int)
-    filterNgramsT s ms = DM.fromList $ map (\a -> filter' s a) $ DM.toList ms
-      where
-        filter' s' (ng@(Ngrams t n),y) = case (Text.length t) < s' of
-              True  -> (ng,y)
-              False -> (Ngrams (Text.take s' t) n , y)
+filterNgramsT :: Int -> Map Ngrams (Map NgramsType Int)
+                     -> Map Ngrams (Map NgramsType Int)
+filterNgramsT s ms = DM.fromList $ map (\a -> filter' s a) $ DM.toList ms
+  where
+    filter' s' (ng@(Ngrams t n),y) = case (Text.length t) < s' of
+          True  -> (ng,y)
+          False -> (Ngrams (Text.take s' t) n , y)
 
 
 documentIdWithNgrams :: HasNodeError err

src/Gargantext/Database/Flow/Annuaire.hs

+{-|
+Module      : Gargantext.Database.Flow.Annuaire
+Description : Database Flow Annuaire
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE FlexibleContexts  #-}
+
+module Gargantext.Database.Flow.Annuaire
+    where
+
+
+
+{-
+import Gargantext.Prelude
+import Gargantext.Database.Flow
+
+-- | Annuaire
+
+flowAnnuaire :: FlowCmdM env ServantErr m => FilePath -> m ()
+flowAnnuaire filePath = do
+  contacts <- liftIO $ deserialiseImtUsersFromFile filePath
+  ps <- flowInsertAnnuaire "Annuaire"
+      $ map (\h-> ToDbContact h)
+      $ map addUniqIdsContact contacts
+  printDebug "length annuaire" ps
+
+

src/Gargantext/Database/Metrics.hs

@@ -26,7 +26,7 @@ import Gargantext.Core.Types (ListType(..), Limit)
 import Gargantext.Database.Flow (FlowCmdM)
 import Gargantext.Database.Metrics.NgramsByNode (getNodesByNgramsOnlyUser, getTficfWith)
 import Gargantext.Database.Schema.Node (defaultList)
-import Gargantext.Database.Types.Node (ListId, CorpusId)
+import Gargantext.Database.Types.Node (ListId, CorpusId, HyperdataCorpus)
 import Gargantext.Database.Flow (getOrMkRootWithCorpus)
 import Gargantext.Database.Config (userMaster)
 import Gargantext.Prelude
@@ -50,7 +50,7 @@ getMetrics :: FlowCmdM env ServantErr m
 getMetrics cId maybeListId tabType maybeLimit = do
   (ngs, ngs', metrics)    <- getLocalMetrics cId maybeListId tabType maybeLimit
   
-  (_masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster ""
+  (_masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster "" (Nothing :: Maybe HyperdataCorpus)
   
   metrics' <- getTficfWith cId masterCorpusId (ngramsTypeFromTabType tabType) ngs'
 

src/Gargantext/Database/Node/Document/Insert.hs

@@ -99,16 +99,11 @@ import Database.PostgreSQL.Simple (formatQuery)
 ---------------------------------------------------------------------------
 -- * Main Insert functions
 
--- ** Database configuration
--- Administrator of the database has to create a uniq index as following SQL command:
--- `create unique index on nodes (typename, parent_id, (hyperdata ->> 'uniqId'));`
-
 -- | Insert Document main function
 -- UserId : user who is inserting the documents
 -- ParentId : folder ID which is parent of the inserted documents
-
-
-
+-- Administrator of the database has to create a uniq index as following SQL command:
+-- `create unique index on nodes (typename, parent_id, (hyperdata ->> 'uniqId'));`
 insertDb :: InsertDb a => UserId -> ParentId -> [a] -> Cmd err [ReturnId]
 insertDb u p = runPGSQuery queryInsert . Only . Values fields . map (insertDb' u p)
       where

src/Gargantext/Database/Schema/Node.hs

@@ -558,8 +558,26 @@ mkRoot uname uId = case uId > 0 of
                False -> nodeError NegativeId
                True  -> mkNodeWithParent NodeUser Nothing uId uname
 
-mkCorpus :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> Cmd err [CorpusId]
-mkCorpus n h p u = insertNodesR [nodeCorpusW n h p u]
+-- |
+-- CorpusDocument is a corpus made from a set of documents
+-- CorpusContact  is a corpus made from a set of contacts (syn of Annuaire)
+data CorpusType = CorpusDocument | CorpusContact
+
+class MkCorpus a
+  where
+    mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
+
+instance MkCorpus HyperdataCorpus
+  where
+    mk n h p u = insertNodesR [nodeCorpusW n h p u]
+
+
+instance MkCorpus HyperdataAnnuaire
+  where
+    mk n h p u = insertNodesR [nodeAnnuaireW n h p u]
+
+
+
 
 getOrMkList :: HasNodeError err => ParentId -> UserId -> Cmd err ListId
 getOrMkList pId uId =
@@ -582,9 +600,6 @@ mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
 mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
 mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
 
-mkAnnuaire :: ParentId -> UserId -> Cmd err [NodeId]
-mkAnnuaire p u = insertNodesR [nodeAnnuaireW Nothing Nothing p u]
-
 -- | Default CorpusId Master and ListId Master
 
 pgNodeId :: NodeId -> Column PGInt4