feat(runtime): make debugger be able to request the log from the even…

…t loop

src/runtime-prototype/app/scheduler/Main.hs

@@ -1,8 +1,28 @@
+{-# LANGUAGE CPP #-}
+
 module Main where
 
+import System.Environment (getArgs)
+
 import qualified Scheduler
 
 ------------------------------------------------------------------------
 
+#ifdef __BAZEL_BUILD__
+import GitHash
+-- When building with cabal we expect the git commit hash to be passed in via
+-- CPP flags, i.e. `--ghc-option=-D__GIT_HASH__=\"X\"`.
+#elif defined __GIT_HASH__
+gitHash :: String
+gitHash = __GIT_HASH__
+#else
+gitHash :: String
+gitHash = "unknown"
+#endif
+
 main :: IO ()
-main = Scheduler.main
+main = do
+  as <- System.Environment.getArgs
+  if any (== "--version") as
+  then putStrLn gitHash
+  else Scheduler.main gitHash

src/runtime-prototype/src/Debugger.hs

@@ -1,4 +1,25 @@
 module Debugger where
 
+import Control.Concurrent.Async
+import System.FilePath
+import System.IO
+import System.Posix.Files
+
+import StuntDouble
+
+------------------------------------------------------------------------
+
+readLog :: IO Log
+readLog = do
+  let pipe = "/tmp" </> "scheduler-admin"
+  -- NOTE: We need to start reading the response before making the request to
+  -- dump the log, otherwise the response will be written to the void.
+  a <- async (withFile (pipe <> "-response") ReadWriteMode hGetLine)
+  appendFile pipe "AdminDumpLog\n"
+  s <- wait a
+  return (read s)
+
 main :: IO ()
-main = putStrLn "debugger"
+main = do
+  l <- readLog
+  print l

src/runtime-prototype/src/Scheduler.hs

@@ -261,8 +261,8 @@ getDbPath = do
           return (home </> ".detsys.db")
         else throwIO e
 
-main :: IO ()
-main = do
+main :: String -> IO ()
+main version = do
   let executorPort = 3001
       executorRef = RemoteRef ("http://localhost:" ++ show executorPort ++ "/api/v1/event") 0
       schedulerPort = 3005
@@ -272,6 +272,6 @@ main = do
   now <- getCurrentTime realTime
   lref <- spawn el (fakeScheduler executorRef) (initState now (makeSeed 0))
   withHttpFrontend el lref schedulerPort $ \pid -> do
-    putStrLn ("Scheduler is listening on port: " ++ show schedulerPort)
+    putStrLn ("Scheduler (version " ++ version ++ ") is listening on port: " ++ show schedulerPort)
     waitForEventLoopQuit el
     cancel pid

src/runtime-prototype/src/StuntDouble/AdminTransport/NamedPipe.hs

@@ -9,7 +9,6 @@ import System.Directory
 import System.FilePath
 import System.IO
 import System.IO.Error
-import System.Posix.Files
 
 import StuntDouble.Envelope
 import StuntDouble.Message
@@ -26,16 +25,18 @@ namedPipeAdminTransport fp name = do
                             -- than `transportReceive` is called.
   let pipe = fp </> getEventLoopName name <> "-admin"
   safeCreateNamedPipe pipe
+  safeCreateNamedPipe (pipe <> "-response")
   h <- openFile pipe ReadWriteMode
   hSetBuffering h LineBuffering
   pid <- async (producer h queue)
   return AdminTransport
-    { adminTransportSend = \s -> withFile (pipe <> "-response") WriteMode $ \h' -> do
+    { adminTransportSend = \s -> withFile (pipe <> "-response") ReadWriteMode $ \h' -> do
         hSetBuffering h' LineBuffering
         -- NOTE: We cannot write back the response on the same pipe as we got
         -- the command on, because `adminTransportRecieve` which runs in a loop
         -- will consume the response.
         hPutStrLn h' s
+        putStrLn ("dumped log into " ++ pipe <> "-response")
     , adminTransportReceive  = atomically (flushTBQueue queue)
     , adminTransportShutdown = do
         adminCleanUpNamedPipe fp name
@@ -47,13 +48,15 @@ namedPipeAdminTransport fp name = do
       l <- hGetLine h
       case readMaybe l of
         Just cmd -> atomically (writeTBQueue queue cmd)
-        Nothing  -> return () -- XXX: Perhaps we should log something here?
+        Nothing  ->
+          putStrLn ("namedPipeAdminTransport: unknown admin command: " ++ l)
 
 adminCleanUpNamedPipe :: FilePath -> EventLoopName -> IO ()
 adminCleanUpNamedPipe fp name =
   catchJust
     (\e -> if isDoesNotExistErrorType (ioeGetErrorType e)
            then Just ()
            else Nothing)
-    (removeFile (fp </> getEventLoopName name </> "admin"))
+    (removeFile (fp </> getEventLoopName name </> "admin") >>
+     removeFile (fp </> getEventLoopName name </> "admin-response"))
     return

src/runtime-prototype/src/StuntDouble/Log.hs

@@ -10,18 +10,19 @@ import StuntDouble.LogicalTime
 ------------------------------------------------------------------------
 
 newtype Log = Log [Timestamped LogEntry]
-  deriving Show
+  deriving (Show, Read)
 
 data Timestamped a = Timestamped a LogicalTimestamp Timestamp
-  deriving Show
+  deriving (Show, Read)
 
 data TimestampedLogically a = TimestampedLogically a LogicalTimestamp
-  deriving Show
+  deriving (Show, Read)
 
 data LogEntry
   = LogSend LocalRef RemoteRef Message
   | LogResumeContinuation RemoteRef LocalRef Message
-  deriving Show
+  deriving (Show, Read)
+
   {-
   = Spawned LocalRef
   | Turn TurnData

src/runtime-prototype/src/StuntDouble/Reference.hs

@@ -10,7 +10,7 @@ import Data.String
 ------------------------------------------------------------------------
 
 newtype LocalRef = LocalRef Int
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Read)
 
 data RemoteRef = RemoteRef
   { address :: String