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