[API][NGRAMS] routes added.

src/Gargantext/API/Ngrams.hs

@@ -19,35 +19,70 @@ add get
 
 -}
 
+{-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeOperators     #-}
 {-# LANGUAGE FlexibleInstances #-}
 
 module Gargantext.API.Ngrams
   where
 
+import Prelude (Enum, Bounded, minBound, maxBound)
+import Control.Monad.IO.Class (liftIO)
 import Data.Aeson (FromJSON, ToJSON)
+import Data.Either(Either(Left))
 import Data.Aeson.TH (deriveJSON)
-
+import Database.PostgreSQL.Simple (Connection)
 import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as DM
-import Data.Map.Strict.Patch (Patch, apply, Edit, EditV, replace, transformWith, fromList)
+import GHC.Generics (Generic)
+--import qualified Data.Map.Strict as DM
+--import Data.Map.Strict.Patch (Patch, replace, fromList)
 import Data.Text (Text)
-import Data.Maybe (catMaybes)
+--import Data.Maybe (catMaybes)
 import Data.Set (Set)
-import qualified Data.Set as Set
+--import qualified Data.Set as Set
 
 import GHC.Generics (Generic)
 
 import Gargantext.Database.Ngram (NgramsId)
+import Gargantext.Database.NodeNgram (updateNodeNgrams)
 import Gargantext.Database.User  (UserId)
 import Gargantext.Text.List.Types (ListType(..))
 import Gargantext.Core.Types.Main (Tree(..))
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Prelude
+import Servant hiding (Patch)
+
+import Data.Swagger (ToSchema, ToParamSchema)
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+
+------------------------------------------------------------------------
+--data FacetFormat = Table | Chart
+data TabType   = Docs   | Terms  | Sources | Authors | Trash
+  deriving (Generic, Enum, Bounded)
+
+instance FromHttpApiData TabType
+  where
+    parseUrlPiece "Docs"    = pure Docs
+    parseUrlPiece "Terms"   = pure Terms
+    parseUrlPiece "Sources" = pure Sources
+    parseUrlPiece "Authors" = pure Authors
+    parseUrlPiece "Trash"   = pure Trash
+    parseUrlPiece _         = Left "Unexpected value of TabType"
+
+instance ToParamSchema   TabType
+instance ToJSON    TabType
+instance FromJSON  TabType
+instance ToSchema  TabType
+instance Arbitrary TabType
+  where
+    arbitrary = elements [minBound .. maxBound]
 
+------------------------------------------------------------------------
 data NgramsElement =
      NgramsElement { _ne_id     :: Int
                    , _ne_ngrams :: Text
@@ -59,14 +94,15 @@ $(deriveJSON (unPrefix "_ne_") ''NgramsElement)
 
 data NgramsTable = NgramsTable { _ngramsTable :: [Tree NgramsElement] }
   deriving (Ord, Eq, Generic)
+$(deriveJSON (unPrefix "_") ''NgramsTable)
 
-instance ToJSON   NgramsTable
-instance FromJSON NgramsTable
 
-instance FromJSON (Tree NgramsElement)
 -- TODO
+instance FromJSON (Tree NgramsElement)
 instance ToJSON   (Tree NgramsElement)
 
+------------------------------------------------------------------------
+-- On the Client side:
 --data Action = InGroup     NgramsId NgramsId
 --            | OutGroup    NgramsId NgramsId
 --            | SetListType NgramsId ListType
@@ -76,12 +112,41 @@ data NgramsPatch =
                  , _np_add_children :: Set NgramsId
                  , _np_rem_children :: Set NgramsId
                  }
-      deriving (Ord, Eq, Show)
-
+      deriving (Ord, Eq, Show, Generic)
 $(deriveJSON (unPrefix "_np_") ''NgramsPatch)
 
-type NgramsIdPatch = Patch NgramsId NgramsPatch
+instance ToSchema  NgramsPatch
+
+instance Arbitrary NgramsPatch where
+  arbitrary = NgramsPatch <$> arbitrary <*> arbitrary <*> arbitrary
+
+                       --
+
+data NgramsIdPatch = 
+     NgramsIdPatch { _nip_ngramsId    :: NgramsId
+                   , _nip_ngramsPatch :: NgramsPatch
+                   }
+      deriving (Ord, Eq, Show, Generic)
+
+$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
+
+instance ToSchema  NgramsIdPatch
+
+instance Arbitrary NgramsIdPatch where
+  arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
+
+                       --
+
+data NgramsIdPatchs =
+     NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
+      deriving (Ord, Eq, Show, Generic)
+$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
+instance ToSchema  NgramsIdPatchs
+instance Arbitrary NgramsIdPatchs where
+  arbitrary = NgramsIdPatchs <$> arbitrary
 
+
+------------------------------------------------------------------------
 ------------------------------------------------------------------------
 type Version = Int
 
@@ -91,21 +156,59 @@ data Versioned a = Versioned
   }
 
 
+{-
+-- TODO sequencs of modifications (Patchs)
+type NgramsIdPatch = Patch NgramsId NgramsPatch
+
 ngramsPatch :: Int -> NgramsPatch
 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
 
-{-
 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 toEdit n p = Edit n p
--}
 ngramsIdPatch :: Patch NgramsId NgramsPatch
 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
                                        ]
 
-
 -- applyPatchBack :: Patch -> IO Patch
 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
-
+-}
+------------------------------------------------------------------------
+------------------------------------------------------------------------
 ------------------------------------------------------------------------
+type CorpusId = Int
+type ListId   = Int
+type TableNgramsApi = Summary " Table Ngrams API"
+                      :> QueryParam "list"   ListId
+                      :> ReqBody '[JSON] NgramsIdPatchs
+                      :> Put     '[JSON] NgramsIdPatchsBack
+
+type NgramsIdPatchsFeed = NgramsIdPatchs
+type NgramsIdPatchsBack = NgramsIdPatchs
+
+
+getDefaultList :: Connection -> CorpusId -> IO ListId
+getDefaultList = undefined
+
+type NgramsIdParent = Int
+type NgramsIdChild  = Int
+
+data Action = Del | Add
+
+
+doNgramsGroup :: Connection -> ListId -> Action -> [(NgramsIdParent, NgramsIdChild)] -> IO [Int] 
+doNgramsGroup = undefined
+
+
+tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
+tableNgramsPatch conn corpusId maybeList patchs = do
+  listId <- case maybeList of
+              Nothing      -> getDefaultList conn corpusId
+              Just listId' -> pure listId'
+  --_ <- doNgramsGroups conn listId Add $ 
+  --_ <- delNgramsGroups conn listId
+  --_ <- updateNodeNgrams   conn 
+  pure (NgramsIdPatchs [])
+
+

src/Gargantext/API/Node.hs

@@ -32,13 +32,11 @@ module Gargantext.API.Node
   , HyperdataDocumentV3(..)
   ) where
 -------------------------------------------------------------------
-import Prelude (Enum, Bounded, minBound, maxBound)
 import Control.Lens (prism')
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad ((>>))
 --import System.IO (putStrLn, readFile)
 
-import Data.Either(Either(Left))
 import Data.Aeson (FromJSON, ToJSON)
 --import Data.Text (Text(), pack)
 import Data.Text (Text())
@@ -50,6 +48,7 @@ import Database.PostgreSQL.Simple (Connection)
 import GHC.Generics (Generic)
 import Servant
 
+import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, tableNgramsPatch, NgramsIdPatchsFeed, NgramsIdPatchsBack, ListId)
 import Gargantext.Prelude
 import Gargantext.Database.Types.Node
 import Gargantext.Database.Node ( runCmd
@@ -106,7 +105,11 @@ type NodeAPI a = Get '[JSON] (Node a)
              :<|> Put    '[JSON] Int
              :<|> Delete '[JSON] Int
              :<|> "children"  :> ChildrenApi a
+             
+             -- TODO gather it
              :<|> "table"     :> TableApi
+             :<|> "list"      :> TableNgramsApi
+             
              :<|> "chart"     :> ChartApi
              :<|> "favorites" :> FavApi
              :<|> "documents" :> DocsApi
@@ -134,7 +137,11 @@ nodeAPI conn p id
               :<|> putNode       conn id
               :<|> deleteNode'   conn id
               :<|> getNodesWith' conn id p
+              
+              -- TODO gather it
               :<|> getTable      conn id
+              :<|> tableNgramsPatch'  conn id
+              
               :<|> getChart      conn id
               :<|> favApi        conn id
               :<|> delDocs       conn id
@@ -150,7 +157,6 @@ instance ToSchema  RenameNode
 instance Arbitrary RenameNode where
   arbitrary = elements [RenameNode "test"]
 ------------------------------------------------------------------------
-
 data PostNode = PostNode { pn_name :: Text
                          , pn_typename :: NodeType}
   deriving (Generic)
@@ -204,28 +210,6 @@ favApi :: Connection -> CorpusId -> (Favorites -> Handler [Int])
                                :<|> (Favorites -> Handler [Int])
 favApi c cId = putFav c cId :<|> delFav c cId
 
-------------------------------------------------------------------------
---data FacetFormat = Table | Chart
-data TabType   = Docs   | Terms  | Sources | Authors | Trash
-  deriving (Generic, Enum, Bounded)
-
-instance FromHttpApiData TabType
-  where
-    parseUrlPiece "Docs"    = pure Docs
-    parseUrlPiece "Terms"   = pure Terms
-    parseUrlPiece "Sources" = pure Sources
-    parseUrlPiece "Authors" = pure Authors
-    parseUrlPiece "Trash"   = pure Trash
-    parseUrlPiece _         = Left "Unexpected value of TabType"
-
-instance ToParamSchema   TabType
-instance ToJSON    TabType
-instance FromJSON  TabType
-instance ToSchema  TabType
-instance Arbitrary TabType
-  where
-    arbitrary = elements [minBound .. maxBound]
-
 ------------------------------------------------------------------------
 type TableApi = Summary " Table API"
               :> QueryParam "view"   TabType
@@ -234,12 +218,12 @@ type TableApi = Summary " Table API"
               :> QueryParam "order"  OrderBy
               :> Get '[JSON] [FacetDoc]
 
+------------------------------------------------------------------------
 type ChartApi = Summary " Chart API"
               :> QueryParam "from" UTCTime
               :> QueryParam "to"   UTCTime
               :> Get '[JSON] [FacetChart]
 
-
                 -- Depending on the Type of the Node, we could post
                 -- New documents for a corpus
                 -- New map list terms
@@ -300,6 +284,8 @@ getNodesWith' :: JSONB a => Connection -> NodeId -> proxy a -> Maybe NodeType
               -> Maybe Int -> Maybe Int -> Handler [Node a]
 getNodesWith' conn id p nodeType offset limit  = liftIO (getNodesWith conn id p nodeType offset limit)
 
+tableNgramsPatch' :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> Handler NgramsIdPatchsBack
+tableNgramsPatch' c cId mL ns = liftIO $ tableNgramsPatch c cId mL ns
 
 query :: Text -> Handler Text
 query s = pure s

src/Gargantext/Database/NodeNgram.hs

@@ -21,16 +21,20 @@ if Node is a List     then it is listing (either Stop, Candidate or Map)
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE NoImplicitPrelude      #-}
+{-# LANGUAGE QuasiQuotes            #-}
 {-# LANGUAGE TemplateHaskell        #-}
 
 
 module Gargantext.Database.NodeNgram where
 
-import Gargantext.Prelude
-import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
+import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
+import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Gargantext.Database.Node (mkCmd, Cmd(..))
+import Gargantext.Prelude
 import Opaleye
+import qualified Database.PostgreSQL.Simple as PGS (Connection, query, Only(..))
 
 -- | TODO : remove id
 data NodeNgramPoly id node_id ngram_id weight ngrams_type
@@ -90,3 +94,22 @@ insertNodeNgramW nns =
   mkCmd $ \c -> fromIntegral
        <$> runInsertMany c nodeNgramTable nns
 
+-- TODO: remove these type (duplicate with others)
+type ListId     = Int
+type NgramsId   = Int
+type ListTypeId = Int
+
+updateNodeNgrams :: PGS.Connection -> [(ListId, NgramsId, ListTypeId)] -> IO [PGS.Only Int]
+updateNodeNgrams c input = PGS.query c updateQuery (PGS.Only $ Values fields $ input)
+  where
+    fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","int4"]
+    updateQuery = [sql| UPDATE nodes_ngrams as old SET
+                 ngrams_type = new.typeList
+                 from (?) as new(node_id,ngram_id,typeList)
+                 WHERE old.node_id = new.node_id
+                 AND   old.gram_id = new.gram_id
+                 RETURNING new.ngram_id
+                 |]
+
+
+

src/Gargantext/Database/NodeNode.hs

@@ -133,8 +133,8 @@ nodeToTrash c cId dId b = PGS.query c trashQuery (b,cId,dId)
 
 -- | Trash Massive
 nodesToTrash :: PGS.Connection -> [(CorpusId,DocId,Bool)] -> IO [Int]
-nodesToTrash c inputData = map (\(PGS.Only a) -> a)
-                        <$> PGS.query c trashQuery (PGS.Only $ Values fields inputData)
+nodesToTrash c input = map (\(PGS.Only a) -> a)
+                        <$> PGS.query c trashQuery (PGS.Only $ Values fields input)
   where
     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","bool"]
     trashQuery :: PGS.Query

src/Gargantext/Text/List/Types.hs

@@ -23,6 +23,10 @@ import Data.Text (Text)
 import GHC.Generics (Generic)
 import Gargantext.Prelude
 import Prelude (Bounded, Enum, minBound, maxBound)
+import Data.Swagger (ToSchema)
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+
 
 -------------------------------------------------------------------
 data ListType = GraphList | StopList | CandidateList
@@ -30,6 +34,9 @@ data ListType = GraphList | StopList | CandidateList
 
 instance FromJSON ListType
 instance ToJSON   ListType
+instance ToSchema ListType
+instance Arbitrary ListType where
+  arbitrary = elements [minBound..maxBound]
 
 type Lists = Map ListType (Map Text [Text])
 

stack.yaml

@@ -6,6 +6,8 @@ packages:
 - 'deps/servant-job'
 - 'deps/clustering-louvain'
 - 'deps/patches-map'
+- 'deps/patches-class'
+
   #- 'deps/imt-api-client'
 
 allow-newer: true