cabal-cache 1.0.0.3 → 1.0.0.4

raw patch · 10 files changed

+239/−108 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• cabal-cache.cabal +3/−1
• src/App/Commands/SyncFromArchive.hs +7/−5
• src/App/Commands/SyncToArchive.hs +46/−24
• src/HaskellWorks/CabalCache/AppError.hs +40/−0
• src/HaskellWorks/CabalCache/Core.hs +16/−14
• src/HaskellWorks/CabalCache/IO/Error.hs +9/−7
• src/HaskellWorks/CabalCache/IO/Lazy.hs +83/−31
• src/HaskellWorks/CabalCache/IO/Tar.hs +7/−6
• src/HaskellWorks/CabalCache/Location.hs +21/−17
• test/HaskellWorks/CabalCache/AwsSpec.hs +7/−3

@@ -1,7 +1,7 @@ cabal-version:          2.2  name:                   cabal-cache-version:                1.0.0.3+version:                1.0.0.4 synopsis:               CI Assistant for Haskell projects description:            CI Assistant for Haskell projects.  Implements package caching. homepage:               https://github.com/haskell-works/cabal-cache@@ -108,6 +108,7 @@       App.Commands.Version       App.Static       HaskellWorks.CabalCache.AWS.Env+      HaskellWorks.CabalCache.AppError       HaskellWorks.CabalCache.Concurrent.DownloadQueue       HaskellWorks.CabalCache.Concurrent.Fork       HaskellWorks.CabalCache.Concurrent.Type@@ -149,6 +150,7 @@           , generic-lens           , hedgehog           , hspec+          , http-types           , hw-hedgehog           , hw-hspec-hedgehog           , lens

@@ -23,6 +23,7 @@ import Data.Maybe import Data.Semigroup                   ((<>)) import Data.Text                        (Text)+import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.Core     (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan) import HaskellWorks.CabalCache.IO.Error (exceptWarn, maybeToExcept, maybeToExceptM) import HaskellWorks.CabalCache.Location ((<.>), (</>))@@ -59,6 +60,7 @@ import qualified System.Directory                                 as IO import qualified System.IO                                        as IO import qualified System.IO.Temp                                   as IO+import qualified System.IO.Unsafe                                 as IO import qualified UnliftIO.Async                                   as IO  {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}@@ -89,7 +91,7 @@   mbPlan <- loadPlan   case mbPlan of     Right planJson -> do-      envAws <- mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)+      envAws <- IO.unsafeInterleaveIO $ mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)       let compilerId                  = planJson ^. the @"compilerId"       let archivePath                 = versionedArchiveUri </> compilerId       let storeCompilerPath           = storePath </> T.unpack compilerId@@ -163,7 +165,7 @@                            case maybeArchiveFileContents of                             Just archiveFileContents -> do-                              existingArchiveFileContents <- IO.readResource envAws existingArchiveFile & maybeToExceptM ("Archive unavailable: " <> show (toText archiveFile))+                              existingArchiveFileContents <- IO.readResource envAws existingArchiveFile & maybeToExceptM (GenericAppError ("Archive unavailable: " <> toText archiveFile))                               let tempArchiveFile = tempPath </> archiveBaseName                               liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents                               IO.extractTar tempArchiveFile storePath@@ -201,12 +203,12 @@        forM_ failures $ \packageId -> CIO.hPutStrLn IO.stderr $ "Failed to download: " <> packageId -    Left errorMessage -> do-      CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> T.pack errorMessage+    Left appError -> do+      CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError    return () -onErrorClean :: MonadIO m => FilePath -> a -> ExceptT String m a -> m a+onErrorClean :: MonadIO m => FilePath -> a -> ExceptT AppError m a -> m a onErrorClean pkgStorePath failureValue f = do   result <- runExceptT $ catchError (exceptWarn f) handler   case result of

@@ -1,4 +1,6 @@+{-# LANGUAGE BlockArguments      #-} {-# LANGUAGE DataKinds           #-}+{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications    #-}@@ -19,6 +21,7 @@ import Data.List                        (isSuffixOf, (\\)) import Data.Maybe import Data.Semigroup                   ((<>))+import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.Core     (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan, relativePaths) import HaskellWorks.CabalCache.Location ((<.>), (</>)) import HaskellWorks.CabalCache.Metadata (createMetadata)@@ -31,6 +34,7 @@ import qualified App.Commands.Options.Types         as Z import qualified Codec.Archive.Tar                  as F import qualified Codec.Compression.GZip             as F+import qualified Control.Concurrent.STM             as STM import qualified Data.ByteString.Lazy               as LBS import qualified Data.ByteString.Lazy.Char8         as LC8 import qualified Data.Set                           as Set@@ -45,10 +49,12 @@ import qualified HaskellWorks.CabalCache.IO.Lazy    as IO import qualified HaskellWorks.CabalCache.IO.Tar     as IO import qualified HaskellWorks.CabalCache.Types      as Z+import qualified Network.HTTP.Types                 as HTTP import qualified System.Directory                   as IO import qualified System.FilePath.Posix              as FP import qualified System.IO                          as IO import qualified System.IO.Temp                     as IO+import qualified System.IO.Unsafe                   as IO import qualified UnliftIO.Async                     as IO  {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}@@ -71,16 +77,17 @@   CIO.putStrLn $ "Threads: "          <> tshow threads   CIO.putStrLn $ "AWS Log level: "    <> tshow awsLogLevel +  tEarlyExit <- STM.newTVarIO False+   mbPlan <- loadPlan   case mbPlan of     Right planJson -> do       let compilerId = planJson ^. the @"compilerId"-      envAws <- mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)+      envAws <- IO.unsafeInterleaveIO $ mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)       let archivePath       = versionedArchiveUri </> compilerId       let scopedArchivePath = scopedArchiveUri </> compilerId       IO.createLocalDirectoryIfMissing archivePath       IO.createLocalDirectoryIfMissing scopedArchivePath-      CIO.putStrLn "Extracting package list"        packages     <- getPackages storePath planJson       nonShareable <- packages & filterM (fmap not . isShareable storePath)@@ -100,38 +107,53 @@         CIO.putStrLn $ "Temp path: " <> tshow tempPath          IO.pooledForConcurrentlyN_ (opts ^. the @"threads") packages $ \pInfo -> do-          let archiveFileBasename = packageDir pInfo <.> ".tar.gz"-          let archiveFile         = versionedArchiveUri </> T.pack archiveFileBasename-          let scopedArchiveFile   = versionedArchiveUri </> T.pack storePathHash </> T.pack archiveFileBasename-          let packageStorePath    = storePath </> packageDir pInfo-          let packageSharePath    = packageStorePath </> "share"-          archiveFileExists <- runResourceT $ IO.resourceExists envAws scopedArchiveFile+          earlyExit <- STM.readTVarIO tEarlyExit+          CIO.putStrLn $ "Stuff"+          unless earlyExit $ do+            let archiveFileBasename = packageDir pInfo <.> ".tar.gz"+            let archiveFile         = versionedArchiveUri </> T.pack archiveFileBasename+            let scopedArchiveFile   = versionedArchiveUri </> T.pack storePathHash </> T.pack archiveFileBasename+            let packageStorePath    = storePath </> packageDir pInfo+            let packageSharePath    = packageStorePath </> "share"+            archiveFileExists <- runResourceT $ IO.resourceExists envAws scopedArchiveFile -          unless archiveFileExists $ do-            packageStorePathExists <- doesDirectoryExist packageStorePath+            unless archiveFileExists $ do+              packageStorePathExists <- doesDirectoryExist packageStorePath -            when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn $ do-              let workingStorePackagePath = tempPath </> packageDir pInfo-              liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath+              when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn $ do+                let workingStorePackagePath = tempPath </> packageDir pInfo+                liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath -              let rp2 = relativePaths storePath pInfo-              CIO.putStrLn $ "Creating " <> toText scopedArchiveFile+                let rp2 = relativePaths storePath pInfo+                CIO.putStrLn $ "Creating " <> toText scopedArchiveFile -              let tempArchiveFile = tempPath </> archiveFileBasename+                let tempArchiveFile = tempPath </> archiveFileBasename -              metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)]+                metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)] -              IO.createTar tempArchiveFile (metas:rp2)+                IO.createTar tempArchiveFile (metas:rp2) -              liftIO (LBS.readFile tempArchiveFile >>= IO.writeResource envAws scopedArchiveFile)+                liftIO (LBS.readFile tempArchiveFile >>= IO.writeResource envAws scopedArchiveFile) -              when (canShare planData (packageId pInfo)) $-                IO.linkOrCopyResource envAws scopedArchiveFile archiveFile+                when (canShare planData (packageId pInfo)) $ do+                  copyResult <- catchError (IO.linkOrCopyResource envAws scopedArchiveFile archiveFile) $ \case+                    e@(AwsAppError (HTTP.Status 301 _)) -> do+                      liftIO $ STM.atomically $ STM.writeTVar tEarlyExit True+                      CIO.hPutStrLn IO.stderr $ mempty+                        <> "ERROR: No write access to archive uris: "+                        <> tshow (fmap toText [scopedArchiveFile, archiveFile])+                        <> " " <> displayAppError e -    Left errorMessage -> do-      CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> T.pack errorMessage+                    _ -> return () -  return ()+                  return ()++    Left (appError :: AppError) -> do+      CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError++  earlyExit <- STM.readTVarIO tEarlyExit++  when earlyExit $ CIO.hPutStrLn IO.stderr $ "Early exit due to error"  isShareable :: MonadIO m => FilePath -> PackageInfo -> m Bool isShareable storePath pkg =

@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.CabalCache.AppError+  ( AppError(..)+  , displayAppError+  , appErrorStatus+  ) where++import Data.String+import Data.Text                    (Text)+import GHC.Generics+import HaskellWorks.CabalCache.Show++import qualified Data.Text          as T+import qualified Network.HTTP.Types as HTTP++data AppError+  = AwsAppError+    { status :: HTTP.Status+    }+  | HttpAppError+    { status :: HTTP.Status+    }+  | RetriesFailedAppError+  | NotFound+  | GenericAppError Text+  deriving (Eq, Show, Generic)++instance IsString AppError where+  fromString = GenericAppError . T.pack++displayAppError :: AppError -> Text+displayAppError (AwsAppError status)  = tshow status+displayAppError RetriesFailedAppError = "Multiple retries failed"+displayAppError (GenericAppError msg) = msg++appErrorStatus :: AppError -> Maybe Int+appErrorStatus (AwsAppError (HTTP.Status statusCode _)) = Just statusCode+appErrorStatus _                                        = Nothing

@@ -14,17 +14,20 @@   , loadPlan   ) where -import Control.DeepSeq           (NFData)-import Control.Lens              hiding ((<.>))-import Control.Monad             (forM)-import Data.Aeson                (eitherDecode)-import Data.Bool                 (bool)-import Data.Generics.Product.Any (the)-import Data.Maybe                (maybeToList)-import Data.Semigroup            ((<>))-import Data.Text                 (Text)-import GHC.Generics              (Generic)-import System.FilePath           ((<.>), (</>))+import Control.DeepSeq                  (NFData)+import Control.Lens                     hiding ((<.>))+import Control.Monad                    (forM)+import Data.Aeson                       (eitherDecode)+import Data.Bifunctor                   (first)+import Data.Bool                        (bool)+import Data.Generics.Product.Any        (the)+import Data.Maybe                       (maybeToList)+import Data.Semigroup                   ((<>))+import Data.String+import Data.Text                        (Text)+import GHC.Generics                     (Generic)+import HaskellWorks.CabalCache.AppError+import System.FilePath                  ((<.>), (</>))  import qualified Data.ByteString.Lazy           as LBS import qualified Data.List                      as List@@ -70,9 +73,8 @@         predicate :: Z.Package -> Bool         predicate package = True -loadPlan :: IO (Either String Z.PlanJson)-loadPlan =-  eitherDecode <$> LBS.readFile ("dist-newstyle" </> "cache" </> "plan.json")+loadPlan :: IO (Either AppError Z.PlanJson)+loadPlan = (first fromString . eitherDecode) <$> LBS.readFile ("dist-newstyle" </> "cache" </> "plan.json")  ------------------------------------------------------------------------------- mkPackageInfo :: FilePath -> Z.CompilerId -> Z.Package -> IO PackageInfo

@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}  module HaskellWorks.CabalCache.IO.Error   ( exceptFatal@@ -9,27 +10,28 @@  import Control.Monad.Except import Control.Monad.IO.Class+import HaskellWorks.CabalCache.AppError  import qualified Data.Text                          as T import qualified HaskellWorks.CabalCache.IO.Console as CIO import qualified System.Exit                        as IO import qualified System.IO                          as IO -exceptFatal :: MonadIO m => ExceptT String m a -> ExceptT String m a+exceptFatal :: MonadIO m => ExceptT AppError m a -> ExceptT AppError m a exceptFatal f = catchError f handler   where handler e = do-          liftIO . CIO.hPutStrLn IO.stderr . T.pack $ "Fatal Error: " <> e+          liftIO . CIO.hPutStrLn IO.stderr $ "Fatal Error: " <> displayAppError e           liftIO IO.exitFailure           throwError e -exceptWarn :: MonadIO m => ExceptT String m a -> ExceptT String m a+exceptWarn :: MonadIO m => ExceptT AppError m a -> ExceptT AppError m a exceptWarn f = catchError f handler   where handler e = do-          liftIO . CIO.hPutStrLn IO.stderr . T.pack $ "Warning: " <> e+          liftIO . CIO.hPutStrLn IO.stderr $ "Warning: " <> displayAppError e           throwError e -maybeToExcept :: Monad m => String -> Maybe a -> ExceptT String m a+maybeToExcept :: Monad m => AppError -> Maybe a -> ExceptT AppError m a maybeToExcept message = maybe (throwError message) pure -maybeToExceptM :: Monad m => String -> m (Maybe a) -> ExceptT String m a+maybeToExceptM :: Monad m => AppError -> m (Maybe a) -> ExceptT AppError m a maybeToExceptM message = ExceptT . fmap (maybe (Left message) Right)

@@ -9,6 +9,7 @@   , writeResource   , createLocalDirectoryIfMissing   , linkOrCopyResource+  , readHttpUri   ) where  import Antiope.Core@@ -22,10 +23,12 @@ import Data.Conduit.Lazy                (lazyConsume) import Data.Either                      (isRight) import Data.Text                        (Text)+import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.Location (Location (..)) import HaskellWorks.CabalCache.Show import Network.AWS                      (MonadAWS, chunkedFile) import Network.AWS.Data.Body            (_streamBody)+import Network.HTTP.Types.Status        (statusCode)  import qualified Antiope.S3.Lazy                    as AWS import qualified Antiope.S3.Types                   as AWS@@ -39,6 +42,7 @@ import qualified Network.AWS.S3.CopyObject          as AWS import qualified Network.AWS.S3.HeadObject          as AWS import qualified Network.AWS.S3.PutObject           as AWS+import qualified Network.HTTP.Client                as HTTP import qualified Network.HTTP.Types                 as HTTP import qualified System.Directory                   as IO import qualified System.FilePath.Posix              as FP@@ -49,10 +53,30 @@ {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-} {-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-} +rightToMaybe :: Either e a -> Maybe a+rightToMaybe (Right a) = Just a+rightToMaybe _         = Nothing++handleAwsError :: MonadCatch m => m a -> m (Either AppError a)+handleAwsError f = catch (Right <$> f) $ \(e :: AWS.Error) ->+  case e of+    (AWS.ServiceError (AWS.ServiceError' _ status@(HTTP.Status 404 _) _ _ _ _)) -> return (Left (AwsAppError status))+    (AWS.ServiceError (AWS.ServiceError' _ status@(HTTP.Status 301 _) _ _ _ _)) -> return (Left (AwsAppError status))+    _                                                                           -> throwM e++handleHttpError :: (MonadCatch m, MonadIO m) => m a -> m (Either AppError a)+handleHttpError f = catch (Right <$> f) $ \(e :: HTTP.HttpException) ->+  case e of+    (HTTP.HttpExceptionRequest _ e) -> case e of+      HTTP.StatusCodeException resp _ -> return (Left (HttpAppError (resp & HTTP.responseStatus)))+      _                               -> return (Left (GenericAppError (tshow e)))+    _                                 -> throwM e+ readResource :: MonadResource m => AWS.Env -> Location -> m (Maybe LBS.ByteString) readResource envAws = \case-  S3 s3Uri    -> runAws envAws $ AWS.downloadFromS3Uri s3Uri-  Local path  -> liftIO $ Just <$> LBS.readFile path+  S3 s3Uri        -> runAws envAws $ AWS.downloadFromS3Uri s3Uri+  Local path      -> liftIO $ Just          <$> LBS.readFile path+  HttpUri httpUri -> liftIO $ rightToMaybe  <$> readHttpUri httpUri  safePathIsSymbolLink :: FilePath -> IO Bool safePathIsSymbolLink filePath = catch (IO.pathIsSymbolicLink filePath) handler@@ -63,7 +87,8 @@  resourceExists :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> Location -> m Bool resourceExists envAws = \case-  S3 s3Uri    -> isRight <$> runResourceT (headS3Uri envAws s3Uri)+  S3 s3Uri        -> isRight <$> runResourceT (headS3Uri envAws s3Uri)+  HttpUri httpUri -> isRight <$> headHttpUri httpUri   Local path  -> do     fileExists <- liftIO $ IO.doesFileExist path     if fileExists@@ -84,54 +109,64 @@     then return (Just a)     else firstExistingResource envAws as -headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either String AWS.HeadObjectResponse)-headS3Uri envAws (AWS.S3Uri b k) =-  catch (Right <$> runAws envAws (AWS.send (AWS.headObject b k))) $ \(e :: AWS.Error) ->-    case e of-      (AWS.ServiceError (AWS.ServiceError' _ (HTTP.Status 404 _) _ _ _ _)) -> return (Left "Not found")-      _                                                                    -> throwM e+headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either AppError AWS.HeadObjectResponse)+headS3Uri envAws (AWS.S3Uri b k) = handleAwsError $ runAws envAws $ AWS.send $ AWS.headObject b k  chunkSize :: AWS.ChunkSize chunkSize = AWS.ChunkSize (1024 * 1024) -uploadToS3 :: MonadUnliftIO m => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m ()+uploadToS3 :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m (Either AppError ()) uploadToS3 envAws (AWS.S3Uri b k) lbs = do   let req = AWS.toBody lbs   let po  = AWS.putObject b k req-  void $ runResAws envAws $ AWS.send po+  handleAwsError $ void $ runResAws envAws $ AWS.send po -writeResource :: MonadUnliftIO m => AWS.Env -> Location -> LBS.ByteString -> m ()+writeResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> LBS.ByteString -> m (Either AppError ()) writeResource envAws loc lbs = case loc of-  S3 s3Uri   -> uploadToS3 envAws s3Uri lbs-  Local path -> liftIO $ LBS.writeFile path lbs+  S3 s3Uri    -> uploadToS3 envAws s3Uri lbs+  Local path  -> liftIO (LBS.writeFile path lbs) >> return (Right ())+  HttpUri uri -> return (Left (GenericAppError "HTTP PUT method not supported"))  createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m () createLocalDirectoryIfMissing = \case-  S3 s3Uri   -> return ()-  Local path -> liftIO $ IO.createDirectoryIfMissing True path+  S3 s3Uri    -> return ()+  Local path  -> liftIO $ IO.createDirectoryIfMissing True path+  HttpUri uri -> return () -copyS3Uri :: MonadUnliftIO m => AWS.Env -> AWS.S3Uri -> AWS.S3Uri -> ExceptT String m ()+copyS3Uri :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> AWS.S3Uri -> ExceptT AppError m () copyS3Uri envAws (AWS.S3Uri sourceBucket sourceObjectKey) (AWS.S3Uri targetBucket targetObjectKey) = ExceptT $ do-  response <- runResourceT $ runAws envAws $ AWS.send (AWS.copyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey)-  let responseCode = response ^. AWS.corsResponseStatus-  if 200 <= responseCode && responseCode < 300-    then return (Right ())-    else do-      liftIO $ CIO.hPutStrLn IO.stderr $ "Error in S3 copy: " <> tshow response-      return (Left "")+  responseResult <- runResourceT $+    handleAwsError $ runAws envAws $ AWS.send (AWS.copyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey)+  case responseResult of+    Right response -> do+      let responseCode = response ^. AWS.corsResponseStatus+      if 200 <= responseCode && responseCode < 300+        then return (Right ())+        else do+          liftIO $ CIO.hPutStrLn IO.stderr $ "Error in S3 copy: " <> tshow response+          return (Left RetriesFailedAppError)+    Left msg -> return (Left msg) -retry :: MonadIO m => Int -> ExceptT String m () -> ExceptT String m ()-retry n f = catchError f $ \e -> if n > 0+retry :: (Show e, MonadIO m) => Int -> ExceptT e m () -> ExceptT e m ()+retry = retryWhen (const True)++retryWhen :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()+retryWhen p n f = catchError f $ \exception -> if n > 0   then do-    liftIO $ CIO.hPutStrLn IO.stderr $ "WARNING: " <> T.pack e <> " (retrying)"+    liftIO $ CIO.hPutStrLn IO.stderr $ "WARNING: " <> tshow exception <> " (retrying)"     liftIO $ IO.threadDelay 1000000-    retry (n - 1) f-  else throwError e+    if (p exception )+      then retry (n - 1) f+      else throwError exception+  else throwError exception -linkOrCopyResource :: MonadUnliftIO m => AWS.Env -> Location -> Location -> ExceptT String m ()+retryUnless :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m ()+retryUnless p = retryWhen (not . p)++linkOrCopyResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> Location -> ExceptT AppError m () linkOrCopyResource envAws source target = case source of   S3 sourceS3Uri -> case target of-    S3 targetS3Uri -> retry 3 (copyS3Uri envAws sourceS3Uri targetS3Uri)+    S3 targetS3Uri -> retryUnless ((== Just 301) . appErrorStatus) 3 (copyS3Uri envAws sourceS3Uri targetS3Uri)     Local _        -> throwError "Can't copy between different file backends"   Local sourcePath -> case target of     S3 _             -> throwError "Can't copy between different file backends"@@ -139,3 +174,20 @@       liftIO $ IO.createDirectoryIfMissing True (FP.takeDirectory targetPath)       targetPathExists <- liftIO $ IO.doesFileExist targetPath       unless targetPathExists $ liftIO $ IO.createFileLink sourcePath targetPath+  HttpUri uri -> throwError "HTTP PUT method not supported"++readHttpUri :: (MonadIO m, MonadCatch m) => Text -> m (Either AppError LBS.ByteString)+readHttpUri httpUri = handleHttpError $ do+  manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings+  request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("GET " <> httpUri))+  response <- liftIO $ HTTP.httpLbs request manager++  return $ HTTP.responseBody response++headHttpUri :: (MonadIO m, MonadCatch m) => Text -> m (Either AppError LBS.ByteString)+headHttpUri httpUri = handleHttpError $ do+  manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings+  request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("HEAD " <> httpUri))+  response <- liftIO $ HTTP.httpLbs request manager++  return $ HTTP.responseBody response

@@ -10,13 +10,14 @@   , extractTar   ) where -import Control.DeepSeq              (NFData)+import Control.DeepSeq                  (NFData) import Control.Lens import Control.Monad.Except-import Control.Monad.IO.Class       (MonadIO, liftIO)+import Control.Monad.IO.Class           (MonadIO, liftIO) import Data.Generics.Product.Any import Data.List import GHC.Generics+import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.Show  import qualified Data.Text                          as T@@ -30,22 +31,22 @@   , entryPaths :: [FilePath]   } deriving (Show, Eq, Generic, NFData) -createTar :: MonadIO m => FilePath -> [TarGroup] -> ExceptT String m ()+createTar :: MonadIO m => FilePath -> [TarGroup] -> ExceptT AppError m () createTar tarFile groups = do   let args = ["-zcf", tarFile] <> foldMap tarGroupToArgs groups   process <- liftIO $ IO.spawnProcess "tar" args   exitCode <- liftIO $ IO.waitForProcess process   case exitCode of     IO.ExitSuccess   -> return ()-    IO.ExitFailure n -> throwError ""+    IO.ExitFailure n -> throwError "Failed to create tar" -extractTar :: MonadIO m => FilePath -> FilePath -> ExceptT String m ()+extractTar :: MonadIO m => FilePath -> FilePath -> ExceptT AppError m () extractTar tarFile targetPath = do   process <- liftIO $ IO.spawnProcess "tar" ["-C", targetPath, "-zxf", tarFile]   exitCode <- liftIO $ IO.waitForProcess process   case exitCode of     IO.ExitSuccess   -> return ()-    IO.ExitFailure n -> throwError ""+    IO.ExitFailure n -> throwError "Failed to extract tar"  tarGroupToArgs :: TarGroup -> [String] tarGroupToArgs tarGroup = ["-C", tarGroup ^. the @"basePath"] <> tarGroup ^. the @"entryPaths"

@@ -16,7 +16,7 @@ import Data.Text    (Text) import GHC.Generics (Generic) -import qualified Data.Text       as Text+import qualified Data.Text       as T import qualified System.FilePath as FP  class IsPath a s | a -> s where@@ -29,22 +29,26 @@ data Location   = S3 S3Uri   | Local FilePath+  | HttpUri Text   deriving (Show, Eq, Generic)  instance ToText Location where-  toText (S3 uri)   = toText uri-  toText (Local p)  = Text.pack p+  toText (S3 uri)       = toText uri+  toText (Local p)      = T.pack p+  toText (HttpUri uri)  = uri  instance IsPath Location Text where-  (S3 b)    </> p = S3    (b </> p)-  (Local b) </> p = Local (b </> Text.unpack p)+  (S3      b) </> p = S3      (b </>          p)+  (Local   b) </> p = Local   (b </> T.unpack p)+  (HttpUri b) </> p = HttpUri (b </>          p) -  (S3 b)    <.> e = S3    (b <.> e)-  (Local b) <.> e = Local (b <.> Text.unpack e)+  (S3      b) <.> e = S3      (b <.>          e)+  (Local   b) <.> e = Local   (b <.> T.unpack e)+  (HttpUri b) <.> e = HttpUri (b <.>          e)  instance IsPath Text Text where-  b </> p = Text.pack (Text.unpack b FP.</> Text.unpack p)-  b <.> e = Text.pack (Text.unpack b FP.<.> Text.unpack e)+  b </> p = T.pack (T.unpack b FP.</> T.unpack p)+  b <.> e = T.pack (T.unpack b FP.<.> T.unpack e)  instance (a ~ Char) => IsPath [a] [a] where   b </> p = b FP.</> p@@ -59,16 +63,16 @@  toLocation :: Text -> Maybe Location toLocation txt = if-  | Text.isPrefixOf "s3://" txt'    -> either (const Nothing) (Just . S3) (fromText txt')-  | Text.isPrefixOf "file://" txt'  -> Just (Local (Text.unpack txt'))-  | Text.isInfixOf  "://" txt'      -> Nothing-  | otherwise                       -> Just (Local (Text.unpack txt'))-  where-    txt' = Text.strip txt+  | T.isPrefixOf "s3://" txt'    -> either (const Nothing) (Just . S3) (fromText txt')+  | T.isPrefixOf "file://" txt'  -> Just (Local (T.unpack txt'))+  | T.isPrefixOf "http://" txt'  -> Just (HttpUri txt')+  | T.isInfixOf  "://" txt'      -> Nothing+  | otherwise                       -> Just (Local (T.unpack txt'))+  where txt' = T.strip txt  ------------------------------------------------------------------------------- stripStart :: Text -> Text -> Text-stripStart what txt = fromMaybe txt (Text.stripPrefix what txt)+stripStart what txt = fromMaybe txt (T.stripPrefix what txt)  stripEnd :: Text -> Text -> Text-stripEnd what txt = fromMaybe txt (Text.stripSuffix what txt)+stripEnd what txt = fromMaybe txt (T.stripSuffix what txt)

@@ -11,11 +11,12 @@ import Control.Monad import Control.Monad.IO.Class import Data.Generics.Product.Any-import Data.Maybe                      (fromJust, isJust)+import Data.Maybe                       (fromJust, isJust)+import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.IO.Lazy import HaskellWorks.Hspec.Hedgehog import Hedgehog-import System.Environment              (lookupEnv)+import System.Environment               (lookupEnv) import Test.Hspec import Text.RawString.QQ @@ -25,6 +26,7 @@ import qualified Data.ByteString.Lazy          as LBS import qualified Data.ByteString.Lazy.Char8    as LBSC import qualified HaskellWorks.CabalCache.Types as Z+import qualified Network.HTTP.Types            as HTTP import qualified System.Environment            as IO  {-# ANN module ("HLint: ignore Redundant do"        :: String) #-}@@ -38,4 +40,6 @@     unless ci $ do       envAws <- liftIO $ mkEnv Oregon (const LBSC.putStrLn)       result <- liftIO $ runResourceT $ headS3Uri envAws $ AWS.S3Uri "jky-mayhem" "hjddhd"-      result === Left "Not found"+      result === Left AwsAppError+        { status = HTTP.Status { HTTP.statusCode = 404 , HTTP.statusMessage = "Not Found" }+        }