From 40e905d0f55f18d6bfefdccc4e61712d64bf0561 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 24 Apr 2019 06:35:44 +0300 Subject: [PATCH 1/2] Nicer DB locked messages * Include indication of whether it's Pantry or Stack * Don't mention anything for the first 5 seconds to avoid spamming the user Since there are now two different delays involved, I've extracted the "talkUntil" logic to its own function. In theory, this could be added as a library function with some more cleanup. --- subs/pantry/src/Pantry/SQLite.hs | 101 +++++++++++++++++++++++-------- 1 file changed, 77 insertions(+), 24 deletions(-) diff --git a/subs/pantry/src/Pantry/SQLite.hs b/subs/pantry/src/Pantry/SQLite.hs index 47d26a5652..be48ecda53 100644 --- a/subs/pantry/src/Pantry/SQLite.hs +++ b/subs/pantry/src/Pantry/SQLite.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} module Pantry.SQLite ( Storage (..) , initStorage @@ -23,7 +25,7 @@ initStorage initStorage description migration fp inner = do ensureDir $ parent fp - migrates <- withWriteLock fp $ wrapMigrationFailure $ + migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $ withSqliteConnInfo (sqinfo True) $ runReaderT $ runMigrationSilent migration forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig @@ -46,7 +48,7 @@ initStorage description migration fp inner = do -- completely. We can investigate more elegant solutions in the -- future, such as separate read and write actions or introducing -- smarter retry logic. - { withStorage_ = withMVar baton . const . withWriteLock fp . flip runSqlPool pool + { withStorage_ = withMVar baton . const . withWriteLock (display description) fp . flip runSqlPool pool , withWriteLock_ = id } where @@ -69,33 +71,84 @@ initStorage description migration fp inner = do -- above. withWriteLock :: HasLogFunc env - => Path Abs File -- ^ SQLite database file + => Utf8Builder -- ^ database description, for lock messages + -> Path Abs File -- ^ SQLite database file -> RIO env a -> RIO env a -withWriteLock dbFile inner = do +withWriteLock desc dbFile inner = do let lockFile = toFilePath dbFile ++ ".pantry-write-lock" withRunInIO $ \run -> do mres <- withTryFileLock lockFile Exclusive $ const $ run inner case mres of Just res -> pure res Nothing -> do - run $ logInfo "Unable to get a write lock on the Pantry database, waiting..." - shouldStopComplainingVar <- newTVarIO False - let complainer = fix $ \loop -> do - delay <- registerDelay $ 60 * 1000 * 1000 -- 1 minute - shouldComplain <- - atomically $ - -- Delay has triggered, time to complain again - (readTVar delay >>= checkSTM >> pure True) <|> - -- Time to stop complaining, ignore that delay immediately - (readTVar shouldStopComplainingVar >>= checkSTM >> pure False) - when shouldComplain $ do - run $ logWarn "Still waiting on the Pantry database write lock..." - loop - stopComplaining = atomically $ writeTVar shouldStopComplainingVar True - worker = withFileLock lockFile Exclusive $ const $ do - run $ logInfo "Acquired the Pantry database write lock" - stopComplaining - run inner - runConcurrently $ Concurrently complainer - *> Concurrently (worker `finally` stopComplaining) + let complainer :: Talker IO + complainer delay = run $ do + -- Wait five seconds before giving the first message to + -- avoid spamming the user for uninteresting file locks + delay $ 5 * 1000 * 1000 -- 5 seconds + logInfo $ "Unable to get a write lock on the " <> desc <> " database, waiting..." + + -- Now loop printing a message every 1 minute + forever $ do + delay (60 * 1000 * 1000) -- 1 minute + `onException` logInfo ("Acquired the " <> desc <> " database write lock") + logWarn ("Still waiting on the " <> desc <> " database write lock...") + talkUntil complainer $ \stopComplaining -> + withFileLock lockFile Exclusive $ const $ do + stopComplaining + run inner + +-- | A thread which can send some information to the user and delay. +type Talker m = Delay -> m () + +-- | Delay the given number of microseconds. If 'StopTalking' is +-- triggered before the timer completes, a 'DoneTalking' exception +-- will be thrown (which is caught internally by 'talkUntil'). +type Delay = forall mio. MonadIO mio => Int -> mio () + +-- | Tell the 'Talker' to stop talking. The next time 'Delay' is +-- called, or if a 'Delay' is currently blocking, the 'Talker' thread +-- will exit with an exception. +type StopTalking m = m () + +-- | Internal exception used by 'talkUntil' to allow short-circuiting +-- of the 'Talker'. Should not be used outside of the 'talkUntil' +-- function. +data DoneTalking = DoneTalking + deriving (Show, Typeable) +instance Exception DoneTalking + +-- | Keep running the 'Talker' action until either the inner action +-- completes or calls the 'StopTalking' action. This can be used to +-- give the user status information while running a long running +-- operations. +talkUntil + :: forall m a. MonadUnliftIO m + => Talker m + -> (StopTalking m -> m a) + -> m a +talkUntil talker inner = do + -- Variable to indicate 'Delay'ing should result in a 'DoneTalking' + -- exception. + shouldStopVar <- newTVarIO False + let -- Relatively simple: set shouldStopVar to True + stopTalking = atomically $ writeTVar shouldStopVar True + + delay :: Delay + delay usec = do + -- Register a delay with the runtime system + delayDoneVar <- registerDelay usec + join $ atomically $ + -- Delay has triggered, keep going + (pure () <$ (readTVar delayDoneVar >>= checkSTM)) <|> + -- Time to stop talking, throw a 'DoneTalking' exception immediately + (throwIO DoneTalking <$ (readTVar shouldStopVar >>= checkSTM)) + + -- Run the 'Talker' and inner action together + runConcurrently $ + -- Ignore a 'DoneTalking' exception from the talker, that's expected behavior + Concurrently (talker delay `catch` \DoneTalking -> pure ()) *> + -- Run the inner action, giving it the 'StopTalking' action, and + -- ensuring it is called regardless of exceptions. + Concurrently (inner stopTalking `finally` stopTalking) From 76139e4ca0f98d94f93f52bc52fbb360b1be4a2a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 24 Apr 2019 14:05:33 +0300 Subject: [PATCH 2/2] onDoneTalking (thanks to @lehins) --- subs/pantry/src/Pantry/SQLite.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/SQLite.hs b/subs/pantry/src/Pantry/SQLite.hs index be48ecda53..fc3a9701f0 100644 --- a/subs/pantry/src/Pantry/SQLite.hs +++ b/subs/pantry/src/Pantry/SQLite.hs @@ -92,7 +92,7 @@ withWriteLock desc dbFile inner = do -- Now loop printing a message every 1 minute forever $ do delay (60 * 1000 * 1000) -- 1 minute - `onException` logInfo ("Acquired the " <> desc <> " database write lock") + `onDoneTalking` logInfo ("Acquired the " <> desc <> " database write lock") logWarn ("Still waiting on the " <> desc <> " database write lock...") talkUntil complainer $ \stopComplaining -> withFileLock lockFile Exclusive $ const $ do @@ -112,6 +112,16 @@ type Delay = forall mio. MonadIO mio => Int -> mio () -- will exit with an exception. type StopTalking m = m () +-- | When a delay was interrupted because we're done talking, perform +-- this action. +onDoneTalking + :: MonadUnliftIO m + => m () -- ^ the delay + -> m () -- ^ action to perform + -> m () +onDoneTalking theDelay theAction = + theDelay `withException` \DoneTalking -> theAction + -- | Internal exception used by 'talkUntil' to allow short-circuiting -- of the 'Talker'. Should not be used outside of the 'talkUntil' -- function.