refactor(runtime): New scheduler, faults can now add events to the ag…

…enda
platonic-io · Nov 16, 2021 · dd398fe · dd398fe
1 parent 33559e6
commit dd398fe
Show file tree

Hide file tree

Showing 3 changed files with 23 additions and 6 deletions.
diff --git a/src/runtime-prototype/src/Scheduler.hs b/src/runtime-prototype/src/Scheduler.hs
@@ -175,9 +175,11 @@ fakeScheduler executorRef (ClientRequest' "LoadTest" [SInt tid, SInt rid] cid) =
   on f (\(IOResultR (IORows rs)) -> case parseRows rs of
            Nothing          -> clientResponse cid (InternalMessage "parse error")
            Just [fs@Faults{}] -> do
+             let (fState, fAgenda) = newFaultState fs
              modify $ \s ->
-               s { faultState = newFaultState fs
+               s { faultState = fState
                  , runId = Just rid
+                 , agenda = agenda s <> fAgenda
                  })
              -- clientResponse cid (InternalMessage (show fs))) -- hmm should we just do one response?
   return (InternalMessage "ok")

diff --git a/src/runtime-prototype/src/Scheduler/Agenda.hs b/src/runtime-prototype/src/Scheduler/Agenda.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Scheduler.Agenda where
 
 import Data.Heap (Entry(Entry), Heap)
@@ -10,6 +12,7 @@ import StuntDouble.Time
 ------------------------------------------------------------------------
 
 newtype Agenda = Agenda (Heap (Entry Time SchedulerEvent))
+  deriving newtype (Semigroup, Monoid)
 
 empty :: Agenda
 empty = Agenda Heap.empty

diff --git a/src/runtime-prototype/src/Scheduler/Fault.hs b/src/runtime-prototype/src/Scheduler/Fault.hs
@@ -10,6 +10,8 @@ import qualified Data.Set as Set
 import Data.Maybe (fromMaybe)
 import qualified Data.Time as Time
 
+import qualified Scheduler.Agenda as Agenda
+import Scheduler.Agenda (Agenda)
 import Scheduler.Event
 import qualified Scheduler.Faults as Faults
 import StuntDouble.LogicalTime
@@ -72,15 +74,17 @@ instance Semigroup FaultState where
 instance Monoid FaultState where
   mempty = FaultState mempty
 
-newFaultState :: Faults.Faults -> FaultState
+newFaultState :: Faults.Faults -> (FaultState, Agenda)
 newFaultState = foldMap mkFaultState . Faults.faults
   where
-    mkFaultState :: Faults.Fault -> FaultState
-    mkFaultState f = FaultState $ uncurry Map.singleton (translate f)
+    mkFaultState :: Faults.Fault -> (FaultState, Agenda)
+    mkFaultState f = (FaultState . fromMaybe mempty $ uncurry Map.singleton <$> (translate f)
+                     , agendaItems f)
 
     nodeName = NodeName "scheduler"
-    (!->) = (,)
-    translate :: Faults.Fault -> (ActorName, FaultStateForActor)
+    k !-> v = Just (k,v)
+
+    translate :: Faults.Fault -> Maybe (ActorName, FaultStateForActor)
     translate (Faults.Omission _f t a) = t !-> mempty { fsOmissions = Set.singleton a}
     translate (Faults.Crash f a) = f !-> mempty { fsPermanentCrash = Just $ LogicalTime nodeName{-?-} a}
     translate (Faults.Pause n f t) = n !-> mempty { fsPause = singleton (TimeInterval f t)}
@@ -89,6 +93,14 @@ newFaultState = foldMap mkFaultState . Faults.faults
     translate (Faults.ClockSkewBump n d f t) = n !-> mempty { fsClockSkew = ClockSkew [(TimeInterval f t, CSABump d)]}
     translate (Faults.ClockSkewStrobe n d p f t) = n !-> mempty { fsClockSkew = ClockSkew [(TimeInterval f t, CSAStrobe d p)]}
 
+    agendaItems :: Faults.Fault -> Agenda
+    agendaItems Faults.Omission{} = mempty
+    agendaItems Faults.Crash{} = mempty
+    agendaItems Faults.Pause{} = mempty
+    agendaItems Faults.Partition{} = mempty
+    agendaItems Faults.ClockSkewBump{} = mempty
+    agendaItems Faults.ClockSkewStrobe{} = mempty
+
 ------------------------------------------------------------------------
 afterLogicalTime :: LogicalTime -> LogicalTime -> Bool
 afterLogicalTime after before = case relation after before of