]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/NodeStory.hs
[nodeStory] draft implementation of NodeStoryEnv
[gargantext.git] / src / Gargantext / Database / NodeStory.hs
1 {-# LANGUAGE Arrows #-}
2 {-# LANGUAGE TemplateHaskell #-}
3
4 module Gargantext.Database.NodeStory where
5
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(..))
24
25
26 data NodeStoryPoly a b = NodeStoryDB { node_id :: a
27 , archive :: b }
28 deriving (Eq)
29
30 type ArchiveQ = Archive NgramsState' NgramsStatePatch'
31
32 type NodeListStoryQ = NodeStoryPoly Int ArchiveQ
33
34 type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
35 type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
36
37 $(makeAdaptorAndInstance "pNodeStory" ''NodeStoryPoly)
38
39 nodeStoryTable :: Table NodeStoryRead NodeStoryWrite
40 nodeStoryTable =
41 Table "node_stories"
42 ( pNodeStory NodeStoryDB { node_id = tableField "node_id"
43 , archive = tableField "archive" } )
44
45 nodeStorySelect :: Select NodeStoryRead
46 nodeStorySelect = selectTable nodeStoryTable
47
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
52 where
53 query :: Select NodeStoryRead
54 query = proc () -> do
55 row@(NodeStoryDB node_id _) <- nodeStorySelect -< ()
56 restrict -< node_id .== sqlInt4 nodeId
57 returnA -< row
58
59 insertNodeArchive :: NodeId -> ArchiveQ -> Cmd err Int64
60 insertNodeArchive (NodeId nId) a = mkCmd $ \c -> runInsert c insert
61 where
62 insert = Insert { iTable = nodeStoryTable
63 , iRows = [NodeStoryDB { node_id = sqlInt4 nId
64 , archive = sqlValueJSONB a }]
65 , iReturning = rCount
66 , iOnConflict = Nothing }
67
68 updateNodeArchive :: NodeId -> ArchiveQ -> Cmd err Int64
69 updateNodeArchive (NodeId nId) a = mkCmd $ \c -> runUpdate c update
70 where
71 update = Update { uTable = nodeStoryTable
72 , uUpdateWith = updateEasy (\(NodeStoryDB { .. }) -> NodeStoryDB { archive = sqlValueJSONB a, .. })
73 , uWhere = (\row -> node_id row .== sqlInt4 nId)
74 , uReturning = rCount }
75
76 nodeStoryRemove :: NodeId -> Cmd err Int64
77 nodeStoryRemove (NodeId nId) = mkCmd $ \c -> runDelete c delete
78 where
79 delete = Delete { dTable = nodeStoryTable
80 , dWhere = (\row -> node_id row .== sqlInt4 nId)
81 , dReturning = rCount }
82
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
89
90 writeNodeStories :: NodeListStory -> Cmd err ()
91 writeNodeStories (NodeStory nls) = do
92 _ <- mapM (\(nId, a) -> upsertNodeArchive nId a) $ Map.toList nls
93 pure ()
94
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
100 Nothing -> do
101 (NodeStory nls') <- getNodeStory nId
102 pure $ NodeStory $ Map.union nls nls'
103 Just _ -> pure ns
104
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
109 m <- getNodeStory ni
110 nodeStoryIncs (Just m) ns
111
112 nodeStoryDec :: NodeListStory -> NodeId -> Cmd err NodeListStory
113 nodeStoryDec ns@(NodeStory nls) ni = do
114 case Map.lookup ni nls of
115 Nothing -> do
116 _ <- nodeStoryRemove ni
117 pure ns
118 Just _ -> do
119 let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
120 _ <- nodeStoryRemove ni
121 pure $ NodeStory ns'
122
123 migrateFromDir :: (HasMail env, HasNodeError err, NS.HasNodeStory env err m, HasDBid NodeType)
124 => m ()
125 migrateFromDir = do
126 listIds <- getNodesIdWithType NodeList
127 (NodeStory nls) <- getRepo listIds
128 _ <- mapM (\(nId, a) -> do
129 n <- nodeExists nId
130 case n of
131 False -> pure 0
132 True -> upsertNodeArchive nId a
133 ) $ Map.toList nls
134 _ <- nodeStoryIncs (Just $ NodeStory nls) listIds
135 pure ()
136
137 ------------------------------------
138
139 nodeStoryEnv :: IO NodeStoryEnv
140 nodeStoryEnv = do
141 mvar <- nodeStoryVar Nothing []
142 saver <- mkNodeStorySaver mvar
143 pure $ NodeStoryEnv { _nse_var = mvar
144 , _nse_saver = saver
145 , _nse_getter = nodeStoryVar (Just mvar) }
146
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)
151 pure mv
152
153 mkNodeStorySaver :: MVar NodeListStory -> IO (IO ())
154 mkNodeStorySaver mvns = mkDebounce settings
155 where
156 settings = defaultDebounceSettings
157 { debounceAction = withMVar mvns (liftBase $ writeNodeStories)
158 , debounceFreq = 1 * minute
159 -- , debounceEdge = trailingEdge -- Trigger on the trailing edge
160 }
161 minute = 60 * second
162 second = 10^(6 :: Int)
163