src/Gargantext/Database/NodeStory.hs

   1 {-# LANGUAGE Arrows #-}
   2 {-# LANGUAGE TemplateHaskell           #-}
   3
   4 module Gargantext.Database.NodeStory where
   5
   6 import Control.Arrow (returnA)
   7 import Control.Concurrent.MVar.Lifted (MVar(), withMVar, newMVar, modifyMVar_)
   8 --import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
   9 import Control.Monad (foldM)
  10 import qualified Data.Map.Strict as Map
  11 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  12 import Gargantext.API.Ngrams.Tools (getRepo)
  13 import Gargantext.Core (HasDBid)
  14 import Gargantext.Core.Mail.Types (HasMail)
  15 import Gargantext.Core.NodeStory (Archive(..), NodeStory(..), NodeListStory, NgramsState', NgramsStatePatch')
  16 import qualified Gargantext.Core.NodeStory as NS
  17 import Gargantext.Core.Types (NodeId(..), NodeType(..))
  18 import Gargantext.Database.Prelude (CmdM, mkCmd, runOpaQuery)
  19 import Gargantext.Database.Query.Table.Node (getNodesIdWithType, nodeExists)
  20 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  21 import Gargantext.Prelude
  22 import Opaleye hiding (FromField)
  23 import Opaleye.Internal.Table (Table(..))
  24
  25
  26 data NodeStoryPoly a b = NodeStoryDB { node_id :: a
  27                                      , archive :: b }
  28   deriving (Eq)
  29
  30 type ArchiveQ = Archive NgramsState' NgramsStatePatch'
  31
  32 type NodeListStoryQ = NodeStoryPoly Int ArchiveQ
  33
  34 type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
  35 type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
  36
  37 $(makeAdaptorAndInstance "pNodeStory" ''NodeStoryPoly)
  38
  39 nodeStoryTable :: Table NodeStoryRead NodeStoryWrite
  40 nodeStoryTable =
  41   Table "node_stories"
  42     ( pNodeStory NodeStoryDB { node_id = tableField "node_id"
  43                              , archive = tableField "archive" } )
  44
  45 nodeStorySelect :: Select NodeStoryRead
  46 nodeStorySelect = selectTable nodeStoryTable
  47
  48 getNodeStory :: CmdM env err m => NodeId -> m NodeListStory
  49 getNodeStory (NodeId nodeId) = do
  50   res <- runOpaQuery query
  51   pure $ NodeStory $ Map.fromListWith (<>) $ (\(NodeStoryDB nId a) -> (nId, a)) <$> res
  52   where
  53     query :: Select NodeStoryRead
  54     query = proc () -> do
  55       row@(NodeStoryDB node_id _) <- nodeStorySelect -< ()
  56       restrict -< node_id .== sqlInt4 nodeId
  57       returnA -< row
  58
  59 insertNodeArchive :: CmdM env err m => NodeId -> ArchiveQ -> m Int64
  60 insertNodeArchive (NodeId nId) a = mkCmd $ \c -> runInsert c insert
  61   where
  62     insert = Insert { iTable      = nodeStoryTable
  63                     , iRows       = [NodeStoryDB { node_id = sqlInt4 nId
  64                                                  , archive = sqlValueJSONB a }]
  65                     , iReturning  = rCount
  66                     , iOnConflict = Nothing }
  67
  68 updateNodeArchive :: CmdM env err m => NodeId -> ArchiveQ -> m Int64
  69 updateNodeArchive (NodeId nId) a = mkCmd $ \c -> runUpdate c update
  70   where
  71     update = Update { uTable      = nodeStoryTable
  72                     , uUpdateWith = updateEasy (\(NodeStoryDB { .. }) -> NodeStoryDB { archive = sqlValueJSONB a, .. })
  73                     , uWhere      = (\row -> node_id row .== sqlInt4 nId)
  74                     , uReturning  = rCount }
  75
  76 nodeStoryRemove :: CmdM env err m => NodeId -> m Int64
  77 nodeStoryRemove (NodeId nId) = mkCmd $ \c -> runDelete c delete
  78   where
  79     delete = Delete { dTable     = nodeStoryTable
  80                     , dWhere     = (\row -> node_id row .== sqlInt4 nId)
  81                     , dReturning = rCount }
  82
  83 upsertNodeArchive :: CmdM env err m => NodeId -> ArchiveQ -> m Int64
  84 upsertNodeArchive nId a = do
  85   (NodeStory m) <- getNodeStory nId
  86   case Map.lookup nId m of
  87     Nothing -> insertNodeArchive nId a
  88     Just _  -> updateNodeArchive nId a
  89
  90 writeNodeStories :: CmdM env err m => NodeListStory -> m ()
  91 writeNodeStories (NodeStory nls) = do
  92   _ <- mapM (\(nId, a) -> upsertNodeArchive nId a) $ Map.toList nls
  93   pure ()
  94
  95 -- | Returns a `NodeListStory`, updating the given one for given `NodeId`
  96 nodeStoryInc :: CmdM env err m => Maybe NodeListStory -> NodeId -> m NodeListStory
  97 nodeStoryInc Nothing nId = getNodeStory nId
  98 nodeStoryInc (Just ns@(NodeStory nls)) nId = do
  99   case Map.lookup nId nls of
 100     Nothing -> do
 101       (NodeStory nls') <- getNodeStory nId
 102       pure $ NodeStory $ Map.union nls nls'
 103     Just _ -> pure ns
 104
 105 nodeStoryIncs :: CmdM env err m => Maybe NodeListStory -> [NodeId] -> m NodeListStory
 106 nodeStoryIncs Nothing [] = pure $ NodeStory $ Map.empty
 107 nodeStoryIncs (Just nls) ns = foldM (\m n -> nodeStoryInc (Just m) n) nls ns
 108 nodeStoryIncs Nothing (ni:ns) = do
 109   m <- getNodeStory ni
 110   nodeStoryIncs (Just m) ns
 111
 112 nodeStoryDec :: CmdM env err m => NodeListStory -> NodeId -> m NodeListStory
 113 nodeStoryDec ns@(NodeStory nls) ni = do
 114   case Map.lookup ni nls of
 115     Nothing -> do
 116       _ <- nodeStoryRemove ni
 117       pure ns
 118     Just _ -> do
 119       let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
 120       _ <- nodeStoryRemove ni
 121       pure $ NodeStory ns'
 122
 123 migrateFromDir :: (HasMail env, HasNodeError err, NS.HasNodeStory env err m, HasDBid NodeType)
 124                => m ()
 125 migrateFromDir = do
 126   listIds <- getNodesIdWithType NodeList
 127   (NodeStory nls) <- getRepo listIds
 128   _ <- mapM (\(nId, a) -> do
 129                 n <- nodeExists nId
 130                 case n of
 131                   False -> pure 0
 132                   True  -> upsertNodeArchive nId a
 133             ) $ Map.toList nls
 134   --_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
 135   pure ()
 136
 137 ------------------------------------
 138
 139 data NodeStoryEnv env err m = NodeStoryEnv
 140   { _nse_var    :: !(MVar NodeListStory)
 141   , _nse_saver  :: !(m ())
 142   , _nse_getter :: [NodeId] -> m (MVar NodeListStory)
 143   --, _nse_cleaner :: !(IO ()) -- every 12 hours: cleans the repos of unused NodeStories
 144   -- , _nse_lock  :: !FileLock -- TODO (it depends on the option: if with database or file only)
 145   }
 146   --deriving (Generic)
 147
 148
 149 nodeStoryEnv :: CmdM env err m => m (NodeStoryEnv env err m)
 150 nodeStoryEnv = do
 151   mvar <- nodeStoryVar Nothing []
 152   --saver <- mkNodeStorySaver mvar
 153   let saver = mkNodeStorySaver mvar
 154   -- let saver = modifyMVar_ mvar $ \mv' -> do
 155   --       writeNodeStories mv'
 156   --       return mv'
 157   pure $ NodeStoryEnv { _nse_var    = mvar
 158                       , _nse_saver  = saver
 159                       , _nse_getter = nodeStoryVar (Just mvar) }
 160
 161 nodeStoryVar :: CmdM env err m => Maybe (MVar NodeListStory) -> [NodeId] -> m (MVar NodeListStory)
 162 nodeStoryVar Nothing nIds = do
 163   state <- nodeStoryIncs Nothing nIds
 164   newMVar state
 165 nodeStoryVar (Just mv) nIds = do
 166   _ <- modifyMVar_ mv $ \nsl -> (nodeStoryIncs (Just nsl) nIds)
 167   pure mv
 168
 169 -- TODO No debounce since this is IO stuff.
 170 -- debounce is useful since it could delay the saving to some later
 171 -- time, asynchronously and we keep operating on memory only.
 172 mkNodeStorySaver :: CmdM env err m => MVar NodeListStory -> m ()
 173 mkNodeStorySaver mvns = withMVar mvns writeNodeStories
 174
 175 -- mkNodeStorySaver :: MVar NodeListStory -> Cmd err (Cmd err ())
 176 -- mkNodeStorySaver mvns = mkDebounce settings
 177 --   where
 178 --     settings = defaultDebounceSettings
 179 --                  { debounceAction = withMVar mvns (\ns -> writeNodeStories ns)
 180 --                  , debounceFreq = 1 * minute
 181 -- --                 , debounceEdge = trailingEdge -- Trigger on the trailing edge
 182 --                  }
 183 --     minute = 60 * second
 184 --     second = 10^(6 :: Int)
 185