Merge branch 'dev-phylo' of https://gitlab.iscpif.fr/gargantext/haskell-gargantext...
[gargantext.git] / src / Gargantext / Database / Schema / NodeNgram.hs
index 84bad35b1d39d34983e088422d92023cd1f82515..ce917fe999ee8884c37e1b83df45704a230f4e3a 100644 (file)
@@ -16,108 +16,286 @@ if Node is a List     then it is listing (either Stop, Candidate or Map)
 
 {-# OPTIONS_GHC -fno-warn-orphans   #-}
 
-{-# LANGUAGE Arrows                 #-}
-{-# LANGUAGE FlexibleInstances      #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
-{-# LANGUAGE NoImplicitPrelude      #-}
-{-# LANGUAGE OverloadedStrings      #-}
-{-# LANGUAGE QuasiQuotes            #-}
-{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE Arrows                     #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FunctionalDependencies     #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE TemplateHaskell            #-}
 
 
 -- TODO NodeNgrams
 module Gargantext.Database.Schema.NodeNgram where
 
+import Data.ByteString (ByteString)
 import Data.Text (Text)
-import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Debug.Trace (trace)
+import Control.Lens.TH (makeLenses)
+import Control.Monad (void)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
 import Database.PostgreSQL.Simple.SqlQQ (sql)
-import Gargantext.Core.Types.Main (ListId, ListTypeId)
-import Gargantext.Database.Utils (mkCmd, Cmd(..))
+import Gargantext.Database.Utils (mkCmd, Cmd, execPGSQuery)
+import Gargantext.Core.Types.Main (ListTypeId)
+import Gargantext.Database.Types.Node (NodeId, ListId, NodeType(..))
+import Gargantext.Database.Config (nodeTypeId, userMaster)
+import Gargantext.Database.Schema.Node (pgNodeId)
+import Gargantext.Database.Schema.Ngrams (NgramsTypeId, pgNgramsTypeId)
 import Gargantext.Prelude
+import Gargantext.Database.Utils (formatPGSQuery)
 import Opaleye
-import qualified Database.PostgreSQL.Simple as PGS (Connection, query, Only(..))
+import qualified Database.PostgreSQL.Simple as DPS
 
 -- | TODO : remove id
-data NodeNgramPoly id node_id ngram_id weight ngrams_type
-   = NodeNgram { nodeNgram_NodeNgramId      :: id
-               , nodeNgram_NodeNgramNodeId  :: node_id
-               , nodeNgram_NodeNgramNgramId :: ngram_id
-               , nodeNgram_NodeNgramWeight  :: weight
-               , nodeNgram_NodeNgramType    :: ngrams_type
+data NodeNgramPoly node_id ngrams_id parent_id ngrams_type list_type weight
+   = NodeNgram { _nn_node_id    :: node_id
+               , _nn_ngrams_id  :: ngrams_id
+               , _nn_parent_id  :: parent_id
+               
+               , _nn_ngramsType :: ngrams_type
+               , _nn_listType   :: list_type
+               , _nn_weight     :: weight
                } deriving (Show)
 
 type NodeNgramWrite =
      NodeNgramPoly
-        (Maybe (Column PGInt4  ))
                (Column PGInt4  )
                (Column PGInt4  )
-               (Column PGFloat8)
+               (Maybe (Column PGInt4))
+               
+               (Column PGInt4  )
                (Column PGInt4  )
+               (Column PGFloat8)
 
 type NodeNgramRead =
      NodeNgramPoly
        (Column PGInt4  )
        (Column PGInt4  )
        (Column PGInt4  )
-       (Column PGFloat8)
+       
+       (Column PGInt4  )
        (Column PGInt4  )
+       (Column PGFloat8)
 
 type NodeNgramReadNull =
      NodeNgramPoly
        (Column (Nullable PGInt4  ))
        (Column (Nullable PGInt4  ))
        (Column (Nullable PGInt4  ))
-       (Column (Nullable PGFloat8))
+       
+       (Column (Nullable PGInt4  ))
        (Column (Nullable PGInt4  ))
+       (Column (Nullable PGFloat8))
 
 type NodeNgram =
-     NodeNgramPoly (Maybe Int) Int Int Double Int
+     NodeNgramPoly NodeId Int (Maybe NgramsParentId) NgramsTypeId Int Double
 
-$(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
-$(makeLensesWith abbreviatedFields    ''NodeNgramPoly)
+newtype NgramsParentId = NgramsParentId Int
+  deriving (Show, Eq, Num)
+
+pgNgramsParentId :: NgramsParentId -> Column PGInt4
+pgNgramsParentId (NgramsParentId n) = pgInt4 n
 
+$(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
+makeLenses ''NodeNgramPoly
 
 nodeNgramTable :: Table NodeNgramWrite NodeNgramRead
 nodeNgramTable  = Table "nodes_ngrams"
   ( pNodeNgram NodeNgram
-    { nodeNgram_NodeNgramId      = optional "id"
-    , nodeNgram_NodeNgramNodeId  = required "node_id"
-    , nodeNgram_NodeNgramNgramId = required "ngram_id"
-    , nodeNgram_NodeNgramWeight  = required "weight"
-    , nodeNgram_NodeNgramType    = required "ngrams_type"
+    { _nn_node_id    = required "node_id"
+    , _nn_ngrams_id  = required "ngrams_id"
+    , _nn_parent_id  = optional "parent_id"
+    , _nn_ngramsType = required "ngrams_type"
+    , _nn_listType   = required "list_type"
+    , _nn_weight     = required "weight"
     }
   )
 
 queryNodeNgramTable :: Query NodeNgramRead
 queryNodeNgramTable = queryTable nodeNgramTable
 
-insertNodeNgrams :: [NodeNgram] -> Cmd Int
+insertNodeNgrams :: [NodeNgram] -> Cmd err Int
 insertNodeNgrams = insertNodeNgramW
-                 . map (\(NodeNgram _ n g w t) ->
-                          NodeNgram Nothing (pgInt4 n)   (pgInt4 g)
-                                            (pgDouble w) (pgInt4 t)
+                 . map (\(NodeNgram n g p ngt lt w) ->
+                          NodeNgram (pgNodeId n)
+                                    (pgInt4 g)
+                                    (pgNgramsParentId <$> p)
+                                    (pgNgramsTypeId ngt)
+                                    (pgInt4 lt)
+                                    (pgDouble w)
                         )
 
-insertNodeNgramW :: [NodeNgramWrite] -> Cmd Int
+insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
 insertNodeNgramW nns =
-  mkCmd $ \c -> fromIntegral
-       <$> runInsertManyOnConflictDoNothing c nodeNgramTable nns
+  mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
+    where
+      insertNothing = (Insert { iTable = nodeNgramTable
+                              , iRows  = nns
+                              , iReturning = rCount
+                              , iOnConflict = (Just DoNothing)
+                              })
 
 type NgramsText = Text
 
-updateNodeNgrams :: PGS.Connection -> [(ListId, NgramsText, ListTypeId)] -> IO [PGS.Only Int]
-updateNodeNgrams c input = PGS.query c updateQuery (PGS.Only $ Values fields $ input)
+updateNodeNgrams' :: ListId -> [(NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ()
+updateNodeNgrams' _      []    = pure ()
+updateNodeNgrams' listId input = void $ execPGSQuery updateQuery (DPS.Only $ Values fields input')
   where
-    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","text","int4"]
-    updateQuery = [sql| UPDATE nodes_ngrams as old SET
-                 ngrams_type = new.typeList
-                 from (?) as new(node_id,terms,typeList)
-                 JOIN ngrams ON ngrams.terms = new.terms
-                 WHERE old.node_id = new.node_id
-                 AND   old.ngram_id = ngrams.id;
-                 -- RETURNING new.ngram_id
-                 |]
+    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
+    input' = map (\(nt,t,lt) -> (listId, nt, t, lt)) input
+
+updateNodeNgrams'_debug :: ListId -> [(NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ByteString
+updateNodeNgrams'_debug listId input = formatPGSQuery updateQuery (DPS.Only $ Values fields input')
+  where
+    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
+    input' = map (\(nt,t,lt) -> (listId, nt, t, lt)) input
+
+updateQuery :: DPS.Query
+updateQuery = [sql|
+WITH new(node_id,ngrams_type,terms,typeList) as (?)
+
+INSERT into nodes_ngrams (node_id,ngrams_id,ngrams_type,list_type,weight)
+
+SELECT node_id,ngrams.id,ngrams_type,typeList,1 FROM new
+JOIN ngrams ON ngrams.terms = new.terms
+ON CONFLICT (node_id, ngrams_id, ngrams_type) DO
+-- DO NOTHING
+
+UPDATE SET list_type = excluded.list_type
+;
+               |]
+
+data Action   = Del | Add
+type NgramsParent = Text
+type NgramsChild  = Text
+
+ngramsGroup :: Action -> ListId -> [(NgramsTypeId, NgramsParent, NgramsChild)] -> Cmd err ()
+ngramsGroup _ _ [] = pure ()
+ngramsGroup a lid input = void $ trace (show input) $ execPGSQuery (ngramsGroupQuery a) (DPS.Only $ Values fields input')
+  where
+    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4","text","text"]
+    input' = map (\(ntpid,p,c) -> (lid, nodeTypeId NodeList, userMaster, ntpid, p,c)) input
+
+
+ngramsGroupQuery :: Action -> DPS.Query
+ngramsGroupQuery a = case a of
+  Add -> [sql|
+WITH input(lid,listTypeId,masterUsername,ntype,parent_terms,child_terms)
+  AS (?),
+  -- (VALUES (15::"int4",5::"int4",'gargantua'::"text",4::"int4",'input'::"text",'designer'::"text"))),
 
+list_master AS (
+   SELECT n.id from nodes n
+   JOIN auth_user u ON n.user_id = u.id
+   JOIN input ON n.typename = input.listTypeId
+   WHERE u.username = input.masterUsername
+   LIMIT 1
+),
+
+list_user AS(
+    -- FIRST import parent from master to user list
+    INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
+    SELECT input.lid,nn.ngrams_id,nn.parent_id,nn.ngrams_type,nn.list_type, nn.weight
+      FROM INPUT
+      JOIN ngrams ng       ON ng.terms     = input.parent_terms
+      JOIN nodes_ngrams nn ON nn.ngrams_id = ng.id
+      JOIN list_master     ON nn.node_id   = list_master.id
+    WHERE
+      nn.ngrams_id = ng.id
+      ON CONFLICT (node_id,ngrams_id,ngrams_type) DO NOTHING
+    )
+
+INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
+
+SELECT input.lid, nc.id, nnpu.id, input.ntype, nnmaster.list_type, nnmaster.weight
+FROM input
+
+JOIN ngrams np ON np.terms = input.parent_terms
+JOIN ngrams nc ON nc.terms = input.child_terms
+
+JOIN nodes_ngrams nnpu     ON nnpu.ngrams_id     = np.id
+JOIN nodes_ngrams nnmaster ON nnmaster.ngrams_id = nc.id
+JOIN list_master           ON nnmaster.node_id   = list_master.id
+
+WHERE
+    nnpu.node_id     = input.lid
+AND nnpu.ngrams_type = input.ntype
+
+AND nnmaster.ngrams_id   = nc.id
+AND nnmaster.ngrams_type = ntype
+
+ON CONFLICT (node_id,ngrams_id,ngrams_type) DO
+UPDATE SET parent_id = excluded.parent_id
+
+
+  |]
+  Del -> [sql|
+WITH input(lid,listTypeId,masterUsername,ntype,parent_terms,child_terms)
+  AS (?),
+  -- (VALUES (15::"int4",5::"int4",'gargantua'::"text",4::"int4",'input'::"text",'designer'::"text"))),
+
+list_master AS (
+   SELECT n.id from nodes n
+   JOIN auth_user u ON n.user_id = u.id
+   JOIN input ON n.typename = input.listTypeId
+   WHERE u.username = input.masterUsername
+   LIMIT 1
+),
+
+list_user AS(
+    -- FIRST import parent from master to user list
+    INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
+    SELECT input.lid,nn.ngrams_id,nn.parent_id,nn.ngrams_type,nn.list_type, nn.weight
+      FROM INPUT
+      JOIN ngrams ng       ON ng.terms     = input.parent_terms
+      JOIN nodes_ngrams nn ON nn.ngrams_id = ng.id
+      JOIN list_master     ON nn.node_id   = list_master.id
+    WHERE
+      nn.ngrams_id = ng.id
+      ON CONFLICT (node_id,ngrams_id,ngrams_type) DO NOTHING
+    )
+
+INSERT INTO nodes_ngrams (node_id,ngrams_id,parent_id,ngrams_type,list_type,weight)
+
+SELECT input.lid, nc.id, NULL, input.ntype, nnmaster.list_type, nnmaster.weight
+FROM input
+
+JOIN ngrams np ON np.terms = input.parent_terms
+JOIN ngrams nc ON nc.terms = input.child_terms
+
+JOIN nodes_ngrams nnmaster ON nnmaster.ngrams_id = nc.id
+JOIN list_master           ON nnmaster.node_id   = list_master.id
+
+WHERE
+    nnmaster.ngrams_id   = nc.id
+AND nnmaster.ngrams_type = ntype
+
+ON CONFLICT (node_id,ngrams_id,ngrams_type) DO
+UPDATE SET parent_id = NULL
+
+  |]
+
+
+data NodeNgramsUpdate = NodeNgramsUpdate
+  { _nnu_user_list_id :: ListId
+  , _nnu_lists_update :: [(NgramsTypeId, NgramsText, ListTypeId)]
+  , _nnu_add_children :: [(NgramsTypeId, NgramsParent, NgramsChild)]
+  , _nnu_rem_children :: [(NgramsTypeId, NgramsParent, NgramsChild)]
+  }
+
+-- TODO wrap these updates in a transaction.
+-- TODO-ACCESS:
+-- * check userId CanUpdateNgrams userListId
+updateNodeNgrams :: NodeNgramsUpdate -> Cmd err ()
+updateNodeNgrams nnu = do
+  updateNodeNgrams' userListId $ _nnu_lists_update nnu
+  ngramsGroup Del   userListId $ _nnu_rem_children nnu
+  ngramsGroup Add   userListId $ _nnu_add_children nnu
+  -- TODO remove duplicate line (fix SQL query)
+  ngramsGroup Add   userListId $ _nnu_add_children nnu
+  where
+    userListId = _nnu_user_list_id nnu