src/Gargantext/Core/NodeStory.hs

   1 {-|
   2 Module      : Gargantext.Core.NodeStory
   3 Description : Node API generation
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 A Node Story is a Map between NodeId and an Archive (with state,
  11 version and history) for that node.
  12
  13 TODO:
  14 - remove
  15 - filter
  16 - charger les listes
  17 -}
  18
  19 {-# OPTIONS_GHC -fno-warn-orphans #-}
  20 {-# LANGUAGE Arrows #-}
  21 {-# LANGUAGE ConstraintKinds   #-}
  22 {-# LANGUAGE QuasiQuotes #-}
  23 {-# LANGUAGE TemplateHaskell   #-}
  24
  25 module Gargantext.Core.NodeStory
  26   ( HasNodeStory
  27   , HasNodeStoryEnv
  28   , hasNodeStory
  29   , HasNodeStoryVar
  30   , hasNodeStoryVar
  31   , HasNodeStorySaver
  32   , hasNodeStorySaver
  33   , NodeStory(..)
  34   , NgramsStatePatch'
  35   , NodeListStory
  36   , initNodeListStoryMock
  37   , NodeStoryEnv(..)
  38   , initNodeStory
  39   , nse_getter
  40   , nse_saver
  41   , nse_var
  42   , unNodeStory
  43   , Archive(..)
  44   , initArchive
  45   , a_history
  46   , a_state
  47   , a_version
  48   , nodeExists
  49   , getNodesIdWithType
  50   , readNodeStoryEnv
  51   , upsertNodeArchive
  52   , getNodeStory )
  53 where
  54
  55 -- import Debug.Trace (traceShow)
  56 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
  57 import Codec.Serialise.Class
  58 import Control.Arrow (returnA)
  59 import Control.Concurrent (MVar(), withMVar, newMVar, modifyMVar_)
  60 import Control.Exception (catch, throw, SomeException(..))
  61 import Control.Lens (makeLenses, Getter, (^.))
  62 import Control.Monad.Except
  63 import Control.Monad.Reader
  64 import Data.Aeson hiding ((.=), decode)
  65 import Data.ByteString.Char8 (hPutStrLn)
  66 import Data.Map.Strict (Map)
  67 import Data.Monoid
  68 import Data.Pool (Pool, withResource)
  69 import Data.Semigroup
  70 import qualified Database.PostgreSQL.Simple as PGS
  71 import Database.PostgreSQL.Simple.SqlQQ (sql)
  72 import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
  73 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  74 import GHC.Generics (Generic)
  75 import Gargantext.API.Ngrams.Types
  76 import Gargantext.Core.Types (NodeId(..), NodeType)
  77 import Gargantext.Core.Utils.Prefix (unPrefix)
  78 import Gargantext.Database.Admin.Config (nodeTypeId)
  79 import Gargantext.Database.Prelude (CmdM', HasConnectionPool, HasConfig)
  80 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
  81 import Gargantext.Prelude
  82 import Opaleye (Column, DefaultFromField(..), Insert(..), Select, SqlInt4, SqlJsonb, Table, Update(..), (.==), fromPGSFromField, rCount, restrict, runInsert, runSelect, runUpdate, selectTable, sqlInt4, sqlValueJSONB, tableField, updateEasy)
  83 import Opaleye.Internal.Table (Table(..))
  84 import System.IO (stderr)
  85 import qualified Data.Map.Strict                        as Map
  86 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
  87
  88 ------------------------------------------------------------------------
  89 data NodeStoryEnv = NodeStoryEnv
  90   { _nse_var    :: !(MVar NodeListStory)
  91   , _nse_saver  :: !(IO ())
  92   , _nse_getter :: [NodeId] -> IO (MVar NodeListStory)
  93   --, _nse_cleaner :: !(IO ()) -- every 12 hours: cleans the repos of unused NodeStories
  94   -- , _nse_lock  :: !FileLock -- TODO (it depends on the option: if with database or file only)
  95   }
  96   deriving (Generic)
  97
  98 type HasNodeStory env err m = ( CmdM' env err m
  99                               , MonadReader env m
 100                               , MonadError  err m
 101                               , HasNodeStoryEnv env
 102                               , HasConfig env
 103                               , HasConnectionPool env
 104                               , HasNodeError err
 105                               )
 106
 107 class (HasNodeStoryVar env, HasNodeStorySaver env)
 108   => HasNodeStoryEnv env where
 109     hasNodeStory :: Getter env NodeStoryEnv
 110
 111 class HasNodeStoryVar env where
 112   hasNodeStoryVar :: Getter env ([NodeId] -> IO (MVar NodeListStory))
 113
 114 class HasNodeStorySaver env where
 115   hasNodeStorySaver :: Getter env (IO ())
 116
 117 ------------------------------------------------------------------------
 118
 119 {- | Node Story for each NodeType where the Key of the Map is NodeId
 120   TODO : generalize for any NodeType, let's start with NodeList which
 121   is implemented already
 122 -}
 123 data NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
 124   deriving (Generic, Show)
 125
 126 instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
 127 instance (ToJSON s, ToJSON p) => ToJSON (NodeStory s p)
 128 instance (Serialise s, Serialise p) => Serialise (NodeStory s p)
 129
 130 data Archive s p = Archive
 131   { _a_version :: !Version
 132   , _a_state   :: !s
 133   , _a_history :: ![p]
 134     -- first patch in the list is the most recent
 135   }
 136   deriving (Generic, Show)
 137
 138 instance (Serialise s, Serialise p) => Serialise (Archive s p)
 139
 140
 141 type NodeListStory     = NodeStory NgramsState' NgramsStatePatch'
 142
 143 type NgramsState'      = Map       TableNgrams.NgramsType NgramsTableMap
 144 type NgramsStatePatch' = PatchMap  TableNgrams.NgramsType NgramsTablePatch
 145 instance Serialise NgramsStatePatch'
 146 instance FromField (Archive NgramsState' NgramsStatePatch')
 147   where
 148     fromField = fromJSONField
 149 instance DefaultFromField SqlJsonb (Archive NgramsState' NgramsStatePatch')
 150   where
 151     defaultFromField = fromPGSFromField
 152
 153 -- TODO Semigroup instance for unions
 154 -- TODO check this
 155 instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
 156   (<>) (Archive { _a_history = p }) (Archive { _a_version = v'
 157                                              , _a_state = s'
 158                                              , _a_history = p'}) =
 159     Archive { _a_version = v'
 160             , _a_state = s'
 161             , _a_history = p' <> p }
 162
 163 instance Monoid (Archive NgramsState' NgramsStatePatch') where
 164   mempty = Archive { _a_version = 0
 165                    , _a_state = mempty
 166                    , _a_history = [] }
 167
 168 instance (FromJSON s, FromJSON p) => FromJSON (Archive s p) where
 169   parseJSON = genericParseJSON $ unPrefix "_a_"
 170
 171 instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
 172   toJSON     = genericToJSON     $ unPrefix "_a_"
 173   toEncoding = genericToEncoding $ unPrefix "_a_"
 174
 175 ------------------------------------------------------------------------
 176 initNodeStory :: Monoid s => NodeId -> NodeStory s p
 177 initNodeStory ni = NodeStory $ Map.singleton ni initArchive
 178
 179 initArchive :: Monoid s => Archive s p
 180 initArchive = Archive { _a_version = 0
 181                       , _a_state = mempty
 182                       , _a_history = [] }
 183
 184 initNodeListStoryMock :: NodeListStory
 185 initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
 186   where
 187     nodeListId = 0
 188     archive        = Archive { _a_version = 0
 189                              , _a_state = ngramsTableMap
 190                              , _a_history = [] }
 191     ngramsTableMap = Map.singleton TableNgrams.NgramsTerms
 192                    $ Map.fromList
 193                    [ (n ^. ne_ngrams, ngramsElementToRepo n)
 194                    | n <- mockTable ^. _NgramsTable
 195                    ]
 196
 197 ------------------------------------------------------------------------
 198
 199
 200 ------------------------------------------------------------------------
 201 -- | Lenses at the bottom of the file because Template Haskell would reorder order of execution in others cases
 202 makeLenses ''NodeStoryEnv
 203 makeLenses ''NodeStory
 204 makeLenses ''Archive
 205
 206 -----------------------------------------
 207
 208
 209 data NodeStoryPoly a b = NodeStoryDB { node_id :: a
 210                                      , archive :: b }
 211   deriving (Eq)
 212
 213 type ArchiveQ = Archive NgramsState' NgramsStatePatch'
 214
 215 type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
 216 type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlJsonb)
 217
 218 $(makeAdaptorAndInstance "pNodeStory" ''NodeStoryPoly)
 219
 220
 221 runPGSQuery :: (PGS.FromRow r, PGS.ToRow q) => Pool PGS.Connection -> PGS.Query -> q -> IO [r]
 222 runPGSQuery pool q a = withResource pool $ \c -> catch (PGS.query c q a) (printError c)
 223   where
 224     printError c (SomeException e) = do
 225       q' <- PGS.formatQuery c q a
 226       hPutStrLn stderr q'
 227       throw (SomeException e)
 228
 229
 230 nodeExists :: Pool PGS.Connection -> NodeId -> IO Bool
 231 nodeExists pool nId = (== [PGS.Only True])
 232   <$> runPGSQuery pool [sql|SELECT true FROM nodes WHERE id = ? AND ? |] (nId, True)
 233
 234 getNodesIdWithType :: Pool PGS.Connection -> NodeType -> IO [NodeId]
 235 getNodesIdWithType pool nt = do
 236   --ns <- withResource pool $ \c -> runSelect c $ selectNodesIdWithType nt
 237   ns <- runPGSQuery pool query (nodeTypeId nt, True)
 238   pure $ map (\(PGS.Only nId) -> NodeId nId) ns
 239   --pure (map NodeId ns)
 240   where
 241     query :: PGS.Query
 242     query = [sql|SELECT id FROM nodes WHERE typename = ? AND ? |]
 243
 244
 245
 246 nodeStoryTable :: Table NodeStoryRead NodeStoryWrite
 247 nodeStoryTable =
 248   Table "node_stories"
 249     ( pNodeStory NodeStoryDB { node_id = tableField "node_id"
 250                              , archive = tableField "archive" } )
 251
 252 nodeStorySelect :: Select NodeStoryRead
 253 nodeStorySelect = selectTable nodeStoryTable
 254
 255 getNodeStory :: Pool PGS.Connection -> NodeId -> IO NodeListStory
 256 getNodeStory pool (NodeId nodeId) = do
 257   res <- withResource pool $ \c -> runSelect c query
 258   pure $ NodeStory $ Map.fromListWith (<>) $ (\(NodeStoryDB nId a) -> (nId, a)) <$> res
 259   where
 260     query :: Select NodeStoryRead
 261     query = proc () -> do
 262       row@(NodeStoryDB node_id _) <- nodeStorySelect -< ()
 263       restrict -< node_id .== sqlInt4 nodeId
 264       returnA -< row
 265
 266 insertNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
 267 insertNodeArchive pool (NodeId nId) a = withResource pool $ \c -> runInsert c insert
 268   where
 269     insert = Insert { iTable      = nodeStoryTable
 270                     , iRows       = [NodeStoryDB { node_id = sqlInt4 nId
 271                                                  , archive = sqlValueJSONB a }]
 272                     , iReturning  = rCount
 273                     , iOnConflict = Nothing }
 274
 275 updateNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
 276 updateNodeArchive pool (NodeId nId) a = withResource pool $ \c -> runUpdate c update
 277   where
 278     update = Update { uTable      = nodeStoryTable
 279                     , uUpdateWith = updateEasy (\(NodeStoryDB { .. }) -> NodeStoryDB { archive = sqlValueJSONB a, .. })
 280                     , uWhere      = (\row -> node_id row .== sqlInt4 nId)
 281                     , uReturning  = rCount }
 282
 283 -- nodeStoryRemove :: Pool PGS.Connection -> NodeId -> IO Int64
 284 -- nodeStoryRemove pool (NodeId nId) = withResource pool $ \c -> runDelete c delete
 285 --   where
 286 --     delete = Delete { dTable     = nodeStoryTable
 287 --                     , dWhere     = (\row -> node_id row .== sqlInt4 nId)
 288 --                     , dReturning = rCount }
 289
 290 upsertNodeArchive :: Pool PGS.Connection -> NodeId -> ArchiveQ -> IO Int64
 291 upsertNodeArchive pool nId a = do
 292   (NodeStory m) <- getNodeStory pool nId
 293   case Map.lookup nId m of
 294     Nothing -> insertNodeArchive pool nId a
 295     Just _  -> updateNodeArchive pool nId a
 296
 297 writeNodeStories :: Pool PGS.Connection -> NodeListStory -> IO ()
 298 writeNodeStories pool (NodeStory nls) = do
 299   _ <- mapM (\(nId, a) -> upsertNodeArchive pool nId a) $ Map.toList nls
 300   pure ()
 301
 302 -- | Returns a `NodeListStory`, updating the given one for given `NodeId`
 303 nodeStoryInc :: Pool PGS.Connection -> Maybe NodeListStory -> NodeId -> IO NodeListStory
 304 nodeStoryInc pool Nothing nId = getNodeStory pool nId
 305 nodeStoryInc pool (Just ns@(NodeStory nls)) nId = do
 306   case Map.lookup nId nls of
 307     Nothing -> do
 308       (NodeStory nls') <- getNodeStory pool nId
 309       pure $ NodeStory $ Map.union nls nls'
 310     Just _ -> pure ns
 311
 312 nodeStoryIncs :: Pool PGS.Connection -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
 313 nodeStoryIncs _ Nothing [] = pure $ NodeStory $ Map.empty
 314 nodeStoryIncs pool (Just nls) ns = foldM (\m n -> nodeStoryInc pool (Just m) n) nls ns
 315 nodeStoryIncs pool Nothing (ni:ns) = do
 316   m <- getNodeStory pool ni
 317   nodeStoryIncs pool (Just m) ns
 318
 319 -- nodeStoryDec :: Pool PGS.Connection -> NodeListStory -> NodeId -> IO NodeListStory
 320 -- nodeStoryDec pool ns@(NodeStory nls) ni = do
 321 --   case Map.lookup ni nls of
 322 --     Nothing -> do
 323 --       _ <- nodeStoryRemove pool ni
 324 --       pure ns
 325 --     Just _ -> do
 326 --       let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
 327 --       _ <- nodeStoryRemove pool ni
 328 --       pure $ NodeStory ns'
 329 ------------------------------------
 330
 331 readNodeStoryEnv :: Pool PGS.Connection -> IO NodeStoryEnv
 332 readNodeStoryEnv pool = do
 333   mvar <- nodeStoryVar pool Nothing []
 334   saver <- mkNodeStorySaver pool mvar
 335   -- let saver = modifyMVar_ mvar $ \mv' -> do
 336   --       writeNodeStories mv'
 337   --       return mv'
 338   pure $ NodeStoryEnv { _nse_var    = mvar
 339                       , _nse_saver  = saver
 340                       , _nse_getter = nodeStoryVar pool (Just mvar) }
 341
 342 nodeStoryVar :: Pool PGS.Connection -> Maybe (MVar NodeListStory) -> [NodeId] -> IO (MVar NodeListStory)
 343 nodeStoryVar pool Nothing nIds = do
 344   state <- nodeStoryIncs pool Nothing nIds
 345   newMVar state
 346 nodeStoryVar pool (Just mv) nIds = do
 347   _ <- modifyMVar_ mv $ \nsl -> (nodeStoryIncs pool (Just nsl) nIds)
 348   pure mv
 349
 350 -- TODO No debounce since this is IO stuff.
 351 -- debounce is useful since it could delay the saving to some later
 352 -- time, asynchronously and we keep operating on memory only.
 353 mkNodeStorySaver :: Pool PGS.Connection -> MVar NodeListStory -> IO (IO ())
 354 mkNodeStorySaver pool mvns = mkDebounce settings
 355   where
 356     settings = defaultDebounceSettings
 357                  { debounceAction = withMVar mvns (\ns -> writeNodeStories pool ns)
 358                  , debounceFreq = 1*minute
 359                  }
 360     minute = 60*second
 361     second = 10^(6 :: Int)
 362 --mkNodeStorySaver pool mvns = withMVar mvns $ writeNodeStories pool
 363
 364 -- mkNodeStorySaver :: MVar NodeListStory -> Cmd err (Cmd err ())
 365 -- mkNodeStorySaver mvns = mkDebounce settings
 366 --   where
 367 --     settings = defaultDebounceSettings
 368 --                  { debounceAction = withMVar mvns (\ns -> writeNodeStories ns)
 369 --                  , debounceFreq = 1 * minute
 370 -- --                 , debounceEdge = trailingEdge -- Trigger on the trailing edge
 371 --                  }
 372 --     minute = 60 * second
 373 --     second = 10^(6 :: Int)
 374
 375
 376 -----------------------------------------