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