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