feat(runtime): add stm transport

src/runtime-prototype/src/StuntDouble.hs

@@ -12,3 +12,4 @@ import StuntDouble.Time as X
 import StuntDouble.Transport as X
 import StuntDouble.Transport.Http as X
 import StuntDouble.Transport.NamedPipe as X
+import StuntDouble.Transport.Stm as X

src/runtime-prototype/src/StuntDouble/Transport/Stm.hs

@@ -0,0 +1,15 @@
+module StuntDouble.Transport.Stm where
+
+import Control.Concurrent.STM
+
+import StuntDouble.Transport
+
+------------------------------------------------------------------------
+
+stmTransport :: IO (Transport IO)
+stmTransport = do
+  chan <- newTChanIO
+  return Transport
+    { transportSend = \e -> atomically (writeTChan chan e)
+    , transportReceive = atomically (readTChan chan)
+    }

src/runtime-prototype/stunt-double.cabal

@@ -27,6 +27,7 @@ library
     StuntDouble.Transport
     StuntDouble.Transport.Http
     StuntDouble.Transport.NamedPipe
+    StuntDouble.Transport.Stm
     StuntDouble.FreeMonad
     StuntDouble.Frontend.Http
     StuntDouble.Log
@@ -79,6 +80,7 @@ test-suite test
   other-modules:
     StuntDouble.ActorMapTest
     StuntDouble.Transport.HttpTest
+    StuntDouble.Transport.StmTest
     StuntDouble.Transport.NamedPipeTest
     StuntDouble.FrontendTest
     StuntDouble.SchedulerTest

src/runtime-prototype/test/StuntDouble/Transport/StmTest.hs

@@ -0,0 +1,18 @@
+module StuntDouble.Transport.StmTest where
+
+import Control.Concurrent.Async
+import Test.HUnit
+
+import StuntDouble
+
+------------------------------------------------------------------------
+
+unit_stmTransport :: IO ()
+unit_stmTransport = do
+  t <- stmTransport
+  let e = Envelope RequestKind (RemoteRef "from" 0) (InternalMessage "msg")
+                   (RemoteRef "a" 1) 0
+  a <- async (transportSend t e)
+  e' <- transportReceive t
+  cancel a
+  e' @?= e