]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Core/NodeStory.hs
Merge branch 'dev' into 79-dev-rewrite-better-record-syntax
[gargantext.git] / src / Gargantext / Core / NodeStory.hs
1 {-|
2 Module : Gargantext.Core.NodeStory
3 Description : Node API generation
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 TODO:
11 - remove
12 - filter
13 - charger les listes
14 -}
15
16 {-# OPTIONS_GHC -fno-warn-orphans #-}
17 {-# LANGUAGE TemplateHaskell #-}
18 {-# LANGUAGE ConstraintKinds #-}
19
20 module Gargantext.Core.NodeStory where
21
22 -- import Debug.Trace (traceShow)
23 import Codec.Serialise (serialise, deserialise)
24 import Codec.Serialise.Class
25 import Control.Concurrent (MVar(), withMVar, newMVar, modifyMVar_)
26 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
27 import Control.Lens (makeLenses, Getter, (^.))
28 import Control.Monad.Except
29 import Control.Monad.Reader
30 import Data.Aeson hiding ((.=), decode)
31 import Data.Map.Strict (Map)
32 import Data.Maybe (fromMaybe)
33 import Data.Monoid
34 import Data.Semigroup
35 import GHC.Generics (Generic)
36 import Gargantext.API.Ngrams.Types
37 import Gargantext.Core.Types (NodeId)
38 import Gargantext.Core.Utils.Prefix (unPrefix)
39 import Gargantext.Database.Prelude (CmdM', HasConnectionPool, HasConfig)
40 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
41 import Gargantext.Prelude
42 import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
43 import System.IO (FilePath, hClose)
44 import System.IO.Temp (withTempFile)
45 import qualified Data.ByteString.Lazy as DBL
46 import qualified Data.List as List
47 import qualified Data.Map.Strict as Map
48 import qualified Data.Map.Strict.Patch.Internal as Patch
49 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
50
51 ------------------------------------------------------------------------
52 data NodeStoryEnv = NodeStoryEnv
53 { _nse_var :: !(MVar NodeListStory)
54 , _nse_saver :: !(IO ())
55 , _nse_getter :: [NodeId] -> IO (MVar NodeListStory)
56 --, _nse_cleaner :: !(IO ()) -- every 12 hours: cleans the repos of unused NodeStories
57 -- , _nse_lock :: !FileLock -- TODO (it depends on the option: if with database or file only)
58 }
59 deriving (Generic)
60
61 type HasNodeStory env err m = ( CmdM' env err m
62 , MonadReader env m
63 , MonadError err m
64 , HasNodeStoryEnv env
65 , HasConfig env
66 , HasConnectionPool env
67 , HasNodeError err
68 )
69
70 class (HasNodeStoryVar env, HasNodeStorySaver env)
71 => HasNodeStoryEnv env where
72 hasNodeStory :: Getter env NodeStoryEnv
73
74 class HasNodeStoryVar env where
75 hasNodeStoryVar :: Getter env ([NodeId] -> IO (MVar NodeListStory))
76
77 class HasNodeStorySaver env where
78 hasNodeStorySaver :: Getter env (IO ())
79
80 ------------------------------------------------------------------------
81 readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
82 readNodeStoryEnv nsd = do
83 mvar <- nodeStoryVar nsd Nothing [0]
84 saver <- mkNodeStorySaver nsd mvar
85 pure $ NodeStoryEnv { _nse_var = mvar
86 , _nse_saver = saver
87 , _nse_getter = nodeStoryVar nsd (Just mvar) }
88
89 ------------------------------------------------------------------------
90 mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
91 mkNodeStorySaver nsd mvns = mkDebounce settings
92 where
93 settings = defaultDebounceSettings
94 { debounceAction = withMVar mvns (writeNodeStories nsd)
95 , debounceFreq = 1 * minute
96 -- , debounceEdge = trailingEdge -- Trigger on the trailing edge
97 }
98 minute = 60 * second
99 second = 10^(6 :: Int)
100
101 nodeStoryVar :: NodeStoryDir
102 -> Maybe (MVar NodeListStory)
103 -> [NodeId]
104 -> IO (MVar NodeListStory)
105 nodeStoryVar nsd Nothing ni = nodeStoryIncs nsd Nothing ni >>= newMVar
106 nodeStoryVar nsd (Just mv) ni = do
107 _ <- modifyMVar_ mv $ \mv' -> (nodeStoryIncs nsd (Just mv') ni)
108 pure mv
109
110
111 nodeStoryInc :: NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
112 nodeStoryInc nsd (Just ns@(NodeStory nls)) ni = do
113 case Map.lookup ni nls of
114 Nothing -> do
115 (NodeStory nls') <- nodeStoryRead nsd ni
116 pure $ NodeStory $ Map.union nls nls'
117 Just _ -> pure ns
118 nodeStoryInc nsd Nothing ni = nodeStoryRead nsd ni
119
120
121 nodeStoryIncs :: NodeStoryDir
122 -> Maybe NodeListStory
123 -> [NodeId]
124 -> IO NodeListStory
125 nodeStoryIncs _ Nothing [] = panic "nodeStoryIncs: Empty"
126 nodeStoryIncs nsd (Just nls) ns = foldM (\m n -> nodeStoryInc nsd (Just m) n) nls ns
127 nodeStoryIncs nsd Nothing (ni:ns) = do
128 m <- nodeStoryRead nsd ni
129 nodeStoryIncs nsd (Just m) ns
130
131
132 nodeStoryDec :: NodeStoryDir
133 -> NodeListStory
134 -> NodeId
135 -> IO NodeListStory
136 nodeStoryDec nsd ns@(NodeStory nls) ni = do
137 case Map.lookup ni nls of
138 Nothing -> do
139 -- we make sure the corresponding file repo is really removed
140 _ <- nodeStoryRemove nsd ni
141 pure ns
142 Just _ -> do
143 let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
144 _ <- nodeStoryRemove nsd ni
145 pure $ NodeStory ns'
146
147 -- | TODO lock
148 nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
149 nodeStoryRead nsd ni = do
150 _repoDir <- createDirectoryIfMissing True nsd
151 let nsp = nodeStoryPath nsd ni
152 exists <- doesFileExist nsp
153 if exists
154 then deserialise <$> DBL.readFile nsp
155 else pure (initNodeStory ni)
156
157 nodeStoryRemove :: NodeStoryDir -> NodeId -> IO ()
158 nodeStoryRemove nsd ni = do
159 let nsp = nodeStoryPath nsd ni
160 exists <- doesFileExist nsp
161 if exists
162 then removeFile nsp
163 else pure ()
164
165
166
167 nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
168 nodeStoryRead_test nsd ni = nodeStoryRead nsd ni >>= \n -> pure
169 $ fmap Map.keys
170 $ fmap _a_state
171 $ Map.lookup ni
172 $ _unNodeStory n
173
174 ------------------------------------------------------------------------
175 type NodeStoryDir = FilePath
176
177 writeNodeStories :: NodeStoryDir -> NodeListStory -> IO ()
178 writeNodeStories fp nls = do
179 done <- mapM (writeNodeStory fp) $ splitByNode nls
180 printDebug "[writeNodeStories]" done
181 pure ()
182
183 writeNodeStory :: NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
184 writeNodeStory rdfp (n, ns) = saverAction' rdfp n ns
185
186 splitByNode :: NodeListStory -> [(NodeId, NodeListStory)]
187 splitByNode (NodeStory m) =
188 List.map (\(n,a) -> (n, NodeStory $ Map.singleton n a)) $ Map.toList m
189
190
191 saverAction' :: Serialise a => NodeStoryDir -> NodeId -> a -> IO ()
192 saverAction' repoDir nId a = do
193 withTempFile repoDir ((cs $ show nId) <> "-tmp-repo.cbor") $ \fp h -> do
194 printDebug "[repoSaverAction]" fp
195 DBL.hPut h $ serialise a
196 hClose h
197 renameFile fp (nodeStoryPath repoDir nId)
198
199 nodeStoryPath :: NodeStoryDir -> NodeId -> FilePath
200 nodeStoryPath repoDir nId = repoDir <> "/" <> filename
201 where
202 filename = "repo" <> "-" <> (cs $ show nId) <> ".cbor"
203
204
205 ------------------------------------------------------------------------
206 -- TODO : repo Migration TODO TESTS
207 repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
208 repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
209
210 repoToNodeListStory :: NgramsRepo -> NodeListStory
211 repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
212 where
213 s' = ngramsState_migration s
214 h' = ngramsStatePatch_migration h
215 ns = List.map (\(n,ns')
216 -> (n, let hs = fromMaybe [] (Map.lookup n h') in
217 Archive { _a_version = List.length hs
218 , _a_state = ns'
219 , _a_history = hs }
220 )
221 ) $ Map.toList s'
222
223 ngramsState_migration :: NgramsState
224 -> Map NodeId NgramsState'
225 ngramsState_migration ns =
226 Map.fromListWith (Map.union) $
227 List.concat $
228 map (\(nt, nTable)
229 -> map (\(nid, table)
230 -> (nid, Map.singleton nt table)
231 ) $ Map.toList nTable
232 ) $ Map.toList ns
233
234
235 ngramsStatePatch_migration :: [NgramsStatePatch]
236 -> Map NodeId [NgramsStatePatch']
237 ngramsStatePatch_migration np' = Map.fromListWith (<>)
238 $ List.concat
239 $ map toPatch np'
240 where
241 toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
242 toPatch p =
243 List.concat $
244 map (\(nt, nTable)
245 -> map (\(nid, table)
246 -> (nid, [fst $ Patch.singleton nt table])
247 ) $ Patch.toList nTable
248 ) $ Patch.toList p
249
250 ------------------------------------------------------------------------
251
252 {- | Node Story for each NodeType where the Key of the Map is NodeId
253 TODO : generalize for any NodeType, let's start with NodeList which
254 is implemented already
255 -}
256 data NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
257 deriving (Generic, Show)
258
259 instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
260 instance (ToJSON s, ToJSON p) => ToJSON (NodeStory s p)
261 instance (Serialise s, Serialise p) => Serialise (NodeStory s p)
262
263 data Archive s p = Archive
264 { _a_version :: !Version
265 , _a_state :: !s
266 , _a_history :: ![p]
267 -- first patch in the list is the most recent
268 }
269 deriving (Generic, Show)
270
271 instance (Serialise s, Serialise p) => Serialise (Archive s p)
272
273
274 type NodeListStory = NodeStory NgramsState' NgramsStatePatch'
275
276 type NgramsState' = Map TableNgrams.NgramsType NgramsTableMap
277 type NgramsStatePatch' = PatchMap TableNgrams.NgramsType NgramsTablePatch
278 instance Serialise NgramsStatePatch'
279
280 -- TODO Semigroup instance for unions
281 -- TODO check this
282 instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
283 (<>) (Archive { _a_history = p }) (Archive { _a_version = v'
284 , _a_state = s'
285 , _a_history = p'}) =
286 Archive { _a_version = v'
287 , _a_state = s'
288 , _a_history = p' <> p }
289
290 instance Monoid (Archive NgramsState' NgramsStatePatch') where
291 mempty = Archive { _a_version = 0
292 , _a_state = mempty
293 , _a_history = [] }
294
295 instance (FromJSON s, FromJSON p) => FromJSON (Archive s p) where
296 parseJSON = genericParseJSON $ unPrefix "_a_"
297
298 instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
299 toJSON = genericToJSON $ unPrefix "_a_"
300 toEncoding = genericToEncoding $ unPrefix "_a_"
301
302 ------------------------------------------------------------------------
303 initNodeStory :: Monoid s => NodeId -> NodeStory s p
304 initNodeStory ni = NodeStory $ Map.singleton ni initArchive
305
306 initArchive :: Monoid s => Archive s p
307 initArchive = Archive { _a_version = 0
308 , _a_state = mempty
309 , _a_history = [] }
310
311 initNodeListStoryMock :: NodeListStory
312 initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
313 where
314 nodeListId = 0
315 archive = Archive { _a_version = 0
316 , _a_state = ngramsTableMap
317 , _a_history = [] }
318 ngramsTableMap = Map.singleton TableNgrams.NgramsTerms
319 $ Map.fromList
320 [ (n ^. ne_ngrams, ngramsElementToRepo n)
321 | n <- mockTable ^. _NgramsTable
322 ]
323
324 ------------------------------------------------------------------------
325
326
327 ------------------------------------------------------------------------
328 -- | Lenses at the bottom of the file because Template Haskell would reorder order of execution in others cases
329 makeLenses ''NodeStoryEnv
330 makeLenses ''NodeStory
331 makeLenses ''Archive