{-# options_haddock prune #-}
module Helic.Interpreter.History where
import qualified Chronos
import qualified Data.Sequence as Seq
import Data.Sequence (Seq ((:|>)), (!?), (|>))
import qualified Data.Text as Text
import Exon (exon)
import qualified Log
import Polysemy.Chronos (ChronosTime)
import qualified Time
import Time (MilliSeconds (MilliSeconds), diff)
import Helic.Data.AgentId (AgentId (AgentId))
import qualified Helic.Data.Event as Event
import Helic.Data.Event (Event (Event, content, time))
import Helic.Data.InstanceName (InstanceName)
import qualified Helic.Effect.Agent as Agent
import Helic.Effect.Agent (Agent, AgentName, AgentNet, AgentTag, AgentTmux, AgentX, Agents, agentIdNet, agentName)
import qualified Helic.Effect.History as History
import Helic.Effect.History (History)
runAgent ::
∀ (tag :: AgentTag) r .
AgentName tag =>
Member (Agent @@ tag) r =>
Event ->
Sem r ()
runAgent :: forall (tag :: AgentTag) (r :: EffectRow).
(AgentName tag, Member (Agent @@ tag) r) =>
Event -> Sem r ()
runAgent (Event InstanceName
_ (AgentId Text
eId) Time
_ Text
_) | Text
eId forall a. Eq a => a -> a -> Bool
== forall (tag :: AgentTag). AgentName tag => Text
agentName @tag =
forall (f :: * -> *). Applicative f => f ()
unit
runAgent Event
event =
forall {k1} (k2 :: k1) (e :: (* -> *) -> * -> *) (r :: EffectRow)
a.
Member (Tagged k2 e) r =>
Sem (e : r) a -> Sem r a
tag (forall (r :: EffectRow). Member Agent r => Event -> Sem r ()
Agent.update Event
event)
broadcast ::
Members Agents r =>
Member Log r =>
Event ->
Sem r ()
broadcast :: forall (r :: EffectRow).
(Members Agents r, Member Log r) =>
Event -> Sem r ()
broadcast event :: Event
event@(Event InstanceName
_ (AgentId Text
ag) Time
_ Text
text) = do
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|broadcasting from #{ag}: #{show text}|]
forall (tag :: AgentTag) (r :: EffectRow).
(AgentName tag, Member (Agent @@ tag) r) =>
Event -> Sem r ()
runAgent @AgentTmux Event
event
forall (tag :: AgentTag) (r :: EffectRow).
(AgentName tag, Member (Agent @@ tag) r) =>
Event -> Sem r ()
runAgent @AgentNet Event
event
forall (tag :: AgentTag) (r :: EffectRow).
(AgentName tag, Member (Agent @@ tag) r) =>
Event -> Sem r ()
runAgent @AgentX Event
event
inRecent ::
Chronos.Time ->
Event ->
Seq Event ->
Bool
inRecent :: Time -> Event -> Seq Event -> Bool
inRecent Time
now (Event InstanceName
_ AgentId
_ Time
_ Text
c) =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Text
c ==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.content)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Seq a -> Seq a
Seq.takeWhileR Event -> Bool
newer
where
newer :: Event -> Bool
newer (Event InstanceName
_ AgentId
_ Time
t Text
_) =
forall dt u i1 i2 diff.
(TimeUnit diff, TimeUnit u, Torsor dt diff, Instant i1 dt,
Instant i2 dt) =>
i1 -> i2 -> u
diff Time
now Time
t forall a. Ord a => a -> a -> Bool
<= Int64 -> MilliSeconds
MilliSeconds Int64
1000
sanitizeNewlines :: Text -> Text
sanitizeNewlines :: Text -> Text
sanitizeNewlines =
Text -> Text -> Text -> Text
Text.replace Text
"\r" Text
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
Text.replace Text
"\r\n" Text
"\n"
sanitize :: Event -> Event
sanitize :: Event -> Event
sanitize event :: Event
event@Event {Text
content :: Text
$sel:content:Event :: Event -> Text
content} =
Event
event { $sel:content:Event :: Text
content = Text -> Text
sanitizeNewlines Text
content }
appendIfValid ::
Chronos.Time ->
Event ->
Seq Event ->
Maybe (Seq Event)
appendIfValid :: Time -> Event -> Seq Event -> Maybe (Seq Event)
appendIfValid Time
now (Event -> Event
sanitize -> event :: Event
event@Event {Text
content :: Text
$sel:content:Event :: Event -> Text
content, Time
time :: Time
$sel:time:Event :: Event -> Time
time}) = \case
Seq Event
Seq.Empty ->
forall a. a -> Maybe a
Just (forall a. a -> Seq a
Seq.singleton Event
event)
Seq Event
_ :|> Event InstanceName
_ AgentId
_ Time
latestTime Text
latest | Text
latest forall a. Eq a => a -> a -> Bool
== Text
content Bool -> Bool -> Bool
|| Time
time forall a. Ord a => a -> a -> Bool
< Time
latestTime ->
forall a. Maybe a
Nothing
Seq Event
hist | Time -> Event -> Seq Event -> Bool
inRecent Time
now Event
event Seq Event
hist ->
forall a. Maybe a
Nothing
Seq Event
hist ->
forall a. a -> Maybe a
Just (Seq Event
hist forall a. Seq a -> a -> Seq a
|> Event
event)
insertEvent ::
Members [AtomicState (Seq Event), ChronosTime] r =>
Event ->
Sem r Bool
insertEvent :: forall (r :: EffectRow).
Members '[AtomicState (Seq Event), ChronosTime] r =>
Event -> Sem r Bool
insertEvent Event
event = do
Time
now <- forall t d (r :: EffectRow). Member (Time t d) r => Sem r t
Time.now
forall s a (r :: EffectRow).
Member (AtomicState s) r =>
(s -> (s, a)) -> Sem r a
atomicState' \ Seq Event
s -> forall {a}. a -> Maybe a -> (a, Bool)
result Seq Event
s (Time -> Event -> Seq Event -> Maybe (Seq Event)
appendIfValid Time
now Event
event Seq Event
s)
where
result :: a -> Maybe a -> (a, Bool)
result a
s = \case
Just a
new -> (a
new, Bool
True)
Maybe a
Nothing -> (a
s, Bool
False)
truncateLog ::
Member (AtomicState (Seq Event)) r =>
Int ->
Sem r (Maybe Int)
truncateLog :: forall (r :: EffectRow).
Member (AtomicState (Seq Event)) r =>
Int -> Sem r (Maybe Int)
truncateLog Int
maxHistory =
forall s a (r :: EffectRow).
Member (AtomicState s) r =>
(s -> (s, a)) -> Sem r a
atomicState' \ Seq Event
evs -> do
let dropped :: Int
dropped = forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq Event
evs forall a. Num a => a -> a -> a
- Int
maxHistory
if Int
dropped forall a. Ord a => a -> a -> Bool
> Int
0
then (forall a. Int -> Seq a -> Seq a
Seq.drop Int
dropped Seq Event
evs, forall a. a -> Maybe a
Just Int
dropped)
else (Seq Event
evs, forall a. Maybe a
Nothing)
logTruncation ::
Member Log r =>
Int ->
Sem r ()
logTruncation :: forall (r :: EffectRow). Member Log r => Int -> Sem r ()
logTruncation Int
num =
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|removed #{show num} #{noun} from the history.|]
where
noun :: Text
noun =
if Int
num forall a. Eq a => a -> a -> Bool
== Int
1 then Text
"entry" else Text
"entries"
receiveEvent ::
Members Agents r =>
Members [AtomicState (Seq Event), ChronosTime, Log] r =>
Maybe Int ->
Event ->
Sem r ()
receiveEvent :: forall (r :: EffectRow).
(Members Agents r,
Members '[AtomicState (Seq Event), ChronosTime, Log] r) =>
Maybe Int -> Event -> Sem r ()
receiveEvent Maybe Int
maxHistory Event
event = do
forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|listen: #{show event}|]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (r :: EffectRow).
Members '[AtomicState (Seq Event), ChronosTime] r =>
Event -> Sem r Bool
insertEvent Event
event)
do
forall (r :: EffectRow).
(Members Agents r, Member Log r) =>
Event -> Sem r ()
broadcast Event
event
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (r :: EffectRow). Member Log r => Int -> Sem r ()
logTruncation forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (r :: EffectRow).
Member (AtomicState (Seq Event)) r =>
Int -> Sem r (Maybe Int)
truncateLog (forall a. a -> Maybe a -> a
fromMaybe Int
100 Maybe Int
maxHistory)
do forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|Ignoring duplicate event: #{Event.describe event}|]
loadEvent ::
Members [AtomicState (Seq Event), ChronosTime, Log] r =>
Int ->
Sem r (Maybe Event)
loadEvent :: forall (r :: EffectRow).
Members '[AtomicState (Seq Event), ChronosTime, Log] r =>
Int -> Sem r (Maybe Event)
loadEvent Int
index = do
Time
now <- forall t d (r :: EffectRow). Member (Time t d) r => Sem r t
Time.now
forall s a (r :: EffectRow).
Member (AtomicState s) r =>
(s -> (s, a)) -> Sem r a
atomicState' \ Seq Event
s -> do
let rindex :: Int
rindex = forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq Event
s forall a. Num a => a -> a -> a
- Int
index forall a. Num a => a -> a -> a
- Int
1
case Seq Event
s forall a. Seq a -> Int -> Maybe a
!? Int
rindex of
Just Event
event ->
(forall a. Int -> Seq a -> Seq a
Seq.deleteAt Int
rindex Seq Event
s forall a. Seq a -> a -> Seq a
|> Event
event { $sel:time:Event :: Time
time = Time
now }, forall a. a -> Maybe a
Just Event
event)
Maybe Event
Nothing ->
(Seq Event
s, forall a. Maybe a
Nothing)
isNetworkCycle ::
Member (Reader InstanceName) r =>
Event ->
Sem r Bool
isNetworkCycle :: forall (r :: EffectRow).
Member (Reader InstanceName) r =>
Event -> Sem r Bool
isNetworkCycle Event {Text
Time
AgentId
InstanceName
$sel:source:Event :: Event -> AgentId
$sel:sender:Event :: Event -> InstanceName
content :: Text
time :: Time
source :: AgentId
sender :: InstanceName
$sel:time:Event :: Event -> Time
$sel:content:Event :: Event -> Text
..} = do
InstanceName
name <- forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask
pure (InstanceName
name forall a. Eq a => a -> a -> Bool
== InstanceName
sender Bool -> Bool -> Bool
&& AgentId
source forall a. Eq a => a -> a -> Bool
== AgentId
agentIdNet)
interpretHistory ::
Members Agents r =>
Members [Reader InstanceName, AtomicState (Seq Event), ChronosTime, Log] r =>
Maybe Int ->
InterpreterFor History r
interpretHistory :: forall (r :: EffectRow).
(Members Agents r,
Members
'[Reader InstanceName, AtomicState (Seq Event), ChronosTime, Log]
r) =>
Maybe Int -> InterpreterFor History r
interpretHistory Maybe Int
maxHistory =
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
History (Sem rInitial) x
History.Get ->
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (r :: EffectRow). Member (AtomicState s) r => Sem r s
atomicGet
History.Receive Event
event ->
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (r :: EffectRow).
Member (Reader InstanceName) r =>
Event -> Sem r Bool
isNetworkCycle Event
event)
do forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|Ignoring network cycle event: #{Event.describe event}|]
do forall (r :: EffectRow).
(Members Agents r,
Members '[AtomicState (Seq Event), ChronosTime, Log] r) =>
Maybe Int -> Event -> Sem r ()
receiveEvent Maybe Int
maxHistory Event
event
History.Load Int
index -> do
Maybe Event
event <- forall (r :: EffectRow).
Members '[AtomicState (Seq Event), ChronosTime, Log] r =>
Int -> Sem r (Maybe Event)
loadEvent Int
index
Maybe Event
event forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (r :: EffectRow).
(Members Agents r, Member Log r) =>
Event -> Sem r ()
broadcast Maybe Event
event