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