{-|
Module      : Gargantext.Core.NodeStory
Description : Node API generation
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

A Node Story is a Map between NodeId and an Archive (with state,
version and history) for that node.

TODO:
- remove
- filter
- charger les listes
-}

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE ConstraintKinds   #-}

module Gargantext.Core.NodeStory where

-- import Debug.Trace (traceShow)
import Codec.Serialise (serialise, deserialise)
import Codec.Serialise.Class 
import Control.Concurrent (MVar(), withMVar, newMVar, modifyMVar_)
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Control.Lens (makeLenses, Getter, (^.))
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson hiding ((.=), decode)
import Data.Map.Strict (Map)
import Data.Monoid
import Data.Semigroup
import GHC.Generics (Generic)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (NodeId)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Prelude (CmdM', HasConnectionPool, HasConfig)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Prelude
import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist, removeFile)
import System.IO (FilePath, hClose)
import System.IO.Temp (withTempFile)
import qualified Data.ByteString.Lazy                   as DBL
import qualified Data.List                              as List
import qualified Data.Map.Strict                        as Map
import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams

------------------------------------------------------------------------
data NodeStoryEnv = NodeStoryEnv
  { NodeStoryEnv -> MVar NodeListStory
_nse_var    :: !(MVar NodeListStory)
  , NodeStoryEnv -> IO ()
_nse_saver  :: !(IO ())
  , NodeStoryEnv -> [NodeId] -> IO (MVar NodeListStory)
_nse_getter :: [NodeId] -> IO (MVar NodeListStory)
  --, _nse_cleaner :: !(IO ()) -- every 12 hours: cleans the repos of unused NodeStories
  -- , _nse_lock  :: !FileLock -- TODO (it depends on the option: if with database or file only)
  }
  deriving ((forall x. NodeStoryEnv -> Rep NodeStoryEnv x)
-> (forall x. Rep NodeStoryEnv x -> NodeStoryEnv)
-> Generic NodeStoryEnv
forall x. Rep NodeStoryEnv x -> NodeStoryEnv
forall x. NodeStoryEnv -> Rep NodeStoryEnv x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NodeStoryEnv x -> NodeStoryEnv
$cfrom :: forall x. NodeStoryEnv -> Rep NodeStoryEnv x
Generic)

type HasNodeStory env err m = ( CmdM' env err m
                              , MonadReader env m
                              , MonadError  err m
                              , HasNodeStoryEnv env
                              , HasConfig env
                              , HasConnectionPool env
                              , HasNodeError err
                              )

class (HasNodeStoryVar env, HasNodeStorySaver env)
  => HasNodeStoryEnv env where
    hasNodeStory :: Getter env NodeStoryEnv

class HasNodeStoryVar env where
  hasNodeStoryVar :: Getter env ([NodeId] -> IO (MVar NodeListStory))

class HasNodeStorySaver env where
  hasNodeStorySaver :: Getter env (IO ())

------------------------------------------------------------------------
readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
readNodeStoryEnv :: NodeStoryDir -> IO NodeStoryEnv
readNodeStoryEnv NodeStoryDir
nsd = do
  MVar NodeListStory
mvar  <- NodeStoryDir
-> Maybe (MVar NodeListStory)
-> [NodeId]
-> IO (MVar NodeListStory)
nodeStoryVar NodeStoryDir
nsd Maybe (MVar NodeListStory)
forall a. Maybe a
Nothing [NodeId
0]
  IO ()
saver <- NodeStoryDir -> MVar NodeListStory -> IO (IO ())
mkNodeStorySaver NodeStoryDir
nsd MVar NodeListStory
mvar
  NodeStoryEnv -> IO NodeStoryEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeStoryEnv -> IO NodeStoryEnv)
-> NodeStoryEnv -> IO NodeStoryEnv
forall a b. (a -> b) -> a -> b
$ NodeStoryEnv :: MVar NodeListStory
-> IO () -> ([NodeId] -> IO (MVar NodeListStory)) -> NodeStoryEnv
NodeStoryEnv { _nse_var :: MVar NodeListStory
_nse_var = MVar NodeListStory
mvar
                      , _nse_saver :: IO ()
_nse_saver = IO ()
saver
                      , _nse_getter :: [NodeId] -> IO (MVar NodeListStory)
_nse_getter = NodeStoryDir
-> Maybe (MVar NodeListStory)
-> [NodeId]
-> IO (MVar NodeListStory)
nodeStoryVar NodeStoryDir
nsd (MVar NodeListStory -> Maybe (MVar NodeListStory)
forall a. a -> Maybe a
Just MVar NodeListStory
mvar) }

------------------------------------------------------------------------
mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
mkNodeStorySaver :: NodeStoryDir -> MVar NodeListStory -> IO (IO ())
mkNodeStorySaver NodeStoryDir
nsd MVar NodeListStory
mvns = DebounceSettings -> IO (IO ())
mkDebounce DebounceSettings
settings
  where
    settings :: DebounceSettings
settings = DebounceSettings
defaultDebounceSettings
                 { debounceAction :: IO ()
debounceAction = MVar NodeListStory -> (NodeListStory -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar NodeListStory
mvns (NodeStoryDir -> NodeListStory -> IO ()
writeNodeStories NodeStoryDir
nsd)
                 , debounceFreq :: Int
debounceFreq = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
minute
--                 , debounceEdge = trailingEdge -- Trigger on the trailing edge
                 }
    minute :: Int
minute = Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
second
    second :: Int
second = Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6 :: Int)

nodeStoryVar :: NodeStoryDir
             -> Maybe (MVar NodeListStory)
             -> [NodeId]
             -> IO (MVar NodeListStory)
nodeStoryVar :: NodeStoryDir
-> Maybe (MVar NodeListStory)
-> [NodeId]
-> IO (MVar NodeListStory)
nodeStoryVar NodeStoryDir
nsd Maybe (MVar NodeListStory)
Nothing [NodeId]
ni = NodeStoryDir -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
nodeStoryIncs NodeStoryDir
nsd Maybe NodeListStory
forall a. Maybe a
Nothing [NodeId]
ni IO NodeListStory
-> (NodeListStory -> IO (MVar NodeListStory))
-> IO (MVar NodeListStory)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeListStory -> IO (MVar NodeListStory)
forall a. a -> IO (MVar a)
newMVar
nodeStoryVar NodeStoryDir
nsd (Just MVar NodeListStory
mv) [NodeId]
ni = do
  ()
_ <- MVar NodeListStory -> (NodeListStory -> IO NodeListStory) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar NodeListStory
mv ((NodeListStory -> IO NodeListStory) -> IO ())
-> (NodeListStory -> IO NodeListStory) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NodeListStory
mv' -> (NodeStoryDir -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
nodeStoryIncs NodeStoryDir
nsd (NodeListStory -> Maybe NodeListStory
forall a. a -> Maybe a
Just NodeListStory
mv') [NodeId]
ni)
  MVar NodeListStory -> IO (MVar NodeListStory)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVar NodeListStory
mv


nodeStoryInc :: NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
nodeStoryInc :: NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
nodeStoryInc NodeStoryDir
nsd (Just ns :: NodeListStory
ns@(NodeStory Map NodeId (Archive NgramsState' NgramsStatePatch')
nls)) NodeId
ni = do
  case NodeId
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
-> Maybe (Archive NgramsState' NgramsStatePatch')
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeId
ni Map NodeId (Archive NgramsState' NgramsStatePatch')
nls of
    Maybe (Archive NgramsState' NgramsStatePatch')
Nothing -> do
      (NodeStory Map NodeId (Archive NgramsState' NgramsStatePatch')
nls') <- NodeStoryDir -> NodeId -> IO NodeListStory
nodeStoryRead NodeStoryDir
nsd NodeId
ni
      NodeListStory -> IO NodeListStory
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeListStory -> IO NodeListStory)
-> NodeListStory -> IO NodeListStory
forall a b. (a -> b) -> a -> b
$ Map NodeId (Archive NgramsState' NgramsStatePatch')
-> NodeListStory
forall s p. Map NodeId (Archive s p) -> NodeStory s p
NodeStory (Map NodeId (Archive NgramsState' NgramsStatePatch')
 -> NodeListStory)
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
-> NodeListStory
forall a b. (a -> b) -> a -> b
$ Map NodeId (Archive NgramsState' NgramsStatePatch')
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map NodeId (Archive NgramsState' NgramsStatePatch')
nls Map NodeId (Archive NgramsState' NgramsStatePatch')
nls'
    Just Archive NgramsState' NgramsStatePatch'
_  -> NodeListStory -> IO NodeListStory
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeListStory
ns
nodeStoryInc NodeStoryDir
nsd Maybe NodeListStory
Nothing NodeId
ni = NodeStoryDir -> NodeId -> IO NodeListStory
nodeStoryRead NodeStoryDir
nsd NodeId
ni


nodeStoryIncs :: NodeStoryDir
              -> Maybe NodeListStory
              -> [NodeId]
              -> IO NodeListStory
nodeStoryIncs :: NodeStoryDir -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
nodeStoryIncs NodeStoryDir
_ Maybe NodeListStory
Nothing    []        = Text -> IO NodeListStory
forall a. HasCallStack => Text -> a
panic Text
"nodeStoryIncs: Empty"
nodeStoryIncs NodeStoryDir
nsd (Just NodeListStory
nls) [NodeId]
ns      = (NodeListStory -> NodeId -> IO NodeListStory)
-> NodeListStory -> [NodeId] -> IO NodeListStory
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\NodeListStory
m NodeId
n -> NodeStoryDir -> Maybe NodeListStory -> NodeId -> IO NodeListStory
nodeStoryInc NodeStoryDir
nsd (NodeListStory -> Maybe NodeListStory
forall a. a -> Maybe a
Just NodeListStory
m) NodeId
n) NodeListStory
nls [NodeId]
ns
nodeStoryIncs NodeStoryDir
nsd Maybe NodeListStory
Nothing    (NodeId
ni:[NodeId]
ns) = do
  NodeListStory
m <- NodeStoryDir -> NodeId -> IO NodeListStory
nodeStoryRead NodeStoryDir
nsd NodeId
ni
  NodeStoryDir -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
nodeStoryIncs NodeStoryDir
nsd (NodeListStory -> Maybe NodeListStory
forall a. a -> Maybe a
Just NodeListStory
m) [NodeId]
ns


nodeStoryDec :: NodeStoryDir
             -> NodeListStory
             -> NodeId
             -> IO NodeListStory
nodeStoryDec :: NodeStoryDir -> NodeListStory -> NodeId -> IO NodeListStory
nodeStoryDec NodeStoryDir
nsd ns :: NodeListStory
ns@(NodeStory Map NodeId (Archive NgramsState' NgramsStatePatch')
nls) NodeId
ni = do
  case NodeId
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
-> Maybe (Archive NgramsState' NgramsStatePatch')
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeId
ni Map NodeId (Archive NgramsState' NgramsStatePatch')
nls of
    Maybe (Archive NgramsState' NgramsStatePatch')
Nothing -> do
      -- we make sure the corresponding file repo is really removed
      ()
_ <- NodeStoryDir -> NodeId -> IO ()
nodeStoryRemove NodeStoryDir
nsd NodeId
ni
      NodeListStory -> IO NodeListStory
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeListStory
ns
    Just Archive NgramsState' NgramsStatePatch'
_  -> do
      let ns' :: Map NodeId (Archive NgramsState' NgramsStatePatch')
ns' = (NodeId -> Archive NgramsState' NgramsStatePatch' -> Bool)
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\NodeId
k Archive NgramsState' NgramsStatePatch'
_v -> NodeId
k NodeId -> NodeId -> Bool
forall a. Eq a => a -> a -> Bool
/= NodeId
ni) Map NodeId (Archive NgramsState' NgramsStatePatch')
nls
      ()
_ <- NodeStoryDir -> NodeId -> IO ()
nodeStoryRemove NodeStoryDir
nsd NodeId
ni
      NodeListStory -> IO NodeListStory
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeListStory -> IO NodeListStory)
-> NodeListStory -> IO NodeListStory
forall a b. (a -> b) -> a -> b
$ Map NodeId (Archive NgramsState' NgramsStatePatch')
-> NodeListStory
forall s p. Map NodeId (Archive s p) -> NodeStory s p
NodeStory Map NodeId (Archive NgramsState' NgramsStatePatch')
ns'

-- | TODO lock
nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
nodeStoryRead :: NodeStoryDir -> NodeId -> IO NodeListStory
nodeStoryRead NodeStoryDir
nsd NodeId
ni = do
  ()
_repoDir <- Bool -> NodeStoryDir -> IO ()
createDirectoryIfMissing Bool
True NodeStoryDir
nsd
  let nsp :: NodeStoryDir
nsp = NodeStoryDir -> NodeId -> NodeStoryDir
nodeStoryPath NodeStoryDir
nsd NodeId
ni
  Bool
exists <- NodeStoryDir -> IO Bool
doesFileExist NodeStoryDir
nsp
  if Bool
exists
     then ByteString -> NodeListStory
forall a. Serialise a => ByteString -> a
deserialise (ByteString -> NodeListStory) -> IO ByteString -> IO NodeListStory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeStoryDir -> IO ByteString
DBL.readFile NodeStoryDir
nsp
     else NodeListStory -> IO NodeListStory
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeId -> NodeListStory
forall s p. Monoid s => NodeId -> NodeStory s p
initNodeStory NodeId
ni)

nodeStoryRemove :: NodeStoryDir -> NodeId -> IO ()
nodeStoryRemove :: NodeStoryDir -> NodeId -> IO ()
nodeStoryRemove NodeStoryDir
nsd NodeId
ni = do
  let nsp :: NodeStoryDir
nsp = NodeStoryDir -> NodeId -> NodeStoryDir
nodeStoryPath NodeStoryDir
nsd NodeId
ni
  Bool
exists <- NodeStoryDir -> IO Bool
doesFileExist NodeStoryDir
nsp
  if Bool
exists
     then NodeStoryDir -> IO ()
removeFile NodeStoryDir
nsp
     else () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()



nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [ TableNgrams.NgramsType ])
nodeStoryRead_test :: NodeStoryDir -> NodeId -> IO (Maybe [NgramsType])
nodeStoryRead_test NodeStoryDir
nsd NodeId
ni = NodeStoryDir -> NodeId -> IO NodeListStory
nodeStoryRead NodeStoryDir
nsd NodeId
ni IO NodeListStory
-> (NodeListStory -> IO (Maybe [NgramsType]))
-> IO (Maybe [NgramsType])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \NodeListStory
n -> Maybe [NgramsType] -> IO (Maybe [NgramsType])
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                          (Maybe [NgramsType] -> IO (Maybe [NgramsType]))
-> Maybe [NgramsType] -> IO (Maybe [NgramsType])
forall a b. (a -> b) -> a -> b
$ (NgramsState' -> [NgramsType])
-> Maybe NgramsState' -> Maybe [NgramsType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NgramsState' -> [NgramsType]
forall k a. Map k a -> [k]
Map.keys
                          (Maybe NgramsState' -> Maybe [NgramsType])
-> Maybe NgramsState' -> Maybe [NgramsType]
forall a b. (a -> b) -> a -> b
$ (Archive NgramsState' NgramsStatePatch' -> NgramsState')
-> Maybe (Archive NgramsState' NgramsStatePatch')
-> Maybe NgramsState'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Archive NgramsState' NgramsStatePatch' -> NgramsState'
forall s p. Archive s p -> s
_a_state
                          (Maybe (Archive NgramsState' NgramsStatePatch')
 -> Maybe NgramsState')
-> Maybe (Archive NgramsState' NgramsStatePatch')
-> Maybe NgramsState'
forall a b. (a -> b) -> a -> b
$ NodeId
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
-> Maybe (Archive NgramsState' NgramsStatePatch')
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeId
ni
                          (Map NodeId (Archive NgramsState' NgramsStatePatch')
 -> Maybe (Archive NgramsState' NgramsStatePatch'))
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
-> Maybe (Archive NgramsState' NgramsStatePatch')
forall a b. (a -> b) -> a -> b
$ NodeListStory
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
forall s p. NodeStory s p -> Map NodeId (Archive s p)
_unNodeStory NodeListStory
n

------------------------------------------------------------------------
type NodeStoryDir = FilePath

writeNodeStories :: NodeStoryDir -> NodeListStory -> IO ()
writeNodeStories :: NodeStoryDir -> NodeListStory -> IO ()
writeNodeStories NodeStoryDir
fp NodeListStory
nls = do
  [()]
done <- ((NodeId, NodeListStory) -> IO ())
-> [(NodeId, NodeListStory)] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
writeNodeStory NodeStoryDir
fp) ([(NodeId, NodeListStory)] -> IO [()])
-> [(NodeId, NodeListStory)] -> IO [()]
forall a b. (a -> b) -> a -> b
$ NodeListStory -> [(NodeId, NodeListStory)]
splitByNode NodeListStory
nls
  NodeStoryDir -> [()] -> IO ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
NodeStoryDir -> a -> m ()
printDebug NodeStoryDir
"[writeNodeStories]" [()]
done
  () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

writeNodeStory :: NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
writeNodeStory :: NodeStoryDir -> (NodeId, NodeListStory) -> IO ()
writeNodeStory NodeStoryDir
rdfp (NodeId
n, NodeListStory
ns) = NodeStoryDir -> NodeId -> NodeListStory -> IO ()
forall a. Serialise a => NodeStoryDir -> NodeId -> a -> IO ()
saverAction' NodeStoryDir
rdfp NodeId
n NodeListStory
ns

splitByNode :: NodeListStory -> [(NodeId, NodeListStory)]
splitByNode :: NodeListStory -> [(NodeId, NodeListStory)]
splitByNode (NodeStory Map NodeId (Archive NgramsState' NgramsStatePatch')
m) =
  ((NodeId, Archive NgramsState' NgramsStatePatch')
 -> (NodeId, NodeListStory))
-> [(NodeId, Archive NgramsState' NgramsStatePatch')]
-> [(NodeId, NodeListStory)]
forall a b. (a -> b) -> [a] -> [b]
List.map (\(NodeId
n,Archive NgramsState' NgramsStatePatch'
a) -> (NodeId
n, Map NodeId (Archive NgramsState' NgramsStatePatch')
-> NodeListStory
forall s p. Map NodeId (Archive s p) -> NodeStory s p
NodeStory (Map NodeId (Archive NgramsState' NgramsStatePatch')
 -> NodeListStory)
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
-> NodeListStory
forall a b. (a -> b) -> a -> b
$ NodeId
-> Archive NgramsState' NgramsStatePatch'
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
forall k a. k -> a -> Map k a
Map.singleton NodeId
n Archive NgramsState' NgramsStatePatch'
a)) ([(NodeId, Archive NgramsState' NgramsStatePatch')]
 -> [(NodeId, NodeListStory)])
-> [(NodeId, Archive NgramsState' NgramsStatePatch')]
-> [(NodeId, NodeListStory)]
forall a b. (a -> b) -> a -> b
$ Map NodeId (Archive NgramsState' NgramsStatePatch')
-> [(NodeId, Archive NgramsState' NgramsStatePatch')]
forall k a. Map k a -> [(k, a)]
Map.toList Map NodeId (Archive NgramsState' NgramsStatePatch')
m


saverAction' :: Serialise a => NodeStoryDir -> NodeId -> a -> IO ()
saverAction' :: NodeStoryDir -> NodeId -> a -> IO ()
saverAction' NodeStoryDir
repoDir NodeId
nId a
a = do
  NodeStoryDir
-> NodeStoryDir -> (NodeStoryDir -> Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
NodeStoryDir
-> NodeStoryDir -> (NodeStoryDir -> Handle -> m a) -> m a
withTempFile NodeStoryDir
repoDir ((NodeStoryDir -> NodeStoryDir
forall a b. ConvertibleStrings a b => a -> b
cs (NodeStoryDir -> NodeStoryDir) -> NodeStoryDir -> NodeStoryDir
forall a b. (a -> b) -> a -> b
$ NodeId -> NodeStoryDir
forall a. Show a => a -> NodeStoryDir
show NodeId
nId) NodeStoryDir -> NodeStoryDir -> NodeStoryDir
forall a. Semigroup a => a -> a -> a
<> NodeStoryDir
"-tmp-repo.cbor") ((NodeStoryDir -> Handle -> IO ()) -> IO ())
-> (NodeStoryDir -> Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NodeStoryDir
fp Handle
h -> do
    NodeStoryDir -> NodeStoryDir -> IO ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
NodeStoryDir -> a -> m ()
printDebug NodeStoryDir
"[repoSaverAction]" NodeStoryDir
fp
    Handle -> ByteString -> IO ()
DBL.hPut Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Serialise a => a -> ByteString
serialise a
a
    Handle -> IO ()
hClose Handle
h
    NodeStoryDir -> NodeStoryDir -> IO ()
renameFile NodeStoryDir
fp (NodeStoryDir -> NodeId -> NodeStoryDir
nodeStoryPath NodeStoryDir
repoDir NodeId
nId)

nodeStoryPath :: NodeStoryDir -> NodeId -> FilePath
nodeStoryPath :: NodeStoryDir -> NodeId -> NodeStoryDir
nodeStoryPath NodeStoryDir
repoDir NodeId
nId = NodeStoryDir
repoDir NodeStoryDir -> NodeStoryDir -> NodeStoryDir
forall a. Semigroup a => a -> a -> a
<> NodeStoryDir
"/" NodeStoryDir -> NodeStoryDir -> NodeStoryDir
forall a. Semigroup a => a -> a -> a
<> NodeStoryDir
filename
  where
    filename :: NodeStoryDir
filename = NodeStoryDir
"repo" NodeStoryDir -> NodeStoryDir -> NodeStoryDir
forall a. Semigroup a => a -> a -> a
<> NodeStoryDir
"-" NodeStoryDir -> NodeStoryDir -> NodeStoryDir
forall a. Semigroup a => a -> a -> a
<> (NodeStoryDir -> NodeStoryDir
forall a b. ConvertibleStrings a b => a -> b
cs (NodeStoryDir -> NodeStoryDir) -> NodeStoryDir -> NodeStoryDir
forall a b. (a -> b) -> a -> b
$ NodeId -> NodeStoryDir
forall a. Show a => a -> NodeStoryDir
show NodeId
nId) NodeStoryDir -> NodeStoryDir -> NodeStoryDir
forall a. Semigroup a => a -> a -> a
<> NodeStoryDir
".cbor"


------------------------------------------------------------------------
-- TODO : repo Migration TODO TESTS
{-
repoMigration :: NodeStoryDir -> NgramsRepo -> IO ()
repoMigration fp r = writeNodeStories fp (repoToNodeListStory r)

repoToNodeListStory :: NgramsRepo -> NodeListStory
repoToNodeListStory (Repo _v s h) = NodeStory $ Map.fromList ns
  where
    s' = ngramsState_migration      s
    h' = ngramsStatePatch_migration h
    ns = List.map (\(n,ns')
                    -> (n, let hs = fromMaybe [] (Map.lookup n h') in
                               Archive { _a_version = List.length hs
                                       , _a_state = ns'
                                       , _a_history = hs }
                       )
                  ) $ Map.toList s'

ngramsState_migration :: NgramsState
                      -> Map NodeId NgramsState'
ngramsState_migration ns =
  Map.fromListWith (Map.union) $ 
  List.concat $
    map (\(nt, nTable)
          -> map (\(nid, table)
                   -> (nid, Map.singleton nt table)
                 ) $ Map.toList nTable
        ) $ Map.toList ns


ngramsStatePatch_migration :: [NgramsStatePatch]
                           -> Map NodeId [NgramsStatePatch']
ngramsStatePatch_migration np' = Map.fromListWith (<>)
                               $ List.concat
                               $ map toPatch np'
  where
    toPatch :: NgramsStatePatch -> [(NodeId, [NgramsStatePatch'])]
    toPatch p = 
      List.concat $
        map (\(nt, nTable)
              -> map (\(nid, table)
                       -> (nid, [fst $ Patch.singleton nt table])
                     ) $ Patch.toList nTable
            ) $ Patch.toList p
-}
------------------------------------------------------------------------

{- | Node Story for each NodeType where the Key of the Map is NodeId
  TODO : generalize for any NodeType, let's start with NodeList which
  is implemented already
-}
data NodeStory s p = NodeStory { NodeStory s p -> Map NodeId (Archive s p)
_unNodeStory :: Map NodeId (Archive s p) }
  deriving ((forall x. NodeStory s p -> Rep (NodeStory s p) x)
-> (forall x. Rep (NodeStory s p) x -> NodeStory s p)
-> Generic (NodeStory s p)
forall x. Rep (NodeStory s p) x -> NodeStory s p
forall x. NodeStory s p -> Rep (NodeStory s p) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s p x. Rep (NodeStory s p) x -> NodeStory s p
forall s p x. NodeStory s p -> Rep (NodeStory s p) x
$cto :: forall s p x. Rep (NodeStory s p) x -> NodeStory s p
$cfrom :: forall s p x. NodeStory s p -> Rep (NodeStory s p) x
Generic, Int -> NodeStory s p -> NodeStoryDir -> NodeStoryDir
[NodeStory s p] -> NodeStoryDir -> NodeStoryDir
NodeStory s p -> NodeStoryDir
(Int -> NodeStory s p -> NodeStoryDir -> NodeStoryDir)
-> (NodeStory s p -> NodeStoryDir)
-> ([NodeStory s p] -> NodeStoryDir -> NodeStoryDir)
-> Show (NodeStory s p)
forall a.
(Int -> a -> NodeStoryDir -> NodeStoryDir)
-> (a -> NodeStoryDir)
-> ([a] -> NodeStoryDir -> NodeStoryDir)
-> Show a
forall s p.
(Show s, Show p) =>
Int -> NodeStory s p -> NodeStoryDir -> NodeStoryDir
forall s p.
(Show s, Show p) =>
[NodeStory s p] -> NodeStoryDir -> NodeStoryDir
forall s p. (Show s, Show p) => NodeStory s p -> NodeStoryDir
showList :: [NodeStory s p] -> NodeStoryDir -> NodeStoryDir
$cshowList :: forall s p.
(Show s, Show p) =>
[NodeStory s p] -> NodeStoryDir -> NodeStoryDir
show :: NodeStory s p -> NodeStoryDir
$cshow :: forall s p. (Show s, Show p) => NodeStory s p -> NodeStoryDir
showsPrec :: Int -> NodeStory s p -> NodeStoryDir -> NodeStoryDir
$cshowsPrec :: forall s p.
(Show s, Show p) =>
Int -> NodeStory s p -> NodeStoryDir -> NodeStoryDir
Show)

instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
instance (ToJSON s, ToJSON p) => ToJSON (NodeStory s p)
instance (Serialise s, Serialise p) => Serialise (NodeStory s p)

data Archive s p = Archive
  { Archive s p -> Int
_a_version :: !Version
  , Archive s p -> s
_a_state   :: !s
  , Archive s p -> [p]
_a_history :: ![p]
    -- first patch in the list is the most recent
  }
  deriving ((forall x. Archive s p -> Rep (Archive s p) x)
-> (forall x. Rep (Archive s p) x -> Archive s p)
-> Generic (Archive s p)
forall x. Rep (Archive s p) x -> Archive s p
forall x. Archive s p -> Rep (Archive s p) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s p x. Rep (Archive s p) x -> Archive s p
forall s p x. Archive s p -> Rep (Archive s p) x
$cto :: forall s p x. Rep (Archive s p) x -> Archive s p
$cfrom :: forall s p x. Archive s p -> Rep (Archive s p) x
Generic, Int -> Archive s p -> NodeStoryDir -> NodeStoryDir
[Archive s p] -> NodeStoryDir -> NodeStoryDir
Archive s p -> NodeStoryDir
(Int -> Archive s p -> NodeStoryDir -> NodeStoryDir)
-> (Archive s p -> NodeStoryDir)
-> ([Archive s p] -> NodeStoryDir -> NodeStoryDir)
-> Show (Archive s p)
forall a.
(Int -> a -> NodeStoryDir -> NodeStoryDir)
-> (a -> NodeStoryDir)
-> ([a] -> NodeStoryDir -> NodeStoryDir)
-> Show a
forall s p.
(Show s, Show p) =>
Int -> Archive s p -> NodeStoryDir -> NodeStoryDir
forall s p.
(Show s, Show p) =>
[Archive s p] -> NodeStoryDir -> NodeStoryDir
forall s p. (Show s, Show p) => Archive s p -> NodeStoryDir
showList :: [Archive s p] -> NodeStoryDir -> NodeStoryDir
$cshowList :: forall s p.
(Show s, Show p) =>
[Archive s p] -> NodeStoryDir -> NodeStoryDir
show :: Archive s p -> NodeStoryDir
$cshow :: forall s p. (Show s, Show p) => Archive s p -> NodeStoryDir
showsPrec :: Int -> Archive s p -> NodeStoryDir -> NodeStoryDir
$cshowsPrec :: forall s p.
(Show s, Show p) =>
Int -> Archive s p -> NodeStoryDir -> NodeStoryDir
Show)

instance (Serialise s, Serialise p) => Serialise (Archive s p)


type NodeListStory     = NodeStory NgramsState' NgramsStatePatch'

type NgramsState'      = Map       TableNgrams.NgramsType NgramsTableMap
type NgramsStatePatch' = PatchMap  TableNgrams.NgramsType NgramsTablePatch
instance Serialise NgramsStatePatch'

-- TODO Semigroup instance for unions
-- TODO check this
instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
  <> :: Archive s p -> Archive s p -> Archive s p
(<>) (Archive { _a_history :: forall s p. Archive s p -> [p]
_a_history = [p]
p }) (Archive { _a_version :: forall s p. Archive s p -> Int
_a_version = Int
v'
                                             , _a_state :: forall s p. Archive s p -> s
_a_state = s
s'
                                             , _a_history :: forall s p. Archive s p -> [p]
_a_history = [p]
p'}) =
    Archive :: forall s p. Int -> s -> [p] -> Archive s p
Archive { _a_version :: Int
_a_version = Int
v'
            , _a_state :: s
_a_state = s
s'
            , _a_history :: [p]
_a_history = [p]
p' [p] -> [p] -> [p]
forall a. Semigroup a => a -> a -> a
<> [p]
p }

instance Monoid (Archive NgramsState' NgramsStatePatch') where
  mempty :: Archive NgramsState' NgramsStatePatch'
mempty = Archive :: forall s p. Int -> s -> [p] -> Archive s p
Archive { _a_version :: Int
_a_version = Int
0
                   , _a_state :: NgramsState'
_a_state = NgramsState'
forall a. Monoid a => a
mempty
                   , _a_history :: [NgramsStatePatch']
_a_history = [] }

instance (FromJSON s, FromJSON p) => FromJSON (Archive s p) where
  parseJSON :: Value -> Parser (Archive s p)
parseJSON = Options -> Value -> Parser (Archive s p)
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON (Options -> Value -> Parser (Archive s p))
-> Options -> Value -> Parser (Archive s p)
forall a b. (a -> b) -> a -> b
$ NodeStoryDir -> Options
unPrefix NodeStoryDir
"_a_"

instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
  toJSON :: Archive s p -> Value
toJSON     = Options -> Archive s p -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON     (Options -> Archive s p -> Value)
-> Options -> Archive s p -> Value
forall a b. (a -> b) -> a -> b
$ NodeStoryDir -> Options
unPrefix NodeStoryDir
"_a_"
  toEncoding :: Archive s p -> Encoding
toEncoding = Options -> Archive s p -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding (Options -> Archive s p -> Encoding)
-> Options -> Archive s p -> Encoding
forall a b. (a -> b) -> a -> b
$ NodeStoryDir -> Options
unPrefix NodeStoryDir
"_a_"

------------------------------------------------------------------------
initNodeStory :: Monoid s => NodeId -> NodeStory s p
initNodeStory :: NodeId -> NodeStory s p
initNodeStory NodeId
ni = Map NodeId (Archive s p) -> NodeStory s p
forall s p. Map NodeId (Archive s p) -> NodeStory s p
NodeStory (Map NodeId (Archive s p) -> NodeStory s p)
-> Map NodeId (Archive s p) -> NodeStory s p
forall a b. (a -> b) -> a -> b
$ NodeId -> Archive s p -> Map NodeId (Archive s p)
forall k a. k -> a -> Map k a
Map.singleton NodeId
ni Archive s p
forall s p. Monoid s => Archive s p
initArchive

initArchive :: Monoid s => Archive s p
initArchive :: Archive s p
initArchive = Archive :: forall s p. Int -> s -> [p] -> Archive s p
Archive { _a_version :: Int
_a_version = Int
0
                      , _a_state :: s
_a_state = s
forall a. Monoid a => a
mempty
                      , _a_history :: [p]
_a_history = [] }

initNodeListStoryMock :: NodeListStory
initNodeListStoryMock :: NodeListStory
initNodeListStoryMock = Map NodeId (Archive NgramsState' NgramsStatePatch')
-> NodeListStory
forall s p. Map NodeId (Archive s p) -> NodeStory s p
NodeStory (Map NodeId (Archive NgramsState' NgramsStatePatch')
 -> NodeListStory)
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
-> NodeListStory
forall a b. (a -> b) -> a -> b
$ NodeId
-> Archive NgramsState' NgramsStatePatch'
-> Map NodeId (Archive NgramsState' NgramsStatePatch')
forall k a. k -> a -> Map k a
Map.singleton NodeId
nodeListId Archive NgramsState' NgramsStatePatch'
forall p. Archive NgramsState' p
archive
  where
    nodeListId :: NodeId
nodeListId = NodeId
0
    archive :: Archive NgramsState' p
archive        = Archive :: forall s p. Int -> s -> [p] -> Archive s p
Archive { _a_version :: Int
_a_version = Int
0
                             , _a_state :: NgramsState'
_a_state = NgramsState'
ngramsTableMap
                             , _a_history :: [p]
_a_history = [] }
    ngramsTableMap :: NgramsState'
ngramsTableMap = NgramsType -> Map NgramsTerm NgramsRepoElement -> NgramsState'
forall k a. k -> a -> Map k a
Map.singleton NgramsType
TableNgrams.NgramsTerms
                   (Map NgramsTerm NgramsRepoElement -> NgramsState')
-> Map NgramsTerm NgramsRepoElement -> NgramsState'
forall a b. (a -> b) -> a -> b
$ [(NgramsTerm, NgramsRepoElement)]
-> Map NgramsTerm NgramsRepoElement
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                   [ (NgramsElement
n NgramsElement
-> Getting NgramsTerm NgramsElement NgramsTerm -> NgramsTerm
forall s a. s -> Getting a s a -> a
^. Getting NgramsTerm NgramsElement NgramsTerm
Lens' NgramsElement NgramsTerm
ne_ngrams, NgramsElement -> NgramsRepoElement
ngramsElementToRepo NgramsElement
n)
                   | NgramsElement
n <- NgramsTable
mockTable NgramsTable
-> Getting [NgramsElement] NgramsTable [NgramsElement]
-> [NgramsElement]
forall s a. s -> Getting a s a -> a
^. Getting [NgramsElement] NgramsTable [NgramsElement]
Iso' NgramsTable [NgramsElement]
_NgramsTable
                   ]

------------------------------------------------------------------------


------------------------------------------------------------------------
-- | Lenses at the bottom of the file because Template Haskell would reorder order of execution in others cases
makeLenses ''NodeStoryEnv
makeLenses ''NodeStory
makeLenses ''Archive