cabal-cache 1.0.0.6 → 1.0.0.7

raw patch · 3 files changed

+48/−40 lines, 3 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 +29/−35
• src/HaskellWorks/CabalCache/IO/Lazy.hs +18/−4

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

@@ -155,41 +155,27 @@                   return True                 else if storeDirectoryExists                   then return True-                  else do-                    maybeExistingArchiveFile <- IO.firstExistingResource envAws [scopedArchiveFile, archiveFile]-                    case maybeExistingArchiveFile of-                      Just existingArchiveFile -> do-                        CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile-                        runResAws envAws $ onErrorClean packageStorePath False $ do-                          maybeArchiveFileContents <- IO.readResource envAws existingArchiveFile+                  else runResAws envAws $ onError (cleanupStorePath packageStorePath packageId) False $ do+                    (existingArchiveFileContents, existingArchiveFile) <- ExceptT $ IO.readFirstAvailableResource envAws [scopedArchiveFile, archiveFile]+                    CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile -                          case maybeArchiveFileContents of-                            Just archiveFileContents -> do-                              existingArchiveFileContents <- IO.readResource envAws existingArchiveFile & maybeToExceptM (GenericAppError ("Archive unavailable: " <> toText archiveFile))-                              let tempArchiveFile = tempPath </> archiveBaseName-                              liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents-                              IO.extractTar tempArchiveFile storePath+                    let tempArchiveFile = tempPath </> archiveBaseName+                    liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents+                    IO.extractTar tempArchiveFile storePath -                              meta <- loadMetadata packageStorePath-                              oldStorePath <- maybeToExcept "store-path is missing from Metadata" (Map.lookup "store-path" meta)+                    meta <- loadMetadata packageStorePath+                    oldStorePath <- maybeToExcept "store-path is missing from Metadata" (Map.lookup "store-path" meta) -                              case confPath pInfo of-                                Tagged conf _ -> do-                                  let theConfPath = storePath </> conf-                                  let tempConfPath = tempPath </> conf-                                  confPathExists <- liftIO $ IO.doesFileExist theConfPath-                                  when confPathExists $ do-                                    confContents <- liftIO $ LBS.readFile theConfPath-                                    liftIO $ LBS.writeFile tempConfPath (replace (LBS.toStrict oldStorePath) (C8.pack storePath) confContents)-                                    liftIO $ IO.renamePath tempConfPath theConfPath-                                  return True-                            Nothing -> do-                              CIO.putStrLn $ "Archive unavailable: " <> toText existingArchiveFile-                              deleteMetadata packageStorePath-                              return False-                      Nothing -> do-                        CIO.hPutStrLn IO.stderr $ "Warning: Sync failure: " <> packageId-                        return False+                    case confPath pInfo of+                      Tagged conf _ -> do+                        let theConfPath = storePath </> conf+                        let tempConfPath = tempPath </> conf+                        confPathExists <- liftIO $ IO.doesFileExist theConfPath+                        when confPathExists $ do+                          confContents <- liftIO $ LBS.readFile theConfPath+                          liftIO $ LBS.writeFile tempConfPath (replace (LBS.toStrict oldStorePath) (C8.pack storePath) confContents)+                          liftIO $ IO.renamePath tempConfPath theConfPath+                        return True           Nothing -> do             CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId             return True@@ -208,13 +194,21 @@    return () -onErrorClean :: MonadIO m => FilePath -> a -> ExceptT AppError m a -> m a-onErrorClean pkgStorePath failureValue f = do+cleanupStorePath :: MonadIO m => FilePath -> Z.PackageId -> AppError -> m ()+cleanupStorePath packageStorePath packageId e = do+  CIO.hPutStrLn IO.stderr $ "Warning: Sync failure: " <> packageId+  deleteStorePath packageStorePath++deleteStorePath :: MonadIO m => FilePath -> m ()+deleteStorePath pkgStorePath = liftIO (IO.removeDirectoryRecursive pkgStorePath)++onError :: MonadIO m => (AppError -> m ()) -> a -> ExceptT AppError m a -> m a+onError h failureValue f = do   result <- runExceptT $ catchError (exceptWarn f) handler   case result of     Left a  -> return failureValue     Right a -> return a-  where handler e = liftIO (IO.removeDirectoryRecursive pkgStorePath) >> return failureValue+  where handler e = lift (h e) >> return failureValue  cmdSyncFromArchive :: Mod CommandFields (IO ()) cmdSyncFromArchive = command "sync-from-archive"  $ flip info idm $ runSyncFromArchive <$> optsSyncFromArchive

@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module HaskellWorks.CabalCache.IO.Lazy   ( readResource+  , readFirstAvailableResource   , resourceExists   , firstExistingResource   , headS3Uri@@ -72,11 +73,24 @@       _                               -> return (Left (GenericAppError (tshow e)))     _                                 -> throwM e -readResource :: MonadResource m => AWS.Env -> Location -> m (Maybe LBS.ByteString)+getS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either AppError LBS.ByteString)+getS3Uri envAws (AWS.S3Uri b k) = handleAwsError $ runAws envAws $ AWS.unsafeDownload b k++readResource :: (MonadResource m, MonadCatch m) => AWS.Env -> Location -> m (Either AppError LBS.ByteString) readResource envAws = \case-  S3 s3Uri        -> runAws envAws $ AWS.downloadFromS3Uri s3Uri-  Local path      -> liftIO $ Just          <$> LBS.readFile path-  HttpUri httpUri -> liftIO $ rightToMaybe  <$> readHttpUri httpUri+  S3 s3Uri        -> getS3Uri envAws s3Uri+  Local path      -> liftIO $ Right <$> LBS.readFile path+  HttpUri httpUri -> liftIO $ readHttpUri httpUri++readFirstAvailableResource :: (MonadResource m, MonadCatch m) => AWS.Env -> [Location] -> m (Either AppError (LBS.ByteString, Location))+readFirstAvailableResource envAws [] = return (Left (GenericAppError "No resources specified in read"))+readFirstAvailableResource envAws (a:as) = do+  result <- readResource envAws a+  case result of+    Right lbs -> return $ Right (lbs, a)+    Left e -> if null as+      then return $ Left e+      else readFirstAvailableResource envAws as  safePathIsSymbolLink :: FilePath -> IO Bool safePathIsSymbolLink filePath = catch (IO.pathIsSymbolicLink filePath) handler