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