src/Gargantext/Core/NodeStoryFile.hs

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