Library Apps.TickGenerator

A box to prevent timing side channels (part of TCB)

Require Import Coq.Program.Basics Coq.NArith.NArith Coq.Lists.List.
Require Import FunctionApp TrustedTickBox.

Set Implicit Arguments.

Local Open Scope list_scope.
Local Open Scope program_scope.

Section tickG.

  Context (world : Type).

  Inductive tickGInput :=
  | TGWakeUp
  | TGClocksGot (nanoseconds : N)
  | TGWantWakeupIn (ticks : N).

  Definition nanos_per_tick := 1%N.

  Open Scope N_scope.

  Inductive GatewayPreState :=
  | Init
  | WaitingToWake
  | WaitingToSleep.

  Record GatewayState :=
    { systemTime : option N;
      nextWakeUpTime : option N;
      waitingOn : GatewayPreState }.

  Definition set_waitingOn (st : GatewayState) (v : GatewayPreState) : GatewayState
    := {| systemTime := st.(systemTime);
          nextWakeUpTime := st.(nextWakeUpTime);
          waitingOn := v |}.

  Inductive tickGWarningOutput :=
  | TGDebugStateTransition (from to : GatewayState) (ev : tickGInput).

  Inductive tickGEventOutput :=
  | TGGetNanosecs
  | TGTick (_ : N)
  | TGSystemSleep (nanoseconds : N).

  Definition tickGOutput := (tickGWarningOutput + tickGEventOutput)%type.

In practice, computations can take around 0.3 milliseconds. So if we are asked to sleep for less than 5 milliseconds, then we should instead sleep for 1 nanosecond, so we don't have to wait for a getClockMonotonic callback.

  Definition tickStarvationBoundary := 500000%N.

  Definition tickGLoopPreBody' (st : GatewayState) : tickGInput(list tickGOutput) × GatewayState :=
    fun i
      match i, st.(waitingOn) with
        | TGWakeUp, _
          (inr TGGetNanosecs :: nil, set_waitingOn st WaitingToWake)
        | TGClocksGot new, Init
          (nil, {| systemTime := Some new ; nextWakeUpTime := st.(nextWakeUpTime) ; waitingOn := Init |})
        | TGClocksGot new, WaitingToWake
          let actions :=
              match st.(systemTime) with
                | Some prev
                  let ticks := (new - prev) / nanos_per_tick in
                  inr (TGTick ticks) :: nil
                | Nonenil
              end in
          (actions, {| systemTime := Some new ; nextWakeUpTime := None ; waitingOn := Init |})
        | TGClocksGot new, WaitingToSleep
          match st.(systemTime), st.(nextWakeUpTime) with
            | Some prev, Some nanos
              ⇒ let diff := new - prev in
                 let new_nanos := nanos - diff in
                 if new_nanos =? 0
                 then (inr (TGTick (diff / nanos_per_tick)) :: nil,
                       {| systemTime := Some new ; nextWakeUpTime := None ; waitingOn := Init |})
                 else (inr (TGSystemSleep new_nanos) :: nil,
                       {| systemTime := Some new ; nextWakeUpTime := Some new_nanos ; waitingOn := Init |})
            | Some prev, None
              ⇒ (inr (TGSystemSleep 0) :: nil, {| systemTime := Some new ; nextWakeUpTime := Some 0 ; waitingOn := Init |})
            | None, _
              ⇒ (inr (TGSystemSleep 0) :: nil, {| systemTime := Some new ; nextWakeUpTime := Some 0 ; waitingOn := Init |})
          end
        | TGWantWakeupIn ticks, _
          ⇒ let nanos := ticks × nanos_per_tick in
             if nanos <? tickStarvationBoundary
             then (inr (TGSystemSleep 1) :: nil, st)
             else match st.(nextWakeUpTime) with
                    | None
                      ⇒ (inr TGGetNanosecs :: nil,
                          {| systemTime := st.(systemTime) ; nextWakeUpTime := Some nanos ; waitingOn := WaitingToSleep |})
                    | Some nextWake
                      ⇒ if nanos <? nextWake
                         then (inr TGGetNanosecs :: nil,
                               {| systemTime := st.(systemTime) ; nextWakeUpTime := Some nanos ; waitingOn := WaitingToSleep |})
                         else (nil, st)
                  end
      end.

  Definition tickGLoopPreBody
             (st : GatewayState)
  : tickGInput(list tickGOutput) × GatewayState
    := fun i
         let (a, st') := tickGLoopPreBody' st i in
         ((inl (TGDebugStateTransition st st' i))::a, st').

  Context (handle : tickGOutputaction world).

  Definition tickGLoopBody {T}
             (loop : GatewayStateT)
             (st : GatewayState)
  : tickGInputaction world × T
    := fun ilet outputs := fst (tickGLoopPreBody st i) in
                let st' := snd (tickGLoopPreBody st i) in
                (fold_left compose (map handle outputs) id,
                 loop st').

  CoFixpoint tickGLoop (st : GatewayState) :=
    Step (tickGLoopBody tickGLoop st).

  Definition tickGInitState : GatewayState := {| systemTime := None ; nextWakeUpTime := None ; waitingOn := Init |}.

  Definition tickG := tickGLoop tickGInitState.

End tickG.