From 908b1fc234e260925899490f4955763351e95693 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Wed, 22 Jul 2020 16:46:20 +0200
Subject: [PATCH] chore(load): retry http

---
 load/Load.hs | 26 ++++++++++++++++++++++++--
 package.yaml |  4 ++++
 2 files changed, 28 insertions(+), 2 deletions(-)

diff --git a/load/Load.hs b/load/Load.hs
index c17a52bd2..c168796c1 100644
--- a/load/Load.hs
+++ b/load/Load.hs
@@ -47,6 +47,8 @@ import qualified Text.HTML.Scalpel as Scalpel
 import qualified Data.Conduit.Combinators as C
 import Data.List (genericLength)
 
+import qualified Control.Retry as Retry
+
 
 instance (a ~ b, Monad m) => Monoid (Kleisli m a b) where
   mempty = Kleisli return
@@ -262,7 +264,7 @@ runSimulation' LoadSheetSubmission = do
   let formURI = formURI' `relativeTo` loadBaseURI
         where formURI' = nullURI { uriPath = unpack . Text.intercalate "/" $ "." : formPath }
               (formPath, _) = renderRoute $ CSheetR loadTerm loadSchool loadCourse loadSheet SubmissionNewR
-  resp <- liftIO . Session.get session $ uriToString id formURI mempty
+  resp <- liftIO . httpRetry . Session.get session $ uriToString id formURI mempty
   void . evaluate $! resp
   procStart <- join $ asks runtime
   -- Just formData <- return . getFormData FIDsubmission $ resp ^. responseBody
@@ -306,8 +308,28 @@ runSimulation' LoadSheetSubmission = do
 
   print ("proc", procEnd - procStart)
   
-  resp3 <- liftIO $ Session.post session (uriToString id formURI mempty) subData
+  resp3 <- liftIO . httpRetry $ Session.post session (uriToString id formURI mempty) subData
   void . evaluate $! resp3
+  where
+    httpRetry act = Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do
+      putStrLn $ "httpRetry; rsIterNumber = " <> tshow rsIterNumber
+      act
+      where policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6
+            handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry
+
+            suggestRetry :: forall m. Monad m => SomeException -> m Bool
+            suggestRetry _ = return True
+
+            logRetry :: forall e m.
+                        ( Exception e
+                        , MonadIO m
+                        )
+                       => Bool -- ^ Will retry
+                       -> e
+                       -> Retry.RetryStatus
+                       -> m ()
+            logRetry shouldRetry err status = liftIO . putStrLn . pack $ Retry.defaultLogMsg shouldRetry err status
+
     
 -- runSimulation' other = terror $ "Not implemented: " <> tshow other
 
diff --git a/package.yaml b/package.yaml
index 7d0088f52..0b8eb5b32 100644
--- a/package.yaml
+++ b/package.yaml
@@ -262,6 +262,8 @@ executables:
     main: Database.hs
     ghc-options:
       - -main-is Database
+      - -threaded
+      - -rtsopts "-with-rtsopts=-N -T"
     source-dirs: test
     dependencies:
       - uniworx
@@ -274,6 +276,8 @@ executables:
     main: Load.hs
     ghc-options:
       - -main-is Load
+      - -threaded
+      - -rtsopts "-with-rtsopts=-N -T"
     source-dirs: load
     dependencies:
       - uniworx