diff --git a/app/App/Commands/Options/Types.hs b/app/App/Commands/Options/Types.hs --- a/app/App/Commands/Options/Types.hs +++ b/app/App/Commands/Options/Types.hs @@ -20,6 +20,7 @@ , threads :: Int , awsLogLevel :: Maybe AWS.LogLevel , hostEndpoint :: Maybe (ByteString, Int, Bool) + , maxRetries :: Int } deriving (Eq, Show, Generic) data PlanOptions = PlanOptions @@ -40,6 +41,7 @@ , threads :: Int , awsLogLevel :: Maybe AWS.LogLevel , hostEndpoint :: Maybe (ByteString, Int, Bool) + , maxRetries :: Int } deriving (Eq, Show, Generic) data VersionOptions = VersionOptions deriving (Eq, Show, Generic) diff --git a/app/App/Commands/SyncFromArchive.hs b/app/App/Commands/SyncFromArchive.hs --- a/app/App/Commands/SyncFromArchive.hs +++ b/app/App/Commands/SyncFromArchive.hs @@ -75,6 +75,7 @@ let versionedArchiveUris = archiveUris & each %~ ( archiveVersion) let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) let scopedArchiveUris = versionedArchiveUris & each %~ ( T.pack storePathHash) + let maxRetries = opts ^. the @"maxRetries" CIO.putStrLn $ "Store path: " <> toText storePath CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash @@ -154,7 +155,7 @@ else if storeDirectoryExists then return DQ.DownloadSuccess else runResAws envAws $ onError (cleanupStorePath packageStorePath packageId) DQ.DownloadFailure $ do - (existingArchiveFileContents, existingArchiveFile) <- ExceptT $ IO.readFirstAvailableResource envAws (foldMap L.tuple2ToList (L.zip archiveFiles scopedArchiveFiles)) + (existingArchiveFileContents, existingArchiveFile) <- ExceptT $ IO.readFirstAvailableResource envAws (foldMap L.tuple2ToList (L.zip archiveFiles scopedArchiveFiles)) maxRetries CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile let tempArchiveFile = tempPath archiveBaseName @@ -263,6 +264,12 @@ ) ) <*> optional parseEndpoint + <*> option auto + ( long "max-retries" + <> help "Max retries for S3 requests" + <> metavar "NUM_RETRIES" + <> value 3 + ) parseEndpoint :: Parser (ByteString, Int, Bool) parseEndpoint = diff --git a/app/App/Commands/SyncToArchive.hs b/app/App/Commands/SyncToArchive.hs --- a/app/App/Commands/SyncToArchive.hs +++ b/app/App/Commands/SyncToArchive.hs @@ -71,6 +71,7 @@ let versionedArchiveUri = archiveUri archiveVersion let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) let scopedArchiveUri = versionedArchiveUri T.pack storePathHash + let maxRetries = opts ^. the @"maxRetries" CIO.putStrLn $ "Store path: " <> toText storePath CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash @@ -146,7 +147,7 @@ IO.createTar tempArchiveFile (rp2 <> [metas]) - void $ catchError (liftIO (LBS.readFile tempArchiveFile) >>= IO.writeResource envAws targetFile) $ \case + void $ catchError (liftIO (LBS.readFile tempArchiveFile) >>= IO.writeResource envAws targetFile maxRetries) $ \case e@(AwsAppError (HTTP.Status 301 _)) -> do liftIO $ STM.atomically $ STM.writeTVar tEarlyExit True CIO.hPutStrLn IO.stderr $ mempty @@ -222,6 +223,12 @@ ) ) <*> optional parseEndpoint + <*> option auto + ( long "max-retries" + <> help "Max retries for S3 requests" + <> metavar "NUM_RETRIES" + <> value 3 + ) parseEndpoint :: Parser (ByteString, Int, Bool) parseEndpoint = diff --git a/cabal-cache.cabal b/cabal-cache.cabal --- a/cabal-cache.cabal +++ b/cabal-cache.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: cabal-cache -version: 1.0.5.4 +version: 1.0.5.5 synopsis: CI Assistant for Haskell projects description: CI Assistant for Haskell projects. Implements package caching. homepage: https://github.com/haskell-works/cabal-cache diff --git a/src/HaskellWorks/CabalCache/IO/Lazy.hs b/src/HaskellWorks/CabalCache/IO/Lazy.hs --- a/src/HaskellWorks/CabalCache/IO/Lazy.hs +++ b/src/HaskellWorks/CabalCache/IO/Lazy.hs @@ -26,10 +26,13 @@ import Control.Monad.Trans.Resource import Data.Either (isRight) import Data.Generics.Product.Any +import Data.Maybe (fromMaybe) import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.Location (Location (..)) import HaskellWorks.CabalCache.Show import Network.URI (URI) +import System.Environment (lookupEnv) +import Text.Read (readMaybe) import qualified Antiope.S3.Lazy as AWS import qualified Control.Concurrent as IO @@ -47,9 +50,6 @@ import qualified System.FilePath.Posix as FP import qualified System.IO as IO import qualified System.IO.Error as IO -import System.Environment (lookupEnv) -import Text.Read (readMaybe) -import Data.Maybe (fromMaybe) {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -} @@ -58,8 +58,9 @@ handleAwsError :: MonadCatch m => m a -> m (Either AppError a) handleAwsError f = catch (Right <$> f) $ \(e :: AWS.Error) -> case e of - (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status 404 _) _ _ _ _)) -> return (Left (AwsAppError s)) (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status 301 _) _ _ _ _)) -> return (Left (AwsAppError s)) + (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status i _) _ _ _ _)) + | i `elem` retryableHTTPStatuses -> return (Left (AwsAppError s)) _ -> throwM e handleHttpError :: (MonadCatch m, MonadIO m) => m a -> ExceptT AppError m a @@ -80,28 +81,28 @@ Right s3Uri -> Right s3Uri Left msg -> Left . GenericAppError $ "Unable to parse URI" <> tshow msg -readResource :: (MonadResource m, MonadCatch m) => AWS.Env -> Location -> m (Either AppError LBS.ByteString) -readResource envAws = \case +readResource :: (MonadResource m, MonadCatch m) => AWS.Env -> Int -> Location -> m (Either AppError LBS.ByteString) +readResource envAws maxRetries = \case Local path -> liftIO $ do fileExists <- IO.doesFileExist path if fileExists then Right <$> LBS.readFile path else pure (Left NotFound) - Uri uri -> runExceptT $ retryS3 $ case uri ^. the @"uriScheme" of + Uri uri -> runExceptT $ retryS3 maxRetries $ case uri ^. the @"uriScheme" of "s3:" -> getS3Uri envAws (reslashUri uri) "http:" -> readHttpUri (reslashUri uri) "https:" -> readHttpUri (reslashUri uri) scheme -> throwE (GenericAppError ("Unrecognised uri scheme: " <> T.pack scheme)) -readFirstAvailableResource :: (MonadResource m, MonadCatch m) => AWS.Env -> [Location] -> m (Either AppError (LBS.ByteString, Location)) -readFirstAvailableResource _ [] = return (Left (GenericAppError "No resources specified in read")) -readFirstAvailableResource envAws (a:as) = do - result <- readResource envAws a +readFirstAvailableResource :: (MonadResource m, MonadCatch m) => AWS.Env -> [Location] -> Int -> m (Either AppError (LBS.ByteString, Location)) +readFirstAvailableResource _ [] _ = return (Left (GenericAppError "No resources specified in read")) +readFirstAvailableResource envAws (a:as) maxRetries = do + result <- readResource envAws maxRetries a case result of Right lbs -> return $ Right (lbs, a) Left e -> if null as then return $ Left e - else readFirstAvailableResource envAws as + else readFirstAvailableResource envAws as maxRetries safePathIsSymbolLink :: FilePath -> IO Bool safePathIsSymbolLink filePath = catch (IO.pathIsSymbolicLink filePath) handler @@ -154,10 +155,10 @@ reslashChar '\\' = '/' reslashChar c = c -writeResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> LBS.ByteString -> ExceptT AppError m () -writeResource envAws loc lbs = ExceptT $ case loc of +writeResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> Int -> LBS.ByteString -> ExceptT AppError m () +writeResource envAws loc maxRetries lbs = ExceptT $ case loc of Local path -> liftIO (LBS.writeFile path lbs) >> return (Right ()) - Uri uri -> runExceptT $ retryS3 $ case uri ^. the @"uriScheme" of + Uri uri -> runExceptT $ retryS3 maxRetries $ case uri ^. the @"uriScheme" of "s3:" -> uploadToS3 envAws (reslashUri uri) lbs "http:" -> throwE (GenericAppError "HTTP PUT method not supported") scheme -> throwE (GenericAppError ("Unrecognised uri scheme: " <> T.pack scheme)) @@ -201,20 +202,19 @@ retryUnless :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m a -> ExceptT e m a retryUnless p = retryWhen (not . p) -retryS3 :: MonadIO m => ExceptT AppError m a -> ExceptT AppError m a -retryS3 a = do - retries <- (fromMaybe 3 . join) <$> liftIO (lookupEnv "CABAL_CACHE_RETRY" >>= \s -> return (readMaybe @Int <$> s)) - retryUnless (\appe -> case appErrorStatus appe of - Just 402 -> False - Just 408 -> False - Just 410 -> False - Just 425 -> False - Just 429 -> False - Just i - | i >= 500 - , i < 600 -> False - Just _ -> True - Nothing -> True) retries a +retryS3 :: MonadIO m => Int -> ExceptT AppError m a -> ExceptT AppError m a +retryS3 maxRetries a = do + retryWhen retryPredicate maxRetries a + where + retryPredicate appe = case appErrorStatus appe of + Just i -> i `elem` retryableHTTPStatuses + Nothing -> False + + -- https://docs.aws.amazon.com/AmazonS3/latest/API/ErrorResponses.html#ErrorCodeList + -- https://stackoverflow.com/a/51770411/2976251 + -- another note: linode rate limiting returns 503 +retryableHTTPStatuses :: [Int] +retryableHTTPStatuses = [408, 409, 425, 426, 502, 503, 504] linkOrCopyResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> Location -> ExceptT AppError m () linkOrCopyResource envAws source target = case source of