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