From c90d926b203f88f30c90847c0813ffa665bb8567 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@gmail.com>
Date: Sun, 12 Apr 2020 20:11:45 +0200
Subject: [PATCH] system-tests: Add test for RequestResume

---
 test/ghc-debugger.cabal  | 13 ++++++++-
 test/test-progs/Clock.hs | 24 +++++++++++++++++
 test/test/SystemTest.hs  | 57 ++++++++++++++++++++++++++++++++++++++++
 3 files changed, 93 insertions(+), 1 deletion(-)
 create mode 100644 test/test-progs/Clock.hs

diff --git a/test/ghc-debugger.cabal b/test/ghc-debugger.cabal
index d0095b0..df276e6 100644
--- a/test/ghc-debugger.cabal
+++ b/test/ghc-debugger.cabal
@@ -50,7 +50,9 @@ test-suite system-test
       , Server
   default-language: Haskell2010
   ghc-options:         -threaded -debug -g3
-  build-tool-depends: ghc-debug-stub:debug-test, ghc-debugger:save-one
+  build-tool-depends: ghc-debug-stub:debug-test
+                    , ghc-debugger:save-one
+                    , ghc-debugger:clock
 
 executable save-one
   main-is:             SaveOne.hs
@@ -68,3 +70,12 @@ executable save-one
                      , ghc-debug-stub
   default-language:    Haskell2010
 
+executable clock
+  main-is:             Clock.hs
+  hs-source-dirs:
+      test-progs
+  ghc-options:         -threaded -debug -g3 -O0
+  build-depends:       base
+                     , ghc-debug-stub
+  default-language:    Haskell2010
+
diff --git a/test/test-progs/Clock.hs b/test/test-progs/Clock.hs
new file mode 100644
index 0000000..31238fe
--- /dev/null
+++ b/test/test-progs/Clock.hs
@@ -0,0 +1,24 @@
+import GHC.Debug.Stub
+import System.Mem
+import Control.Concurrent
+import System.IO
+import Data.Word
+import GHC.Stats
+import GHC.Clock
+
+loop :: IO ()
+loop = do
+  time <- getMonotonicTimeNSec
+  print time
+  hFlush stdout
+  threadDelay oneSecond
+  loop
+  where
+    oneSecond = 1000000
+
+main :: IO ()
+main = do
+  start
+  print "sync"
+  hFlush stdout
+  loop
diff --git a/test/test/SystemTest.hs b/test/test/SystemTest.hs
index eb0242c..ec7f907 100644
--- a/test/test/SystemTest.hs
+++ b/test/test/SystemTest.hs
@@ -16,7 +16,15 @@ import Control.Monad
 
 import Control.Concurrent.Async
 import Control.Concurrent
+import Control.Monad.Extra
 
+import Data.Word
+import Data.IORef
+import GHC.Clock
+import System.Timeout
+import Data.List.Extra
+
+-- TODO use timeout for tests
 spec :: SpecWith ()
 spec = do
   describe "debuggeeDwarf" $
@@ -54,6 +62,44 @@ spec = do
             hg <- buildHeapGraph (derefBox d) 20 () o
             ppHeapGraph hg `shouldBe` "I# 1"
 
+    describe "RequestResume" $
+      it "should resume a paused debugee" $
+        withStartedDebuggeeAndHandles "clock" $ \ h d -> do
+          waitForSync $ Server.stdout h
+          ref <- newIORef []
+          withAsync (pipeStreamToListThread ref (Server.stdout h)) $ \_ -> do
+            request d RequestPause
+            (t:_) <- readIORef ref
+            assertNoNewClockTimes ref t
+
+            request d RequestResume
+
+            assertNewClockTime ref
+            where
+              oneSecondInMicros = 1000000
+              fiveSecondsInMicros = 5000000
+
+              assertNoNewClockTimes :: IORef [ClockTime] -> ClockTime -> Expectation
+              assertNoNewClockTimes ref t0 = do
+                result <- timeout fiveSecondsInMicros $ whileM $ do
+                  threadDelay oneSecondInMicros
+                  (t1:_) <- readIORef ref
+                  return $ t0 == t1
+
+                result `shouldBe` Nothing
+
+              assertNewClockTime :: IORef [ClockTime] -> Expectation
+              assertNewClockTime ref = do
+                now <- getMonotonicTimeNSec
+                print $ "now2 : " ++ show now
+                result <- timeout fiveSecondsInMicros $ whileM $ do
+                  threadDelay 5000
+                  (t:_) <- readIORef ref
+                  return $ t < now
+
+                result `shouldBe` Just ()
+
+
 waitForSync :: Handle -> IO ()
 waitForSync h = do
   hSetBuffering h LineBuffering
@@ -71,6 +117,17 @@ pipeStreamThread h = forever $ do
         l <- hGetLine h
         print l
 
+type ClockTime = Word64
+
+pipeStreamToListThread :: IORef [ClockTime] -> Handle -> IO ()
+pipeStreamToListThread ref h = forever $ do
+  l <- hGetLine h
+  timesList <- readIORef ref
+  writeIORef ref $ (toClockTime l) : timesList
+  where
+    toClockTime :: String -> ClockTime
+    toClockTime s = read . trim $ s
+
 shouldContainCuName :: Dwarf -> String -> Expectation
 shouldContainCuName dwarf name = allCuNames `shouldContain` [name]
   where