Cleanup refactoring of config/settings/env
[gargantext.git] / src / Gargantext / Database / Action / Flow / Pairing.hs
index d1175d89a9342327eb8ff43d107473f75fa16bad..12b9038c226f97339d8383dd7d5906b62012607d 100644 (file)
@@ -9,77 +9,83 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE QuasiQuotes       #-}
--- {-# LANGUAGE Arrows #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE Arrows      #-}
 
 module Gargantext.Database.Action.Flow.Pairing
   -- (pairing)
     where
 
-import Data.Set (Set)
 import Control.Lens (_Just, (^.))
 import Data.Map (Map, fromList, fromListWith)
 import Data.Maybe (catMaybes, fromMaybe)
-import Data.Text (Text, toLower)
-import Database.PostgreSQL.Simple.SqlQQ (sql)
-import Gargantext.Core.Types (TableResult(..))
+import Data.Set (Set)
+import Data.Text (Text)
+import Gargantext.API.Ngrams.Tools
+import Gargantext.API.Prelude (GargNoServer)
+import Gargantext.Core.Types (TableResult(..), Term)
+import Gargantext.Core.Types.Main
 import Gargantext.Database
-import Gargantext.Database.Action.Flow.Utils
+import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser)
+import Gargantext.Database.Admin.Config
 import Gargantext.Database.Admin.Types.Hyperdata -- (HyperdataContact(..))
 import Gargantext.Database.Admin.Types.Node -- (AnnuaireId, CorpusId, ListId, DocId, ContactId, NodeId)
-import Gargantext.Database.Prelude (Cmd, runPGSQuery)
+import Gargantext.Database.Query.Prelude (leftJoin2, returnA, queryNodeNodeTable)
 import Gargantext.Database.Query.Table.Node.Children (getAllContacts)
+import Gargantext.Database.Query.Table.Node.Select (selectNodesWithUsername)
+import Gargantext.Database.Query.Table.Node (defaultList)
+import Gargantext.Database.Query.Table.NodeNode (insertNodeNode)
 import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
 import Gargantext.Database.Schema.Node
 import Gargantext.Prelude hiding (sum)
-import Safe (lastMay)
+import Opaleye
 import qualified Data.List as List
-import qualified Data.Map  as DM
 import qualified Data.Map  as Map
-import qualified Data.Text as DT
 import qualified Data.Set  as Set
-
--- TODO mv this type in Types Main
-type Terms = Text
-
-
-
-{-
-pairingPolicy :: (Terms -> Terms)
-              -> NgramsT Ngrams
-              -> NgramsT Ngrams
-pairingPolicy f (NgramsT nt (Ngrams ng _)) = (NgramsT nt (Ngrams (f ng) 1))
+import qualified Data.Text as DT
 
 
-pairMaps :: Map (NgramsT Ngrams) a
-         -> Map (NgramsT Ngrams) NgramsId
-         -> Map NgramsIndexed (Map NgramsType a)
-pairMaps m1 m2 =
-  DM.fromList
-    [ (NgramsIndexed ng nId, DM.singleton nt n2i)
-    | (k@(NgramsT nt ng),n2i) <- DM.toList m1
-    , Just nId <- [DM.lookup k m2]
-    ]
--}
+-- | isPairedWith
+-- All NodeAnnuaire paired with a Corpus of NodeId nId:
+-- isPairedWith NodeAnnuaire corpusId
+isPairedWith :: NodeId -> NodeType -> Cmd err [NodeId]
+isPairedWith nId nt = runOpaQuery (selectQuery nt nId)
+  where
+    selectQuery :: NodeType -> NodeId -> Query (Column PGInt4)
+    selectQuery nt' nId' = proc () -> do
+      (node, node_node) <- queryJoin -< ()
+      restrict -< (node^.node_typename)    .== (pgInt4 $ nodeTypeId nt')
+      restrict -< (node_node^.nn_node1_id) .== (toNullable $ pgNodeId nId')
+      returnA  -<  node^.node_id
+
+    queryJoin :: Query (NodeRead, NodeNodeReadNull)
+    queryJoin = leftJoin2 queryNodeTable queryNodeNodeTable cond
+      where
+        cond (node, node_node) = node^.node_id .== node_node^. nn_node2_id
 
 -----------------------------------------------------------------------
-
-pairing :: AnnuaireId -> CorpusId -> ListId -> Cmd err Int
-pairing a c l = do
-  dataPaired <- dataPairing a (c,l,Authors) lastName toLower
+pairing :: AnnuaireId -> CorpusId -> Maybe ListId -> GargNoServer Int
+pairing a c l' = do
+  l <- case l' of
+    Nothing -> defaultList c
+    Just l'' -> pure l''
+  dataPaired <- dataPairing a (c,l,Authors) takeName takeName
   r <- insertDB $ prepareInsert dataPaired
-  pure (fromIntegral r)
+  _ <- insertNodeNode [ NodeNode c a Nothing Nothing]
+  pure r
 
 
 dataPairing :: AnnuaireId
              -> (CorpusId, ListId, NgramsType)
              -> (ContactName -> Projected)
              -> (DocAuthor   -> Projected)
-             -> Cmd err (Map ContactId (Set DocId))
+             -> GargNoServer (Map ContactId (Set DocId))
 dataPairing aId (cId, lId, ngt) fc fa = do
   mc <- getNgramsContactId aId
   md <- getNgramsDocId cId lId ngt
 
+  printDebug "ngramsContactId" mc
+  printDebug "ngramsDocId"     md
   let
     from = projectionFrom (Set.fromList $ Map.keys mc) fc
     to   = projectionTo   (Set.fromList $ Map.keys md) fa
@@ -98,8 +104,6 @@ prepareInsert m =  map (\(n1,n2) -> NodeNode n1 n2 Nothing Nothing)
                        )
                 $ Map.toList m
 
-
-
 ------------------------------------------------------------------------
 type ContactName = Text
 type DocAuthor   = Text
@@ -110,13 +114,12 @@ projectionFrom ss f = fromList $ map (\s -> (s, f s)) (Set.toList ss)
 
 projectionTo :: Set DocAuthor -> (DocAuthor -> Projected) -> Map Projected (Set DocAuthor)
 projectionTo ss f = fromListWith (<>) $ map (\s -> (f s, Set.singleton s)) (Set.toList ss)
-
 ------------------------------------------------------------------------
-lastName :: Terms -> Terms
-lastName texte = DT.toLower
-               $ maybe texte (\x -> if DT.length x > 3 then x else texte)
-                             (lastName' texte)
+takeName :: Term -> Term
+takeName texte = DT.toLower texte'
   where
+    texte' = maybe texte (\x -> if DT.length x > 3 then x else texte)
+                           (lastName' texte)
     lastName' = lastMay . DT.splitOn " "
 
 
@@ -148,19 +151,15 @@ align mc ma md = fromListWith (<>)
         Nothing -> Set.empty
         Just  a -> a
 
-
 fusion :: Map ContactName (Set ContactId)
        -> Map ContactName (Set DocId)
        -> Map ContactId   (Set DocId)
-fusion mc md = undefined
-{- fromListWith (<>)
-       $ catMaybes
-       $ map (\c -> case Map.lookup c mc of
-             Nothing -> Nothing
-             Just  x -> map (\
-
-       $ toList mc
--}
+fusion mc md = Map.fromListWith (<>)
+             $ catMaybes
+             $ [ (,) <$> Just cId <*> Map.lookup cn md
+                      | (cn, setContactId) <- Map.toList mc
+                      , cId <- Set.toList setContactId
+               ]
 ------------------------------------------------------------------------
 
 getNgramsContactId :: AnnuaireId
@@ -173,33 +172,15 @@ getNgramsContactId aId = do
                               <*> Just ( Set.singleton (contact^.node_id))
               ) (tr_docs contacts)
 
--- | TODO
--- filter Trash / map Authors
--- Indexing all ngramsType like Authors
-getNgramsDocId :: CorpusId
-                  -> ListId
-                  -> NgramsType
-                  -> Cmd err (Map DocAuthor (Set NodeId))
-getNgramsDocId corpusId listId ngramsType
-  = fromListWith (<>)
-  <$> map (\(t,nId) -> (t, Set.singleton (NodeId nId)))
-  <$> selectNgramsDocId corpusId listId ngramsType
-
-
-selectNgramsDocId :: CorpusId
-                   -> ListId
-                   -> NgramsType
-                   -> Cmd err [(Text, Int)]
-selectNgramsDocId corpusId' listId' ngramsType' =
- runPGSQuery selectQuery (corpusId', listId', ngramsTypeId ngramsType')
-   where
-     selectQuery = [sql| SELECT ng.terms,nnng.node2_id from ngrams ng
-                    JOIN node_node_ngrams nnng ON nnng.ngrams_id = ng.id
-                    JOIN nodes_nodes      nn   ON nn.node2_id    = nnng.node2_id
-
-                    WHERE nn.node1_id = ?
-                      AND nnng.node1_id    = ?
-                      AND nnng.ngrams_type = ?
-                    ;
-                   |]
 
+getNgramsDocId :: CorpusId
+                -> ListId
+                -> NgramsType
+                -> GargNoServer (Map DocAuthor (Set NodeId))
+getNgramsDocId cId lId nt = do
+  repo <- getRepo
+  lIds <- selectNodesWithUsername NodeList userMaster
+  let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
+
+  groupNodesByNgrams ngs
+    <$> getNodesByNgramsOnlyUser cId (lIds <> [lId]) nt (Map.keys ngs)