Merge branch 'dev-ngrams-table' into dev

src/Gargantext/API/Ngrams.hs

@@ -10,10 +10,6 @@ Portability : POSIX
 Ngrams API
 
 -- | TODO
--- get data of NgramsTable
--- post :: update NodeNodeNgrams
--- group ngrams
-
 get ngrams filtered by NgramsType
 add get 
 
@@ -37,7 +33,7 @@ module Gargantext.API.Ngrams
 import Prelude (round)
 -- import Gargantext.Database.Schema.User  (UserId)
 import Data.Functor (($>))
-import Data.Patch.Class (Replace, replace)
+import Data.Patch.Class (Replace, replace, new)
 --import qualified Data.Map.Strict.Patch as PM
 import Data.Monoid
 --import Data.Semigroup
@@ -47,25 +43,26 @@ import qualified Data.Set as Set
 -- import qualified Data.Map.Strict as DM
 import Data.Map.Strict (Map)
 --import qualified Data.Set as Set
-import Control.Lens (Prism', prism', (.~), (#))
-import Control.Monad (guard)
+import Control.Lens (makeLenses, Prism', prism', (^..), (.~), (#), to, withIndex, folded, ifolded)
+import Control.Monad (guard, void)
 import Control.Monad.Error.Class (MonadError, throwError)
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import Data.Either(Either(Left))
 import Data.Map (lookup)
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
-import Data.Swagger hiding (version)
+import Data.Swagger hiding (version, patch)
 import Data.Text (Text)
 import GHC.Generics (Generic)
---import Gargantext.Core.Types.Main (Tree(..))
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Types.Node (NodeType(..))
 import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
+import Gargantext.Database.Schema.NodeNgram
+import Gargantext.Database.Schema.NodeNgramsNgrams
 import Gargantext.Database.Utils (Cmd)
 import Gargantext.Prelude
-import Gargantext.Core.Types (ListType(..), ListId, CorpusId, Limit, Offset)
+import Gargantext.Core.Types (ListType(..), ListTypeId, ListId, CorpusId, Limit, Offset, listTypeId)
 import Prelude (Enum, Bounded, minBound, maxBound)
 import Servant hiding (Patch)
 import Test.QuickCheck (elements)
@@ -109,7 +106,9 @@ data NgramsElement =
                    , _ne_children    :: Set NgramsTerm
                    }
       deriving (Ord, Eq, Show, Generic)
-$(deriveJSON (unPrefix "_ne_") ''NgramsElement)
+
+deriveJSON (unPrefix "_ne_") ''NgramsElement
+makeLenses ''NgramsElement
 
 instance ToSchema NgramsElement
 instance Arbitrary NgramsElement where
@@ -179,7 +178,8 @@ data NgramsPatch =
                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
                  }
       deriving (Ord, Eq, Show, Generic)
-$(deriveJSON (unPrefix "_") ''NgramsPatch)
+deriveJSON (unPrefix "_") ''NgramsPatch
+makeLenses ''NgramsPatch
 
 -- instance Semigroup NgramsPatch where
 
@@ -188,13 +188,10 @@ instance ToSchema  NgramsPatch
 instance Arbitrary NgramsPatch where
   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 
--- TODO:
--- * This should be a Map NgramsId NgramsPatch
--- * Patchs -> Patches
 newtype NgramsTablePatch =
-     NgramsTablePatch { _nip_ngramsIdPatchs :: Map NgramsTerm NgramsPatch }
-      deriving (Ord, Eq, Show, Generic, Arbitrary)
-$(deriveJSON (unPrefix "_nip_") ''NgramsTablePatch)
+     NgramsTablePatch { _ntp_ngrams_patches :: Map NgramsTerm NgramsPatch }
+      deriving (Ord, Eq, Show, Generic, Arbitrary, ToJSON, FromJSON)
+makeLenses ''NgramsTablePatch
 instance ToSchema  NgramsTablePatch
 
 -- TODO: replace by mempty once we have the Monoid instance
@@ -209,6 +206,12 @@ data Versioned a = Versioned
   { _v_version :: Version
   , _v_data    :: a
   }
+  deriving (Generic)
+deriveJSON (unPrefix "_v_") ''Versioned
+makeLenses ''Versioned
+instance ToSchema a => ToSchema (Versioned a)
+instance Arbitrary a => Arbitrary (Versioned a) where
+  arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 
 {-
 -- TODO sequencs of modifications (Patchs)
@@ -237,12 +240,12 @@ type TableNgramsApiGet = Summary " Table Ngrams API Get"
                       :> QueryParam "list"   ListId
                       :> QueryParam "limit"  Limit
                       :> QueryParam "offset" Offset
-                      :> Get    '[JSON] NgramsTable
+                      :> Get    '[JSON] (Versioned NgramsTable)
 
 type TableNgramsApi = Summary " Table Ngrams API Change"
                       :> QueryParam "list"   ListId
-                      :> ReqBody '[JSON] NgramsTablePatch -- (Versioned NgramsTablePatch)
-                      :> Put     '[JSON] NgramsTablePatch -- (Versioned NgramsTablePatch)
+                      :> ReqBody '[JSON] (Versioned NgramsTablePatch)
+                      :> Put     '[JSON] (Versioned NgramsTablePatch)
 
 data NgramError = UnsupportedVersion
   deriving (Show)
@@ -260,23 +263,26 @@ instance HasNgramError ServantErr where
 ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
 ngramError nne = throwError $ _NgramError # nne
 
-{-
-toLists :: ListId -> NgramsTablePatch -> [(ListId, NgramsId, ListTypeId)]
--- toLists = undefined
-toLists lId np = [ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
-
-toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
-toList = undefined
-
-toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsTablePatch -> [NodeNgramsNgrams]
-toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
-
-toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
--- toGroup = undefined
-toGroup lId addOrRem (NgramsIdPatch ngId patch)  =
-  map (\ng -> (NodeNgramsNgrams lId ngId ng (Just 1))) (Set.toList $ addOrRem patch)
-
--}
+-- TODO: Replace.old is ignored which means that if the current list
+-- `GraphList` and that the patch is `Replace CandidateList StopList` then
+-- the list is going to be `StopList` while it should keep `GraphList`.
+-- However this should not happen in non conflicting situations.
+mkListsUpdate :: ListId -> NgramsTablePatch -> [(ListId, NgramsTerm, ListTypeId)]
+mkListsUpdate lId patches =
+  [ (lId, ng, listTypeId lt)
+  | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
+  , lt <- patch ^.. patch_list . new
+  ]
+
+mkChildrenGroups :: ListId
+                 -> (PatchSet NgramsElement -> Set NgramsElement)
+                 -> NgramsTablePatch
+                 -> [(ListId, NgramsParent, NgramsChild, Maybe Double)]
+mkChildrenGroups lId addOrRem patches =
+  [ (lId, parent, child, Just 1)
+  | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
+  , child <- patch ^.. patch_children . to addOrRem . folded . ne_ngrams
+  ]
 
 -- Apply the given patch to the DB and returns the patch to be applied on the
 -- cilent.
@@ -285,29 +291,24 @@ toGroup lId addOrRem (NgramsIdPatch ngId patch)  =
 -- number is always 1 and the returned patch is always empty.
 tableNgramsPatch :: (HasNgramError err, HasNodeError err)
                  => CorpusId -> Maybe ListId
-                 -- -> Versioned NgramsTablePatch
-                 -- -> Cmd err (Versioned NgramsTablePatch)
-                 -> any
-                 -> Cmd err any
-tableNgramsPatch _ _ _ = undefined
-{-
-tableNgramsPatch corpusId maybeList (Versioned version _patch) = do
+                 -> Versioned NgramsTablePatch
+                 -> Cmd err (Versioned NgramsTablePatch)
+tableNgramsPatch corpusId maybeList (Versioned version patch) = do
   when (version /= 1) $ ngramError UnsupportedVersion
-  _listId <- maybe (defaultList corpusId) pure maybeList
-{-
-  _ <- ngramsGroup' Add $ toGroups listId _np_add_children patch
-  _ <- ngramsGroup' Del $ toGroups listId _np_rem_children patch
-  _ <- updateNodeNgrams (toLists listId patch)
--}
+  listId <- maybe (defaultList corpusId) pure maybeList
+  void $ updateNodeNgrams $ NodeNgramsUpdate
+    { _nnu_lists_update = mkListsUpdate listId patch
+    , _nnu_rem_children = mkChildrenGroups listId _rem patch
+    , _nnu_add_children = mkChildrenGroups listId _add patch
+    }
   pure $ Versioned 1 emptyNgramsTablePatch
--}
 
 -- | TODO Errors management
 --  TODO: polymorphic for Annuaire or Corpus or ...
 getTableNgrams :: HasNodeError err
                => CorpusId -> Maybe TabType
                -> Maybe ListId -> Maybe Limit -> Maybe Offset
-               -> Cmd err NgramsTable
+               -> Cmd err (Versioned NgramsTable)
 getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
   let lieu = "Garg.API.Ngrams: " :: Text
   let ngramsType = case maybeTabType of
@@ -331,7 +332,8 @@ getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
 
   -- printDebug "ngramsTableDatas" ngramsTableDatas
 
-  pure $ NgramsTable $ map (\(Ngrams.NgramsTableData ngs _ lt w) ->
+  pure $ Versioned 1 $
+         NgramsTable $ map (\(Ngrams.NgramsTableData ngs _ lt w) ->
                               NgramsElement ngs
                                             (maybe (panic $ lieu <> "listType") identity lt)
                                             (round w)

src/Gargantext/Database/Schema/NodeNgram.hs

@@ -37,6 +37,7 @@ 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, runPGSQuery)
+import Gargantext.Database.Schema.NodeNgramsNgrams
 import Gargantext.Prelude
 import Opaleye
 import qualified Database.PostgreSQL.Simple as PGS (Only(..))
@@ -114,8 +115,10 @@ insertNodeNgramW nns =
 
 type NgramsText = Text
 
-updateNodeNgrams :: [(ListId, NgramsText, ListTypeId)] -> Cmd err [PGS.Only Int]
-updateNodeNgrams input = runPGSQuery updateQuery (PGS.Only $ Values fields $ input)
+updateNodeNgrams' :: [(ListId, NgramsText, ListTypeId)] -> Cmd err [Int]
+updateNodeNgrams' [] = pure []
+updateNodeNgrams' input = map (\(PGS.Only a) -> a) <$>
+                          runPGSQuery updateQuery (PGS.Only $ Values fields $ input)
   where
     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","text","int4"]
     updateQuery = [sql| UPDATE nodes_ngrams as old SET
@@ -127,3 +130,16 @@ updateNodeNgrams input = runPGSQuery updateQuery (PGS.Only $ Values fields $ inp
                  -- RETURNING new.ngram_id
                  |]
 
+data NodeNgramsUpdate = NodeNgramsUpdate
+  { _nnu_lists_update :: [(ListId, NgramsText, ListTypeId)]
+  , _nnu_add_children :: [(ListId, NgramsParent, NgramsChild, Maybe Double)]
+  , _nnu_rem_children :: [(ListId, NgramsParent, NgramsChild, Maybe Double)]
+  }
+
+-- TODO wrap these updates in a transaction.
+updateNodeNgrams :: NodeNgramsUpdate -> Cmd err [Int]
+updateNodeNgrams nnu = do
+  xs <- updateNodeNgrams' $ _nnu_lists_update nnu
+  ys <- ngramsGroup Del   $ _nnu_rem_children nnu
+  zs <- ngramsGroup Add   $ _nnu_add_children nnu
+  pure $ xs <> ys <> zs

src/Gargantext/Database/Schema/NodeNgramsNgrams.hs

@@ -41,6 +41,7 @@ import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
 import Gargantext.Database.Utils (Cmd, runOpaQuery, runPGSQuery, connection)
+import Gargantext.Core.Types.Main (ListId)
 import Gargantext.Prelude
 import Opaleye
 import qualified Database.PostgreSQL.Simple as PGS
@@ -52,7 +53,6 @@ data NodeNgramsNgramsPoly node_id ngram1_id ngram2_id weight =
                    , _nng_Weight   :: weight
                    } deriving (Show)
 
-
 type NodeNgramsNgramsWrite =
   NodeNgramsNgramsPoly (Column PGInt4          )
                      (Column PGInt4          )
@@ -124,16 +124,18 @@ data Action   = Del | Add
 type NgramsParent = Text
 type NgramsChild  = Text
 
-ngramsGroup' :: Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)]
+
+ngramsGroup :: Action -> [(ListId, NgramsParent, NgramsChild, Maybe Double)]
              -> Cmd err [Int]
-ngramsGroup' action ngs = runNodeNgramsNgrams q ngs
+ngramsGroup _ [] = pure []
+ngramsGroup action ngs = runNodeNgramsNgrams q ngs
   where
     q = case action of
           Del -> queryDelNodeNgramsNgrams
           Add -> queryInsertNodeNgramsNgrams
 
 
-runNodeNgramsNgrams :: PGS.Query -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> Cmd err [Int]
+runNodeNgramsNgrams :: PGS.Query -> [(ListId, NgramsParent, NgramsChild, Maybe Double)] -> Cmd err [Int]
 runNodeNgramsNgrams q ngs = map (\(PGS.Only a) -> a) <$> runPGSQuery q (PGS.Only $ Values fields ngs' )
   where
     ngs'   = map (\(n,ng1,ng2,w) -> (n,ng1,ng2,maybe 0 identity w)) ngs