{-| Module : Gargantext.API.Ngrams Description : Server API Copyright : (c) CNRS, 2017-Present License : AGPL + CECILL v3 Maintainer : team@gargantext.org Stability : experimental Portability : POSIX Ngrams API -- | TODO get ngrams filtered by NgramsType add get -} {-# 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 #-} module Gargantext.API.Ngrams 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 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_, (%%~)) import Control.Monad.Error.Class (MonadError) import Control.Monad.Reader import Control.Monad.State import Data.Aeson hiding ((.=)) 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, patch) import Data.Text (Text, isInfixOf, count) import Data.Validity import GHC.Generics (Generic) import Gargantext.Core.Utils.Prefix (unPrefix) -- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..)) import Gargantext.Database.Config (userMaster) import Gargantext.Database.Metrics.NgramsByNode (getOccByNgramsOnlySlow) 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.FileLock (FileLock) import Test.QuickCheck (elements) import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) data TODO = TODO deriving (Generic) instance ToSchema TODO where instance ToParamSchema TODO where ------------------------------------------------------------------------ --data FacetFormat = Table | Chart data TabType = Docs | Terms | Sources | Authors | Institutes | Trash | Contacts deriving (Generic, Enum, Bounded) instance FromHttpApiData TabType where parseUrlPiece "Docs" = pure Docs parseUrlPiece "Terms" = pure Terms parseUrlPiece "Sources" = pure Sources parseUrlPiece "Institutes" = pure Institutes parseUrlPiece "Authors" = pure Authors parseUrlPiece "Trash" = pure Trash parseUrlPiece "Contacts" = pure Contacts 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] newtype MSet a = MSet (Map a ()) deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid) instance ToJSON a => ToJSON (MSet a) where toJSON (MSet m) = toJSON (Map.keys m) toEncoding (MSet m) = toEncoding (Map.keys m) mSetFromSet :: Set a -> MSet a mSetFromSet = MSet . Map.fromSet (const ()) mSetFromList :: Ord a => [a] -> MSet a mSetFromList = MSet . Map.fromList . map (\x -> (x, ())) -- mSetToSet :: Ord a => MSet a -> Set a -- mSetToSet (MSet a) = Set.fromList ( Map.keys a) mSetToSet :: Ord a => MSet a -> Set a mSetToSet = Set.fromList . mSetToList mSetToList :: MSet a -> [a] mSetToList (MSet a) = Map.keys a instance Foldable MSet where foldMap f (MSet m) = Map.foldMapWithKey (\k _ -> f k) m instance (Ord a, FromJSON a) => FromJSON (MSet a) where parseJSON = fmap mSetFromList . parseJSON instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where -- TODO declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO) ------------------------------------------------------------------------ type NgramsTerm = Text data RootParent = RootParent { _rp_root :: NgramsTerm , _rp_parent :: NgramsTerm } deriving (Ord, Eq, Show, Generic) deriveJSON (unPrefix "_rp_") ''RootParent makeLenses ''RootParent data NgramsRepoElement = NgramsRepoElement { _nre_size :: Int , _nre_list :: ListType --, _nre_root_parent :: Maybe RootParent , _nre_root :: Maybe NgramsTerm , _nre_parent :: Maybe NgramsTerm , _nre_children :: MSet NgramsTerm } deriving (Ord, Eq, Show, Generic) deriveJSON (unPrefix "_nre_") ''NgramsRepoElement makeLenses ''NgramsRepoElement data NgramsElement = NgramsElement { _ne_ngrams :: NgramsTerm , _ne_size :: Int , _ne_list :: ListType , _ne_occurrences :: Int , _ne_root :: Maybe NgramsTerm , _ne_parent :: Maybe 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 ngrams list rp children = NgramsElement ngrams size list 1 (_rp_root <$> rp) (_rp_parent <$> rp) children where -- TODO review size = 1 + count " " ngrams newNgramsElement :: NgramsTerm -> NgramsElement newNgramsElement ngrams = mkNgramsElement ngrams GraphTerm Nothing mempty instance ToSchema NgramsElement instance Arbitrary NgramsElement where arbitrary = elements [newNgramsElement "sport"] ngramsElementToRepo :: NgramsElement -> NgramsRepoElement ngramsElementToRepo (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_children = c } ngramsElementFromRepo :: NgramsTerm -> NgramsRepoElement -> NgramsElement ngramsElementFromRepo ngrams (NgramsRepoElement { _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 , _ne_occurrences = panic $ "API.Ngrams._ne_occurrences" {- -- Here we could use 0 if we want to avoid any `panic`. -- It will not happen using getTableNgrams if -- getOccByNgramsOnly provides a count of occurrences for -- all the ngrams given. -} } ------------------------------------------------------------------------ newtype NgramsTable = NgramsTable [NgramsElement] deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show) type ListNgrams = NgramsTable makePrisms ''NgramsTable -- | Question: why these repetition of Type in this instance -- may you document it please ? instance Each NgramsTable NgramsTable NgramsElement NgramsElement where each = _NgramsTable . each -- TODO discuss -- | TODO Check N and Weight {- toNgramsElement :: [NgramsTableData] -> [NgramsElement] toNgramsElement ns = map toNgramsElement' ns where toNgramsElement' (NgramsTableData _ p t _ lt w) = NgramsElement t lt' (round w) p' c' where p' = case p of Nothing -> Nothing 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 (<>) $ map (first fromJust) $ filter (isJust . fst) $ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns -} mockTable :: NgramsTable mockTable = NgramsTable [ mkNgramsElement "animal" GraphTerm Nothing (mSetFromList ["dog", "cat"]) , mkNgramsElement "cat" GraphTerm (rp "animal") mempty , mkNgramsElement "cats" StopTerm Nothing mempty , mkNgramsElement "dog" GraphTerm (rp "animal") (mSetFromList ["dogs"]) , mkNgramsElement "dogs" StopTerm (rp "dog") mempty , mkNgramsElement "fox" GraphTerm 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 "moon" CandidateTerm Nothing mempty , mkNgramsElement "sky" StopTerm Nothing mempty ] where rp n = Just $ RootParent n n instance Arbitrary NgramsTable where arbitrary = pure mockTable instance ToSchema NgramsTable ------------------------------------------------------------------------ type NgramsTableMap = Map NgramsTerm NgramsRepoElement ------------------------------------------------------------------------ -- On the Client side: --data Action = InGroup NgramsId NgramsId -- | OutGroup NgramsId NgramsId -- | SetListType NgramsId ListType data PatchSet a = PatchSet { _rem :: Set a , _add :: Set a } deriving (Eq, Ord, Show, Generic) makeLenses ''PatchSet makePrisms ''PatchSet instance ToJSON a => ToJSON (PatchSet a) where toJSON = genericToJSON $ unPrefix "_" toEncoding = genericToEncoding $ unPrefix "_" instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where parseJSON = genericParseJSON $ unPrefix "_" {- instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where arbitrary = PatchSet <$> arbitrary <*> arbitrary type instance Patched (PatchSet a) = Set a type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a) type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a instance Ord a => Semigroup (PatchSet a) where p <> q = PatchSet { _rem = (q ^. rem) `Set.difference` (p ^. add) <> p ^. rem , _add = (q ^. add) `Set.difference` (p ^. rem) <> p ^. add } -- TODO Review instance Ord a => Monoid (PatchSet a) where mempty = PatchSet mempty mempty instance Ord a => Group (PatchSet a) where invert (PatchSet r a) = PatchSet a r instance Ord a => Composable (PatchSet a) where composable _ _ = undefined instance Ord a => Action (PatchSet a) (Set a) where act p source = (source `Set.difference` (p ^. rem)) <> p ^. add instance Applicable (PatchSet a) (Set a) where applicable _ _ = mempty instance Ord a => Validity (PatchSet a) where validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint" instance Ord a => Transformable (PatchSet a) where transformable = undefined conflicts _p _q = undefined transformWith conflict p q = undefined conflict p q instance ToSchema a => ToSchema (PatchSet a) -} type AddRem = Replace (Maybe ()) remPatch, addPatch :: AddRem remPatch = replace (Just ()) Nothing addPatch = replace Nothing (Just ()) isRem :: Replace (Maybe ()) -> Bool isRem = (== remPatch) 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 -- TODO this breaks module abstraction makePrisms ''PM.PatchMap makePrisms ''PatchMSet _PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a) _PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet where f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a) f = Map.partition isRem >>> both %~ Map.keysSet g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ())) g (rems, adds) = Map.fromSet (const remPatch) rems <> Map.fromSet (const addPatch) adds instance Ord a => Action (PatchMSet a) (MSet a) where act (PatchMSet p) (MSet m) = MSet $ act p m instance Ord a => Applicable (PatchMSet a) (MSet a) where applicable (PatchMSet p) (MSet m) = applicable p m instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where toJSON = toJSON . view _PatchMSetIso toEncoding = toEncoding . view _PatchMSetIso instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where parseJSON = fmap (_PatchMSetIso #) . parseJSON instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary instance ToSchema a => ToSchema (PatchMSet a) where -- TODO declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy TODO) type instance Patched (PatchMSet a) = MSet a instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where arbitrary = uncurry replace <$> arbitrary -- If they happen to be equal then the patch is Keep. instance ToSchema a => ToSchema (Replace a) where declareNamedSchema (_ :: proxy (Replace a)) = do -- 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" ] data NgramsPatch = NgramsPatch { _patch_children :: PatchMSet NgramsTerm , _patch_list :: Replace ListType -- TODO Map UserId ListType } deriving (Eq, Show, Generic) deriveJSON (unPrefix "_") ''NgramsPatch makeLenses ''NgramsPatch instance ToSchema NgramsPatch instance Arbitrary NgramsPatch where arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary) type NgramsPatchIso = PairPatch (PatchMSet NgramsTerm) (Replace ListType) _NgramsPatch :: Iso' NgramsPatch NgramsPatchIso _NgramsPatch = iso (\(NgramsPatch c l) -> c :*: l) (\(c :*: l) -> NgramsPatch c l) instance Semigroup NgramsPatch where p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch) instance Monoid NgramsPatch where mempty = _NgramsPatch # mempty instance Validity NgramsPatch where validate p = p ^. _NgramsPatch . to validate instance Transformable NgramsPatch where transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch) conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch) transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q') where (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch) type ConflictResolutionNgramsPatch = ( ConflictResolutionPatchMSet NgramsTerm , ConflictResolutionReplace ListType ) type instance ConflictResolution NgramsPatch = ConflictResolutionNgramsPatch type PatchedNgramsPatch = (Set NgramsTerm, ListType) -- ~ Patched NgramsPatchIso type instance Patched NgramsPatch = PatchedNgramsPatch instance Applicable NgramsPatch (Maybe NgramsRepoElement) where applicable p Nothing = check (p == mempty) "NgramsPatch should be empty here" applicable p (Just nre) = applicable (p ^. patch_children) (nre ^. nre_children) <> applicable (p ^. patch_list) (nre ^. nre_list) instance Action NgramsPatch NgramsRepoElement where act p = (nre_children %~ act (p ^. patch_children)) . (nre_list %~ act (p ^. patch_list)) instance Action NgramsPatch (Maybe NgramsRepoElement) where act = fmap . act newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch) deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable) instance FromField NgramsTablePatch where fromField = fromField' instance FromField (PatchMap NgramsType (PatchMap NodeId NgramsTablePatch)) where fromField = fromField' --instance (Ord k, Action pv (Maybe v)) => Action (PatchMap k pv) (Map k v) where -- type instance ConflictResolution NgramsTablePatch = NgramsTerm -> ConflictResolutionNgramsPatch type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch -- ~ Patched (PatchMap NgramsTerm NgramsPatch) type instance Patched NgramsTablePatch = PatchedNgramsTablePatch makePrisms ''NgramsTablePatch instance ToSchema (PatchMap NgramsTerm NgramsPatch) instance ToSchema NgramsTablePatch instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where applicable p = applicable (p ^. _NgramsTablePatch) instance Action NgramsTablePatch (Maybe NgramsTableMap) where act p = fmap (execState (reParentNgramsTablePatch p)) . act (p ^. _NgramsTablePatch) instance Arbitrary NgramsTablePatch where arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary -- Should it be less than an Lens' to preserve PatchMap's abstraction. -- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch) -- ntp_ngrams_patches = _NgramsTablePatch . undefined type ReParent a = forall m. MonadState NgramsTableMap m => a -> m () reRootChildren :: NgramsTerm -> ReParent NgramsTerm reRootChildren root ngram = do nre <- use $ at ngram forOf_ (_Just . nre_children . folded) nre $ \child -> do at child . _Just . nre_root ?= root reRootChildren root child reParent :: Maybe RootParent -> ReParent NgramsTerm reParent rp child = do at child . _Just %= ( (nre_parent .~ (_rp_parent <$> rp)) . (nre_root .~ (_rp_root <$> rp)) ) reRootChildren (fromMaybe child (rp ^? _Just . rp_root)) child reParentAddRem :: RootParent -> NgramsTerm -> ReParent AddRem reParentAddRem rp child p = reParent (if isRem p then Nothing else Just rp) child reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch reParentNgramsPatch parent ngramsPatch = do root_of_parent <- use (at parent . _Just . nre_root) let root = fromMaybe parent root_of_parent rp = RootParent { _rp_root = root, _rp_parent = parent } itraverse_ (reParentAddRem rp) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap) -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap reParentNgramsTablePatch :: ReParent NgramsTablePatch reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap) -- TODO FoldableWithIndex/TraversableWithIndex for PatchMap ------------------------------------------------------------------------ ------------------------------------------------------------------------ type Version = Int data Versioned a = Versioned { _v_version :: Version , _v_data :: a } deriving (Generic, Show) 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) type NgramsIdPatch = Patch NgramsId NgramsPatch ngramsPatch :: Int -> NgramsPatch ngramsPatch n = NgramsPatch (DM.fromList [(1, StopTerm)]) (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 ... ) -} ------------------------------------------------------------------------ ------------------------------------------------------------------------ ------------------------------------------------------------------------ {- -- 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`. -- However this should not happen in non conflicting situations. mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)] mkListsUpdate nt patches = [ (ngramsTypeId nt, ng, listTypeId lt) | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex , lt <- patch ^.. patch_list . new ] mkChildrenGroups :: (PatchSet NgramsTerm -> Set NgramsTerm) -> NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsParent, NgramsChild)] mkChildrenGroups addOrRem nt patches = [ (ngramsTypeId nt, parent, child) | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex , child <- patch ^.. patch_children . to addOrRem . folded ] -} ngramsTypeFromTabType :: TabType -> 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 _ -> panic $ lieu <> "No Ngrams for this tab" -- TODO: This `panic` would disapear with custom NgramsType. ------------------------------------------------------------------------ data Repo s p = Repo { _r_version :: Version , _r_state :: s , _r_history :: [p] -- first patch in the list is the most recent } deriving (Generic) instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where parseJSON = genericParseJSON $ unPrefix "_r_" instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where toJSON = genericToJSON $ unPrefix "_r_" toEncoding = genericToEncoding $ unPrefix "_r_" 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) initMockRepo :: NgramsRepo initMockRepo = Repo 1 s [] where s = Map.singleton Ngrams.NgramsTerms $ Map.singleton 47254 $ Map.fromList [ (n ^. ne_ngrams, ngramsElementToRepo n) | n <- mockTable ^. _NgramsTable ] data RepoEnv = RepoEnv { _renv_var :: !(MVar NgramsRepo) , _renv_saver :: !(IO ()) , _renv_lock :: !FileLock } deriving (Generic) makeLenses ''RepoEnv class HasRepoVar env where repoVar :: Getter env (MVar NgramsRepo) instance HasRepoVar (MVar NgramsRepo) where repoVar = identity class HasRepoSaver env where repoSaver :: Getter env (IO ()) class (HasRepoVar env, HasRepoSaver env) => HasRepo env where repoEnv :: Getter env RepoEnv instance HasRepo RepoEnv where repoEnv = identity instance HasRepoVar RepoEnv where repoVar = renv_var instance HasRepoSaver RepoEnv where repoSaver = renv_saver type RepoCmdM env err m = ( MonadReader env m , MonadError err m , MonadIO m , HasRepo env ) ------------------------------------------------------------------------ saveRepo :: ( MonadReader env m, MonadIO m, HasRepoSaver env ) => m () saveRepo = liftIO =<< view repoSaver listTypeConflictResolution :: ListType -> ListType -> ListType listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType ngramsStatePatchConflictResolution :: NgramsType -> NodeId -> NgramsTerm -> ConflictResolutionNgramsPatch ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm = (const ours, ours) -- undefined {- TODO think this through -}, listTypeConflictResolution) -- Current state: -- Insertions are not considered as patches, -- they do not extend history, -- they do not bump version. insertNewOnly :: a -> Maybe b -> a insertNewOnly m = maybe m (const $ error "insertNewOnly: impossible") -- TODO error handling something :: Monoid a => Maybe a -> a something Nothing = mempty something (Just a) = a {- unused -- TODO refactor with putListNgrams copyListNgrams :: RepoCmdM env err m => NodeId -> NodeId -> NgramsType -> m () copyListNgrams srcListId dstListId ngramsType = do var <- view repoVar liftIO $ modifyMVar_ var $ pure . (r_state . at ngramsType %~ (Just . f . something)) saveRepo where f :: Map NodeId NgramsTableMap -> Map NodeId NgramsTableMap f m = m & at dstListId %~ insertNewOnly (m ^. at srcListId) -- TODO refactor with putListNgrams -- The list must be non-empty! -- The added ngrams must be non-existent! addListNgrams :: RepoCmdM env err m => NodeId -> NgramsType -> [NgramsElement] -> m () addListNgrams listId ngramsType nes = do var <- view repoVar liftIO $ modifyMVar_ var $ pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m) saveRepo where m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes -} -- If the given list of ngrams elements contains ngrams already in -- the repo, they will be ignored. putListNgrams :: RepoCmdM env err m => NodeId -> NgramsType -> [NgramsElement] -> m () putListNgrams _ _ [] = pure () putListNgrams listId ngramsType nes = do -- printDebug "putListNgrams" (length nes) var <- view repoVar liftIO $ modifyMVar_ var $ pure . (r_state . at ngramsType %~ (Just . (at listId %~ (Just . (<> m) . something)) . something)) saveRepo where m = Map.fromList $ (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) <$> nes tableNgramsPost :: RepoCmdM env err m => TabType -> NodeId -> [NgramsTerm] -> m () tableNgramsPost tabType listId = putListNgrams listId (ngramsTypeFromTabType tabType) . fmap newNgramsElement -- Apply the given patch to the DB and returns the patch to be applied on the -- client. tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m) => TabType -> ListId -> Versioned NgramsTablePatch -> m (Versioned NgramsTablePatch) tableNgramsPut tabType listId (Versioned p_version p_table) | p_table == mempty = do let ngramsType = ngramsTypeFromTabType tabType var <- view repoVar r <- liftIO $ readMVar var let q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history) q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just pure (Versioned (r ^. r_version) q_table) | otherwise = do let ngramsType = ngramsTypeFromTabType tabType (p0, p0_validity) = PM.singleton listId p_table (p, p_validity) = PM.singleton ngramsType p0 assertValid p0_validity assertValid p_validity var <- view repoVar vq' <- liftIO $ 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' :) q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just {- -- Ideally we would like to check these properties. However: -- * They should be checked only to debug the code. The client data -- should be able to trigger these. -- * What kind of error should they throw (we are in IO here)? -- * Should we keep modifyMVar? -- * Should we throw the validation in an Exception, catch it around -- modifyMVar and throw it back as an Error? assertValid $ transformable p q assertValid $ applicable p' (r ^. r_state) -} pure (r', Versioned (r' ^. r_version) q'_table) saveRepo pure vq' mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement mergeNgramsElement _neOld neNew = neNew {- { _ne_list :: ListType If we merge the parents/children we can potentially create cycles! , _ne_parent :: Maybe NgramsTerm , _ne_children :: MSet NgramsTerm } -} getNgramsTableMap :: RepoCmdM env err m => NodeId -> NgramsType -> m (Versioned NgramsTableMap) getNgramsTableMap nodeId ngramsType = do v <- view repoVar repo <- liftIO $ readMVar v pure $ Versioned (repo ^. r_version) (repo ^. r_state . at ngramsType . _Just . at nodeId . _Just) type MinSize = Int type MaxSize = Int -- | TODO Errors management -- TODO: polymorphic for Annuaire or Corpus or ... -- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut). -- TODO: should take only one ListId getTableNgrams :: forall env err m. (RepoCmdM env err m, HasNodeError err, HasConnection env) => NodeType -> NodeId -> TabType -> ListId -> Limit -> Maybe Offset -> Maybe ListType -> Maybe MinSize -> Maybe MaxSize -> Maybe OrderBy -> (NgramsTerm -> Bool) -> m (Versioned NgramsTable) getTableNgrams nType nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery = do lIds <- selectNodesWithUsername NodeList userMaster let ngramsType = ngramsTypeFromTabType tabType offset' = maybe 0 identity offset listType' = maybe (const True) (==) listType minSize' = maybe (const True) (<=) minSize maxSize' = maybe (const True) (>=) maxSize selected_node n = minSize' s && maxSize' s && searchQuery (n ^. ne_ngrams) && listType' (n ^. ne_list) where s = n ^. ne_size selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root) --------------------------------------- sortOnOrder Nothing = identity sortOnOrder (Just TermAsc) = List.sortOn $ view ne_ngrams sortOnOrder (Just TermDesc) = List.sortOn $ Down . view ne_ngrams sortOnOrder (Just ScoreAsc) = List.sortOn $ view ne_occurrences sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences --------------------------------------- selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement] selectAndPaginate tableMap = roots <> inners where list = tableMap ^.. each rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root") (tableMap ^. at r)) (ne ^. ne_root) selected_nodes = list & take limit_ . drop offset' . filter selected_node . sortOnOrder orderBy roots = rootOf <$> selected_nodes rootsSet = Set.fromList (_ne_ngrams <$> roots) inners = list & filter (selected_inner rootsSet) --------------------------------------- setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t setScores False table = pure table setScores True table = do let ngrams_terms = (table ^.. each . ne_ngrams) occurrences <- getOccByNgramsOnlySlow nType nId (lIds <> [listId]) ngramsType ngrams_terms let setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences pure $ table & each %~ setOcc --------------------------------------- -- lists <- catMaybes <$> listsWith userMaster -- trace (show lists) $ -- getNgramsTableMap ({-lists <>-} listIds) ngramsType let nSco = needsScores orderBy tableMap1 <- getNgramsTableMap listId ngramsType tableMap2 <- tableMap1 & v_data %%~ setScores nSco . Map.mapWithKey ngramsElementFromRepo tableMap2 & v_data %%~ fmap NgramsTable . setScores (not nSco) . selectAndPaginate -- 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) instance FromHttpApiData OrderBy where parseUrlPiece "TermAsc" = pure TermAsc parseUrlPiece "TermDesc" = pure TermDesc parseUrlPiece "ScoreAsc" = pure ScoreAsc parseUrlPiece "ScoreDesc" = pure ScoreDesc parseUrlPiece _ = Left "Unexpected value of OrderBy" instance ToParamSchema OrderBy instance FromJSON OrderBy instance ToJSON OrderBy instance ToSchema OrderBy instance Arbitrary OrderBy where arbitrary = elements [minBound..maxBound] needsScores :: Maybe OrderBy -> Bool needsScores (Just ScoreAsc) = True needsScores (Just ScoreDesc) = True needsScores _ = False type TableNgramsApiGet = Summary " Table Ngrams API Get" :> QueryParamR "ngramsType" TabType :> QueryParamR "list" ListId :> QueryParamR "limit" Limit :> QueryParam "offset" Offset :> QueryParam "listType" ListType :> QueryParam "minTermSize" MinSize :> QueryParam "maxTermSize" MaxSize :> QueryParam "orderBy" OrderBy :> QueryParam "search" Text :> Get '[JSON] (Versioned NgramsTable) type TableNgramsApiPut = Summary " Table Ngrams API Change" :> QueryParamR "ngramsType" TabType :> QueryParamR "list" ListId :> ReqBody '[JSON] (Versioned NgramsTablePatch) :> Put '[JSON] (Versioned NgramsTablePatch) type TableNgramsApiPost = Summary " Table Ngrams API Adds new ngrams" :> QueryParamR "ngramsType" TabType :> QueryParamR "list" ListId :> ReqBody '[JSON] [NgramsTerm] :> Post '[JSON] () type TableNgramsApi = TableNgramsApiGet :<|> TableNgramsApiPut :<|> TableNgramsApiPost getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnection env) => NodeId -> TabType -> ListId -> Limit -> Maybe Offset -> Maybe ListType -> Maybe MinSize -> Maybe MaxSize -> Maybe OrderBy -> Maybe Text -- full text search -> m (Versioned NgramsTable) getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy mt = getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery where searchQuery = maybe (const True) isInfixOf mt -- | Text search is deactivated for now for ngrams by doc only getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnection env) => DocId -> TabType -> ListId -> Limit -> Maybe Offset -> Maybe ListType -> Maybe MinSize -> Maybe MaxSize -> Maybe OrderBy -> Maybe Text -- full text search -> m (Versioned NgramsTable) getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do ns <- selectNodesWithUsername NodeList userMaster let ngramsType = ngramsTypeFromTabType tabType ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType let searchQuery = flip S.member (S.fromList ngs) getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery apiNgramsTableCorpus :: ( RepoCmdM env err m , HasNodeError err , HasInvalidError err , HasConnection env ) => NodeId -> ServerT TableNgramsApi m apiNgramsTableCorpus cId = getTableNgramsCorpus cId :<|> tableNgramsPut :<|> tableNgramsPost apiNgramsTableDoc :: ( RepoCmdM env err m , HasNodeError err , HasInvalidError err , HasConnection 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)