Merge pull request #4771 from commercialhaskell/nice-lock-message

Nicer DB locked messages

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,94 @@ 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
+                  `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
+            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 ()
+
+-- | 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.
+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)