cabal-cache 1.0.1.2 → 1.0.1.3

raw patch · 8 files changed

+276/−226 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• cabal-cache.cabal +3/−2
• src/App/Commands/Options/Parser.hs +2/−88
• src/App/Commands/SyncFromArchive.hs +126/−76
• src/App/Commands/SyncToArchive.hs +99/−48
• src/HaskellWorks/CabalCache/Core.hs +10/−0
• src/HaskellWorks/CabalCache/Error.hs +9/−0
• src/HaskellWorks/CabalCache/GhcPkg.hs +23/−12
• src/HaskellWorks/CabalCache/Types.hs +4/−0

@@ -1,7 +1,7 @@ cabal-version:          2.2  name:                   cabal-cache-version:                1.0.1.2+version:                1.0.1.3 synopsis:               CI Assistant for Haskell projects description:            CI Assistant for Haskell projects.  Implements package caching. homepage:               https://github.com/haskell-works/cabal-cache@@ -110,12 +110,13 @@       App.Commands.SyncToArchive       App.Commands.Version       App.Static-      HaskellWorks.CabalCache.AWS.Env       HaskellWorks.CabalCache.AppError+      HaskellWorks.CabalCache.AWS.Env       HaskellWorks.CabalCache.Concurrent.DownloadQueue       HaskellWorks.CabalCache.Concurrent.Fork       HaskellWorks.CabalCache.Concurrent.Type       HaskellWorks.CabalCache.Core+      HaskellWorks.CabalCache.Error       HaskellWorks.CabalCache.GhcPkg       HaskellWorks.CabalCache.Hash       HaskellWorks.CabalCache.IO.Console

@@ -2,97 +2,11 @@  module App.Commands.Options.Parser where -import Antiope.Core                     (FromText, Region (..), fromText)-import Antiope.Options.Applicative-import App.Commands.Options.Types       (SyncFromArchiveOptions (..), SyncToArchiveOptions (..), VersionOptions (..))-import App.Static                       (homeDirectory)-import Control.Applicative-import HaskellWorks.CabalCache.Location (Location (..), toLocation, (</>))+import Antiope.Core               (FromText, fromText)+import App.Commands.Options.Types (VersionOptions (..)) import Options.Applicative  import qualified Data.Text as Text--optsSyncFromArchive :: Parser SyncFromArchiveOptions-optsSyncFromArchive = SyncFromArchiveOptions-  <$> option (auto <|> text)-      (  long "region"-      <> metavar "AWS_REGION"-      <> showDefault <> value Oregon-      <> help "The AWS region in which to operate"-      )-  <*> option (maybeReader (toLocation . Text.pack))-      (   long "archive-uri"-      <>  help "Archive URI to sync to"-      <>  metavar "S3_URI"-      <>  value (Local $ homeDirectory </> ".cabal" </> "archive")-      )-  <*> strOption-      (   long "store-path"-      <>  help "Path to cabal store"-      <>  metavar "DIRECTORY"-      <>  value (homeDirectory </> ".cabal" </> "store")-      )-  <*> optional-      ( strOption-        (   long "store-path-hash"-        <>  help "Store path hash (do not use)"-        <>  metavar "HASH"-        )-      )-  <*> option auto-      (   long "threads"-      <>  help "Number of concurrent threads"-      <>  metavar "NUM_THREADS"-      <>  value 4-      )-  <*> optional-      ( option autoText-        (   long "aws-log-level"-        <>  help "AWS Log Level.  One of (Error, Info, Debug, Trace)"-        <>  metavar "AWS_LOG_LEVEL"-        )-      )--optsSyncToArchive :: Parser SyncToArchiveOptions-optsSyncToArchive = SyncToArchiveOptions-  <$> option (auto <|> text)-      (  long "region"-      <> metavar "AWS_REGION"-      <> showDefault <> value Oregon-      <> help "The AWS region in which to operate"-      )-  <*> option (maybeReader (toLocation . Text.pack))-      (   long "archive-uri"-      <>  help "Archive URI to sync to"-      <>  metavar "S3_URI"-      <>  value (Local $ homeDirectory </> ".cabal" </> "archive")-      )-  <*> strOption-      (   long "store-path"-      <>  help "Path to cabal store"-      <>  metavar "DIRECTORY"-      <>  value (homeDirectory </> ".cabal" </> "store")-      )-  <*> optional-      ( strOption-        (   long "store-path-hash"-        <>  help "Store path hash (do not use)"-        <>  metavar "HASH"-        )-      )-  <*> option auto-      (   long "threads"-      <>  help "Number of concurrent threads"-      <>  metavar "NUM_THREADS"-      <>  value 4-      )-  <*> optional-      ( option autoText-        (   long "aws-log-level"-        <>  help "AWS Log Level.  One of (Error, Info, Debug, Trace)"-        <>  metavar "AWS_LOG_LEVEL"-        )-      )  optsVersion :: Parser VersionOptions optsVersion = pure VersionOptions

@@ -8,9 +8,13 @@   ( cmdSyncFromArchive   ) where -import Antiope.Core                     (runResAws, toText)+import Antiope.Core                     (Region (..), runResAws, toText) import Antiope.Env                      (mkEnv)-import App.Commands.Options.Parser      (optsSyncFromArchive)+import Antiope.Options.Applicative+import App.Commands.Options.Parser      (text)+import App.Commands.Options.Types       (SyncFromArchiveOptions (SyncFromArchiveOptions))+import App.Static                       (homeDirectory)+import Control.Applicative import Control.Lens                     hiding ((<.>)) import Control.Monad                    (unless, void, when) import Control.Monad.Catch              (MonadCatch)@@ -20,10 +24,10 @@ import Data.Generics.Product.Any        (the) import Data.Maybe import Data.Semigroup                   ((<>))-import Foreign.C.Error ( eXDEV )+import Foreign.C.Error                  (eXDEV) import HaskellWorks.CabalCache.AppError-import HaskellWorks.CabalCache.IO.Error (exceptWarn, maybeToExcept, catchErrno)-import HaskellWorks.CabalCache.Location ((<.>), (</>))+import HaskellWorks.CabalCache.IO.Error (catchErrno, exceptWarn, maybeToExcept)+import HaskellWorks.CabalCache.Location (Location (..), toLocation, (<.>), (</>)) import HaskellWorks.CabalCache.Metadata (loadMetadata) import HaskellWorks.CabalCache.Show import HaskellWorks.CabalCache.Version  (archiveVersion)@@ -75,99 +79,104 @@   CIO.putStrLn $ "Threads: "          <> tshow threads   CIO.putStrLn $ "AWS Log level: "    <> tshow awsLogLevel -  GhcPkg.testAvailability-   mbPlan <- Z.loadPlan+   case mbPlan of     Right planJson -> do-      envAws <- IO.unsafeInterleaveIO $ mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)-      let compilerId                  = planJson ^. the @"compilerId"-      let storeCompilerPath           = storePath </> T.unpack compilerId-      let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db"-      let storeCompilerLibPath        = storeCompilerPath </> "lib"+      compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson -      CIO.putStrLn "Creating store directories"-      createDirectoryIfMissing True storePath-      createDirectoryIfMissing True storeCompilerPath-      createDirectoryIfMissing True storeCompilerLibPath+      case compilerContextResult of+        Right compilerContext -> do+          GhcPkg.testAvailability compilerContext -      storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath+          envAws <- IO.unsafeInterleaveIO $ mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)+          let compilerId                  = planJson ^. the @"compilerId"+          let storeCompilerPath           = storePath </> T.unpack compilerId+          let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db"+          let storeCompilerLibPath        = storeCompilerPath </> "lib" -      unless storeCompilerPackageDbPathExists $ do-        CIO.putStrLn "Package DB missing. Creating Package DB"-        GhcPkg.init storeCompilerPackageDbPath+          CIO.putStrLn "Creating store directories"+          createDirectoryIfMissing True storePath+          createDirectoryIfMissing True storeCompilerPath+          createDirectoryIfMissing True storeCompilerLibPath -      packages <- Z.getPackages storePath planJson+          storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath -      let installPlan = planJson ^. the @"installPlan"-      let planPackages = M.fromList $ fmap (\p -> (p ^. the @"id", p)) installPlan+          unless storeCompilerPackageDbPathExists $ do+            CIO.putStrLn "Package DB missing. Creating Package DB"+            GhcPkg.init compilerContext storeCompilerPackageDbPath -      let planDeps0 = installPlan >>= \p -> fmap (p ^. the @"id", ) $ mempty-            <> (p ^. the @"depends")-            <> (p ^. the @"exeDepends")-            <> (p ^.. the @"components" . each . the @"lib" . each . the @"depends"    . each)-            <> (p ^.. the @"components" . each . the @"lib" . each . the @"exeDepends" . each)-      let planDeps  = planDeps0 <> fmap (\p -> ("[universe]", p ^. the @"id")) installPlan+          packages <- Z.getPackages storePath planJson -      downloadQueue <- STM.atomically $ DQ.createDownloadQueue planDeps+          let installPlan = planJson ^. the @"installPlan"+          let planPackages = M.fromList $ fmap (\p -> (p ^. the @"id", p)) installPlan -      let pInfos = M.fromList $ fmap (\p -> (p ^. the @"packageId", p)) packages+          let planDeps0 = installPlan >>= \p -> fmap (p ^. the @"id", ) $ mempty+                <> (p ^. the @"depends")+                <> (p ^. the @"exeDepends")+                <> (p ^.. the @"components" . each . the @"lib" . each . the @"depends"    . each)+                <> (p ^.. the @"components" . each . the @"lib" . each . the @"exeDepends" . each)+          let planDeps  = planDeps0 <> fmap (\p -> ("[universe]", p ^. the @"id")) installPlan -      IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do-        IO.createDirectoryIfMissing True (tempPath </> T.unpack compilerId </> "package.db")+          downloadQueue <- STM.atomically $ DQ.createDownloadQueue planDeps -        IO.forkThreadsWait threads $ DQ.runQueue downloadQueue $ \packageId -> case M.lookup packageId pInfos of-          Just pInfo -> do-            let archiveBaseName   = Z.packageDir pInfo <.> ".tar.gz"-            let archiveFile       = versionedArchiveUri </> T.pack archiveBaseName-            let scopedArchiveFile = scopedArchiveUri </> T.pack archiveBaseName-            let packageStorePath  = storePath </> Z.packageDir pInfo-            storeDirectoryExists <- doesDirectoryExist packageStorePath-            let maybePackage = M.lookup packageId planPackages+          let pInfos = M.fromList $ fmap (\p -> (p ^. the @"packageId", p)) packages -            case maybePackage of-              Nothing -> do-                CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageId-                return True-              Just package -> if skippable package-                then do-                  CIO.putStrLn $ "Skipping: " <> packageId-                  return True-                else if storeDirectoryExists-                  then return True-                  else runResAws envAws $ onError (cleanupStorePath packageStorePath packageId) False $ do-                    (existingArchiveFileContents, existingArchiveFile) <- ExceptT $ IO.readFirstAvailableResource envAws [archiveFile, scopedArchiveFile]-                    CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile+          IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do+            IO.createDirectoryIfMissing True (tempPath </> T.unpack compilerId </> "package.db") -                    let tempArchiveFile = tempPath </> archiveBaseName-                    liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents-                    IO.extractTar tempArchiveFile storePath+            IO.forkThreadsWait threads $ DQ.runQueue downloadQueue $ \packageId -> case M.lookup packageId pInfos of+              Just pInfo -> do+                let archiveBaseName   = Z.packageDir pInfo <.> ".tar.gz"+                let archiveFile       = versionedArchiveUri </> T.pack archiveBaseName+                let scopedArchiveFile = scopedArchiveUri </> T.pack archiveBaseName+                let packageStorePath  = storePath </> Z.packageDir pInfo+                storeDirectoryExists <- doesDirectoryExist packageStorePath+                let maybePackage = M.lookup packageId planPackages -                    meta <- loadMetadata packageStorePath-                    oldStorePath <- maybeToExcept "store-path is missing from Metadata" (Map.lookup "store-path" meta)+                case maybePackage of+                  Nothing -> do+                    CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageId+                    return True+                  Just package -> if skippable package+                    then do+                      CIO.putStrLn $ "Skipping: " <> packageId+                      return True+                    else if storeDirectoryExists+                      then return True+                      else runResAws envAws $ onError (cleanupStorePath packageStorePath packageId) False $ do+                        (existingArchiveFileContents, existingArchiveFile) <- ExceptT $ IO.readFirstAvailableResource envAws [archiveFile, scopedArchiveFile]+                        CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile -                    case Z.confPath pInfo of-                      Z.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 $ catchErrno [eXDEV] (IO.renameFile tempConfPath theConfPath) (IO.copyFile tempConfPath theConfPath >> IO.removeFile tempConfPath)+                        let tempArchiveFile = tempPath </> archiveBaseName+                        liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents+                        IO.extractTar tempArchiveFile storePath -                        return True-          Nothing -> do-            CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId-            return True+                        meta <- loadMetadata packageStorePath+                        oldStorePath <- maybeToExcept "store-path is missing from Metadata" (Map.lookup "store-path" meta) -      CIO.putStrLn "Recaching package database"-      GhcPkg.recache storeCompilerPackageDbPath+                        case Z.confPath pInfo of+                          Z.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 $ catchErrno [eXDEV] (IO.renameFile tempConfPath theConfPath) (IO.copyFile tempConfPath theConfPath >> IO.removeFile tempConfPath) -      failures <- STM.atomically $ STM.readTVar $ downloadQueue ^. the @"tFailures"+                            return True+              Nothing -> do+                CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId+                return True -      forM_ failures $ \packageId -> CIO.hPutStrLn IO.stderr $ "Failed to download: " <> packageId+          CIO.putStrLn "Recaching package database"+          GhcPkg.recache compilerContext storeCompilerPackageDbPath +          failures <- STM.atomically $ STM.readTVar $ downloadQueue ^. the @"tFailures"++          forM_ failures $ \packageId -> CIO.hPutStrLn IO.stderr $ "Failed to download: " <> packageId+        Left msg -> CIO.hPutStrLn IO.stderr msg     Left appError -> do       CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError @@ -186,6 +195,47 @@     Left _  -> return failureValue     Right a -> return a   where handler e = lift (h e) >> return failureValue++optsSyncFromArchive :: Parser SyncFromArchiveOptions+optsSyncFromArchive = SyncFromArchiveOptions+  <$> option (auto <|> text)+      (  long "region"+      <> metavar "AWS_REGION"+      <> showDefault <> value Oregon+      <> help "The AWS region in which to operate"+      )+  <*> option (maybeReader (toLocation . T.pack))+      (   long "archive-uri"+      <>  help "Archive URI to sync to"+      <>  metavar "S3_URI"+      <>  value (Local $ homeDirectory </> ".cabal" </> "archive")+      )+  <*> strOption+      (   long "store-path"+      <>  help "Path to cabal store"+      <>  metavar "DIRECTORY"+      <>  value (homeDirectory </> ".cabal" </> "store")+      )+  <*> optional+      ( strOption+        (   long "store-path-hash"+        <>  help "Store path hash (do not use)"+        <>  metavar "HASH"+        )+      )+  <*> option auto+      (   long "threads"+      <>  help "Number of concurrent threads"+      <>  metavar "NUM_THREADS"+      <>  value 4+      )+  <*> optional+      ( option autoText+        (   long "aws-log-level"+        <>  help "AWS Log Level.  One of (Error, Info, Debug, Trace)"+        <>  metavar "AWS_LOG_LEVEL"+        )+      )  cmdSyncFromArchive :: Mod CommandFields (IO ()) cmdSyncFromArchive = command "sync-from-archive"  $ flip info idm $ runSyncFromArchive <$> optsSyncFromArchive

@@ -9,9 +9,13 @@   ( cmdSyncToArchive   ) where -import Antiope.Core                     (toText)+import Antiope.Core                     (Region (..), toText) import Antiope.Env                      (mkEnv)-import App.Commands.Options.Parser      (optsSyncToArchive)+import Antiope.Options.Applicative+import App.Commands.Options.Parser      (text)+import App.Commands.Options.Types       (SyncToArchiveOptions (SyncToArchiveOptions))+import App.Static                       (homeDirectory)+import Control.Applicative import Control.Lens                     hiding ((<.>)) import Control.Monad                    (filterM, unless, when) import Control.Monad.Except@@ -21,7 +25,7 @@ import Data.Maybe import Data.Semigroup                   ((<>)) import HaskellWorks.CabalCache.AppError-import HaskellWorks.CabalCache.Location ((<.>), (</>))+import HaskellWorks.CabalCache.Location (Location (..), toLocation, (<.>), (</>)) import HaskellWorks.CabalCache.Metadata (createMetadata) import HaskellWorks.CabalCache.Show import HaskellWorks.CabalCache.Topology (buildPlanData, canShare)@@ -33,6 +37,7 @@ 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.Text                          as Text import qualified Data.Text                          as T import qualified HaskellWorks.CabalCache.AWS.Env    as AWS import qualified HaskellWorks.CabalCache.Core       as Z@@ -75,70 +80,75 @@   mbPlan <- Z.loadPlan   case mbPlan of     Right planJson -> do-      let compilerId = planJson ^. the @"compilerId"-      envAws <- IO.unsafeInterleaveIO $ mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)-      let archivePath       = versionedArchiveUri </> compilerId-      let scopedArchivePath = scopedArchiveUri </> compilerId-      IO.createLocalDirectoryIfMissing archivePath-      IO.createLocalDirectoryIfMissing scopedArchivePath+      compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson -      packages     <- Z.getPackages storePath planJson-      nonShareable <- packages & filterM (fmap not . isShareable storePath)-      let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId")+      case compilerContextResult of+        Right compilerContext -> do+          let compilerId = planJson ^. the @"compilerId"+          envAws <- IO.unsafeInterleaveIO $ mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)+          let archivePath       = versionedArchiveUri </> compilerId+          let scopedArchivePath = scopedArchiveUri </> compilerId+          IO.createLocalDirectoryIfMissing archivePath+          IO.createLocalDirectoryIfMissing scopedArchivePath -      let storeCompilerPath           = storePath </> T.unpack compilerId-      let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db"+          packages     <- Z.getPackages storePath planJson+          nonShareable <- packages & filterM (fmap not . isShareable storePath)+          let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId") -      storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath+          let storeCompilerPath           = storePath </> T.unpack compilerId+          let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db" -      unless storeCompilerPackageDbPathExists $-        GhcPkg.init storeCompilerPackageDbPath+          storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath -      CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages"+          unless storeCompilerPackageDbPathExists $+            GhcPkg.init compilerContext storeCompilerPackageDbPath -      IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do-        CIO.putStrLn $ "Temp path: " <> tshow tempPath+          CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages" -        IO.pooledForConcurrentlyN_ (opts ^. the @"threads") packages $ \pInfo -> do-          earlyExit <- STM.readTVarIO tEarlyExit-          unless earlyExit $ do-            let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz"-            let archiveFile         = versionedArchiveUri </> T.pack archiveFileBasename-            let scopedArchiveFile   = versionedArchiveUri </> T.pack storePathHash </> T.pack archiveFileBasename-            let packageStorePath    = storePath </> Z.packageDir pInfo+          IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do+            CIO.putStrLn $ "Temp path: " <> tshow tempPath -            -- 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+            IO.pooledForConcurrentlyN_ (opts ^. the @"threads") packages $ \pInfo -> do+              earlyExit <- STM.readTVarIO tEarlyExit+              unless earlyExit $ do+                let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz"+                let archiveFile         = versionedArchiveUri </> T.pack archiveFileBasename+                let scopedArchiveFile   = versionedArchiveUri </> T.pack storePathHash </> T.pack archiveFileBasename+                let packageStorePath    = storePath </> Z.packageDir pInfo -            archiveFileExists <- runResourceT $ IO.resourceExists envAws targetFile+                -- 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 -            unless archiveFileExists $ do-              packageStorePathExists <- doesDirectoryExist packageStorePath+                archiveFileExists <- runResourceT $ IO.resourceExists envAws targetFile -              when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn $ do-                let workingStorePackagePath = tempPath </> Z.packageDir pInfo-                liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath+                unless archiveFileExists $ do+                  packageStorePathExists <- doesDirectoryExist packageStorePath -                let rp2 = Z.relativePaths storePath pInfo+                  when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn $ do+                    let workingStorePackagePath = tempPath </> Z.packageDir pInfo+                    liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath -                CIO.putStrLn $ "Creating " <> toText targetFile+                    let rp2 = Z.relativePaths storePath pInfo -                let tempArchiveFile = tempPath </> archiveFileBasename+                    CIO.putStrLn $ "Creating " <> toText targetFile -                metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)]+                    let tempArchiveFile = tempPath </> archiveFileBasename -                IO.createTar tempArchiveFile (rp2 <> [metas])+                    metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)] -                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+                    IO.createTar tempArchiveFile (rp2 <> [metas]) -                  _ -> 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 ()+        Left msg -> CIO.hPutStrLn IO.stderr msg+     Left (appError :: AppError) -> do       CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError @@ -150,6 +160,47 @@ isShareable storePath pkg =   let packageSharePath = storePath </> Z.packageDir pkg </> "share"   in IO.listMaybeDirectory packageSharePath <&> (\\ ["doc"]) <&> null++optsSyncToArchive :: Parser SyncToArchiveOptions+optsSyncToArchive = SyncToArchiveOptions+  <$> option (auto <|> text)+      (  long "region"+      <> metavar "AWS_REGION"+      <> showDefault <> value Oregon+      <> help "The AWS region in which to operate"+      )+  <*> option (maybeReader (toLocation . Text.pack))+      (   long "archive-uri"+      <>  help "Archive URI to sync to"+      <>  metavar "S3_URI"+      <>  value (Local $ homeDirectory </> ".cabal" </> "archive")+      )+  <*> strOption+      (   long "store-path"+      <>  help "Path to cabal store"+      <>  metavar "DIRECTORY"+      <>  value (homeDirectory </> ".cabal" </> "store")+      )+  <*> optional+      ( strOption+        (   long "store-path-hash"+        <>  help "Store path hash (do not use)"+        <>  metavar "HASH"+        )+      )+  <*> option auto+      (   long "threads"+      <>  help "Number of concurrent threads"+      <>  metavar "NUM_THREADS"+      <>  value 4+      )+  <*> optional+      ( option autoText+        (   long "aws-log-level"+        <>  help "AWS Log Level.  One of (Error, Info, Debug, Trace)"+        <>  metavar "AWS_LOG_LEVEL"+        )+      )  cmdSyncToArchive :: Mod CommandFields (IO ()) cmdSyncToArchive = command "sync-to-archive"  $ flip info idm $ runSyncToArchive <$> optsSyncToArchive

@@ -12,11 +12,13 @@   , getPackages   , relativePaths   , loadPlan+  , mkCompilerContext   ) where  import Control.DeepSeq                  (NFData) import Control.Lens                     hiding ((<.>)) import Control.Monad                    (forM)+import Control.Monad.Except import Data.Aeson                       (eitherDecode) import Data.Bifunctor                   (first) import Data.Bool                        (bool)@@ -26,6 +28,7 @@ import Data.Text                        (Text) import GHC.Generics                     (Generic) import HaskellWorks.CabalCache.AppError+import HaskellWorks.CabalCache.Error import System.FilePath                  ((<.>), (</>))  import qualified Data.ByteString.Lazy           as LBS@@ -53,6 +56,13 @@   , confPath   :: Tagged ConfPath Presence   , libs       :: [Library]   } deriving (Show, Eq, Generic, NFData)++mkCompilerContext :: MonadIO m => Z.PlanJson -> ExceptT Text m Z.CompilerContext+mkCompilerContext plan = do+  compilerVersion <- T.stripPrefix "ghc-" (plan ^. the @"compilerId") & nothingToError "No compiler version available in plan"+  let ghcPkgCmd = "ghc-pkg-" <> compilerVersion+  ghcPkgCmdPath <- liftIO (IO.findExecutable (T.unpack ghcPkgCmd)) >>= nothingToError (ghcPkgCmd <> " is not in path")+  return (Z.CompilerContext [ghcPkgCmdPath])  relativePaths :: FilePath -> PackageInfo -> [IO.TarGroup] relativePaths basePath pInfo =

@@ -0,0 +1,9 @@+module HaskellWorks.CabalCache.Error+  ( nothingToError+  ) where++import Control.Monad.Except++nothingToError :: MonadError e m => e -> Maybe a -> m a+nothingToError _ (Just a) = return a+nothingToError e Nothing  = throwError e

@@ -1,13 +1,24 @@+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE TypeApplications #-}+ module HaskellWorks.CabalCache.GhcPkg where -import System.Exit    (ExitCode (..), exitWith)-import System.Process (spawnProcess, waitForProcess)+import Control.Lens+import Data.Generics.Product.Any+import System.Exit               (ExitCode (..), exitWith)+import System.Process            (waitForProcess) -import qualified System.IO as IO+import qualified HaskellWorks.CabalCache.Types as Z+import qualified System.IO                     as IO+import qualified System.Process                as IO -runGhcPkg :: [String] -> IO ()-runGhcPkg params = do-  hGhcPkg2 <- spawnProcess "ghc-pkg" params+system :: [String] -> IO IO.ProcessHandle+system (cmd:args) = IO.spawnProcess cmd args+system []         = error "No command supplied" -- TODO Better error handling++runGhcPkg :: Z.CompilerContext -> [String] -> IO ()+runGhcPkg cc params = do+  hGhcPkg2 <- system ((cc ^. the @"ghcPkgCmd") <> params)   exitCodeGhcPkg2 <- waitForProcess hGhcPkg2   case exitCodeGhcPkg2 of     ExitFailure _ -> do@@ -15,11 +26,11 @@       exitWith (ExitFailure 1)     _ -> return () -testAvailability :: IO ()-testAvailability = runGhcPkg ["--version"]+testAvailability :: Z.CompilerContext -> IO ()+testAvailability cc = runGhcPkg cc ["--version"] -recache :: FilePath -> IO ()-recache packageDb = runGhcPkg ["recache", "--package-db", packageDb]+recache :: Z.CompilerContext -> FilePath -> IO ()+recache cc packageDb = runGhcPkg cc ["recache", "--package-db", packageDb] -init :: FilePath -> IO ()-init packageDb = runGhcPkg ["init", packageDb]+init :: Z.CompilerContext -> FilePath -> IO ()+init cc packageDb = runGhcPkg cc ["init", packageDb]

@@ -40,6 +40,10 @@   , exeDepends :: [Text]   } deriving (Eq, Show, Generic) +newtype CompilerContext = CompilerContext+  { ghcPkgCmd :: [String]+  } deriving (Show, Eq, Generic)+ instance FromJSON PlanJson where   parseJSON = withObject "PlanJson" $ \v -> PlanJson     <$> v .: "compiler-id"