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 Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
  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 Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
  46 import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
  47 import System.IO (FilePath, hClose)
  48 import System.IO.Temp (withTempFile)
  49 import qualified Data.ByteString.Lazy                   as DBL
  50 import qualified Data.List                              as List
  51 import qualified Data.Map.Strict                        as Map
  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 []
  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    []        = pure $ NodeStory $ Map.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 {-
 211 repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
 212 repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
 213
 214 repoToNodeListStory :: NgramsRepo -> NodeListStory
 215 repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
 216   where
 217     s' = ngramsState_migration      s
 218     h' = ngramsStatePatch_migration h
 219     ns = List.map (\(n,ns')
 220                     -> (n, let hs = fromMaybe [] (Map.lookup n h') in
 221                                Archive { _a_version = List.length hs
 222                                        , _a_state = ns'
 223                                        , _a_history = hs }
 224                        )
 225                   ) $ Map.toList s'
 226
 227 ngramsState_migration :: NgramsState
 228                       -> Map NodeId NgramsState'
 229 ngramsState_migration ns =
 230   Map.fromListWith (Map.union) $
 231   List.concat $
 232     map (\(nt, nTable)
 233           -> map (\(nid, table)
 234                    -> (nid, Map.singleton nt table)
 235                  ) $ Map.toList nTable
 236         ) $ Map.toList ns
 237
 238
 239 ngramsStatePatch_migration :: [NgramsStatePatch]
 240                            -> Map NodeId [NgramsStatePatch']
 241 ngramsStatePatch_migration np' = Map.fromListWith (<>)
 242                                $ List.concat
 243                                $ map toPatch np'
 244   where
 245     toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
 246     toPatch p =
 247       List.concat $
 248         map (\(nt, nTable)
 249               -> map (\(nid, table)
 250                        -> (nid, [fst $ Patch.singleton nt table])
 251                      ) $ Patch.toList nTable
 252             ) $ Patch.toList p
 253 -}
 254 ------------------------------------------------------------------------
 255
 256 {- | Node Story for each NodeType where the Key of the Map is NodeId
 257   TODO : generalize for any NodeType, let's start with NodeList which
 258   is implemented already
 259 -}
 260 data NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
 261   deriving (Generic, Show)
 262
 263 instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
 264 instance (ToJSON s, ToJSON p) => ToJSON (NodeStory s p)
 265 instance (Serialise s, Serialise p) => Serialise (NodeStory s p)
 266
 267 data Archive s p = Archive
 268   { _a_version :: !Version
 269   , _a_state   :: !s
 270   , _a_history :: ![p]
 271     -- first patch in the list is the most recent
 272   }
 273   deriving (Generic, Show)
 274
 275 instance (Serialise s, Serialise p) => Serialise (Archive s p)
 276
 277
 278 type NodeListStory     = NodeStory NgramsState' NgramsStatePatch'
 279
 280 type NgramsState'      = Map       TableNgrams.NgramsType NgramsTableMap
 281 type NgramsStatePatch' = PatchMap  TableNgrams.NgramsType NgramsTablePatch
 282 instance Serialise NgramsStatePatch'
 283 instance FromField (Archive NgramsState' NgramsStatePatch')
 284   where
 285     fromField = fromJSONField
 286 instance DefaultFromField SqlJsonb (Archive NgramsState' NgramsStatePatch')
 287   where
 288     defaultFromField = fromPGSFromField
 289
 290 -- TODO Semigroup instance for unions
 291 -- TODO check this
 292 instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
 293   (<>) (Archive { _a_history = p }) (Archive { _a_version = v'
 294                                              , _a_state = s'
 295                                              , _a_history = p'}) =
 296     Archive { _a_version = v'
 297             , _a_state = s'
 298             , _a_history = p' <> p }
 299
 300 instance Monoid (Archive NgramsState' NgramsStatePatch') where
 301   mempty = Archive { _a_version = 0
 302                    , _a_state = mempty
 303                    , _a_history = [] }
 304
 305 instance (FromJSON s, FromJSON p) => FromJSON (Archive s p) where
 306   parseJSON = genericParseJSON $ unPrefix "_a_"
 307
 308 instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
 309   toJSON     = genericToJSON     $ unPrefix "_a_"
 310   toEncoding = genericToEncoding $ unPrefix "_a_"
 311
 312 ------------------------------------------------------------------------
 313 initNodeStory :: Monoid s => NodeId -> NodeStory s p
 314 initNodeStory ni = NodeStory $ Map.singleton ni initArchive
 315
 316 initArchive :: Monoid s => Archive s p
 317 initArchive = Archive { _a_version = 0
 318                       , _a_state = mempty
 319                       , _a_history = [] }
 320
 321 initNodeListStoryMock :: NodeListStory
 322 initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
 323   where
 324     nodeListId = 0
 325     archive        = Archive { _a_version = 0
 326                              , _a_state = ngramsTableMap
 327                              , _a_history = [] }
 328     ngramsTableMap = Map.singleton TableNgrams.NgramsTerms
 329                    $ Map.fromList
 330                    [ (n ^. ne_ngrams, ngramsElementToRepo n)
 331                    | n <- mockTable ^. _NgramsTable
 332                    ]
 333
 334 ------------------------------------------------------------------------
 335
 336
 337 ------------------------------------------------------------------------
 338 -- | Lenses at the bottom of the file because Template Haskell would reorder order of execution in others cases
 339 makeLenses ''NodeStoryEnv
 340 makeLenses ''NodeStory
 341 makeLenses ''Archive