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