From 7e1c7a1c8418d3df6a40efb22c66562b6f243855 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Thu, 13 Sep 2018 14:20:42 -0700 Subject: [PATCH] Timeout effect --- semantic.cabal | 1 + src/Semantic/REPL.hs | 3 ++- src/Semantic/Task.hs | 18 +++++++++++++----- src/Semantic/Timeout.hs | 29 +++++++++++++++++++++++++++++ 4 files changed, 45 insertions(+), 6 deletions(-) create mode 100644 src/Semantic/Timeout.hs diff --git a/semantic.cabal b/semantic.cabal index e41d8c92b..67902ba4b 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -191,6 +191,7 @@ library , Semantic.Telemetry.Haystack , Semantic.Telemetry.Log , Semantic.Telemetry.Stat + , Semantic.Timeout , Semantic.Util , Semantic.Util.Rewriting , Semantic.Version diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 1f3e6a6fa..34a97cc2e 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -34,6 +34,7 @@ import Semantic.IO as IO import Semantic.Resolution import Semantic.Task hiding (Error) import Semantic.Telemetry +import Semantic.Timeout import Semantic.Telemetry.Log (LogOptions, Message(..), writeLogMessage) import Semantic.Util import System.Console.Haskeline @@ -70,7 +71,7 @@ runREPL prefs settings = interpret $ \case rubyREPL = repl (Proxy @'Language.Ruby) rubyParser -repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . IO.runFiles . runResolution . runTaskF $ do +repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runTimeout (runM . runDistribute) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . IO.runFiles . runResolution . runTaskF $ do blobs <- catMaybes <$> traverse IO.readFile (flip File (Language.reflect proxy) <$> paths) package <- fmap (fmap quieterm) <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs (Language.reflect proxy) []) modules <- topologicalSort <$> runImportGraphToModules proxy (snd <$> package) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index d85e1de09..164fb8351 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -75,10 +75,11 @@ import Diffing.Algorithm (Diffable) import Diffing.Interpreter import Parsing.CMark import Parsing.Parser -import Parsing.TreeSitter +import Parsing.TreeSitter hiding (Timeout) import Prologue hiding (MonadError (..), project) import Semantic.Config import Semantic.Distribute +import Semantic.Timeout import qualified Semantic.IO as IO import Semantic.Resolution import Semantic.Telemetry @@ -93,6 +94,7 @@ type TaskEff = Eff '[ Task , Trace , Telemetry , Exc SomeException + , Timeout , Distribute , Lift IO ] @@ -146,6 +148,7 @@ runTaskWithConfig options logger statter task = do run = runM . runDistribute + . runTimeout (runM . runDistribute) . runError . runTelemetry logger statter . runTraceInTelemetry @@ -180,7 +183,7 @@ instance Effect Task where handleState c dist (Request (Serialize format input) k) = Request (Serialize format input) (dist . (<$ c) . k) -- | Run a 'Task' effect by performing the actions in 'IO'. -runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, PureEffects effs) => Eff (Task ': effs) a -> Eff effs a +runTaskF :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Eff (Task ': effs) a -> Eff effs a runTaskF = interpret $ \ task -> case task of Parse parser blob -> runParser blob parser Analyze interpret analysis -> pure (interpret analysis) @@ -196,13 +199,13 @@ runTaskF = interpret $ \ task -> case task of logError :: Member Telemetry effs => Config -> Level -> Blob -> Error.Error String -> [(String, String)] -> Eff effs () logError Config{..} level blob err = writeLog level (Error.formatError configLogPrintSource configIsTerminal blob err) -data ParserCancelled = ParserTimedOut FilePath Language +data ParserCancelled = ParserTimedOut FilePath Language | AssignmentTimedOut FilePath Language deriving (Show, Typeable) instance Exception ParserCancelled -- | Parse a 'Blob' in 'IO'. -runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs, PureEffects effs) => Blob -> Parser term -> Eff effs term +runParser :: (Member (Exc SomeException) effs, Member (Lift IO) effs, Member (Reader Config) effs, Member Telemetry effs, Member Timeout effs, Member Trace effs, PureEffects effs) => Blob -> Parser term -> Eff effs term runParser blob@Blob{..} parser = case parser of ASTParser language -> time "parse.tree_sitter_ast_parse" languageTag $ do @@ -230,6 +233,7 @@ runParser blob@Blob{..} parser = case parser of , Member (Lift IO) effs , Member (Reader Config) effs , Member Telemetry effs + , Member Timeout effs , Member Trace effs , PureEffects effs ) @@ -244,7 +248,8 @@ runParser blob@Blob{..} parser = case parser of writeStat (increment "parse.parse_failures" languageTag) writeLog Error "failed parsing" (("task", "parse") : blobFields) throwError (toException err) - time "parse.assign" languageTag $ + + res <- timeout 10000 . time "parse.assign" languageTag $ case assign blobSource assignment ast of Left err -> do writeStat (increment "parse.assign_errors" languageTag) @@ -260,3 +265,6 @@ runParser blob@Blob{..} parser = case parser of logError config Warning blob err (("task", "assign") : blobFields) when (optionsFailOnWarning (configOptions config)) $ throwError (toException err) term <$ writeStat (count "parse.nodes" (length term) languageTag) + case res of + Just r -> pure r + Nothing -> throwError (SomeException (AssignmentTimedOut blobPath blobLanguage)) diff --git a/src/Semantic/Timeout.hs b/src/Semantic/Timeout.hs new file mode 100644 index 000000000..051b5ca4a --- /dev/null +++ b/src/Semantic/Timeout.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TypeOperators, GADTs, RankNTypes #-} +module Semantic.Timeout +( timeout +, Timeout +, runTimeout +) where + +import Prologue hiding (MonadError (..)) + +import Control.Monad.Effect +import Control.Monad.IO.Class +import qualified System.Timeout as System + + +data Timeout task output where + Timeout :: Int -> task output -> Timeout task (Maybe output) + +timeout :: (Member Timeout effs) => Int -> Eff effs output -> Eff effs (Maybe output) +timeout time = send . Timeout time + +instance PureEffect Timeout +instance Effect Timeout where + handleState c dist (Request (Timeout i task) k) = Request (Timeout i (dist (task <$ c))) (dist . maybe (k Nothing <$ c) (fmap (k . Just))) + +runTimeout :: (Member (Lift IO) effects, PureEffects effects) + => (forall x . Eff effects x -> IO x) + -> Eff (Timeout ': effects) a + -> Eff effects a +runTimeout handler = interpret (\ (Timeout i task) -> liftIO (System.timeout i (handler (runTimeout handler task))))