TUI: press 'S' to launch speedscope

sandwich/CHANGELOG.md

@@ -1,5 +1,9 @@
 # Changelog for sandwich
 
+## Unreleased
+
+* TUI: be able to press 'S' to open the speedscope profile in a browser.
+
 ## 0.3.1.0
 
 * Add a socket formatter (`Test.Sandwich.Formatters.Socket`) and a TUI debug socket (`Test.Sandwich.Formatters.TerminalUI.DebugSocket`).

sandwich/sandwich.cabal

@@ -72,6 +72,7 @@ library
       Test.Sandwich.Formatters.TerminalUI.Filter
       Test.Sandwich.Formatters.TerminalUI.Keys
       Test.Sandwich.Formatters.TerminalUI.OpenInEditor
+      Test.Sandwich.Formatters.TerminalUI.SpeedScope
       Test.Sandwich.Formatters.TerminalUI.Types
       Test.Sandwich.Golden.Update
       Test.Sandwich.Instrumentation

sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs

@@ -45,6 +45,7 @@ import qualified Data.Sequence as Seq
 import qualified Data.Set as S
 import Data.String.Interpolate
 import Data.Text (Text)
+import qualified Data.Text.Encoding as TE
 import Data.Time
 import qualified Data.Vector as Vec
 import GHC.Stack
@@ -59,6 +60,7 @@ import Test.Sandwich.Formatters.TerminalUI.DebugSocket
 import Test.Sandwich.Formatters.TerminalUI.Draw
 import Test.Sandwich.Formatters.TerminalUI.Filter
 import Test.Sandwich.Formatters.TerminalUI.Keys
+import Test.Sandwich.Formatters.TerminalUI.SpeedScope
 import Test.Sandwich.Formatters.TerminalUI.Types
 import Test.Sandwich.Interpreters.RunTree.Util
 import Test.Sandwich.Interpreters.StartTree
@@ -92,10 +94,13 @@ runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do
 
   -- Create debug channel for optional debug socket server
   debugChan <- liftIO $ newBroadcastTChanIO
-  let debugFn :: Text -> IO ()
-      debugFn msg = do
-        now <- getCurrentTime
+  let debugFn :: UTCTime -> Text -> IO ()
+      debugFn now msg =
         atomically $ writeTChan debugChan (BS8.pack [i|#{formatTime defaultTimeLocale "%H:%M:%S%3Q" now} #{msg}\n|])
+  let debugFnNow :: Text -> IO ()
+      debugFnNow msg = getCurrentTime >>= flip debugFn msg
+
+  speedScopeServer <- liftIO $ newMVar Nothing
 
   let initialState = updateFilteredTree $
         AppState {
@@ -117,7 +122,8 @@ runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do
           , _appShowVisibilityThresholds = terminalUIShowVisibilityThresholds
           , _appShowLogSizes = terminalUIShowLogSizes
 
-          , _appOpenInEditor = terminalUIOpenInEditor terminalUIDefaultEditor debugFn
+          , _appOpenInEditor = terminalUIOpenInEditor terminalUIDefaultEditor debugFnNow
+          , _appSpeedScopeServer = speedScopeServer
           , _appDebug = debugFn
           , _appCustomExceptionFormatters = terminalUICustomExceptionFormatters
         }
@@ -129,15 +135,15 @@ runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do
   currentFixedTree <- liftIO $ newTVarIO rtsFixed
   let eventAsync = liftIO $ forever $ do
         handleAny (\e -> flip runLoggingT logFn (logError [i|Got exception in event async: #{e}|]) >> threadDelay terminalUIRefreshPeriod) $ do
-          debugFn "eventAsync: waiting for tree change"
+          debugFnNow "eventAsync: waiting for tree change"
           (newFixedTree, somethingRunning) <- atomically $ flip runStateT False $ do
             currentFixed <- lift $ readTVar currentFixedTree
             newFixed <- mapM fixRunTree' rts
             when (fmap getCommons newFixed == fmap getCommons currentFixed) (lift retry)
             lift $ writeTVar currentFixedTree newFixed
             return newFixed
           let nodeCount = length $ concatMap getCommons newFixedTree
-          debugFn [i|eventAsync: tree changed, nodes=#{nodeCount} somethingRunning=#{somethingRunning}|]
+          debugFnNow [i|eventAsync: tree changed, nodes=#{nodeCount} somethingRunning=#{somethingRunning}|]
           writeBChan eventChan (RunTreeUpdated newFixedTree somethingRunning)
           threadDelay terminalUIRefreshPeriod
 
@@ -151,7 +157,7 @@ runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do
 
   let updateCurrentTimeForever period = forever $ do
         now <- getCurrentTime
-        debugFn "CurrentTimeUpdated tick"
+        debugFn now "CurrentTimeUpdated tick"
         writeBChan eventChan (CurrentTimeUpdated now)
         threadDelay period
 
@@ -332,6 +338,9 @@ appEvent s (VtyEvent e) =
         whenJust folderPath $ liftIO . openFileExplorerFolderPortable
     V.EvKey c [] | c == openTestRootKey -> withContinueS s $
       whenJust (baseContextRunRoot (s ^. appBaseContext)) $ liftIO . openFileExplorerFolderPortable
+    V.EvKey c [] | c == openSpeedScopeKey -> withContinueS s $ liftIO $
+      flip runLoggingT (\_ _ _ x -> getCurrentTime >>= \now -> (s ^. appDebug) now (TE.decodeUtf8 (fromLogStr x))) $
+        openSpeedScope (s ^. appSpeedScopeServer) (s ^. appBaseContext)
     V.EvKey c [] | c == openTestInEditorKey -> case listSelectedElement (s ^. appMainList) of
       Just (_i, MainListElem {node=(runTreeLoc -> Just loc)}) -> openSrcLoc s loc
       _ -> continue s

sandwich/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs

@@ -2,6 +2,7 @@
 
 module Test.Sandwich.Formatters.TerminalUI.CrossPlatform (
   openFileExplorerFolderPortable
+  , openUrlPortable
   ) where
 
 import Control.Monad
@@ -18,12 +19,26 @@ openFileExplorerFolderPortable folder = do
   findExecutable "explorer.exe" >>= \case
     Just p -> void $ readCreateProcessWithExitCode (proc p [folder]) ""
     Nothing -> return ()
+
+openUrlPortable :: String -> IO ()
+openUrlPortable url = do
+  findExecutable "explorer.exe" >>= \case
+    Just p -> void $ readCreateProcessWithExitCode (proc p [url]) ""
+    Nothing -> return ()
 #elif darwin_HOST_OS
 openFileExplorerFolderPortable :: String -> IO ()
 openFileExplorerFolderPortable folder =
   void $ readCreateProcessWithExitCode (proc "open" [folder]) ""
+
+openUrlPortable :: String -> IO ()
+openUrlPortable url =
+  void $ readCreateProcessWithExitCode (proc "open" [url]) ""
 #else
 openFileExplorerFolderPortable :: String -> IO ()
 openFileExplorerFolderPortable folder =
   void $ readCreateProcessWithExitCode (proc "xdg-open" [folder]) ""
+
+openUrlPortable :: String -> IO ()
+openUrlPortable url =
+  void $ readCreateProcessWithExitCode (proc "xdg-open" [url]) ""
 #endif

sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs

@@ -118,6 +118,13 @@ topBox app = hBox [columnPadding settingsColumn
                                               , str "] "
                                               , str "Log level"]
 
+                                       , hBox [str "["
+                                              , highlightKeyIfPredicate (const True) app (str $ showKey openSpeedScopeKey)
+                                              , str "] "
+                                              , withAttr hotkeyMessageAttr $ str "Open "
+                                              , highlightMessageIfPredicate (const True) app (str "speedscope")
+                                              ]
+
                                        , keyIndicator "q" "Exit"]
 
 scrollNodeLabel :: String

sandwich/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs

@@ -26,6 +26,7 @@ openTestRootKey = V.KChar 'O'
 openTestInEditorKey = V.KChar 't'
 openFailureInEditorKey = V.KChar 'f'
 openLogsInEditorKey = V.KChar 'l'
+openSpeedScopeKey = V.KChar 'S'
 
 -- Column 3
 cycleVisibilityThresholdKey = V.KChar 'v'

sandwich/src/Test/Sandwich/Formatters/TerminalUI/SpeedScope.hs

@@ -0,0 +1,189 @@
+
+module Test.Sandwich.Formatters.TerminalUI.SpeedScope (
+  SpeedScopeServer(..)
+  , openSpeedScope
+  ) where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Monad.Logger
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.List as L
+import Data.String.Interpolate
+import qualified Data.Text as T
+import Network.Socket
+import Network.Socket.ByteString (recv, sendAll)
+import System.Exit
+import System.FilePath
+import System.Process
+import Test.Sandwich.Formatters.TerminalUI.CrossPlatform
+import Test.Sandwich.ManagedAsync
+import Test.Sandwich.TestTimer
+import Test.Sandwich.Types.RunTree
+import Test.Sandwich.Types.TestTimer
+import UnliftIO.Async
+import UnliftIO.Directory
+import UnliftIO.Exception
+import UnliftIO.MVar
+import UnliftIO.Temporary
+
+
+speedScopeVersion :: String
+speedScopeVersion = "1.25.0"
+
+speedScopeUrl :: String
+speedScopeUrl = [i|https://registry.npmjs.org/speedscope/-/speedscope-#{speedScopeVersion}.tgz|]
+
+profilePath :: String
+profilePath = "/speedscope.json"
+
+data SpeedScopeServer = SpeedScopeServer {
+  speedScopeServerSocket :: Socket
+  , speedScopeServerAsync :: Async ()
+  , speedScopeServerUrl :: String
+  }
+
+openSpeedScope :: (MonadLoggerIO m, MonadUnliftIO m) => MVar (Maybe SpeedScopeServer) -> BaseContext -> m ()
+openSpeedScope serverVar (BaseContext {..}) = handle logException $
+  modifyMVar_ serverVar $ \maybeServer -> do
+    server <- case maybeServer of
+      Just server -> return server
+      Nothing -> do
+        bundleDir <- ensureSpeedScopeBundle
+        server <- liftIO $ startServer baseContextRunId baseContextTestTimer bundleDir
+        logDebugN [i|Serving speedscope at #{speedScopeServerUrl server}|]
+        return server
+
+    liftIO $ openUrlPortable (speedScopeServerUrl server)
+    return $ Just server
+  where
+    logException (e :: SomeException) = logDebugN [i|Failed to open speedscope: #{e}|]
+
+-- * Bundle
+
+ensureSpeedScopeBundle :: (MonadLoggerIO m, MonadUnliftIO m) => m (Maybe FilePath)
+ensureSpeedScopeBundle = flip catch logException $ do
+  cacheDir <- getXdgDirectory XdgCache ("sandwich" </> ("speedscope-" <> speedScopeVersion))
+  doesFileExist (cacheDir </> "index.html") >>= \case
+    True -> return $ Just cacheDir
+    False -> withSystemTempDirectory "sandwich-speedscope" $ \tmpDir -> do
+      let tarball = tmpDir </> "speedscope.tgz"
+      logDebugN [i|Downloading #{speedScopeUrl}|]
+      run "curl" ["-sSL", speedScopeUrl, "-o", tarball]
+      run "tar" ["xzf", tarball, "-C", tmpDir]
+
+      -- The npm tarball puts the self-contained app in package/dist/release.
+      let releaseDir = tmpDir </> "package" </> "dist" </> "release"
+      doesFileExist (releaseDir </> "index.html") >>= \case
+        False -> do
+          logDebugN [i|No index.html in the speedscope tarball; falling back to speedscope.app|]
+          return Nothing
+        True -> do
+          createDirectoryIfMissing True cacheDir
+          files <- listDirectory releaseDir
+          forM_ files $ \file -> copyFile (releaseDir </> file) (cacheDir </> file)
+          logDebugN [i|Unpacked speedscope to #{cacheDir}|]
+          return $ Just cacheDir
+  where
+    logException (e :: SomeException) = do
+      logDebugN [i|Couldn't fetch speedscope (#{e}); falling back to speedscope.app|]
+      return Nothing
+
+    run cmd args = liftIO (readProcessWithExitCode cmd args "") >>= \case
+      (ExitSuccess, _, _) -> return ()
+      (code, _, stderr') -> throwIO $ userError [i|#{cmd} failed (#{code}): #{stderr'}|]
+
+-- * Server
+
+startServer :: T.Text -> TestTimer -> Maybe FilePath -> IO SpeedScopeServer
+startServer runId testTimer bundleDir = do
+  sock <- socket AF_INET Stream defaultProtocol
+  setSocketOption sock ReuseAddr 1
+  bind sock (SockAddrInet 0 (tupleToHostAddress (127, 0, 0, 1)))
+  listen sock 16
+  port <- socketPort sock
+
+  asy <- managedAsync runId "speedscope-server" $ void $ forever $ do
+    (conn, _) <- accept sock
+    void $ managedAsync runId "speedscope-request" $
+      handleRequest conn `finally` close conn
+
+  let url = case bundleDir of
+        Just _ -> [i|http://127.0.0.1:#{port}/index.html\#profileURL=#{profilePath}&title=Sandwich|]
+        -- This won't work on Safari, since it treats it as mixed content.
+        Nothing -> [i|https://www.speedscope.app/\#profileURL=http%3A%2F%2F127.0.0.1%3A#{port}#{profilePath}&title=Sandwich|]
+
+  return $ SpeedScopeServer {
+    speedScopeServerSocket = sock
+    , speedScopeServerAsync = asy
+    , speedScopeServerUrl = url
+    }
+
+  where
+    handleRequest conn = handle (\(_ :: SomeException) -> return ()) $ do
+      path <- requestPath conn
+      case path of
+        Nothing -> respond conn "400 Bad Request" "text/plain" "Bad request"
+        Just p | p == profilePath -> renderSpeedScopeFile testTimer >>= \case
+          Nothing -> respond conn "404 Not Found" "text/plain" "No test timer is running"
+          Just contents -> respond conn "200 OK" "application/json" contents
+        Just p -> case bundleDir of
+          Nothing -> respond conn "404 Not Found" "text/plain" "Not found"
+          Just dir -> case bundleFile dir p of
+            Nothing -> respond conn "404 Not Found" "text/plain" "Not found"
+            Just file -> doesFileExist file >>= \case
+              False -> respond conn "404 Not Found" "text/plain" "Not found"
+              True -> do
+                contents <- BL.readFile file
+                respond conn "200 OK" (contentType file) contents
+
+    bundleFile :: FilePath -> String -> Maybe FilePath
+    bundleFile dir path = case segments of
+      [] -> Just (dir </> "index.html")
+      [file] | isValid file, not (isAbsolute file), file /= ".." -> Just (dir </> file)
+      _ -> Nothing
+      where
+        segments = filter (`notElem` ["", ".", "/"]) $ splitDirectories $
+          takeWhile (`notElem` ("?#" :: String)) path
+
+    requestPath :: Socket -> IO (Maybe String)
+    requestPath conn = go mempty
+      where
+        go acc
+          | BS.length acc > 16384 = return Nothing
+          | otherwise = case BS8.lines acc of
+              (firstLine:_:_) -> return $ case BS8.words firstLine of
+                (_method:path:_) -> Just (BS8.unpack path)
+                _ -> Nothing
+              _ -> recv conn 4096 >>= \chunk -> if BS.null chunk then return Nothing else go (acc <> chunk)
+
+    respond :: Socket -> String -> String -> BL.ByteString -> IO ()
+    respond conn status contentType' body = do
+      sendAll conn $ BS8.pack $ L.intercalate "\r\n" [
+        [i|HTTP/1.1 #{status}|]
+        , [i|Content-Type: #{contentType'}|]
+        , [i|Content-Length: #{BL.length body}|]
+        -- So that speedscope.app can fetch the profile from us, when we're falling back to it.
+        , "Access-Control-Allow-Origin: *"
+        , "Cache-Control: no-store"
+        , "Connection: close"
+        , "", ""
+        ]
+      mapM_ (sendAll conn) (BL.toChunks body)
+
+    contentType :: FilePath -> String
+    contentType file = case takeExtension file of
+      ".html" -> "text/html; charset=utf-8"
+      ".js" -> "text/javascript"
+      ".css" -> "text/css"
+      ".json" -> "application/json"
+      ".wasm" -> "application/wasm"
+      ".woff2" -> "font/woff2"
+      ".png" -> "image/png"
+      ".ico" -> "image/x-icon"
+      ".txt" -> "text/plain"
+      ".md" -> "text/plain"
+      _ -> "application/octet-stream"

sandwich/src/Test/Sandwich/Formatters/TerminalUI/Types.hs

@@ -14,8 +14,10 @@ import Data.Time
 import GHC.Stack
 import Lens.Micro.TH
 import Test.Sandwich.Formatters.TerminalUI.OpenInEditor
+import Test.Sandwich.Formatters.TerminalUI.SpeedScope
 import Test.Sandwich.RunTree
 import Test.Sandwich.Types.RunTree
+import UnliftIO.MVar
 
 
 data TerminalUIFormatter = TerminalUIFormatter {
@@ -141,7 +143,8 @@ data AppState = AppState {
   , _appShowLogSizes :: Bool
 
   , _appOpenInEditor :: SrcLoc -> IO ()
-  , _appDebug :: T.Text -> IO ()
+  , _appSpeedScopeServer :: MVar (Maybe SpeedScopeServer)
+  , _appDebug :: UTCTime -> T.Text -> IO ()
   , _appCustomExceptionFormatters :: CustomExceptionFormatters
   }