Log exceptions in Curator to see when the STM exceptions happen (pure…

…script#284)

app/Curator.hs

@@ -14,6 +14,7 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Encoding
+import qualified Data.Time as Time
 import qualified Data.Vector as Vector
 import qualified Dhall.Core
 import qualified Dhall.Map
@@ -78,10 +79,10 @@ main = do
  chanPackageSetsUpdater <- Queue.newTQueueIO
 
  -- Start threads
- Concurrent.forkIO $ fetcher token chanFetcher chanMetadataUpdater chanPackageSetsUpdater
- Concurrent.forkIO $ spagoUpdater token chanSpagoUpdater chanFetcher
- Concurrent.forkIO $ metadataUpdater chanMetadataUpdater
- Concurrent.forkIO $ packageSetsUpdater token chanPackageSetsUpdater
+ spawnThread "fetcher"  $ fetcher token chanFetcher chanMetadataUpdater chanPackageSetsUpdater
+ spawnThread "spagoUpdater" $ spagoUpdater token chanSpagoUpdater chanFetcher
+ spawnThread "metaUpdater"  $ metadataUpdater chanMetadataUpdater
+ spawnThread "setsUpdater"  $ packageSetsUpdater token chanPackageSetsUpdater
 
  {- |
 
@@ -105,6 +106,15 @@ main = do
 
  sleep = Concurrent.threadDelay
 
+ spawnThread name thread = Concurrent.forkIO $ catch thread $ \(err :: SomeException) -> do
+ now <- Time.getCurrentTime
+ BSL.appendFile "curator-errors.log"
+ $ "Current time: " <> repr now <> "\n"
+ <> "Got error from thread '" <> name <> "'\n"
+ <> "Exception was:\n\n"
+ <> (BSL.fromStrict . Encoding.encodeUtf8 . tshow) err
+ <> "\n\n\n"
+
  ensureRepo org repo = do
  isThere <- testdir $ Turtle.decodeString $ "data" </> repo
  -- clone if needed
@@ -208,7 +218,7 @@ fetcher token controlChan metadataChan psChan = forever $ do
  fetchRepoMetadata :: (PackageName, Package) -> IO ()
  fetchRepoMetadata (_, Package{ repo = Local _, ..}) = pure ()
  fetchRepoMetadata (packageName, Package{ repo = Remote repoUrl, .. }) =
- Retry.recoverAll (Retry.fullJitterBackoff 10000 <> Retry.limitRetries 10) $ \Retry.RetryStatus{..} -> do
+ Retry.recoverAll (Retry.fullJitterBackoff 50000 <> Retry.limitRetries 25) $ \Retry.RetryStatus{..} -> do
  let !(owner:repo:_rest)
  = Text.split (=='/')
  $ Text.replace "https://github.com/" ""

package.yaml

@@ -122,6 +122,7 @@ executables:
  - vector
  - temporary
  - retry
+ - time
 
 tests:
  spec: