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 -}
  11
  12 {-# OPTIONS_GHC -fno-warn-orphans #-}
  13 {-# LANGUAGE TemplateHaskell   #-}
  14 {-# LANGUAGE ConstraintKinds   #-}
  15
  16 module Gargantext.Core.NodeStory where
  17
  18 -- import Debug.Trace (traceShow)
  19 import Codec.Serialise (serialise, deserialise)
  20 import Codec.Serialise.Class
  21 import Control.Concurrent (MVar(), withMVar, newMVar, modifyMVar_)
  22 import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
  23 import Control.Lens (makeLenses, Getter, (^.))
  24 import Control.Monad.Except
  25 import Control.Monad.Reader
  26 import Data.Aeson hiding ((.=), decode)
  27 import Data.Map.Strict (Map)
  28 import Data.Maybe (fromMaybe)
  29 import Data.Monoid
  30 import Data.Semigroup
  31 import GHC.Generics (Generic)
  32 import Gargantext.API.Ngrams.Types
  33 import Gargantext.Core.Types (NodeId)
  34 import Gargantext.Core.Utils.Prefix (unPrefix)
  35 import Gargantext.Database.Prelude (CmdM', HasConnectionPool, HasConfig)
  36 import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
  37 import Gargantext.Prelude
  38 import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist)
  39 import System.IO (FilePath, hClose)
  40 import System.IO.Temp (withTempFile)
  41 import qualified Data.ByteString.Lazy                   as DBL
  42 import qualified Data.List                              as List
  43 import qualified Data.Map.Strict                        as Map
  44 import qualified Data.Map.Strict.Patch.Internal         as Patch
  45 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
  46
  47 ------------------------------------------------------------------------
  48 data NodeStoryEnv = NodeStoryEnv
  49   { _nse_var    :: !(MVar NodeListStory)
  50   , _nse_saver  :: !(IO ())
  51   , _nse_getter :: NodeId -> IO (MVar NodeListStory)
  52   --, _nse_cleaner :: !(IO ()) -- every 12 hours: cleans the repos of unused NodeStories
  53   -- , _nse_lock  :: !FileLock -- TODO (it depends on the option: if with database or file only)
  54   }
  55   deriving (Generic)
  56
  57 type HasNodeStory env err m = ( CmdM' env err m
  58                               , MonadReader env m
  59                               , MonadError  err m
  60                               , HasNodeStoryEnv env
  61                               , HasConfig env
  62                               , HasConnectionPool env
  63                               , HasNodeError err
  64                               )
  65
  66 class (HasNodeStoryVar env, HasNodeStorySaver env)
  67   => HasNodeStoryEnv env where
  68     hasNodeStory :: Getter env NodeStoryEnv
  69
  70 class HasNodeStoryVar env where
  71   hasNodeStoryVar :: Getter env (NodeId -> IO (MVar NodeListStory))
  72
  73 class HasNodeStorySaver env where
  74   hasNodeStorySaver :: Getter env (IO ())
  75
  76 ------------------------------------------------------------------------
  77 readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
  78 readNodeStoryEnv nsd = do
  79   mvar  <- nodeStoryVar nsd Nothing 0
  80   saver <- mkNodeStorySaver nsd mvar
  81   pure $ NodeStoryEnv mvar saver (nodeStoryVar nsd (Just mvar))
  82
  83 ------------------------------------------------------------------------
  84 mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
  85 mkNodeStorySaver nsd mvns = mkDebounce settings
  86   where
  87     settings = defaultDebounceSettings
  88                  { debounceAction = withMVar mvns (writeNodeStories nsd)
  89                  , debounceFreq = 1 * minute
  90 --                 , debounceEdge = trailingEdge -- Trigger on the trailing edge
  91                  }
  92     minute = 60 * second
  93     second = 10^(6 :: Int)
  94
  95 nodeStoryVar :: NodeStoryDir
  96              -> Maybe (MVar NodeListStory)
  97              -> NodeId
  98              -> IO (MVar NodeListStory)
  99 nodeStoryVar nsd Nothing ni = nodeStoryInc nsd Nothing ni >>= newMVar
 100 nodeStoryVar nsd (Just mv) ni = do
 101   _ <- modifyMVar_ mv $ \mv' -> (nodeStoryInc nsd (Just mv') ni)
 102   pure mv
 103
 104
 105 nodeStoryInc :: NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
 106 nodeStoryInc nsd (Just ns@(NodeStory nls)) ni = do
 107   case Map.lookup ni nls of
 108     Nothing -> do
 109       (NodeStory nls') <- nodeStoryRead nsd ni
 110       pure $ NodeStory $ Map.union nls nls'
 111     Just _  -> pure ns
 112 nodeStoryInc nsd Nothing ni = nodeStoryRead nsd ni
 113
 114
 115 -- | TODO lock
 116 nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
 117 nodeStoryRead nsd ni = do
 118   _repoDir <- createDirectoryIfMissing True nsd
 119   let nsp = nodeStoryPath nsd ni
 120   exists <- doesFileExist nsp
 121   if exists
 122      then deserialise <$> DBL.readFile nsp
 123      else pure (initNodeStory ni)
 124
 125 nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
 126 nodeStoryRead_test nsd ni = nodeStoryRead nsd ni >>= \n -> pure
 127                           $ fmap Map.keys
 128                           $ fmap _a_state
 129                           $ Map.lookup ni
 130                           $ _unNodeStory n
 131
 132 ------------------------------------------------------------------------
 133 type NodeStoryDir = FilePath
 134
 135 writeNodeStories :: NodeStoryDir -> NodeListStory -> IO ()
 136 writeNodeStories fp nls = do
 137   done <- mapM (writeNodeStory fp) $ splitByNode nls
 138   printDebug "[writeNodeStories]" done
 139   pure ()
 140
 141 writeNodeStory :: NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
 142 writeNodeStory rdfp (n, ns) = saverAction' rdfp n ns
 143
 144 splitByNode :: NodeListStory -> [(NodeId, NodeListStory)]
 145 splitByNode (NodeStory m) =
 146   List.map (\(n,a) -> (n, NodeStory $ Map.singleton n a)) $ Map.toList m
 147
 148
 149 saverAction' :: Serialise a => NodeStoryDir -> NodeId -> a -> IO ()
 150 saverAction' repoDir nId a = do
 151   withTempFile repoDir ((cs $ show nId) <> "-tmp-repo.cbor") $ \fp h -> do
 152     printDebug "[repoSaverAction]" fp
 153     DBL.hPut h $ serialise a
 154     hClose h
 155     renameFile fp (nodeStoryPath repoDir nId)
 156
 157 nodeStoryPath :: NodeStoryDir -> NodeId -> FilePath
 158 nodeStoryPath repoDir nId = repoDir <> "/" <> filename
 159   where
 160     filename = "repo" <> "-" <> (cs $ show nId) <> ".cbor"
 161
 162
 163 ------------------------------------------------------------------------
 164 -- TODO : repo Migration TODO TESTS
 165 repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
 166 repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)
 167
 168 repoToNodeListStory :: NgramsRepo -> NodeListStory
 169 repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
 170   where
 171     s' = ngramsState_migration      s
 172     h' = ngramsStatePatch_migration h
 173     ns = List.map (\(n,ns')
 174                     -> (n, let hs = fromMaybe [] (Map.lookup n h') in
 175                                Archive (List.length hs) ns' hs
 176                        )
 177                   ) $ Map.toList s'
 178
 179 ngramsState_migration :: NgramsState
 180                       -> Map NodeId NgramsState'
 181 ngramsState_migration ns =
 182   Map.fromListWith (Map.union) $
 183   List.concat $
 184     map (\(nt, nTable)
 185           -> map (\(nid, table)
 186                    -> (nid, Map.singleton nt table)
 187                  ) $ Map.toList nTable
 188         ) $ Map.toList ns
 189
 190
 191 ngramsStatePatch_migration :: [NgramsStatePatch]
 192                            -> Map NodeId [NgramsStatePatch']
 193 ngramsStatePatch_migration np' = Map.fromListWith (<>)
 194                                $ List.concat
 195                                $ map toPatch np'
 196   where
 197     toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
 198     toPatch p =
 199       List.concat $
 200         map (\(nt, nTable)
 201               -> map (\(nid, table)
 202                        -> (nid, [fst $ Patch.singleton nt table])
 203                      ) $ Patch.toList nTable
 204             ) $ Patch.toList p
 205
 206 ------------------------------------------------------------------------
 207
 208 {- | Node Story for each NodeType where the Key of the Map is NodeId
 209   TODO : generalize for any NodeType, let's start with NodeList which
 210   is implemented already
 211 -}
 212 data NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
 213   deriving (Generic, Show)
 214
 215 instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
 216 instance (ToJSON s, ToJSON p) => ToJSON (NodeStory s p)
 217 instance (Serialise s, Serialise p) => Serialise (NodeStory s p)
 218
 219 data Archive s p = Archive
 220   { _a_version :: !Version
 221   , _a_state   :: !s
 222   , _a_history :: ![p]
 223     -- first patch in the list is the most recent
 224   }
 225   deriving (Generic, Show)
 226
 227 instance (Serialise s, Serialise p) => Serialise (Archive s p)
 228
 229
 230 type NodeListStory     = NodeStory NgramsState' NgramsStatePatch'
 231
 232 type NgramsState'      = Map       TableNgrams.NgramsType NgramsTableMap
 233 type NgramsStatePatch' = PatchMap  TableNgrams.NgramsType NgramsTablePatch
 234 instance Serialise NgramsStatePatch'
 235
 236 -- TODO Semigroup instance for unions
 237 -- TODO check this
 238 instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
 239   (<>) (Archive _v _s p) (Archive v' s' p') = Archive v' s' (p' <> p)
 240
 241 instance Monoid (Archive NgramsState' NgramsStatePatch') where
 242   mempty = Archive 0 mempty []
 243
 244 instance (FromJSON s, FromJSON p) => FromJSON (Archive s p) where
 245   parseJSON = genericParseJSON $ unPrefix "_a_"
 246
 247 instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
 248   toJSON     = genericToJSON     $ unPrefix "_a_"
 249   toEncoding = genericToEncoding $ unPrefix "_a_"
 250
 251 ------------------------------------------------------------------------
 252 initNodeStory :: Monoid s => NodeId -> NodeStory s p
 253 initNodeStory ni = NodeStory $ Map.singleton ni initArchive
 254
 255 initArchive :: Monoid s => Archive s p
 256 initArchive = Archive 0 mempty []
 257
 258 initNodeListStoryMock :: NodeListStory
 259 initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
 260   where
 261     nodeListId = 0
 262     archive        = Archive 0 ngramsTableMap []
 263     ngramsTableMap = Map.singleton TableNgrams.NgramsTerms
 264                    $ Map.fromList
 265                    [ (n ^. ne_ngrams, ngramsElementToRepo n)
 266                    | n <- mockTable ^. _NgramsTable
 267                    ]
 268
 269 ------------------------------------------------------------------------
 270
 271
 272 ------------------------------------------------------------------------
 273 -- | Lenses at the bottom of the file because Template Haskell would reorder order of execution in others cases
 274 makeLenses ''NodeStoryEnv
 275 makeLenses ''NodeStory
 276 makeLenses ''Archive