Thread blocked indefinitely in an STM transaction

[thomascrevoisier]

Thread blocked indefinitely in an STM transaction

[ThomasCrevoisier]

Thanks for reporting this.
Some questions :

• Do you reproduce it systematically ?
• Can you share a snippet of code which leads to this problem ? I'll investigate

[Anarchist666]

There was such a code:

takeScreenshots :: (Int, String) -> TargetClient ()
takeScreenshots (index, url) = do
    let outputFileName = "./png/" ++ whithoutExtension ++ ".png"
            where whithoutExtension
                      | length splited < 1 = []
                      | otherwise          = head $ drop (length splited - 1) $ splited
                  splited = splitOn "/" url

    liftIO $ putStrLn $ "Take screenshot [" ++ (show index) ++ "]: " ++ url
    traverse_ waitFor [P.enable, Network.enable Network.defaultEnableParams]
    waitFor $ P.navigate url
    waitFor $ P.onLoadEventFired

    metrics <- waitFor $ P.getLayoutMetrics
    case metrics of
        (Left error) -> liftIO $ print error >> return ()
        (Right metrics) -> do
            setMetricsResult <- setMetrics metrics
            case setMetricsResult of
                Left error -> liftIO $ print error >> return ()
                Right _    -> do
                    captureResul <- capture metrics
                    case captureResul of
                        Left error  -> liftIO $ print error >> return ()
                        Right event -> do
                            clearMetrics
                            liftIO $ writeData outputFileName event
    traverse_ waitFor [P.enable, Network.enable Network.defaultEnableParams]

and call mapM_ ((withTarget p) . takeScreenshots) indexedUrls

then I remade it like this

module Advert.Screenshot (takeScreenshots) where

import Control.Monad.Trans (liftIO)
import Data.Foldable (traverse_)
import Data.List.Split (splitOn)
import Chrome.Target.Client (TargetClient)
import Chrome.Target.Message (MethodResult, AnyResult)
import Chrome.Target.Async (waitFor, onEvent, stopEventListener)
import qualified Chrome.API.Emulation as E (setVisibleSize, clearDeviceMetricsOverride)
import qualified Chrome.API.Emulation.Types as ET
import qualified Chrome.API.DOM.Types as DT
import qualified Chrome.API.Page as P
import qualified Chrome.API.Page.Types as PT
import qualified Chrome.API.Network as Network
import Chrome.Target.Message (ResponseError)
import Data.ByteString.Base64 (decode)
import Data.ByteString as B (ByteString, writeFile)
import Data.ByteString.Char8 as C8 (pack)
import System.Exit (exitFailure)

writeData :: FilePath -> PT.CaptureScreenshotResult -> IO ()
writeData outputFileName event = (writeDecodedData outputFileName) . decode . C8.pack $ PT._screenshotData event

writeDecodedData :: FilePath -> Either String B.ByteString -> IO ()
writeDecodedData _ (Left error) = putStrLn error
writeDecodedData outputFileName (Right event) = B.writeFile outputFileName event

getWidth :: DT.Rect -> Double
getWidth (DT.Rect _ _ width _) = width

getHeight :: DT.Rect -> Double
getHeight (DT.Rect _ _ _ height) = height

setMetrics :: PT.GetLayoutMetricsResult -> TargetClient (MethodResult AnyResult)
setMetrics metrics = do
    let rect = P.contentSize metrics
        visibleSize = ET.SetVisibleSizeParams { ET.width  = round $ getWidth rect
                                              , ET.height = round $ getHeight rect
                                              }
    setMetricsResult <- waitFor $ E.setVisibleSize visibleSize
    return setMetricsResult

clearMetrics :: TargetClient (MethodResult AnyResult)
clearMetrics = do
    let visibleSize = ET.SetVisibleSizeParams { ET.width  = 100
                                              , ET.height = 100
                                              }
    waitFor $ E.setVisibleSize visibleSize
    waitFor $ E.clearDeviceMetricsOverride

capture :: PT.GetLayoutMetricsResult -> TargetClient (MethodResult PT.CaptureScreenshotResult)
capture metrics = do
    let rect = P.contentSize metrics
        clip = PT.Viewport 0 0 (getWidth rect) (getHeight rect) 1
        screenshotParams = PT.CaptureScreenshotParams "png" 0 clip True
    captureResult <- waitFor $ P.captureScreenshot screenshotParams
    return captureResult

takeOneScreenshot :: (Int, String) -> TargetClient ()
takeOneScreenshot (index, url) = do
    let outputFileName = "./png/" ++ whithoutExtension ++ ".png"
            where whithoutExtension
                      | length splited < 1 = []
                      | otherwise          = head $ drop (length splited - 1) $ splited
                  splited = splitOn "/" url

    liftIO $ putStrLn $ "Take screenshot [" ++ (show index) ++ "]: " ++ url
    waitFor $ P.navigate url
    waitFor $ P.onLoadEventFired

    metrics <- waitFor $ P.getLayoutMetrics
    case metrics of
        (Left error) -> liftIO $ print error >> return ()
        (Right metrics) -> do
            setMetricsResult <- setMetrics metrics
            case setMetricsResult of
                Left error -> liftIO $ print error >> return ()
                Right _    -> do
                    captureResul <- capture metrics
                    case captureResul of
                        Left error  -> liftIO $ print error >> return ()
                        Right event -> do
                            clearMetrics
                            liftIO $ writeData outputFileName event


takeScreenshots :: [(Int, String)] -> TargetClient ()
takeScreenshots indexedUrls = do
    traverse_ waitFor [P.enable, Network.enable Network.defaultEnableParams]    
    mapM_ takeOneScreenshot indexedUrls
    traverse_ waitFor [P.disable, Network.disable]

and now there is no problem.

The function called about 1000 times.

[Anarchist666]

This exception was returned in ghc 8.2.2.