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