Add timeout to called functions (fixes #29)

- 10 seconds for synchronous calls

- 5 minutes for asynchronous calls

Maybe make this configurable?

Author: saep

library/Neovim/Plugin.hs

@@ -52,10 +52,11 @@ import           Data.Maybe                   (catMaybes)
 import           Data.MessagePack
 import           Data.Traversable             (forM)
 import           System.Log.Logger
-import           Text.PrettyPrint.ANSI.Leijen (Doc)
+import           Text.PrettyPrint.ANSI.Leijen (Doc, (<+>), Pretty(..), text)
 import           UnliftIO.Exception           (SomeException, try)
-import           UnliftIO.Async               (Async, async)
+import           UnliftIO.Async               (Async, async, race)
 import           UnliftIO.STM
+import           UnliftIO.Concurrent          (threadDelay)
 
 import           Prelude
 
@@ -301,6 +302,14 @@ registerStatefulFunctionality (Plugin { environment = env, exports = fs }) = do
             Left e -> return . Left $ show (e :: SomeException)
             Right res -> return $ Right res
 
+    timeoutAndLog :: Word ->  FunctionName -> Neovim anyEnv String
+    timeoutAndLog seconds functionName = do
+        threadDelay (fromIntegral seconds * 1000 * 1000)
+        return . show $
+            pretty functionName <+> text "has been aborted after"
+            <+> text (show seconds) <+> text "seconds"
+
+
     listeningThread :: TQueue SomeMessage
                     -> TVar (Map FunctionName ([Object] -> Neovim env Object))
                     -> Neovim env ()
@@ -309,13 +318,24 @@ registerStatefulFunctionality (Plugin { environment = env, exports = fs }) = do
 
         forM_ (fromMessage msg) $ \req@Request{..} -> do
             route' <- liftIO $ readTVarIO route
-            forM_ (Map.lookup reqMethod route') $ \f ->
-                respond req =<< executeFunction f reqArgs
+            forM_ (Map.lookup reqMethod route') $ \f -> do
+                respond req . either Left id =<< race
+                    (timeoutAndLog 10 reqMethod)
+                    (executeFunction f reqArgs)
 
         forM_ (fromMessage msg) $ \Notification{..} -> do
             route' <- liftIO $ readTVarIO route
             forM_ (Map.lookup notMethod route') $ \f ->
-                void $ executeFunction f notArgs
+                void . async $ do
+                    result <- either Left id <$> race
+                        (timeoutAndLog 600 notMethod)
+                        (executeFunction f notArgs)
+                    case result of
+                      Left message ->
+                          nvim_err_writeln' message
+                      Right _ ->
+                          return ()
+
 
         listeningThread q route
 

library/Neovim/RPC/SocketReader.hs

@@ -106,7 +106,7 @@ handleResponse i result = do
 -- function call identifier.
 handleRequestOrNotification :: Maybe Int64 -> FunctionName -> [Object]
                             -> ConduitT a Void SocketHandler ()
-handleRequestOrNotification mi m params = do
+handleRequestOrNotification requestId functionToCall params = do
     cfg <- lift Internal.ask'
     void . liftIO . async $ race logTimeout (handle cfg)
     return ()
@@ -115,7 +115,7 @@ handleRequestOrNotification mi m params = do
     lookupFunction
         :: TMVar Internal.FunctionMap
         -> STM (Maybe (FunctionalityDescription, Internal.FunctionType))
-    lookupFunction funMap = Map.lookup m <$> readTMVar funMap
+    lookupFunction funMap = Map.lookup functionToCall <$> readTMVar funMap
 
     logTimeout :: IO ()
     logTimeout = do
@@ -127,25 +127,25 @@ handleRequestOrNotification mi m params = do
     handle rpc = atomically (lookupFunction (Internal.globalFunctionMap rpc)) >>= \case
 
         Nothing -> do
-            let errM = "No provider for: " <> show m
+            let errM = "No provider for: " <> show functionToCall
             debugM logger errM
-            forM_ mi $ \i -> atomically' . writeTQueue (Internal.eventQueue rpc)
+            forM_ requestId $ \i -> atomically' . writeTQueue (Internal.eventQueue rpc)
                 . SomeMessage $ MsgpackRPC.Response i (Left (toObject errM))
 
         Just (copts, Internal.Stateful c) -> do
             now <- liftIO getCurrentTime
             reply <- liftIO newEmptyTMVarIO
             let q = (recipients . Internal.customConfig) rpc
-            liftIO . debugM logger $ "Executing stateful function with ID: " <> show mi
-            case mi of
+            liftIO . debugM logger $ "Executing stateful function with ID: " <> show requestId
+            case requestId of
                 Just i -> do
                     atomically' . modifyTVar q $ Map.insert i (now, reply)
                     atomically' . writeTQueue c . SomeMessage $
-                        Request m i (parseParams copts params)
+                        Request functionToCall i (parseParams copts params)
 
                 Nothing ->
                     atomically' . writeTQueue c . SomeMessage $
-                        Notification m (parseParams copts params)
+                        Notification functionToCall (parseParams copts params)
 
 
 parseParams :: FunctionalityDescription -> [Object] -> [Object]