-}
{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -fno-warn-orphans #-}
, TableNgramsApiPost
, getTableNgrams
+ , setListNgrams
+ , rmListNgrams
, putListNgrams
+ , putListNgrams'
, tableNgramsPost
, apiNgramsTableCorpus
, apiNgramsTableDoc
, NgramsStatePatch
, NgramsTablePatch
+ , NgramsTableMap
- , NgramsElement
+ , NgramsElement(..)
, mkNgramsElement
, mergeNgramsElement
, Repo(..)
, r_version
, r_state
+ , r_history
, NgramsRepo
, NgramsRepoElement(..)
, saveRepo
, HasRepo(..)
, RepoCmdM
, QueryParamR
- , TODO(..)
+ , TODO
-- Internals
, getNgramsTableMap
+ , dumpJsonTableMap
, tableNgramsPull
, tableNgramsPut
+ , Version
, Versioned(..)
, currentVersion
, listNgramsChangedSince
)
where
--- import Debug.Trace (trace)
-import Prelude (Enum, Bounded, Semigroup(..), minBound, maxBound {-, round-}, error)
--- import Gargantext.Database.Schema.User (UserId)
-import Data.Patch.Class (Replace, replace, Action(act), Applicable(..),
- Composable(..), Transformable(..),
- PairPatch(..), Patched, ConflictResolution,
- ConflictResolutionReplace, ours)
-import qualified Data.Map.Strict.Patch as PM
-import Data.Monoid
-import Data.Ord (Down(..))
-import Data.Foldable
---import Data.Semigroup
-import Data.Set (Set)
-import qualified Data.Set as S
-import qualified Data.List as List
-import Data.Maybe (fromMaybe)
--- import Data.Tuple.Extra (first)
-import qualified Data.Map.Strict as Map
-import Data.Map.Strict (Map)
-import qualified Data.Set as Set
+import Codec.Serialise (Serialise())
import Control.Category ((>>>))
import Control.Concurrent
-import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, forOf_, (%%~), (?~), mapped)
+import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (.~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, forOf_, (%%~), (?~), mapped)
+import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.Error.Class (MonadError)
import Control.Monad.Reader
import Control.Monad.State
+import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson hiding ((.=))
import Data.Aeson.TH (deriveJSON)
-import Data.Either(Either(Left))
--- import Data.Map (lookup)
+import qualified Data.Aeson.Text as DAT
+import Data.Either (Either(Left))
+import Data.Foldable
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
+import qualified Data.List as List
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import qualified Data.Map.Strict.Patch as PM
+import Data.Maybe (fromMaybe)
+import Data.Monoid
+import Data.Ord (Down(..))
+import Data.Patch.Class (Replace, replace, Action(act), Applicable(..), Composable(..), Transformable(..), PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, ours)
+import Data.Set (Set)
+import qualified Data.Set as S
+import qualified Data.Set as Set
import Data.Swagger hiding (version, patch)
-import Data.Text (Text, isInfixOf, count)
+import Data.Text (Text, count, isInfixOf, unpack)
+import Data.Text.Lazy.IO as DTL
import Data.Validity
+import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import Formatting (hprint, int, (%))
import Formatting.Clock (timeSpecs)
import GHC.Generics (Generic)
-import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
--- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
-import Gargantext.Database.Config (userMaster)
-import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlyFast)
-import Gargantext.Database.Schema.Ngrams (NgramsType)
-import Gargantext.Database.Types.Node (NodeType(..))
-import Gargantext.Database.Utils (fromField', HasConnection)
-import Gargantext.Database.Node.Select
-import Gargantext.Database.Ngrams
---import Gargantext.Database.Lists (listsWith)
-import Gargantext.Database.Schema.Node (HasNodeError)
-import Database.PostgreSQL.Simple.FromField (FromField, fromField)
-import qualified Gargantext.Database.Schema.Ngrams as Ngrams
--- import Gargantext.Database.Schema.NodeNgram hiding (Action)
-import Gargantext.Prelude
--- import Gargantext.Core.Types (ListTypeId, listTypeId)
-import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, HasInvalidError, assertValid)
import Servant hiding (Patch)
import System.Clock (getTime, TimeSpec, Clock(..))
import System.FileLock (FileLock)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-data TODO = TODO
- deriving (Generic)
+import Prelude (error)
+import Protolude (maybeToEither)
+import Gargantext.Prelude
-instance ToSchema TODO where
-instance ToParamSchema TODO where
+import Gargantext.Core.Types (ListType(..), NodeId, ListId, DocId, Limit, Offset, HasInvalidError, assertValid)
+import Gargantext.Core.Types (TODO)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
+import Gargantext.Database.Action.Metrics.NgramsByNode (getOccByNgramsOnlyFast')
+import Gargantext.Database.Query.Table.Node.Select
+import Gargantext.Database.Query.Table.Ngrams hiding (NgramsType(..), ngrams, ngramsType, ngrams_terms)
+import Gargantext.Database.Admin.Config (userMaster)
+import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
+import Gargantext.Database.Admin.Types.Node (NodeType(..))
+import Gargantext.Database.Prelude (fromField', HasConnectionPool, HasConfig)
+import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
------------------------------------------------------------------------
--data FacetFormat = Table | Chart
deriving (Generic, Enum, Bounded, Show)
instance FromHttpApiData TabType
- where
+ where
parseUrlPiece "Docs" = pure Docs
parseUrlPiece "Trash" = pure Trash
parseUrlPiece "MoreFav" = pure MoreFav
parseUrlPiece "MoreTrash" = pure MoreTrash
-
+
parseUrlPiece "Terms" = pure Terms
parseUrlPiece "Sources" = pure Sources
parseUrlPiece "Institutes" = pure Institutes
parseUrlPiece "Authors" = pure Authors
-
+
parseUrlPiece "Contacts" = pure Contacts
-
+
parseUrlPiece _ = Left "Unexpected value of TabType"
instance ToParamSchema TabType
instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
-- TODO
- declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
+ declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
------------------------------------------------------------------------
type NgramsTerm = Text
deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
makeLenses ''NgramsRepoElement
+instance ToSchema NgramsRepoElement where
+ declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
+
+instance Serialise (MSet NgramsTerm)
+instance Serialise NgramsRepoElement
+
data NgramsElement =
NgramsElement { _ne_ngrams :: NgramsTerm
, _ne_size :: Int
, _ne_occurrences :: Int
, _ne_root :: Maybe NgramsTerm
, _ne_parent :: Maybe NgramsTerm
- , _ne_children :: MSet NgramsTerm
+ , _ne_children :: MSet NgramsTerm
}
deriving (Ord, Eq, Show, Generic)
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
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 MapTerm mayList) Nothing mempty
instance ToSchema NgramsElement where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ne_")
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
}
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`.
newtype NgramsTable = NgramsTable [NgramsElement]
deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
-type ListNgrams = NgramsTable
+type NgramsList = NgramsTable
makePrisms ''NgramsTable
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 (<>)
mockTable :: NgramsTable
mockTable = NgramsTable
- [ mkNgramsElement "animal" GraphTerm Nothing (mSetFromList ["dog", "cat"])
- , mkNgramsElement "cat" GraphTerm (rp "animal") mempty
+ [ mkNgramsElement "animal" MapTerm Nothing (mSetFromList ["dog", "cat"])
+ , mkNgramsElement "cat" MapTerm (rp "animal") mempty
, mkNgramsElement "cats" StopTerm Nothing mempty
- , mkNgramsElement "dog" GraphTerm (rp "animal") (mSetFromList ["dogs"])
+ , mkNgramsElement "dog" MapTerm (rp "animal") (mSetFromList ["dogs"])
, mkNgramsElement "dogs" StopTerm (rp "dog") mempty
- , mkNgramsElement "fox" GraphTerm Nothing mempty
+ , mkNgramsElement "fox" MapTerm Nothing mempty
, mkNgramsElement "object" CandidateTerm Nothing mempty
, mkNgramsElement "nothing" StopTerm Nothing mempty
- , mkNgramsElement "organic" GraphTerm Nothing (mSetFromList ["flower"])
- , mkNgramsElement "flower" GraphTerm (rp "organic") mempty
+ , mkNgramsElement "organic" MapTerm Nothing (mSetFromList ["flower"])
+ , mkNgramsElement "flower" MapTerm (rp "organic") mempty
, mkNgramsElement "moon" CandidateTerm Nothing mempty
, mkNgramsElement "sky" StopTerm Nothing mempty
]
------------------------------------------------------------------------
type NgramsTableMap = Map NgramsTerm NgramsRepoElement
-
------------------------------------------------------------------------
-- On the Client side:
--data Action = InGroup NgramsId NgramsId
type AddRem = Replace (Maybe ())
+instance Serialise AddRem
+
remPatch, addPatch :: AddRem
remPatch = replace (Just ()) Nothing
addPatch = replace Nothing (Just ())
type PatchMap = PM.PatchMap
+
newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
deriving (Eq, Show, Generic, Validity, Semigroup, Monoid,
Transformable, Composable)
type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
+instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
+instance (Serialise a, Ord a) => Serialise (PatchMSet a)
+
-- TODO this breaks module abstraction
makePrisms ''PM.PatchMap
instance ToSchema a => ToSchema (PatchMSet a) where
-- TODO
- declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO)
+ declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
type instance Patched (PatchMSet a) = MSet a
-- TODO Keep constructor is not supported here.
aSchema <- declareSchemaRef (Proxy :: Proxy a)
return $ NamedSchema (Just "Replace") $ mempty
- & type_ ?~ SwaggerObject
- & properties .~
- InsOrdHashMap.fromList
- [ ("old", aSchema)
- , ("new", aSchema)
- ]
- & required .~ [ "old", "new" ]
+ & type_ ?~ SwaggerObject
+ & properties .~
+ InsOrdHashMap.fromList
+ [ ("old", aSchema)
+ , ("new", aSchema)
+ ]
+ & required .~ [ "old", "new" ]
data NgramsPatch =
NgramsPatch { _patch_children :: PatchMSet NgramsTerm
instance Arbitrary NgramsPatch where
arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
+instance Serialise NgramsPatch
+instance Serialise (Replace ListType)
+instance Serialise ListType
+
type NgramsPatchIso = PairPatch (PatchMSet NgramsTerm) (Replace ListType)
_NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
+instance Serialise NgramsTablePatch
+instance Serialise (PatchMap NgramsTerm NgramsPatch)
+
instance FromField NgramsTablePatch
where
fromField = fromField'
-instance FromField (PatchMap NgramsType (PatchMap NodeId NgramsTablePatch))
+instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch))
where
fromField = fromField'
{ _v_version :: Version
, _v_data :: a
}
- deriving (Generic, Show)
+ deriving (Generic, Show, Eq)
deriveJSON (unPrefix "_v_") ''Versioned
makeLenses ''Versioned
-instance ToSchema a => ToSchema (Versioned a) where
- declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_v_")
+instance (Typeable a, ToSchema a) => ToSchema (Versioned a) where
+ declareNamedSchema = wellNamedSchema "_v_"
instance Arbitrary a => Arbitrary (Versioned a) where
arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
+
{-
--- TODO sequencs of modifications (Patchs)
+-- TODO sequences of modifications (Patchs)
type NgramsIdPatch = Patch NgramsId NgramsPatch
ngramsPatch :: Int -> NgramsPatch
{-
-- TODO: Replace.old is ignored which means that if the current list
--- `GraphTerm` and that the patch is `Replace CandidateTerm StopTerm` then
--- the list is going to be `StopTerm` while it should keep `GraphTerm`.
+-- `MapTerm` and that the patch is `Replace CandidateTerm StopTerm` then
+-- the list is going to be `StopTerm` while it should keep `MapTerm`.
-- However this should not happen in non conflicting situations.
mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
mkListsUpdate nt patches =
]
-}
-ngramsTypeFromTabType :: TabType -> NgramsType
+ngramsTypeFromTabType :: TabType -> TableNgrams.NgramsType
ngramsTypeFromTabType tabType =
let lieu = "Garg.API.Ngrams: " :: Text in
case tabType of
- Sources -> Ngrams.Sources
- Authors -> Ngrams.Authors
- Institutes -> Ngrams.Institutes
- Terms -> Ngrams.NgramsTerms
+ Sources -> TableNgrams.Sources
+ Authors -> TableNgrams.Authors
+ Institutes -> TableNgrams.Institutes
+ Terms -> TableNgrams.NgramsTerms
_ -> panic $ lieu <> "No Ngrams for this tab"
-- TODO: This `panic` would disapear with custom NgramsType.
toJSON = genericToJSON $ unPrefix "_r_"
toEncoding = genericToEncoding $ unPrefix "_r_"
+instance (Serialise s, Serialise p) => Serialise (Repo s p)
+
makeLenses ''Repo
initRepo :: Monoid s => Repo s p
initRepo = Repo 1 mempty []
type NgramsRepo = Repo NgramsState NgramsStatePatch
-type NgramsState = Map NgramsType (Map NodeId NgramsTableMap)
-type NgramsStatePatch = PatchMap NgramsType (PatchMap NodeId NgramsTablePatch)
+type NgramsState = Map TableNgrams.NgramsType (Map NodeId NgramsTableMap)
+type NgramsStatePatch = PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch)
+
+instance Serialise (PM.PatchMap NodeId NgramsTablePatch)
+instance Serialise NgramsStatePatch
initMockRepo :: NgramsRepo
initMockRepo = Repo 1 s []
where
- s = Map.singleton Ngrams.NgramsTerms
+ s = Map.singleton TableNgrams.NgramsTerms
$ Map.singleton 47254
$ Map.fromList
[ (n ^. ne_ngrams, ngramsElementToRepo n) | n <- mockTable ^. _NgramsTable ]
instance HasRepoSaver RepoEnv where
repoSaver = renv_saver
-type RepoCmdM env err m =
- ( MonadReader env m
- , MonadError err m
- , MonadIO m
- , HasRepo env
+type RepoCmdM env err m =
+ ( MonadReader env m
+ , MonadError err m
+ , MonadBaseControl IO m
+ , HasRepo env
)
------------------------------------------------------------------------
-saveRepo :: ( MonadReader env m, MonadIO m, HasRepoSaver env )
+saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
=> m ()
-saveRepo = liftIO =<< view repoSaver
+saveRepo = liftBase =<< view repoSaver
listTypeConflictResolution :: ListType -> ListType -> ListType
listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
ngramsStatePatchConflictResolution
- :: NgramsType -> NodeId -> NgramsTerm
+ :: TableNgrams.NgramsType
+ -> NodeId
+ -> NgramsTerm
-> ConflictResolutionNgramsPatch
ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
= (const ours, ours)
-> m ()
copyListNgrams srcListId dstListId ngramsType = do
var <- view repoVar
- liftIO $ modifyMVar_ var $
+ liftBase $ modifyMVar_ var $
pure . (r_state . at ngramsType %~ (Just . f . something))
saveRepo
where
-> [NgramsElement] -> m ()
addListNgrams listId ngramsType nes = do
var <- view repoVar
- liftIO $ modifyMVar_ var $
+ liftBase $ modifyMVar_ var $
pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m)
saveRepo
where
m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
-}
+rmListNgrams :: RepoCmdM env err m
+ => ListId
+ -> TableNgrams.NgramsType
+ -> m ()
+rmListNgrams l nt = setListNgrams l nt mempty
+
+-- | TODO: incr the Version number
+-- && should use patch
+setListNgrams :: RepoCmdM env err m
+ => NodeId
+ -> TableNgrams.NgramsType
+ -> Map NgramsTerm NgramsRepoElement
+ -> m ()
+setListNgrams listId ngramsType ns = do
+ var <- view repoVar
+ liftBase $ modifyMVar_ var $
+ pure . ( r_state
+ . at ngramsType %~
+ (Just .
+ (at listId .~ ( Just ns))
+ . something
+ )
+ )
+ saveRepo
+
+
-- If the given list of ngrams elements contains ngrams already in
-- the repo, they will be ignored.
putListNgrams :: RepoCmdM env err m
- => NodeId -> NgramsType
+ => NodeId
+ -> TableNgrams.NgramsType
-> [NgramsElement] -> m ()
putListNgrams _ _ [] = pure ()
-putListNgrams listId ngramsType nes = do
- -- printDebug "putListNgrams" (length nes)
+putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
+ where
+ m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
+
+putListNgrams' :: RepoCmdM env err m
+ => NodeId
+ -> TableNgrams.NgramsType
+ -> Map NgramsTerm NgramsRepoElement
+ -> m ()
+putListNgrams' nodeId ngramsType ns = do
+ printDebug "[putLictNgrams'] nodeId" nodeId
+ printDebug "[putLictNgrams'] ngramsType" ngramsType
+ printDebug "[putListNgrams'] ns" ns
var <- view repoVar
- liftIO $ modifyMVar_ var $
- pure . (r_state . at ngramsType %~ (Just . (at listId %~ (Just . (<> m) . something)) . something))
+ liftBase $ modifyMVar_ var $ \r -> do
+ pure $ r & r_version +~ 1
+ & r_history %~ (mempty :)
+ & r_state . at ngramsType %~
+ (Just .
+ (at nodeId %~
+ ( 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 tabType listId mayList =
- putListNgrams listId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
-currentVersion :: RepoCmdM env err m => m Version
+-- TODO-ACCESS check
+tableNgramsPost :: RepoCmdM env err m
+ => TabType
+ -> NodeId
+ -> Maybe ListType
+ -> [NgramsTerm] -> m ()
+tableNgramsPost tabType nodeId mayList =
+ putListNgrams nodeId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
+
+currentVersion :: RepoCmdM env err m
+ => m Version
currentVersion = do
var <- view repoVar
- r <- liftIO $ readMVar var
+ r <- liftBase $ readMVar var
pure $ r ^. r_version
tableNgramsPull :: RepoCmdM env err m
- => ListId -> NgramsType
+ => ListId
+ -> TableNgrams.NgramsType
-> Version
-> m (Versioned NgramsTablePatch)
tableNgramsPull listId ngramsType p_version = do
var <- view repoVar
- r <- liftIO $ readMVar var
+ r <- liftBase $ readMVar var
let
q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
assertValid p_validity
var <- view repoVar
- vq' <- liftIO $ modifyMVar var $ \r -> do
+ vq' <- liftBase $ modifyMVar var $ \r -> do
let
q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
(p', q') = transformWith ngramsStatePatchConflictResolution p q
r' = r & r_version +~ 1
- & r_state %~ act p'
- & r_history %~ (p' :)
+ & r_state %~ act p'
+ & r_history %~ (p' :)
q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
{-
-- Ideally we would like to check these properties. However:
-}
getNgramsTableMap :: RepoCmdM env err m
- => NodeId -> NgramsType -> m (Versioned NgramsTableMap)
+ => NodeId
+ -> TableNgrams.NgramsType
+ -> m (Versioned NgramsTableMap)
getNgramsTableMap nodeId ngramsType = do
v <- view repoVar
- repo <- liftIO $ readMVar v
+ repo <- liftBase $ readMVar v
pure $ Versioned (repo ^. r_version)
(repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
+dumpJsonTableMap :: RepoCmdM env err m
+ => Text
+ -> NodeId
+ -> TableNgrams.NgramsType
+ -> m ()
+dumpJsonTableMap fpath nodeId ngramsType = do
+ m <- getNgramsTableMap nodeId ngramsType
+ liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
+ pure ()
+
type MinSize = Int
type MaxSize = Int
-- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
-- TODO: should take only one ListId
-getTime' :: MonadIO m => m TimeSpec
-getTime' = liftIO $ getTime ProcessCPUTime
+getTime' :: MonadBase IO m => m TimeSpec
+getTime' = liftBase $ getTime ProcessCPUTime
getTableNgrams :: forall env err m.
- (RepoCmdM env err m, HasNodeError err, HasConnection env)
+ (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeType -> NodeId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
setScores True table = do
let ngrams_terms = (table ^.. each . ne_ngrams)
t1 <- getTime'
- occurrences <- getOccByNgramsOnlyFast nId
+ occurrences <- getOccByNgramsOnlyFast' nId
+ listId
ngramsType
ngrams_terms
t2 <- getTime'
- liftIO $ hprint stderr
+ liftBase $ hprint stderr
("getTableNgrams/setScores #ngrams=" % int % " time=" % timeSpecs % "\n")
(length ngrams_terms) t1 t2
{-
-- trace (show lists) $
-- getNgramsTableMap ({-lists <>-} listIds) ngramsType
- let nSco = needsScores orderBy
+ let scoresNeeded = needsScores orderBy
tableMap1 <- getNgramsTableMap listId ngramsType
t1 <- getTime'
- tableMap2 <- tableMap1 & v_data %%~ setScores nSco
+ tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
. Map.mapWithKey ngramsElementFromRepo
t2 <- getTime'
tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
- . setScores (not nSco)
+ . setScores (not scoresNeeded)
. selectAndPaginate
t3 <- getTime'
- liftIO $ hprint stderr
+ liftBase $ hprint stderr
("getTableNgrams total=" % timeSpecs
% " map1=" % timeSpecs
% " map2=" % timeSpecs
% " map3=" % timeSpecs
- % " sql=" % (if nSco then "map2" else "map3")
+ % " sql=" % (if scoresNeeded then "map2" else "map3")
% "\n"
) t0 t3 t0 t1 t1 t2 t2 t3
pure tableMap3
+scoresRecomputeTableNgrams :: forall env err m. (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env) => NodeId -> TabType -> ListId -> m Int
+scoresRecomputeTableNgrams nId tabType listId = do
+ tableMap <- getNgramsTableMap listId ngramsType
+ _ <- tableMap & v_data %%~ setScores
+ . Map.mapWithKey ngramsElementFromRepo
+
+ pure $ 1
+ where
+ ngramsType = ngramsTypeFromTabType tabType
+
+ setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
+ setScores table = do
+ let ngrams_terms = (table ^.. each . ne_ngrams)
+ occurrences <- getOccByNgramsOnlyFast' nId
+ listId
+ ngramsType
+ ngrams_terms
+ let
+ setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
+
+ pure $ table & each %~ setOcc
+
+
+
-- APIs
-- TODO: find a better place for the code above, All APIs stay here
type QueryParamR = QueryParam' '[Required, Strict]
-
data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
deriving (Generic, Enum, Bounded, Read, Show)
parseUrlPiece "ScoreDesc" = pure ScoreDesc
parseUrlPiece _ = Left "Unexpected value of OrderBy"
+
instance ToParamSchema OrderBy
instance FromJSON OrderBy
instance ToJSON OrderBy
:> ReqBody '[JSON] [NgramsTerm]
:> Post '[JSON] ()
+type RecomputeScoresNgramsApiGet = Summary " Recompute scores for ngrams table"
+ :> QueryParamR "ngramsType" TabType
+ :> QueryParamR "list" ListId
+ :> "recompute" :> Post '[JSON] Int
+
+type TableNgramsApiGetVersion = Summary " Table Ngrams API Get Version"
+ :> QueryParamR "ngramsType" TabType
+ :> QueryParamR "list" ListId
+ :> Get '[JSON] Version
+
type TableNgramsApi = TableNgramsApiGet
:<|> TableNgramsApiPut
:<|> TableNgramsApiPost
-
-getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
- => NodeId -> TabType
- -> ListId -> Limit -> Maybe Offset
+ :<|> RecomputeScoresNgramsApiGet
+ :<|> "version" :> TableNgramsApiGetVersion
+
+getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
+ => NodeId
+ -> TabType
+ -> ListId
+ -> Limit
+ -> Maybe Offset
-> Maybe ListType
-> Maybe MinSize -> Maybe MaxSize
-> Maybe OrderBy
where
searchQuery = maybe (const True) isInfixOf mt
+getTableNgramsVersion :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
+ => NodeId
+ -> TabType
+ -> ListId
+ -> m Version
+getTableNgramsVersion nId tabType listId = do
+ -- TODO: limit?
+ Versioned { _v_version = v } <- getTableNgramsCorpus nId tabType listId 100000 Nothing Nothing Nothing Nothing Nothing Nothing
+ pure v
+
-- | Text search is deactivated for now for ngrams by doc only
-getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
+getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> DocId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
-
-
apiNgramsTableCorpus :: ( RepoCmdM env err m
, HasNodeError err
, HasInvalidError err
- , HasConnection env
+ , HasConnectionPool env
+ , HasConfig env
)
=> NodeId -> ServerT TableNgramsApi m
apiNgramsTableCorpus cId = getTableNgramsCorpus cId
:<|> tableNgramsPut
:<|> tableNgramsPost
-
+ :<|> scoresRecomputeTableNgrams cId
+ :<|> getTableNgramsVersion cId
apiNgramsTableDoc :: ( RepoCmdM env err m
, HasNodeError err
, HasInvalidError err
- , HasConnection env
+ , HasConnectionPool env
+ , HasConfig env
)
=> DocId -> ServerT TableNgramsApi m
apiNgramsTableDoc dId = getTableNgramsDoc dId
:<|> tableNgramsPut
:<|> tableNgramsPost
- -- > add new ngrams in database (TODO AD)
- -- > index all the corpus accordingly (TODO AD)
+ :<|> scoresRecomputeTableNgrams dId
+ :<|> getTableNgramsVersion 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 -> TableNgrams.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
+
+--{-
+instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
+ where
+ parseUrlPiece x = maybeToEither x (decode $ cs x)