cabal-cache 1.0.5.4 → 1.0.5.5
raw patch · 5 files changed
+48/−32 lines, 5 files
Files
- app/App/Commands/Options/Types.hs +2/−0
- app/App/Commands/SyncFromArchive.hs +8/−1
- app/App/Commands/SyncToArchive.hs +8/−1
- cabal-cache.cabal +1/−1
- src/HaskellWorks/CabalCache/IO/Lazy.hs +29/−29
app/App/Commands/Options/Types.hs view
@@ -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)
app/App/Commands/SyncFromArchive.hs view
@@ -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 =
app/App/Commands/SyncToArchive.hs view
@@ -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 =
cabal-cache.cabal view
@@ -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
src/HaskellWorks/CabalCache/IO/Lazy.hs view
@@ -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