diff --git a/cabal-cache.cabal b/cabal-cache.cabal --- a/cabal-cache.cabal +++ b/cabal-cache.cabal @@ -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 diff --git a/src/App/Commands/Options/Parser.hs b/src/App/Commands/Options/Parser.hs --- a/src/App/Commands/Options/Parser.hs +++ b/src/App/Commands/Options/Parser.hs @@ -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 diff --git a/src/App/Commands/SyncFromArchive.hs b/src/App/Commands/SyncFromArchive.hs --- a/src/App/Commands/SyncFromArchive.hs +++ b/src/App/Commands/SyncFromArchive.hs @@ -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 diff --git a/src/App/Commands/SyncToArchive.hs b/src/App/Commands/SyncToArchive.hs --- a/src/App/Commands/SyncToArchive.hs +++ b/src/App/Commands/SyncToArchive.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/Core.hs b/src/HaskellWorks/CabalCache/Core.hs --- a/src/HaskellWorks/CabalCache/Core.hs +++ b/src/HaskellWorks/CabalCache/Core.hs @@ -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 = diff --git a/src/HaskellWorks/CabalCache/Error.hs b/src/HaskellWorks/CabalCache/Error.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Error.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/GhcPkg.hs b/src/HaskellWorks/CabalCache/GhcPkg.hs --- a/src/HaskellWorks/CabalCache/GhcPkg.hs +++ b/src/HaskellWorks/CabalCache/GhcPkg.hs @@ -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] diff --git a/src/HaskellWorks/CabalCache/Types.hs b/src/HaskellWorks/CabalCache/Types.hs --- a/src/HaskellWorks/CabalCache/Types.hs +++ b/src/HaskellWorks/CabalCache/Types.hs @@ -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"