diff --git a/src/runtime-prototype/src/StuntDouble/ActorMap.hs b/src/runtime-prototype/src/StuntDouble/ActorMap.hs index 6580c54e..dd7b4620 100644 --- a/src/runtime-prototype/src/StuntDouble/ActorMap.hs +++ b/src/runtime-prototype/src/StuntDouble/ActorMap.hs @@ -54,7 +54,7 @@ data Resolution = TimeoutR | TimerR | IOResultR IOResult - | MessageR Message + | InternalMessageR Message | ExceptionR SomeException data ActorF x @@ -275,7 +275,6 @@ clientRequest ls lref msg = do cref <- atomically (stateTVar (lsNextPromise ls) (\p -> (ClientRef (unPromise p), p + 1))) returnVar <- newEmptyTMVarIO respVar <- newEmptyTMVarIO - -- XXX: assoc cref respVar ls atomically (modifyTVar' (lsAsyncState ls) (\s -> s { asyncStateClientResponses = Map.insert cref respVar (asyncStateClientResponses s) })) @@ -354,7 +353,7 @@ act name as time transport s0 = foldM go s0 as let respVar = asyncStateClientResponses s Map.! cref -- XXX: partial atomically (putTMVar respVar msg) return s - { asyncStateClientResponses = Map.delete cref (asyncStateClientResponses s)} + { asyncStateClientResponses = Map.delete cref (asyncStateClientResponses s) } data Reaction = Receive Promise Envelope @@ -374,7 +373,7 @@ react (Receive p e) s = RequestKind -> (Request e, s) ResponseKind -> case Map.lookup p (asyncStateContinuations s) of - Just (k, lref) -> (ResumeContinuation (k (MessageR (envelopeMessage e))) lref, + Just (k, lref) -> (ResumeContinuation (k (InternalMessageR (envelopeMessage e))) lref, s { asyncStateContinuations = Map.delete p (asyncStateContinuations s) }) Nothing -> @@ -587,5 +586,5 @@ handleEvent (Admin cmd) ls = case cmd of threadDelay 100000 mapM_ cancel pids handleEvent (ClientRequestEvent lref msg cref returnVar) ls = do - reply <- actorPokeIO ls lref msg -- XXX: cref needs to be fed in here... + reply <- actorPokeIO ls lref (ClientRequest (getMessage msg) cref) atomically (putTMVar returnVar reply) diff --git a/src/runtime-prototype/src/StuntDouble/EventLoop/Transport/Http.hs b/src/runtime-prototype/src/StuntDouble/EventLoop/Transport/Http.hs index af7b3297..aadd6a06 100644 --- a/src/runtime-prototype/src/StuntDouble/EventLoop/Transport/Http.hs +++ b/src/runtime-prototype/src/StuntDouble/EventLoop/Transport/Http.hs @@ -93,3 +93,7 @@ instance FromJSON RemoteRef deriving instance Generic CorrelationId instance ToJSON CorrelationId instance FromJSON CorrelationId + +deriving instance Generic ClientRef +instance ToJSON ClientRef +instance FromJSON ClientRef diff --git a/src/runtime-prototype/src/StuntDouble/Message.hs b/src/runtime-prototype/src/StuntDouble/Message.hs index 280804a8..eb0c1a5e 100644 --- a/src/runtime-prototype/src/StuntDouble/Message.hs +++ b/src/runtime-prototype/src/StuntDouble/Message.hs @@ -1,7 +1,14 @@ module StuntDouble.Message where -newtype Message = Message String +import StuntDouble.Reference + +------------------------------------------------------------------------ + +data Message + = InternalMessage String + | ClientRequest String ClientRef deriving (Eq, Show, Read) getMessage :: Message -> String -getMessage (Message msg) = msg +getMessage (InternalMessage msg) = msg +getMessage (ClientRequest msg _cref) = msg diff --git a/src/runtime-prototype/src/StuntDouble/Reference.hs b/src/runtime-prototype/src/StuntDouble/Reference.hs index e1669c10..be9bbad3 100644 --- a/src/runtime-prototype/src/StuntDouble/Reference.hs +++ b/src/runtime-prototype/src/StuntDouble/Reference.hs @@ -25,4 +25,4 @@ newtype EventLoopName = EventLoopName { getEventLoopName :: String } deriving (Eq, Ord, Show, IsString) newtype ClientRef = ClientRef Int - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Read) diff --git a/src/runtime-prototype/stunt-double.cabal b/src/runtime-prototype/stunt-double.cabal index 67fefad2..d64de8bf 100644 --- a/src/runtime-prototype/stunt-double.cabal +++ b/src/runtime-prototype/stunt-double.cabal @@ -92,7 +92,6 @@ test-suite test other-modules: StuntDouble.ActorMapTest StuntDouble.EventLoop.TransportTest - StuntDouble.EventLoopTest StuntDouble.SchedulerTest TastyDiscover -- TODO(stevan: This doesn't work, because tasty-discovery finds the module diff --git a/src/runtime-prototype/test/StuntDouble/ActorMapTest.hs b/src/runtime-prototype/test/StuntDouble/ActorMapTest.hs index a430246f..df750474 100644 --- a/src/runtime-prototype/test/StuntDouble/ActorMapTest.hs +++ b/src/runtime-prototype/test/StuntDouble/ActorMapTest.hs @@ -32,15 +32,15 @@ eventLoopA :: String -> EventLoopName eventLoopA suffix = EventLoopName ("event-loop-actormap-a" ++ "-" ++ suffix) testActor :: Message -> Actor -testActor (Message "hi") = Actor (return (Message "bye!")) +testActor (InternalMessage "hi") = Actor (return (InternalMessage "bye!")) ------------------------------------------------------------------------ unit_actorMapInvoke :: Assertion unit_actorMapInvoke = withEventLoop (eventLoopA "invoke") $ \el _h -> do lref <- spawn el testActor emptyState - reply <- ainvoke el lref (Message "hi") - reply @?= Message "bye!" + reply <- ainvoke el lref (InternalMessage "hi") + reply @?= InternalMessage "bye!" unit_actorMapSend :: Assertion unit_actorMapSend = do @@ -48,23 +48,23 @@ unit_actorMapSend = do withEventLoop ev $ \el _h -> do lref <- spawn el testActor emptyState let rref = localToRemoteRef ev lref - a <- asend el rref (Message "hi") + a <- asend el rref (InternalMessage "hi") reply <- wait a - reply @?= Message "bye!" + reply @?= InternalMessage "bye!" ------------------------------------------------------------------------ testActor1 :: Message -> Actor -testActor1 (Message "inc") = Actor (return (Message "ack")) +testActor1 (InternalMessage "inc") = Actor (return (InternalMessage "ack")) testActor2 :: RemoteRef -> Message -> Actor -testActor2 rref msg@(Message "inc") = Actor $ do +testActor2 rref msg@(InternalMessage "inc") = Actor $ do p <- send rref msg - on p (\(MessageR (Message "ack")) -> modify (add "x" 1)) - return (Message "inced") -testActor2 _rref (Message "sum") = Actor $ do + on p (\(InternalMessageR (InternalMessage "ack")) -> modify (add "x" 1)) + return (InternalMessage "inced") +testActor2 _rref (InternalMessage "sum") = Actor $ do s <- get - return (Message (show (getField "x" s))) + return (InternalMessage (show (getField "x" s))) eventLoopB :: String -> EventLoopName eventLoopB suffix = EventLoopName ("event-loop-actormap-b" ++ "-" ++ suffix) @@ -81,42 +81,42 @@ unit_actorMapOnAndState = do lref1 <- spawn elA testActor1 emptyState let rref1 = localToRemoteRef evA lref1 lref2 <- spawn elB (testActor2 rref1) (stateFromList [("x", Integer 0)]) - reply <- ainvoke elB lref2 (Message "inc") - reply @?= Message "inced" + reply <- ainvoke elB lref2 (InternalMessage "inc") + reply @?= InternalMessage "inced" threadDelay 100000 - reply2 <- ainvoke elB lref2 (Message "sum") + reply2 <- ainvoke elB lref2 (InternalMessage "sum") quit elA quit elB return reply2) - (\(e :: SomeException) -> return (Message (show e))) - reply2 @?= Message "Integer 1" + (\(e :: SomeException) -> return (InternalMessage (show e))) + reply2 @?= InternalMessage "Integer 1" ------------------------------------------------------------------------ testActor3 :: Message -> Actor -testActor3 (Message "go") = Actor $ do +testActor3 (InternalMessage "go") = Actor $ do p <- asyncIO (return (String "io done")) on p (\(IOResultR (String "io done")) -> modify (add "x" 1)) - return (Message "done") + return (InternalMessage "done") unit_actorMapIO :: Assertion unit_actorMapIO = withEventLoop (eventLoopA "io") $ \el _h -> do lref <- spawn el testActor3 (stateFromList [("x", Integer 0)]) - _done <- ainvoke el lref (Message "go") + _done <- ainvoke el lref (InternalMessage "go") threadDelay 100000 s <- getActorState el lref s @?= stateFromList [("x", Integer 1)] testActor4 :: Message -> Actor -testActor4 (Message "go") = Actor $ do +testActor4 (InternalMessage "go") = Actor $ do p <- asyncIO (error "failed") on p (\(ExceptionR _exception) -> modify (add "x" 1)) - return (Message "done") + return (InternalMessage "done") unit_actorMapIOFail :: Assertion unit_actorMapIOFail = withEventLoop (eventLoopA "io_fail") $ \el _h -> do lref <- spawn el testActor4 (stateFromList [("x", Integer 0)]) - _done <- ainvoke el lref (Message "go") + _done <- ainvoke el lref (InternalMessage "go") threadDelay 100000 s <- getActorState el lref s @?= stateFromList [("x", Integer 1)] @@ -124,10 +124,10 @@ unit_actorMapIOFail = withEventLoop (eventLoopA "io_fail") $ \el _h -> do ------------------------------------------------------------------------ testActor5 :: RemoteRef -> Message -> Actor -testActor5 rref (Message "go") = Actor $ do - p <- send rref (Message "hi") +testActor5 rref (InternalMessage "go") = Actor $ do + p <- send rref (InternalMessage "hi") on p (\TimeoutR -> modify (add "x" 1)) - return (Message "done") + return (InternalMessage "done") unit_actorMapSendTimeout :: Assertion unit_actorMapSendTimeout = do @@ -135,7 +135,7 @@ unit_actorMapSendTimeout = do withEventLoop ev $ \el h -> do let rref = RemoteRef "doesnt_exist" 0 lref <- spawn el (testActor5 rref) (stateFromList [("x", Integer 0)]) - _done <- ainvoke el lref (Message "go") + _done <- ainvoke el lref (InternalMessage "go") -- Timeout happens after 60 seconds. advanceFakeTime h 59 threadDelay 100000 @@ -149,40 +149,40 @@ unit_actorMapSendTimeout = do ------------------------------------------------------------------------ testActor6 :: Message -> Actor -testActor6 (Message "go") = Actor $ do +testActor6 (InternalMessage "go") = Actor $ do d <- random t <- getTime - return (Message (show d ++ " " ++ show t)) + return (InternalMessage (show d ++ " " ++ show t)) unit_actorMapRandomAndTime :: Assertion unit_actorMapRandomAndTime = do let ev = eventLoopA "random_and_time" withEventLoop ev $ \el h -> do lref <- spawn el testActor6 emptyState - result <- ainvoke el lref (Message "go") - result @?= Message "0.9871468153391151 1970-01-01 00:00:00 UTC" + result <- ainvoke el lref (InternalMessage "go") + result @?= InternalMessage "0.9871468153391151 1970-01-01 00:00:00 UTC" advanceFakeTime h 1 - result2 <- ainvoke el lref (Message "go") - result2 @?= Message "6.761085639865827e-2 1970-01-01 00:00:01 UTC" + result2 <- ainvoke el lref (InternalMessage "go") + result2 @?= InternalMessage "6.761085639865827e-2 1970-01-01 00:00:01 UTC" testActor7 :: Message -> Actor -testActor7 (Message "go") = Actor $ do +testActor7 (InternalMessage "go") = Actor $ do p <- setTimer 10 on p (\TimerR -> modify (add "x" 1)) - return (Message "done") + return (InternalMessage "done") unit_actorMapTimer :: Assertion unit_actorMapTimer = do let ev = eventLoopA "timer" withEventLoop ev $ \el h -> do lref <- spawn el testActor7 (stateFromList [("x", Integer 0)]) - _done <- ainvoke el lref (Message "go") + _done <- ainvoke el lref (InternalMessage "go") -- Timer happens after 10 seconds. advanceFakeTime h 9 - threadDelay 10000 + threadDelay 100000 s <- getActorState el lref s @?= stateFromList [("x", Integer 0)] advanceFakeTime h 1 - threadDelay 10000 + threadDelay 100000 s' <- getActorState el lref s' @?= stateFromList [("x", Integer 1)] diff --git a/src/runtime-prototype/test/StuntDouble/EventLoop/Transport/HttpTest.hs b/src/runtime-prototype/test/StuntDouble/EventLoop/Transport/HttpTest.hs index b50d2531..59bf2341 100644 --- a/src/runtime-prototype/test/StuntDouble/EventLoop/Transport/HttpTest.hs +++ b/src/runtime-prototype/test/StuntDouble/EventLoop/Transport/HttpTest.hs @@ -18,7 +18,8 @@ unit_httpSendReceive = do let port = 3001 url = "http://localhost:" ++ show port catch (do t <- httpTransport port - let e = Envelope RequestKind (RemoteRef url 0) (Message "msg") (RemoteRef url 1) 0 + let e = Envelope RequestKind (RemoteRef url 0) (InternalMessage "msg") + (RemoteRef url 1) 0 -- XXX: add better way to detect when http server is ready... threadDelay 100000 a <- async (transportSend t e) diff --git a/src/runtime-prototype/test/StuntDouble/EventLoop/TransportTest.hs b/src/runtime-prototype/test/StuntDouble/EventLoop/TransportTest.hs index 93ebbd75..6fec9072 100644 --- a/src/runtime-prototype/test/StuntDouble/EventLoop/TransportTest.hs +++ b/src/runtime-prototype/test/StuntDouble/EventLoop/TransportTest.hs @@ -11,7 +11,8 @@ import StuntDouble unit_sendReceive :: IO () unit_sendReceive = do t <- namedPipeTransport "/tmp" (EventLoopName "a") - let e = Envelope RequestKind (RemoteRef "from" 0) (Message "msg") (RemoteRef "a" 1) 0 + let e = Envelope RequestKind (RemoteRef "from" 0) (InternalMessage "msg") + (RemoteRef "a" 1) 0 a <- async (transportSend t e) e' <- transportReceive t cancel a diff --git a/src/runtime-prototype/test/StuntDouble/EventLoopTest.hs b/src/runtime-prototype/test/StuntDouble/EventLoopTest.hs deleted file mode 100644 index 19289be3..00000000 --- a/src/runtime-prototype/test/StuntDouble/EventLoopTest.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module StuntDouble.EventLoopTest where - -import Control.Exception -import Control.Concurrent -import Control.Concurrent.Async -import Test.HUnit hiding (State) - -import StuntDouble - ------------------------------------------------------------------------- - -testActor :: Message -> Actor -testActor (Message "hi") = return (Now (Message "bye!")) - -testActor2 :: RemoteRef -> Message -> Actor -testActor2 rref (Message "init") = do - a <- remoteCall rref (Message "hi") - return (Later a (\(Message msg) -> return (Now (Message ("Got: " ++ msg))))) - -testActor3 :: Message -> Actor -testActor3 (Message "init") = do - a <- asyncIO (threadDelay 300000 >> return (String "result")) - return (LaterIO a (\(String result) -> return (Now (Message ("Got: " ++ result))))) - -eventLoopA :: String -> EventLoopName -eventLoopA suffix = EventLoopName ("event-loop-a" ++ "-" ++ suffix) - -eventLoopB :: String -> EventLoopName -eventLoopB suffix = EventLoopName ("event-loop-b" ++ "-" ++ suffix) - ------------------------------------------------------------------------- - -unit_invoke :: Assertion -unit_invoke = do - elog <- emptyEventLog - let ev = eventLoopA "invoke" - el <- makeEventLoop (NamedPipe "/tmp") ev elog - lref <- spawn el testActor emptyState - reply <- invoke el lref (Message "hi") - reply @?= Message "bye!" - l <- fmap (filter (not . isComment)) (eventLog el) - quit el - l @?= - [LogInvoke (dummyDeveloperRef el) lref (Message "hi") (Message "bye!") ev] - -unit_send :: Assertion -unit_send = do - elog <- emptyEventLog - let ev = eventLoopA "send" - el <- makeEventLoop (NamedPipe "/tmp") ev elog - catch - (do lref <- spawn el testActor emptyState - let rref = localToRemoteRef ev lref - a <- send el rref (Message "hi") - reply <- wait a - reply @?= Just (Message "bye!") - l <- fmap (filter (not . isComment)) (eventLog el) - quit el - l @?= - [ LogSendStart (dummyDeveloperRef el) rref (Message "hi") 0 ev - , LogRequest (dummyDeveloperRef el) rref (Message "hi") (Message "bye!") ev - , LogReceive rref (dummyDeveloperRef el) (Message "bye!") 0 ev - , LogSendFinish (CorrelationId 0) (Message "bye!") ev - ]) - (\(e :: SomeException) -> dump el >> eventLog el >>= mapM_ print) - -unit_sendLater :: Assertion -unit_sendLater = do - elog <- emptyEventLog - let evA = eventLoopA "sendLater" - evB = eventLoopB "sendLater" - el1 <- makeEventLoop (NamedPipe "/tmp") evA elog - el2 <- makeEventLoop (NamedPipe "/tmp") evB elog - - lref1 <- spawn el1 testActor emptyState - lref2 <- spawn el2 (testActor2 (localToRemoteRef evA lref1)) emptyState - a <- send el2 (localToRemoteRef evB lref2) (Message "init") - reply <- wait a - reply @?= Just (Message "Got: bye!") - - {- - catch - (do lref1 <- spawn el1 testActor - lref2 <- spawn el2 (testActor2 (localToRemoteRef eventLoopA lref1)) - a <- send el2 (localToRemoteRef eventLoopB lref2) (Message "init") - reply <- wait a - reply @?= Message "Got: bye!") - (\(e :: SomeException) -> dump el1 >> dump el2 >> eventLog el1 >>= mapM_ print) - dump el1 - dump el2 - -} - - quit el1 - quit el2 - -unit_asyncIO :: Assertion -unit_asyncIO = do - elog <- emptyEventLog - let ev = eventLoopA "asyncIO" - el <- makeEventLoop (NamedPipe "/tmp") ev elog - lref <- spawn el testActor3 emptyState - a <- send el (localToRemoteRef ev lref) (Message "init") - reply <- wait a - reply @?= Just (Message "Got: result") - quit el - {- - catch (do lref <- spawn el testActor3 - a <- send el (localToRemoteRef ev lref) (Message "init") - reply <- wait a - reply @?= Message "Got: result") - (\(e :: SomeException) -> dump el >> eventLog el >>= mapM_ print >> print e) --} - -statefulActor :: Message -> Actor -statefulActor (Message intStr) = do - s <- getState - let int :: Integer - int = read intStr - s' :: State - s' = add "x" int s - putState s' - return (Now (Message (show (getHashMap s')))) - -unit_state :: Assertion -unit_state = do - elog <- emptyEventLog - let ev = eventLoopA "state" - el <- makeEventLoop (NamedPipe "/tmp") ev elog - lref <- spawn el statefulActor (stateFromList [("x", Integer 0)]) - reply <- invoke el lref (Message "1") - reply @?= Message "fromList [(\"x\",Integer 1)]" - reply2 <- invoke el lref (Message "2") - reply2 @?= Message "fromList [(\"x\",Integer 3)]" - quit el diff --git a/src/runtime-prototype/test/StuntDouble/SchedulerTest.hs b/src/runtime-prototype/test/StuntDouble/SchedulerTest.hs index 2ea18a79..38e47545 100644 --- a/src/runtime-prototype/test/StuntDouble/SchedulerTest.hs +++ b/src/runtime-prototype/test/StuntDouble/SchedulerTest.hs @@ -21,25 +21,25 @@ fakeExecutor = do t <- httpTransport executorPort e <- transportReceive t envelopeMessage e @?= envelopeMessage e -- XXX: check if cmd is of the right shape - let resp = replyEnvelope e (Message "XXX: needs the right shape") + let resp = replyEnvelope e (InternalMessage "XXX: needs the right shape") transportSend t resp fakeScheduler :: RemoteRef -> Message -> Actor -fakeScheduler executor (Message "step") = do +fakeScheduler executor (InternalMessage "step") = do Just (cmd, heap') <- "heap" ^. pop "heap" .= (heap' :: Datatype) - a <- remoteCall executor (Message (prettyCommand cmd)) + a <- remoteCall executor (InternalMessage (prettyCommand cmd)) Left (Just resp) <- unsafeAwait (Left a) -- assert resp -- XXX: check if of the right shape now <- get "time" seed <- get "seed" arrivalTime <- genArrivalTime now seed op2 push arrivalTime (parseCommand resp) %= "heap" - return (Now (Message "stepped")) + return (Now (InternalMessage "stepped")) where parseCommand :: Message -> Datatype - parseCommand (Message m) = Pair (Text (Text.pack (show m))) (List []) -- XXX: args + parseCommand (InternalMessage m) = Pair (Text (Text.pack (show m))) (List []) -- XXX: args prettyCommand :: Text -> String prettyCommand _ = "XXX: command" @@ -57,9 +57,9 @@ unit_scheduler = do , ("seed", Integer 0) ] catch (do lref <- spawn el (fakeScheduler executorRef) initState - a <- send el (localToRemoteRef ev lref) (Message "step") + a <- send el (localToRemoteRef ev lref) (InternalMessage "step") reply <- wait a - reply @?= Just (Message "stepped")) + reply @?= Just (InternalMessage "stepped")) -- (\(e :: SomeException) -> dump el >> eventLog el >>= mapM_ print >> print e) (\(e :: SomeException) -> putStrLn "failed")