[API] get / put NgramsList (todo: tests)

src/Gargantext/API.hs

@@ -92,6 +92,7 @@ import Gargantext.API.Search (SearchPairsAPI, searchPairs)
 import Gargantext.API.Types
 import qualified Gargantext.API.Annuaire as Annuaire
 import qualified Gargantext.API.Export as Export
+import qualified Gargantext.API.Ngrams.List as List
 import qualified Gargantext.API.Corpus.New as New
 import Gargantext.Database.Types.Node
 import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
@@ -257,7 +258,7 @@ type GargPrivateAPI' =
                         :> Capture "node_id" NodeId
                         :> NodeAPI HyperdataAny
 
-           -- Corpus endpoint
+           -- Corpus endpoints
            :<|> "corpus":> Summary "Corpus endpoint"
                         :> Capture "corpus_id" CorpusId
                         :> NodeAPI HyperdataCorpus
@@ -314,6 +315,11 @@ type GargPrivateAPI' =
            -- :<|> New.AddWithFile
        --  :<|> "scraper" :> WithCallbacks ScraperAPI
        --  :<|> "new"  :> New.Api
+
+           :<|> "list" :> Summary "List export API"
+                       :> Capture "listId" ListId
+                       :> List.API
+
            :<|> "fib" :> Summary "Fib test"
                       :> Capture "x" Int
                       :> FibAPI -- Get '[JSON] Int
@@ -404,6 +410,7 @@ serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
      :<|> addAnnuaireWithForm
      -- :<|> New.api  uid -- TODO-SECURITY
      -- :<|> New.info uid -- TODO-SECURITY
+     :<|> List.api
      :<|> fibAPI
 
 

src/Gargantext/API/Export.hs

@@ -11,10 +11,8 @@ Main exports of Gargantext:
 - corpus
 - document and ngrams
 - lists
-
 -}
 
-
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE FlexibleContexts  #-}

src/Gargantext/API/Ngrams.hs

@@ -40,12 +40,14 @@ module Gargantext.API.Ngrams
 
   , getTableNgrams
   , putListNgrams
+  , putListNgrams'
   , tableNgramsPost
   , apiNgramsTableCorpus
   , apiNgramsTableDoc
 
   , NgramsStatePatch
   , NgramsTablePatch
+  , NgramsTableMap
 
   , NgramsElement(..)
   , mkNgramsElement
@@ -85,6 +87,7 @@ module Gargantext.API.Ngrams
   , tableNgramsPull
   , tableNgramsPut
 
+  , Version
   , Versioned(..)
   , currentVersion
   , listNgramsChangedSince
@@ -239,6 +242,10 @@ data NgramsRepoElement = NgramsRepoElement
 deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
 makeLenses ''NgramsRepoElement
 
+instance ToSchema NgramsRepoElement where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
+
+
 data NgramsElement =
      NgramsElement { _ne_ngrams      :: NgramsTerm
                    , _ne_size        :: Int
@@ -253,7 +260,11 @@ data NgramsElement =
 deriveJSON (unPrefix "_ne_") ''NgramsElement
 makeLenses ''NgramsElement
 
-mkNgramsElement :: NgramsTerm -> ListType -> Maybe RootParent -> MSet NgramsTerm -> NgramsElement
+mkNgramsElement :: NgramsTerm
+                -> ListType
+                -> Maybe RootParent
+                -> MSet NgramsTerm
+                -> NgramsElement
 mkNgramsElement ngrams list rp children =
   NgramsElement ngrams size list 1 (_rp_root <$> rp) (_rp_parent <$> rp) children
   where
@@ -261,7 +272,8 @@ mkNgramsElement ngrams list rp children =
     size = 1 + count " " ngrams
 
 newNgramsElement :: Maybe ListType -> NgramsTerm -> NgramsElement
-newNgramsElement mayList ngrams = mkNgramsElement ngrams (fromMaybe GraphTerm mayList) Nothing mempty
+newNgramsElement mayList ngrams =
+  mkNgramsElement ngrams (fromMaybe GraphTerm mayList) Nothing mempty
 
 instance ToSchema NgramsElement where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
@@ -270,17 +282,17 @@ instance Arbitrary NgramsElement where
 
 ngramsElementToRepo :: NgramsElement -> NgramsRepoElement
 ngramsElementToRepo
-  (NgramsElement { _ne_size = s
-                 , _ne_list = l
-                 , _ne_root = r
-                 , _ne_parent = p
+  (NgramsElement { _ne_size     = s
+                 , _ne_list     = l
+                 , _ne_root     = r
+                 , _ne_parent   = p
                  , _ne_children = c
                  }) =
   NgramsRepoElement
-    { _nre_size = s
-    , _nre_list = l
-    , _nre_parent = p
-    , _nre_root   = r
+    { _nre_size     = s
+    , _nre_list     = l
+    , _nre_parent   = p
+    , _nre_root     = r
     , _nre_children = c
     }
 
@@ -288,18 +300,18 @@ ngramsElementFromRepo :: NgramsTerm -> NgramsRepoElement -> NgramsElement
 ngramsElementFromRepo
   ngrams
   (NgramsRepoElement
-      { _nre_size = s
-      , _nre_list = l
-      , _nre_parent = p
-      , _nre_root = r
+      { _nre_size     = s
+      , _nre_list     = l
+      , _nre_parent   = p
+      , _nre_root     = r
       , _nre_children = c
       }) =
-  NgramsElement { _ne_size = s
-                , _ne_list = l
-                , _ne_root = r
-                , _ne_parent = p
-                , _ne_children = c
-                , _ne_ngrams = ngrams
+  NgramsElement { _ne_size        = s
+                , _ne_list        = l
+                , _ne_root        = r
+                , _ne_parent      = p
+                , _ne_children    = c
+                , _ne_ngrams      = ngrams
                 , _ne_occurrences = panic $ "API.Ngrams._ne_occurrences"
                 {-
                 -- Here we could use 0 if we want to avoid any `panic`.
@@ -313,7 +325,7 @@ ngramsElementFromRepo
 newtype NgramsTable = NgramsTable [NgramsElement]
   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 
-type ListNgrams = NgramsTable
+type NgramsList = NgramsTable
 
 makePrisms ''NgramsTable
 
@@ -335,10 +347,10 @@ toNgramsElement ns = map toNgramsElement' ns
                  Just x  -> lookup x mapParent
           c' = maybe mempty identity $ lookup t mapChildren
           lt' = maybe (panic "API.Ngrams: listypeId") identity lt
-      
+
       mapParent :: Map Int Text
       mapParent   = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
-      
+
       mapChildren :: Map Text (Set Text)
       mapChildren = Map.mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
                   $ Map.fromListWith (<>)
@@ -372,7 +384,6 @@ instance ToSchema NgramsTable
 
 ------------------------------------------------------------------------
 type NgramsTableMap = Map NgramsTerm NgramsRepoElement
-
 ------------------------------------------------------------------------
 -- On the Client side:
 --data Action = InGroup     NgramsId NgramsId
@@ -847,24 +858,47 @@ putListNgrams :: RepoCmdM env err m
               => NodeId -> NgramsType
               -> [NgramsElement] -> m ()
 putListNgrams _ _ [] = pure ()
-putListNgrams listId ngramsType nes = do
+putListNgrams listId ngramsType nes = putListNgrams' listId ngramsType m
+  where
+    m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
+
+putListNgrams' :: RepoCmdM env err m
+               => ListId -> NgramsType
+               -> Map NgramsTerm NgramsRepoElement
+               -> m ()
+putListNgrams' listId ngramsType ns = do
   -- printDebug "putListNgrams" (length nes)
   var <- view repoVar
   liftIO $ modifyMVar_ var $
-    pure . (r_state . at ngramsType %~ (Just . (at listId %~ (Just . (<> m) . something)) . something))
+    pure . ( r_state
+           . at ngramsType %~
+             (Just .
+               (at listId %~
+                 ( Just
+                 . (<> ns)
+                 . something
+                 )
+               )
+               . something
+             )
+           )
   saveRepo
-  where
-    m = Map.fromList $ (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) <$> nes
+
 
 -- TODO-ACCESS check
-tableNgramsPost :: RepoCmdM env err m => TabType -> NodeId -> Maybe ListType -> [NgramsTerm] -> m ()
+tableNgramsPost :: RepoCmdM env err m
+                => TabType
+                -> NodeId
+                -> Maybe ListType
+                -> [NgramsTerm] -> m ()
 tableNgramsPost tabType listId mayList =
   putListNgrams listId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
 
-currentVersion :: RepoCmdM env err m => m Version
+currentVersion :: RepoCmdM env err m
+               => m Version
 currentVersion = do
   var <- view repoVar
-  r <- liftIO $ readMVar var
+  r   <- liftIO $ readMVar var
   pure $ r ^. r_version
 
 tableNgramsPull :: RepoCmdM env err m
@@ -937,7 +971,9 @@ mergeNgramsElement _neOld neNew = neNew
   -}
 
 getNgramsTableMap :: RepoCmdM env err m
-                  => NodeId -> NgramsType -> m (Versioned NgramsTableMap)
+                  => ListId
+                  -> NgramsType
+                  -> m (Versioned NgramsTableMap)
 getNgramsTableMap nodeId ngramsType = do
   v    <- view repoVar
   repo <- liftIO $ readMVar v
@@ -1172,9 +1208,20 @@ apiNgramsTableDoc dId =  getTableNgramsDoc dId
                         -- > add new ngrams in database (TODO AD)
                         -- > index all the corpus accordingly (TODO AD)
 
-listNgramsChangedSince :: RepoCmdM env err m => ListId -> NgramsType -> Version -> m (Versioned Bool)
+listNgramsChangedSince :: RepoCmdM env err m
+                       => ListId -> NgramsType -> Version -> m (Versioned Bool)
 listNgramsChangedSince listId ngramsType version
   | version < 0 =
       Versioned <$> currentVersion <*> pure True
   | otherwise   =
       tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
+
+
+-- Instances
+instance Arbitrary NgramsRepoElement where
+  arbitrary = elements $ map ngramsElementToRepo ns
+    where
+      NgramsTable ns = mockTable
+
+
+

src/Gargantext/API/Ngrams/List.hs

+{-|
+Module      : Gargantext.API.Ngrams.List
+Description : Get Ngrams (lists)
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+-}
+
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeOperators     #-}
+
+module Gargantext.API.Ngrams.List
+  where
+
+import Gargantext.Prelude
+import Gargantext.API.Ngrams
+import Servant
+import Data.List (zip)
+import Data.Map (Map, toList, fromList)
+import Gargantext.Database.Types.Node
+import Gargantext.Database.Schema.Ngrams (NgramsType(..), ngramsTypes)
+import Gargantext.Database.Flow (FlowCmdM)
+import Gargantext.API.Types (GargServer)
+import Gargantext.API.Ngrams (putListNgrams')
+
+type NgramsList = (Map NgramsType (Versioned NgramsTableMap))
+
+type API = Get '[JSON] NgramsList
+      :<|> ReqBody '[JSON] NgramsList :> Put '[JSON] Bool
+
+api :: ListId -> GargServer API
+api l = get l :<|> put l
+
+get :: RepoCmdM env err m 
+    => ListId -> m NgramsList
+get lId = fromList
+       <$> zip ngramsTypes
+       <$> mapM (getNgramsTableMap lId) ngramsTypes
+
+put :: FlowCmdM env err m
+    => ListId
+    -> NgramsList
+    -> m Bool
+put l m = do
+  -- TODO check with Version for optim
+  _ <- mapM (\(nt, Versioned _v ns) -> putListNgrams' l nt ns) $ toList m
+  pure True
+

src/Gargantext/Database/Flow/List.hs

@@ -102,6 +102,6 @@ listInsert :: FlowCmdM env err m
 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
                              -> putListNgrams lId typeList ngElmts
                              ) $ toList ngs
+
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
-

src/Gargantext/Database/Schema/Ngrams.hs

@@ -46,7 +46,7 @@ import Gargantext.Prelude
 import Opaleye hiding (FromField)
 import Servant (FromHttpApiData, parseUrlPiece, Proxy(..))
 import Text.Read (read)
-import Data.Swagger (ToParamSchema, toParamSchema)
+import Data.Swagger (ToParamSchema, toParamSchema, ToSchema)
 import Prelude (Enum, Bounded, minBound, maxBound, Functor)
 import qualified Database.PostgreSQL.Simple as PGS
 
@@ -100,6 +100,14 @@ dbGetNgramsDb = runOpaQuery queryNgramsTable
 data NgramsType = Authors | Institutes | Sources | NgramsTerms
   deriving (Eq, Show, Read, Ord, Enum, Bounded, Generic)
 
+ngramsTypes :: [NgramsType]
+ngramsTypes = [minBound..]
+
+instance ToSchema NgramsType
+{-  where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
+-}
+
 instance FromJSON NgramsType
 instance FromJSONKey NgramsType where
    fromJSONKey = FromJSONKeyTextParser (parseJSON . String)