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