cabal-cache 1.0.0.9 → 1.0.0.10

raw patch · 4 files changed

+23/−26 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• cabal-cache.cabal +1/−1
• src/App/Commands/SyncFromArchive.hs +3/−8
• src/App/Commands/SyncToArchive.hs +12/−14
• src/HaskellWorks/CabalCache/IO/Lazy.hs +7/−3

@@ -1,7 +1,7 @@ cabal-version:          2.2  name:                   cabal-cache-version:                1.0.0.9+version:                1.0.0.10 synopsis:               CI Assistant for Haskell projects description:            CI Assistant for Haskell projects.  Implements package caching. homepage:               https://github.com/haskell-works/cabal-cache

@@ -112,12 +112,6 @@        let pInfos = M.fromList $ fmap (\p -> (p ^. the @"packageId", p)) packages -      -- forM_ planDeps $ \(a, b) -> do-      --   let maybeName = M.lookup a planPackages <&> (^. the @"name")-      --   case maybeName of-      --     Just name -> CIO.putStrLn $ name <> " " <> a <> " -> " <> b-      --     Nothing   -> CIO.putStrLn $ "*********" <> a <> " -> " <> b-       IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do         IO.createDirectoryIfMissing True (tempPath </> T.unpack compilerId </> "package.db") @@ -141,7 +135,7 @@                 else if storeDirectoryExists                   then return True                   else runResAws envAws $ onError (cleanupStorePath packageStorePath packageId) False $ do-                    (existingArchiveFileContents, existingArchiveFile) <- ExceptT $ IO.readFirstAvailableResource envAws [scopedArchiveFile, archiveFile]+                    (existingArchiveFileContents, existingArchiveFile) <- ExceptT $ IO.readFirstAvailableResource envAws [archiveFile, scopedArchiveFile]                     CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile                      let tempArchiveFile = tempPath </> archiveBaseName@@ -180,7 +174,8 @@ cleanupStorePath :: (MonadIO m, MonadCatch m) => FilePath -> Z.PackageId -> AppError -> m () cleanupStorePath packageStorePath packageId e = do   CIO.hPutStrLn IO.stderr $ "Warning: Sync failure: " <> packageId <> ", reason: " <> displayAppError e-  void $ IO.removePathRecursive packageStorePath+  pathExists <- liftIO $ IO.doesPathExist packageStorePath+  when pathExists $ void $ IO.removePathRecursive packageStorePath  onError :: MonadIO m => (AppError -> m ()) -> a -> ExceptT AppError m a -> m a onError h failureValue f = do

@@ -116,28 +116,26 @@                 liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath                  let rp2 = Z.relativePaths storePath pInfo-                CIO.putStrLn $ "Creating " <> toText scopedArchiveFile+                -- either write "normal" package, or a user-specific one if the package cannot be shared+                let targetFile = if canShare planData (Z.packageId pInfo) then archiveFile else scopedArchiveFile +                CIO.putStrLn $ "Creating " <> toText targetFile+                 let tempArchiveFile = tempPath </> archiveFileBasename                  metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)]                  IO.createTar tempArchiveFile (metas:rp2) -                void $ liftIO (LBS.readFile tempArchiveFile >>= IO.writeResource envAws scopedArchiveFile)--                when (canShare planData (Z.packageId pInfo)) $ do-                  void $ 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--                    _ -> return ()+                void $ catchError (liftIO (LBS.readFile tempArchiveFile) >>= IO.writeResource envAws targetFile) $ \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 -                  return ()+                  _ -> return ()      Left (appError :: AppError) -> do       CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError

@@ -68,7 +68,11 @@ readResource :: (MonadResource m, MonadCatch m) => AWS.Env -> Location -> m (Either AppError LBS.ByteString) readResource envAws = \case   S3 s3Uri        -> getS3Uri envAws s3Uri-  Local path      -> liftIO $ Right <$> LBS.readFile path+  Local path      -> liftIO $ do+    fileExists <- IO.doesFileExist path+    if fileExists+      then Right <$> LBS.readFile path+      else pure (Left NotFound)   HttpUri httpUri -> liftIO $ readHttpUri httpUri  readFirstAvailableResource :: (MonadResource m, MonadCatch m) => AWS.Env -> [Location] -> m (Either AppError (LBS.ByteString, Location))@@ -121,8 +125,8 @@   let po  = AWS.putObject b k req   handleAwsError $ void $ runResAws envAws $ AWS.send po -writeResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> LBS.ByteString -> m (Either AppError ())-writeResource envAws loc lbs = case loc of+writeResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> LBS.ByteString -> ExceptT AppError m ()+writeResource envAws loc lbs = ExceptT $ case loc of   S3 s3Uri   -> uploadToS3 envAws s3Uri lbs   Local path -> liftIO (LBS.writeFile path lbs) >> return (Right ())   HttpUri _  -> return (Left (GenericAppError "HTTP PUT method not supported"))