From a777458252812d7ab880a04be983be91c95e7eb4 Mon Sep 17 00:00:00 2001 From: Stevan Andjelkovic Date: Fri, 1 Oct 2021 15:12:54 +0200 Subject: [PATCH] feat(runtime): make debugger be able to request the log from the event loop --- src/runtime-prototype/app/scheduler/Main.hs | 22 +++++++++++++++++- src/runtime-prototype/src/Debugger.hs | 23 ++++++++++++++++++- src/runtime-prototype/src/Scheduler.hs | 6 ++--- .../StuntDouble/AdminTransport/NamedPipe.hs | 11 +++++---- src/runtime-prototype/src/StuntDouble/Log.hs | 9 ++++---- .../src/StuntDouble/Reference.hs | 2 +- 6 files changed, 59 insertions(+), 14 deletions(-) diff --git a/src/runtime-prototype/app/scheduler/Main.hs b/src/runtime-prototype/app/scheduler/Main.hs index 29ce477b..e4dbd225 100644 --- a/src/runtime-prototype/app/scheduler/Main.hs +++ b/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 diff --git a/src/runtime-prototype/src/Debugger.hs b/src/runtime-prototype/src/Debugger.hs index 2a7cea46..6a9ce65a 100644 --- a/src/runtime-prototype/src/Debugger.hs +++ b/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 diff --git a/src/runtime-prototype/src/Scheduler.hs b/src/runtime-prototype/src/Scheduler.hs index bdba226d..9b29543d 100644 --- a/src/runtime-prototype/src/Scheduler.hs +++ b/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 diff --git a/src/runtime-prototype/src/StuntDouble/AdminTransport/NamedPipe.hs b/src/runtime-prototype/src/StuntDouble/AdminTransport/NamedPipe.hs index 60755cb9..204dd2b1 100644 --- a/src/runtime-prototype/src/StuntDouble/AdminTransport/NamedPipe.hs +++ b/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,7 +48,8 @@ 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 = @@ -55,5 +57,6 @@ adminCleanUpNamedPipe fp name = (\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 diff --git a/src/runtime-prototype/src/StuntDouble/Log.hs b/src/runtime-prototype/src/StuntDouble/Log.hs index 21ed8f86..a88aedf3 100644 --- a/src/runtime-prototype/src/StuntDouble/Log.hs +++ b/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 diff --git a/src/runtime-prototype/src/StuntDouble/Reference.hs b/src/runtime-prototype/src/StuntDouble/Reference.hs index 2e5d6e66..70781f06 100644 --- a/src/runtime-prototype/src/StuntDouble/Reference.hs +++ b/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