1 {-# LANGUAGE Arrows #-}
2 {-# LANGUAGE TemplateHaskell #-}
4 module Gargantext.Database.NodeStory where
6 import Control.Arrow (returnA)
7 import Control.Concurrent (MVar(), withMVar, newMVar, modifyMVar_)
8 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
9 import Control.Monad (foldM)
10 import qualified Data.Map.Strict as Map
11 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
12 import Gargantext.API.Ngrams.Tools (getRepo)
13 import Gargantext.Core (HasDBid)
14 import Gargantext.Core.Mail.Types (HasMail)
15 import Gargantext.Core.NodeStory (Archive(..), NodeStory(..), NodeStoryEnv(..), NodeListStory, NgramsState', NgramsStatePatch')
16 import qualified Gargantext.Core.NodeStory as NS
17 import Gargantext.Core.Types (NodeId(..), NodeType(..))
18 import Gargantext.Database.Prelude (Cmd, mkCmd, runOpaQuery)
19 import Gargantext.Database.Query.Table.Node (getNodesIdWithType, nodeExists)
20 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
21 import Gargantext.Prelude
22 import Opaleye hiding (FromField)
23 import Opaleye.Internal.Table (Table(..))
26 data NodeStoryPoly a b = NodeStoryDB { node_id :: a
30 type ArchiveQ = Archive NgramsState' NgramsStatePatch'
32 type NodeListStoryQ = NodeStoryPoly Int ArchiveQ
34 type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
35 type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
37 $(makeAdaptorAndInstance "pNodeStory" ''NodeStoryPoly)
39 nodeStoryTable :: Table NodeStoryRead NodeStoryWrite
42 ( pNodeStory NodeStoryDB { node_id = tableField "node_id"
43 , archive = tableField "archive" } )
45 nodeStorySelect :: Select NodeStoryRead
46 nodeStorySelect = selectTable nodeStoryTable
48 getNodeStory :: NodeId -> Cmd err NodeListStory
49 getNodeStory (NodeId nodeId) = do
50 res <- runOpaQuery query
51 pure $ NodeStory $ Map.fromListWith (<>) $ (\(NodeStoryDB nId a) -> (nId, a)) <$> res
53 query :: Select NodeStoryRead
55 row@(NodeStoryDB node_id _) <- nodeStorySelect -< ()
56 restrict -< node_id .== sqlInt4 nodeId
59 insertNodeArchive :: NodeId -> ArchiveQ -> Cmd err Int64
60 insertNodeArchive (NodeId nId) a = mkCmd $ \c -> runInsert c insert
62 insert = Insert { iTable = nodeStoryTable
63 , iRows = [NodeStoryDB { node_id = sqlInt4 nId
64 , archive = sqlValueJSONB a }]
66 , iOnConflict = Nothing }
68 updateNodeArchive :: NodeId -> ArchiveQ -> Cmd err Int64
69 updateNodeArchive (NodeId nId) a = mkCmd $ \c -> runUpdate c update
71 update = Update { uTable = nodeStoryTable
72 , uUpdateWith = updateEasy (\(NodeStoryDB { .. }) -> NodeStoryDB { archive = sqlValueJSONB a, .. })
73 , uWhere = (\row -> node_id row .== sqlInt4 nId)
74 , uReturning = rCount }
76 nodeStoryRemove :: NodeId -> Cmd err Int64
77 nodeStoryRemove (NodeId nId) = mkCmd $ \c -> runDelete c delete
79 delete = Delete { dTable = nodeStoryTable
80 , dWhere = (\row -> node_id row .== sqlInt4 nId)
81 , dReturning = rCount }
83 upsertNodeArchive :: NodeId -> ArchiveQ -> Cmd err Int64
84 upsertNodeArchive nId a = do
85 (NodeStory m) <- getNodeStory nId
86 case Map.lookup nId m of
87 Nothing -> insertNodeArchive nId a
88 Just _ -> updateNodeArchive nId a
90 writeNodeStories :: NodeListStory -> Cmd err ()
91 writeNodeStories (NodeStory nls) = do
92 _ <- mapM (\(nId, a) -> upsertNodeArchive nId a) $ Map.toList nls
95 -- | Returns a `NodeListStory`, updating the given one for given `NodeId`
96 nodeStoryInc :: Maybe NodeListStory -> NodeId -> Cmd err NodeListStory
97 nodeStoryInc Nothing nId = getNodeStory nId
98 nodeStoryInc (Just ns@(NodeStory nls)) nId = do
99 case Map.lookup nId nls of
101 (NodeStory nls') <- getNodeStory nId
102 pure $ NodeStory $ Map.union nls nls'
105 nodeStoryIncs :: Maybe NodeListStory -> [NodeId] -> Cmd err NodeListStory
106 nodeStoryIncs Nothing [] = pure $ NodeStory $ Map.empty
107 nodeStoryIncs (Just nls) ns = foldM (\m n -> nodeStoryInc (Just m) n) nls ns
108 nodeStoryIncs Nothing (ni:ns) = do
110 nodeStoryIncs (Just m) ns
112 nodeStoryDec :: NodeListStory -> NodeId -> Cmd err NodeListStory
113 nodeStoryDec ns@(NodeStory nls) ni = do
114 case Map.lookup ni nls of
116 _ <- nodeStoryRemove ni
119 let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
120 _ <- nodeStoryRemove ni
123 migrateFromDir :: (HasMail env, HasNodeError err, NS.HasNodeStory env err m, HasDBid NodeType)
126 listIds <- getNodesIdWithType NodeList
127 (NodeStory nls) <- getRepo listIds
128 _ <- mapM (\(nId, a) -> do
132 True -> upsertNodeArchive nId a
134 _ <- nodeStoryIncs (Just $ NodeStory nls) listIds
137 ------------------------------------
139 nodeStoryEnv :: IO NodeStoryEnv
141 mvar <- nodeStoryVar Nothing []
142 saver <- mkNodeStorySaver mvar
143 pure $ NodeStoryEnv { _nse_var = mvar
145 , _nse_getter = nodeStoryVar (Just mvar) }
147 nodeStoryVar :: Maybe (MVar NodeListStory) -> [NodeId] -> IO (MVar NodeListStory)
148 nodeStoryVar Nothing nis = (liftBase $ nodeStoryIncs Nothing nis) >>= newMVar
149 nodeStoryVar (Just mv) nis = do
150 _ <- modifyMVar_ mv $ \mv' -> (liftBase $ nodeStoryIncs (Just mv') nis)
153 mkNodeStorySaver :: MVar NodeListStory -> IO (IO ())
154 mkNodeStorySaver mvns = mkDebounce settings
156 settings = defaultDebounceSettings
157 { debounceAction = withMVar mvns (liftBase $ writeNodeStories)
158 , debounceFreq = 1 * minute
159 -- , debounceEdge = trailingEdge -- Trigger on the trailing edge
162 second = 10^(6 :: Int)