src/Gargantext/Core/NodeStoryFile.hs

   1 {-|
   2 Module      : Gargantext.API.Ngrams.Types
   3 Description : Ngrams List Types
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 NOTE This is legacy code. It keeps node stories in a directory
  11  repo. We now have migrated to the DB. However this code is needed to
  12  make the migration (see  Gargantext.API.Ngrams.Tools)
  13
  14 -}
  15
  16 module Gargantext.Core.NodeStoryFile where
  17
  18 import Control.Lens (view)
  19 import Control.Monad (foldM)
  20 import Codec.Serialise (serialise, deserialise)
  21 import Codec.Serialise.Class
  22 import Control.Concurrent (MVar(), modifyMVar_, newMVar, readMVar, withMVar)
  23 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
  24 import Gargantext.Core.NodeStory hiding (readNodeStoryEnv)
  25 import Gargantext.Core.Types (ListId, NodeId(..))
  26 import Gargantext.Database.Prelude (CmdM, hasConfig)
  27 import Gargantext.Prelude
  28 import Gargantext.Prelude.Config (gc_repofilepath)
  29 import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
  30 import System.IO (FilePath, hClose)
  31 import System.IO.Temp (withTempFile)
  32 import qualified Data.ByteString.Lazy                   as DBL
  33 import qualified Data.List                              as List
  34 import qualified Data.Map.Strict                        as Map
  35 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
  36
  37
  38 getRepo :: HasNodeStory env err m
  39          => [ListId] -> m NodeListStory
  40 getRepo listIds = do
  41   g <- getNodeListStory
  42   liftBase $ do
  43     v <- g listIds
  44     readMVar v
  45   -- v  <- liftBase $ f listIds
  46   -- v' <- liftBase $ readMVar v
  47   -- pure $ v'
  48
  49 getRepoReadConfig :: (CmdM env err m)
  50              => [ListId] -> m NodeListStory
  51 getRepoReadConfig listIds = do
  52   repoFP <- view $ hasConfig . gc_repofilepath
  53   env <- liftBase $ readNodeStoryEnv repoFP
  54   let g = view nse_getter env
  55   liftBase $ do
  56     v <- g listIds
  57     readMVar v
  58
  59 getNodeListStory :: HasNodeStory env err m
  60                  => m ([NodeId] -> IO (MVar NodeListStory))
  61 getNodeListStory = do
  62   env <- view hasNodeStory
  63   pure $ view nse_getter env
  64
  65
  66
  67 readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
  68 readNodeStoryEnv nsd = do
  69   mvar  <- nodeStoryVar nsd Nothing []
  70   saver <- mkNodeStorySaver nsd mvar
  71   let saver_immediate = withMVar mvar (writeNodeStories nsd)
  72   pure $ NodeStoryEnv { _nse_var = mvar
  73                       , _nse_saver = saver
  74                       , _nse_saver_immediate = saver_immediate
  75                       , _nse_getter = nodeStoryVar nsd (Just mvar) }
  76
  77 ------------------------------------------------------------------------
  78 mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
  79 mkNodeStorySaver nsd mvns = mkDebounce settings
  80   where
  81     settings = defaultDebounceSettings
  82                  { debounceAction = withMVar mvns (writeNodeStories nsd)
  83                  , debounceFreq = 1 * minute
  84 --                 , debounceEdge = trailingEdge -- Trigger on the trailing edge
  85                  }
  86     minute = 60 * second
  87     second = 10^(6 :: Int)
  88
  89 nodeStoryVar :: NodeStoryDir
  90              -> Maybe (MVar NodeListStory)
  91              -> [NodeId]
  92              -> IO (MVar NodeListStory)
  93 nodeStoryVar nsd Nothing ni = nodeStoryIncs nsd Nothing ni >>= newMVar
  94 nodeStoryVar nsd (Just mv) ni = do
  95   _ <- modifyMVar_ mv $ \mv' -> (nodeStoryIncs nsd (Just mv') ni)
  96   pure mv
  97
  98
  99 nodeStoryInc :: NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
 100 nodeStoryInc nsd (Just ns@(NodeStory nls)) ni = do
 101   case Map.lookup ni nls of
 102     Nothing -> do
 103       (NodeStory nls') <- nodeStoryRead nsd ni
 104       pure $ NodeStory $ Map.union nls nls'
 105     Just _  -> pure ns
 106 nodeStoryInc nsd Nothing ni = nodeStoryRead nsd ni
 107
 108
 109 nodeStoryIncs :: NodeStoryDir
 110               -> Maybe NodeListStory
 111               -> [NodeId]
 112               -> IO NodeListStory
 113 nodeStoryIncs _ Nothing    []        = pure $ NodeStory $ Map.empty
 114 nodeStoryIncs nsd (Just nls) ns      = foldM (\m n -> nodeStoryInc nsd (Just m) n) nls ns
 115 nodeStoryIncs nsd Nothing    (ni:ns) = do
 116   m <- nodeStoryRead nsd ni
 117   nodeStoryIncs nsd (Just m) ns
 118
 119
 120 nodeStoryDec :: NodeStoryDir
 121              -> NodeListStory
 122              -> NodeId
 123              -> IO NodeListStory
 124 nodeStoryDec nsd ns@(NodeStory nls) ni = do
 125   case Map.lookup ni nls of
 126     Nothing -> do
 127       -- we make sure the corresponding file repo is really removed
 128       _ <- nodeStoryRemove nsd ni
 129       pure ns
 130     Just _  -> do
 131       let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
 132       _ <- nodeStoryRemove nsd ni
 133       pure $ NodeStory ns'
 134
 135 -- | TODO lock
 136 nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
 137 nodeStoryRead nsd ni = do
 138   _repoDir <- createDirectoryIfMissing True nsd
 139   let nsp = nodeStoryPath nsd ni
 140   exists <- doesFileExist nsp
 141   if exists
 142      then deserialise <$> DBL.readFile nsp
 143      else pure (initNodeStory ni)
 144
 145 nodeStoryRemove :: NodeStoryDir -> NodeId -> IO ()
 146 nodeStoryRemove nsd ni = do
 147   let nsp = nodeStoryPath nsd ni
 148   exists <- doesFileExist nsp
 149   if exists
 150      then removeFile nsp
 151      else pure ()
 152
 153
 154
 155 nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
 156 nodeStoryRead_test nsd ni = nodeStoryRead nsd ni >>= \n -> pure
 157                           $ fmap Map.keys
 158                           $ fmap _a_state
 159                           $ Map.lookup ni
 160                           $ _unNodeStory n
 161
 162 ------------------------------------------------------------------------
 163 type NodeStoryDir = FilePath
 164
 165 writeNodeStories :: NodeStoryDir -> NodeListStory -> IO ()
 166 writeNodeStories fp nls = do
 167   _done <- mapM (writeNodeStory fp) $ splitByNode nls
 168   -- printDebug "[writeNodeStories]" done
 169   pure ()
 170
 171 writeNodeStory :: NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
 172 writeNodeStory rdfp (n, ns) = saverAction' rdfp n ns
 173
 174 splitByNode :: NodeListStory -> [(NodeId, NodeListStory)]
 175 splitByNode (NodeStory m) =
 176   List.map (\(n,a) -> (n, NodeStory $ Map.singleton n a)) $ Map.toList m
 177
 178
 179 saverAction' :: Serialise a => NodeStoryDir -> NodeId -> a -> IO ()
 180 saverAction' repoDir nId a = do
 181   withTempFile repoDir ((cs $ show nId) <> "-tmp-repo.cbor") $ \fp h -> do
 182     -- printDebug "[repoSaverAction]" fp
 183     DBL.hPut h $ serialise a
 184     hClose h
 185     renameFile fp (nodeStoryPath repoDir nId)
 186
 187 nodeStoryPath :: NodeStoryDir -> NodeId -> FilePath
 188 nodeStoryPath repoDir nId = repoDir <> "/" <> filename
 189   where
 190     filename = "repo" <> "-" <> (cs $ show nId) <> ".cbor"
 191
 192
 193 ------------------------------------------------------------------------
 194 -- TODO : repo Migration TODO TESTS
 195 {-
 196 repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
 197 repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
 198
 199 repoToNodeListStory :: NgramsRepo -> NodeListStory
 200 repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
 201   where
 202     s' = ngramsState_migration      s
 203     h' = ngramsStatePatch_migration h
 204     ns = List.map (\(n,ns')
 205                     -> (n, let hs = fromMaybe [] (Map.lookup n h') in
 206                                Archive { _a_version = List.length hs
 207                                        , _a_state = ns'
 208                                        , _a_history = hs }
 209                        )
 210                   ) $ Map.toList s'
 211
 212 ngramsState_migration :: NgramsState
 213                       -> Map NodeId NgramsState'
 214 ngramsState_migration ns =
 215   Map.fromListWith (Map.union) $
 216   List.concat $
 217     map (\(nt, nTable)
 218           -> map (\(nid, table)
 219                    -> (nid, Map.singleton nt table)
 220                  ) $ Map.toList nTable
 221         ) $ Map.toList ns
 222
 223
 224 ngramsStatePatch_migration :: [NgramsStatePatch]
 225                            -> Map NodeId [NgramsStatePatch']
 226 ngramsStatePatch_migration np' = Map.fromListWith (<>)
 227                                $ List.concat
 228                                $ map toPatch np'
 229   where
 230     toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
 231     toPatch p =
 232       List.concat $
 233         map (\(nt, nTable)
 234               -> map (\(nid, table)
 235                        -> (nid, [fst $ Patch.singleton nt table])
 236                      ) $ Patch.toList nTable
 237             ) $ Patch.toList p
 238 -}