Fix random SQLite busy database is locked errors

ghcide/ghcide.cabal

@@ -74,6 +74,7 @@ library
         parallel,
         prettyprinter-ansi-terminal,
         prettyprinter,
+        random,
         regex-tdfa >= 1.3.1.0,
         retrie,
         rope-utf16-splay,
@@ -392,11 +393,13 @@ test-suite ghcide-tests
         process,
         QuickCheck,
         quickcheck-instances,
+        random,
         rope-utf16-splay,
         regex-tdfa ^>= 1.3.1,
         safe,
         safe-exceptions,
         shake,
+        sqlite-simple,
         stm,
         stm-containers,
         hls-graph,
@@ -421,6 +424,7 @@ test-suite ghcide-tests
         Experiments
         Experiments.Types
         Progress
+        HieDbRetry
     default-extensions:
         BangPatterns
         DeriveFunctor

ghcide/session-loader/Development/IDE/Session.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE RankNTypes   #-}
 {-# LANGUAGE TypeFamilies #-}
 
 {-|
@@ -11,6 +12,8 @@ module Development.IDE.Session
   ,setInitialDynFlags
   ,getHieDbLoc
   ,runWithDb
+  ,retryOnSqliteBusy
+  ,retryOnException
   ) where
 
 -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses
@@ -41,7 +44,7 @@ import qualified Data.Text                            as T
 import           Data.Time.Clock
 import           Data.Version
 import           Development.IDE.Core.RuleTypes
-import           Development.IDE.Core.Shake
+import           Development.IDE.Core.Shake           hiding (withHieDb)
 import qualified Development.IDE.GHC.Compat           as Compat
 import           Development.IDE.GHC.Compat.Core      hiding (Target,
                                                        TargetFile, TargetModule,
@@ -82,9 +85,12 @@ import           Data.Foldable                        (for_)
 import qualified Data.HashSet                         as Set
 import           Database.SQLite.Simple
 import           Development.IDE.Core.Tracing         (withTrace)
+import           Development.IDE.Types.Shake          (WithHieDb)
 import           HieDb.Create
 import           HieDb.Types
 import           HieDb.Utils
+import           System.Random                        (RandomGen)
+import qualified System.Random                        as Random
 
 -- | Bump this version number when making changes to the format of the data stored in hiedb
 hiedbDataVersion :: String
@@ -165,28 +171,118 @@ setInitialDynFlags logger rootDir SessionLoadingOptions{..} = do
   mapM_ setUnsafeGlobalDynFlags dynFlags
   pure libdir
 
+-- | If the action throws exception that satisfies predicate then we sleep for
+-- a duration determined by the random exponential backoff formula,
+-- `uniformRandom(0, min (maxDelay, (baseDelay * 2) ^ retryAttempt))`, and try
+-- the action again for a maximum of `maxRetryCount` times.
+-- `MonadIO`, `MonadCatch` are used as constraints because there are a few
+-- HieDb functions that don't return IO values.
+retryOnException
+  :: (MonadIO m, MonadCatch m, RandomGen g, Exception e)
+  => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just
+  -> Logger
+  -> Int -- ^ maximum backoff delay in microseconds
+  -> Int -- ^ base backoff delay in microseconds
+  -> Int -- ^ maximum number of times to retry
+  -> g -- ^ random number generator
+  -> m a -- ^ action that may throw exception
+  -> m a
+retryOnException exceptionPred logger maxDelay !baseDelay !maxRetryCount rng action = do
+  result <- tryJust exceptionPred action
+  case result of
+    Left e
+      | maxRetryCount > 0 -> do
+        -- multiply by 2 because baseDelay is midpoint of uniform range
+        let newBaseDelay = min maxDelay (baseDelay * 2)
+        let (delay, newRng) = Random.randomR (0, newBaseDelay) rng
+        let newMaxRetryCount = maxRetryCount - 1
+        liftIO $ do
+          logWarning logger $ "Retrying - " <> makeLogMsgComponentsText (Right delay) newMaxRetryCount e
+          threadDelay delay
+        retryOnException exceptionPred logger maxDelay newBaseDelay newMaxRetryCount newRng action
+
+      | otherwise -> do
+        liftIO $ do
+          logWarning logger $ "Retries exhausted - " <> makeLogMsgComponentsText (Left baseDelay) maxRetryCount e
+          throwIO e
+
+    Right b -> pure b
+  where
+    -- e.g. delay: 1010102, maximumDelay: 12010, maxRetryCount: 9, exception: SQLError { ... }
+    makeLogMsgComponentsText delay newMaxRetryCount e =
+      let
+        logMsgComponents =
+          [ either
+              (("base delay: " <>) . T.pack . show)
+              (("delay: " <>) . T.pack . show)
+              delay
+          , "maximumDelay: " <> T.pack (show maxDelay)
+          , "maxRetryCount: " <> T.pack (show newMaxRetryCount)
+          , "exception: " <> T.pack (show e)]
+      in
+        T.intercalate ", " logMsgComponents
+
+-- | in microseconds
+oneSecond :: Int
+oneSecond = 1000000
+
+-- | in microseconds
+oneMillisecond :: Int
+oneMillisecond = 1000
+
+-- | default maximum number of times to retry hiedb call
+maxRetryCount :: Int
+maxRetryCount = 10
+
+retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g)
+                  => Logger -> g -> m a -> m a
+retryOnSqliteBusy logger rng action =
+  let isErrorBusy e
+        | SQLError{ sqlError = ErrorBusy } <- e = Just e
+        | otherwise = Nothing
+  in
+    retryOnException isErrorBusy logger oneSecond oneMillisecond maxRetryCount rng action
+
+makeWithHieDbRetryable :: RandomGen g => Logger -> g -> HieDb -> WithHieDb
+makeWithHieDbRetryable logger rng hieDb f =
+  retryOnSqliteBusy logger rng (f hieDb)
+
 -- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for
 -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial
 -- by a worker thread using a dedicated database connection.
 -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
-runWithDb :: Logger -> FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
+runWithDb :: Logger -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO ()
 runWithDb logger fp k = do
+  -- use non-deterministic seed because maybe multiple HLS start at same time
+  -- and send bursts of requests
+  rng <- Random.newStdGen
   -- Delete the database if it has an incompatible schema version
-  withHieDb fp (const $ pure ())
-    `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp
+  retryOnSqliteBusy
+    logger
+    rng
+    (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp)
+
   withHieDb fp $ \writedb -> do
-    initConn writedb
+    -- the type signature is necessary to avoid concretizing the tyvar
+    -- e.g. `withWriteDbRetrable initConn` without type signature will
+    -- instantiate tyvar `a` to `()`
+    let withWriteDbRetryable :: WithHieDb
+        withWriteDbRetryable = makeWithHieDbRetryable logger rng writedb
+    withWriteDbRetryable initConn
+
     chan <- newTQueueIO
-    withAsync (writerThread writedb chan) $ \_ -> do
-      withHieDb fp (flip k chan)
+
+    withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do
+      withHieDb fp (\readDb -> k (makeWithHieDbRetryable logger rng readDb) chan)
   where
-    writerThread db chan = do
+    writerThread :: WithHieDb -> IndexQueue -> IO ()
+    writerThread withHieDbRetryable chan = do
       -- Clear the index of any files that might have been deleted since the last run
-      deleteMissingRealFiles db
-      _ <- garbageCollectTypeNames db
+      _ <- withHieDbRetryable deleteMissingRealFiles
+      _ <- withHieDbRetryable garbageCollectTypeNames
       forever $ do
         k <- atomically $ readTQueue chan
-        k db
+        k withHieDbRetryable
           `Safe.catch` \e@SQLError{} -> do
             logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e
           `Safe.catchAny` \e -> do

ghcide/src/Development/IDE/Core/Actions.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE TypeFamilies    #-}
+{-# LANGUAGE RankNTypes   #-}
+{-# LANGUAGE TypeFamilies #-}
 module Development.IDE.Core.Actions
 ( getAtPoint
 , getDefinition
@@ -83,24 +84,20 @@ usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k)
 -- | Goto Definition.
 getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
 getDefinition file pos = runMaybeT $ do
-    ide <- ask
+    ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
     (HAR _ hf _ _ _, mapping) <- useE GetHieAst file
     (ImportMap imports, _) <- useE GetImportMap file
     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
-    hiedb <- lift $ asks hiedb
-    dbWriter <- lift $ asks hiedbWriter
-    toCurrentLocations mapping <$> AtPoint.gotoDefinition hiedb (lookupMod dbWriter) opts imports hf pos'
+    toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
 
 getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
 getTypeDefinition file pos = runMaybeT $ do
-    ide <- ask
+    ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
     (hf, mapping) <- useE GetHieAst file
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
-    hiedb <- lift $ asks hiedb
-    dbWriter <- lift $ asks hiedbWriter
-    toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition hiedb (lookupMod dbWriter) opts hf pos'
+    toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
 
 highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
 highlightAtPoint file pos = runMaybeT $ do
@@ -112,13 +109,13 @@ highlightAtPoint file pos = runMaybeT $ do
 -- Refs are not an IDE action, so it is OK to be slow and (more) accurate
 refsAtPoint :: NormalizedFilePath -> Position -> Action [Location]
 refsAtPoint file pos = do
-    ShakeExtras{hiedb} <- getShakeExtras
+    ShakeExtras{withHieDb} <- getShakeExtras
     fs <- HM.keys <$> getFilesOfInterestUntracked
     asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs
-    AtPoint.referencesAtPoint hiedb file pos (AtPoint.FOIReferences asts)
+    AtPoint.referencesAtPoint withHieDb file pos (AtPoint.FOIReferences asts)
 
 workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation])
 workspaceSymbols query = runMaybeT $ do
-  hiedb <- lift $ asks hiedb
-  res <- liftIO $ HieDb.searchDef hiedb $ T.unpack query
+  ShakeExtras{withHieDb} <- ask
+  res <- liftIO $ withHieDb (\hieDb -> HieDb.searchDef hieDb $ T.unpack query)
   pure $ mapMaybe AtPoint.defRowToSymbolInfo res

ghcide/src/Development/IDE/Core/Compile.hs

@@ -521,7 +521,7 @@ indexHieFile se mod_summary srcPath !hash hf = do
       -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around
       let !hf' = hf{hie_hs_src = mempty}
       modifyTVar' indexPending $ HashMap.insert srcPath hash
-      writeTQueue indexQueue $ \db -> do
+      writeTQueue indexQueue $ \withHieDb -> do
         -- We are now in the worker thread
         -- Check if a newer index of this file has been scheduled, and if so skip this one
         newerScheduled <- atomically $ do
@@ -532,7 +532,7 @@ indexHieFile se mod_summary srcPath !hash hf = do
             Just pendingHash -> pendingHash /= hash
         unless newerScheduled $ do
           pre optProgressStyle
-          addRefsFromLoaded db targetPath (RealFile $ fromNormalizedFilePath srcPath) hash hf'
+          withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf')
           post
   where
     mod_location    = ms_location mod_summary

ghcide/src/Development/IDE/Core/FileStore.hs

@@ -294,7 +294,7 @@ setSomethingModified state keys reason = do
         fail "setSomethingModified can't be called on this type of VFSHandle"
     -- Update database to remove any files that might have been renamed/deleted
     atomically $ do
-        writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles
+        writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
         modifyTVar' (dirtyKeys $ shakeExtras state) $ \x ->
             foldl' (flip HSet.insert) x keys
     void $ restartShakeSession (shakeExtras state) reason []

ghcide/src/Development/IDE/Core/Rules.hs

@@ -596,9 +596,9 @@ persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap me
 
 readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction Compat.HieFile
 readHieFileForSrcFromDisk file = do
-  db <- asks hiedb
+  ShakeExtras{withHieDb} <- ask
   log <- asks $ L.logDebug . logger
-  row <- MaybeT $ liftIO $ HieDb.lookupHieFileFromSource db $ fromNormalizedFilePath file
+  row <- MaybeT $ liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb $ fromNormalizedFilePath file)
   let hie_loc = HieDb.hieModuleHieFile row
   liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file)
   exceptToMaybeT $ readHieFileFromDisk hie_loc
@@ -770,13 +770,13 @@ getModIfaceFromDiskAndIndexRule =
   -- doesn't need early cutoff since all its dependencies already have it
   defineNoDiagnostics $ \GetModIfaceFromDiskAndIndex f -> do
   x <- use_ GetModIfaceFromDisk f
-  se@ShakeExtras{hiedb} <- getShakeExtras
+  se@ShakeExtras{withHieDb} <- getShakeExtras
 
   -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db
   let ms = hirModSummary x
       hie_loc = Compat.ml_hie_file $ ms_location ms
   hash <- liftIO $ Util.getFileHash hie_loc
-  mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f)
+  mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f))
   hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow
   case mrow of
     Just row

ghcide/src/Development/IDE/Core/Service.hs

@@ -30,7 +30,8 @@ import qualified Language.LSP.Types              as LSP
 
 import           Control.Monad
 import           Development.IDE.Core.Shake
-import           System.Environment             (lookupEnv)
+import           Development.IDE.Types.Shake     (WithHieDb)
+import           System.Environment              (lookupEnv)
 
 
 ------------------------------------------------------------
@@ -44,10 +45,10 @@ initialise :: Config
            -> Debouncer LSP.NormalizedUri
            -> IdeOptions
            -> VFSHandle
-           -> HieDb
+           -> WithHieDb
            -> IndexQueue
            -> IO IdeState
-initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hiedbChan = do
+initialise defaultConfig mainRule lspEnv logger debouncer options vfs withHieDb hiedbChan = do
     shakeProfiling <- do
         let fromConf = optShakeProfiling options
         fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"
@@ -60,7 +61,7 @@ initialise defaultConfig mainRule lspEnv logger debouncer options vfs hiedb hied
         shakeProfiling
         (optReportProgress options)
         (optTesting options)
-        hiedb
+        withHieDb
         hiedbChan
         vfs
         (optShakeOptions options)

ghcide/src/Development/IDE/Core/Shake.hs

@@ -182,7 +182,9 @@ data HieDbWriter
   }
 
 -- | Actions to queue up on the index worker thread
-type IndexQueue = TQueue (HieDb -> IO ())
+-- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()`
+-- with (currently) retry functionality
+type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
 
 -- information we stash inside the shakeExtra field
 data ShakeExtras = ShakeExtras
@@ -219,7 +221,7 @@ data ShakeExtras = ShakeExtras
     -- | A work queue for actions added via 'runInShakeSession'
     ,actionQueue :: ActionQueue
     ,clientCapabilities :: ClientCapabilities
-    , hiedb :: HieDb -- ^ Use only to read.
+    , withHieDb :: WithHieDb -- ^ Use only to read.
     , hiedbWriter :: HieDbWriter -- ^ use to write
     , persistentKeys :: TVar (HMap.HashMap Key GetStalePersistent)
       -- ^ Registery for functions that compute/get "stale" results for the rule
@@ -499,14 +501,14 @@ shakeOpen :: Maybe (LSP.LanguageContextEnv Config)
           -> Maybe FilePath
           -> IdeReportProgress
           -> IdeTesting
-          -> HieDb
+          -> WithHieDb
           -> IndexQueue
           -> VFSHandle
           -> ShakeOptions
           -> Rules ()
           -> IO IdeState
 shakeOpen lspEnv defaultConfig logger debouncer
-  shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo
+  shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue vfs opts rules = mdo
 
     us <- mkSplitUniqSupply 'r'
     ideNc <- newIORef (initNameCache us knownKeyNames)
@@ -528,7 +530,7 @@ shakeOpen lspEnv defaultConfig logger debouncer
         -- lazily initialize the exports map with the contents of the hiedb
         _ <- async $ do
             logDebug logger "Initializing exports map from hiedb"
-            em <- createExportsMapHieDb hiedb
+            em <- createExportsMapHieDb withHieDb
             atomically $ modifyTVar' exportsMap (<> em)
             logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")"