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