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 mvar saver (nodeStoryVar nsd (Just mvar))
  86
  87 ------------------------------------------------------------------------
  88 mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
  89 mkNodeStorySaver nsd mvns = mkDebounce settings
  90   where
  91     settings = defaultDebounceSettings
  92                  { debounceAction = withMVar mvns (writeNodeStories nsd)
  93                  , debounceFreq = 1 * minute
  94 --                 , debounceEdge = trailingEdge -- Trigger on the trailing edge
  95                  }
  96     minute = 60 * second
  97     second = 10^(6 :: Int)
  98
  99 nodeStoryVar :: NodeStoryDir
 100              -> Maybe (MVar NodeListStory)
 101              -> [NodeId]
 102              -> IO (MVar NodeListStory)
 103 nodeStoryVar nsd Nothing ni = nodeStoryIncs nsd Nothing ni >>= newMVar
 104 nodeStoryVar nsd (Just mv) ni = do
 105   _ <- modifyMVar_ mv $ \mv' -> (nodeStoryIncs nsd (Just mv') ni)
 106   pure mv
 107
 108
 109 nodeStoryInc :: NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
 110 nodeStoryInc nsd (Just ns@(NodeStory nls)) ni = do
 111   case Map.lookup ni nls of
 112     Nothing -> do
 113       (NodeStory nls') <- nodeStoryRead nsd ni
 114       pure $ NodeStory $ Map.union nls nls'
 115     Just _  -> pure ns
 116 nodeStoryInc nsd Nothing ni = nodeStoryRead nsd ni
 117
 118
 119 nodeStoryIncs :: NodeStoryDir
 120               -> Maybe NodeListStory
 121               -> [NodeId]
 122               -> IO NodeListStory
 123 nodeStoryIncs _ Nothing    []        = panic "nodeStoryIncs: Empty"
 124 nodeStoryIncs nsd (Just nls) ns      = foldM (\m n -> nodeStoryInc nsd (Just m) n) nls ns
 125 nodeStoryIncs nsd Nothing    (ni:ns) = do
 126   m <- nodeStoryRead nsd ni
 127   nodeStoryIncs nsd (Just m) ns
 128
 129
 130 nodeStoryDec :: NodeStoryDir
 131              -> NodeListStory
 132              -> NodeId
 133              -> IO NodeListStory
 134 nodeStoryDec nsd ns@(NodeStory nls) ni = do
 135   case Map.lookup ni nls of
 136     Nothing -> do
 137       -- we make sure the corresponding file repo is really removed
 138       _ <- nodeStoryRemove nsd ni
 139       pure ns
 140     Just _  -> do
 141       let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
 142       _ <- nodeStoryRemove nsd ni
 143       pure $ NodeStory ns'
 144
 145 -- | TODO lock
 146 nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
 147 nodeStoryRead nsd ni = do
 148   _repoDir <- createDirectoryIfMissing True nsd
 149   let nsp = nodeStoryPath nsd ni
 150   exists <- doesFileExist nsp
 151   if exists
 152      then deserialise <$> DBL.readFile nsp
 153      else pure (initNodeStory ni)
 154
 155 nodeStoryRemove :: NodeStoryDir -> NodeId -> IO ()
 156 nodeStoryRemove nsd ni = do
 157   let nsp = nodeStoryPath nsd ni
 158   exists <- doesFileExist nsp
 159   if exists
 160      then removeFile nsp
 161      else pure ()
 162
 163
 164
 165 nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
 166 nodeStoryRead_test nsd ni = nodeStoryRead nsd ni >>= \n -> pure
 167                           $ fmap Map.keys
 168                           $ fmap _a_state
 169                           $ Map.lookup ni
 170                           $ _unNodeStory n
 171
 172 ------------------------------------------------------------------------
 173 type NodeStoryDir = FilePath
 174
 175 writeNodeStories :: NodeStoryDir -> NodeListStory -> IO ()
 176 writeNodeStories fp nls = do
 177   done <- mapM (writeNodeStory fp) $ splitByNode nls
 178   printDebug "[writeNodeStories]" done
 179   pure ()
 180
 181 writeNodeStory :: NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
 182 writeNodeStory rdfp (n, ns) = saverAction' rdfp n ns
 183
 184 splitByNode :: NodeListStory -> [(NodeId, NodeListStory)]
 185 splitByNode (NodeStory m) =
 186   List.map (\(n,a) -> (n, NodeStory $ Map.singleton n a)) $ Map.toList m
 187
 188
 189 saverAction' :: Serialise a => NodeStoryDir -> NodeId -> a -> IO ()
 190 saverAction' repoDir nId a = do
 191   withTempFile repoDir ((cs $ show nId) <> "-tmp-repo.cbor") $ \fp h -> do
 192     printDebug "[repoSaverAction]" fp
 193     DBL.hPut h $ serialise a
 194     hClose h
 195     renameFile fp (nodeStoryPath repoDir nId)
 196
 197 nodeStoryPath :: NodeStoryDir -> NodeId -> FilePath
 198 nodeStoryPath repoDir nId = repoDir <> "/" <> filename
 199   where
 200     filename = "repo" <> "-" <> (cs $ show nId) <> ".cbor"
 201
 202
 203 ------------------------------------------------------------------------
 204 -- TODO : repo Migration TODO TESTS
 205 repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
 206 repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
 207
 208 repoToNodeListStory :: NgramsRepo -> NodeListStory
 209 repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
 210   where
 211     s' = ngramsState_migration      s
 212     h' = ngramsStatePatch_migration h
 213     ns = List.map (\(n,ns')
 214                     -> (n, let hs = fromMaybe [] (Map.lookup n h') in
 215                                Archive (List.length hs) ns' hs
 216                        )
 217                   ) $ Map.toList s'
 218
 219 ngramsState_migration :: NgramsState
 220                       -> Map NodeId NgramsState'
 221 ngramsState_migration ns =
 222   Map.fromListWith (Map.union) $
 223   List.concat $
 224     map (\(nt, nTable)
 225           -> map (\(nid, table)
 226                    -> (nid, Map.singleton nt table)
 227                  ) $ Map.toList nTable
 228         ) $ Map.toList ns
 229
 230
 231 ngramsStatePatch_migration :: [NgramsStatePatch]
 232                            -> Map NodeId [NgramsStatePatch']
 233 ngramsStatePatch_migration np' = Map.fromListWith (<>)
 234                                $ List.concat
 235                                $ map toPatch np'
 236   where
 237     toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
 238     toPatch p =
 239       List.concat $
 240         map (\(nt, nTable)
 241               -> map (\(nid, table)
 242                        -> (nid, [fst $ Patch.singleton nt table])
 243                      ) $ Patch.toList nTable
 244             ) $ Patch.toList p
 245
 246 ------------------------------------------------------------------------
 247
 248 {- | Node Story for each NodeType where the Key of the Map is NodeId
 249   TODO : generalize for any NodeType, let's start with NodeList which
 250   is implemented already
 251 -}
 252 data NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
 253   deriving (Generic, Show)
 254
 255 instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
 256 instance (ToJSON s, ToJSON p) => ToJSON (NodeStory s p)
 257 instance (Serialise s, Serialise p) => Serialise (NodeStory s p)
 258
 259 data Archive s p = Archive
 260   { _a_version :: !Version
 261   , _a_state   :: !s
 262   , _a_history :: ![p]
 263     -- first patch in the list is the most recent
 264   }
 265   deriving (Generic, Show)
 266
 267 instance (Serialise s, Serialise p) => Serialise (Archive s p)
 268
 269
 270 type NodeListStory     = NodeStory NgramsState' NgramsStatePatch'
 271
 272 type NgramsState'      = Map       TableNgrams.NgramsType NgramsTableMap
 273 type NgramsStatePatch' = PatchMap  TableNgrams.NgramsType NgramsTablePatch
 274 instance Serialise NgramsStatePatch'
 275
 276 -- TODO Semigroup instance for unions
 277 -- TODO check this
 278 instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
 279   (<>) (Archive _v _s p) (Archive v' s' p') = Archive v' s' (p' <> p)
 280
 281 instance Monoid (Archive NgramsState' NgramsStatePatch') where
 282   mempty = Archive 0 mempty []
 283
 284 instance (FromJSON s, FromJSON p) => FromJSON (Archive s p) where
 285   parseJSON = genericParseJSON $ unPrefix "_a_"
 286
 287 instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
 288   toJSON     = genericToJSON     $ unPrefix "_a_"
 289   toEncoding = genericToEncoding $ unPrefix "_a_"
 290
 291 ------------------------------------------------------------------------
 292 initNodeStory :: Monoid s => NodeId -> NodeStory s p
 293 initNodeStory ni = NodeStory $ Map.singleton ni initArchive
 294
 295 initArchive :: Monoid s => Archive s p
 296 initArchive = Archive 0 mempty []
 297
 298 initNodeListStoryMock :: NodeListStory
 299 initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
 300   where
 301     nodeListId = 0
 302     archive        = Archive 0 ngramsTableMap []
 303     ngramsTableMap = Map.singleton TableNgrams.NgramsTerms
 304                    $ Map.fromList
 305                    [ (n ^. ne_ngrams, ngramsElementToRepo n)
 306                    | n <- mockTable ^. _NgramsTable
 307                    ]
 308
 309 ------------------------------------------------------------------------
 310
 311
 312 ------------------------------------------------------------------------
 313 -- | Lenses at the bottom of the file because Template Haskell would reorder order of execution in others cases
 314 makeLenses ''NodeStoryEnv
 315 makeLenses ''NodeStory
 316 makeLenses ''Archive