cabal-cache-1.2.0.0: app/App/Commands/SyncFromArchive.hs
{- HLINT ignore "Redundant id" -}
module App.Commands.SyncFromArchive
( cmdSyncFromArchive,
) where
import App.Amazonka
import App.Commands.Options.Parser (optsPackageIds, text)
import App.Commands.Options.Types (SyncFromArchiveOptions (SyncFromArchiveOptions))
import App.Run
import Control.Lens ((^..), (%~), Each(each))
import Control.Lens.Combinators (traverse1)
import Data.ByteString.Lazy.Search (replace)
import Data.Generics.Product.Any (the)
import Data.List.NonEmpty (NonEmpty)
import Effectful
import Effectful.Zoo.Amazonka.Data.AwsError
import Effectful.Zoo.Core
import Effectful.Zoo.Core.Error.Static
import Effectful.Zoo.Lazy.Dynamic
import HaskellWorks.CabalCache.AppError (AwsStatusError, HttpError (..), displayAwsStatusError, displayHttpError)
import HaskellWorks.CabalCache.Concurrent.Fork
import HaskellWorks.CabalCache.Concurrent.Type
import HaskellWorks.CabalCache.Error (DecodeError(..), ExitFailure(..), InvalidUrl(..), NotFound, UnsupportedUri(..))
import HaskellWorks.CabalCache.IO.Lazy (readFirstAvailableResource)
import HaskellWorks.CabalCache.IO.Tar (ArchiveError(..))
import HaskellWorks.CabalCache.Location (toLocation, (<.>), (</>), Location)
import HaskellWorks.CabalCache.Metadata (loadMetadata)
import HaskellWorks.CabalCache.Version (archiveVersion)
import HaskellWorks.Prelude
import Options.Applicative (CommandFields, Mod, Parser)
import Options.Applicative.NonEmpty (some1)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
import qualified Amazonka as AWS
import qualified Amazonka.Data as AWS
import qualified App.Commands.Options.Types as Z
import qualified App.Static as AS
import qualified Control.Concurrent.STM as STM
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as M
import qualified Data.Map.Strict as Map
import qualified Data.Set as S
import qualified Data.Text as T
import qualified HaskellWorks.CabalCache.Concurrent.DownloadQueue as DQ
import qualified HaskellWorks.CabalCache.Core as Z
import qualified HaskellWorks.CabalCache.Data.List as L
import qualified HaskellWorks.CabalCache.GhcPkg as GhcPkg
import qualified HaskellWorks.CabalCache.Hash as H
import qualified HaskellWorks.CabalCache.IO.Console as CIO
import qualified HaskellWorks.CabalCache.IO.Tar as IO
import qualified HaskellWorks.CabalCache.Store as M
import qualified HaskellWorks.CabalCache.Types as Z
import qualified Options.Applicative as OA
import qualified System.Directory as IO
import qualified System.IO as IO
import qualified System.IO.Temp as IO
{- HLINT ignore "Monoid law, left identity" -}
{- HLINT ignore "Reduce duplication" -}
{- HLINT ignore "Redundant do" -}
skippable :: Z.Package -> Bool
skippable package = package.packageType == "pre-existing"
recoverOrVoid :: forall x r. ()
=> Eff (Error x : r) Void
-> Eff r x
recoverOrVoid f =
f & fmap absurd
& trap pure
runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO ()
runSyncFromArchive opts = runApp do
let mHostEndpoint = opts.hostEndpoint :: Maybe (ByteString, Int, Bool)
let storePath = opts.storePath
let archiveUris = opts.archiveUris :: NonEmpty Location
let threads = opts.threads
let awsLogLevel = opts.awsLogLevel
let versionedArchiveUris = archiveUris & traverse1 %~ (</> archiveVersion) :: NonEmpty Location
let storePathHash = opts.storePathHash & fromMaybe (H.hashStorePath storePath)
let scopedArchiveUris = versionedArchiveUris & traverse1 %~ (</> T.pack storePathHash)
let maxRetries = opts.maxRetries
let ignorePackages = opts.ignorePackages
CIO.putStrLn $ "Store path: " <> AWS.toText storePath
CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash
forM_ archiveUris $ \archiveUri -> do
CIO.putStrLn $ "Archive URI: " <> AWS.toText archiveUri
CIO.putStrLn $ "Archive version: " <> archiveVersion
CIO.putStrLn $ "Threads: " <> tshow threads
CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel
planJson <- Z.loadPlan (opts.path </> opts.buildPath)
& do trap @DecodeError \e -> do
CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> tshow e
throw ExitFailure
compilerContext <- Z.mkCompilerContext planJson
& do trap @Text \e -> do
CIO.hPutStrLn IO.stderr e
throw ExitFailure
liftIO $ GhcPkg.testAvailability compilerContext
let compilerId = planJson.compilerId
let storeCompilerPath = storePath </> T.unpack compilerId
let storeCompilerPackageDbPath = storeCompilerPath </> "package.db"
let storeCompilerLibPath = storeCompilerPath </> "lib"
CIO.putStrLn "Creating store directories"
liftIO $ createDirectoryIfMissing True storePath
liftIO $ createDirectoryIfMissing True storeCompilerPath
liftIO $ createDirectoryIfMissing True storeCompilerLibPath
storeCompilerPackageDbPathExists <- liftIO $ doesDirectoryExist storeCompilerPackageDbPath
unless storeCompilerPackageDbPathExists do
CIO.putStrLn "Package DB missing. Creating Package DB"
liftIO $ GhcPkg.contextInit compilerContext storeCompilerPackageDbPath
packages <- liftIO $ Z.getPackages storePath planJson
let installPlan = planJson.installPlan
let planPackages = M.fromList $ fmap (\p -> (p.id, p)) installPlan
let planDeps0 = installPlan >>= \p -> fmap (p.id, ) $ mempty
<> p.depends
<> p.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.id)) installPlan
downloadQueue <- liftIO $ STM.atomically $ DQ.createDownloadQueue planDeps
let pInfos = M.fromList $ fmap (\p -> (p.packageId, p)) packages
runLazy (mkAwsEnv opts.region mHostEndpoint awsLogLevel) do
IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do
liftIO $ IO.createDirectoryIfMissing True (tempPath </> T.unpack compilerId </> "package.db")
forkThreadsWait threads $ DQ.runQueue downloadQueue $ \packageId -> do
recoverOrVoid @DQ.DownloadStatus do
pInfo <- pure (M.lookup packageId pInfos)
& do onNothingM do
CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId
DQ.downloadSucceed
let archiveBaseName = pInfo.packageDir <.> ".tar.gz"
let archiveFiles = versionedArchiveUris & traverse1 %~ (</> T.pack archiveBaseName)
let scopedArchiveFiles = scopedArchiveUris & traverse1 %~ (</> T.pack archiveBaseName)
let packageStorePath = storePath </> pInfo.packageDir
let packageName = pInfo.packageName
storeDirectoryExists <- liftIO $ doesDirectoryExist packageStorePath
package <- pure (M.lookup packageId planPackages)
& do onNothingM do
CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageName
DQ.downloadSucceed
when (skippable package) do
CIO.putStrLn $ "Skipping: " <> packageName
DQ.downloadSucceed
when (packageName `S.member` ignorePackages) do
CIO.putStrLn $ "Ignoring: " <> packageName
DQ.downloadFail
when storeDirectoryExists DQ.downloadSucceed
ensureStorePathCleanup packageStorePath do
let locations = sconcat $ fmap L.tuple2ToNel (NEL.zip archiveFiles scopedArchiveFiles)
(existingArchiveFileContents, existingArchiveFile) <- readFirstAvailableResource locations maxRetries
& do trap @AwsError \e -> do
CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> tshow e
DQ.downloadFail
& do trap @AwsStatusError \e -> do
CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> displayAwsStatusError e
DQ.downloadFail
& do trap @HttpError \e -> do
CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> displayHttpError e
DQ.downloadFail
& do trap @NotFound \_ -> do
CIO.putStrLn $ "Not found: " <> tshow locations
DQ.downloadFail
& do trap @InvalidUrl \(InvalidUrl url' reason') -> do
CIO.hPutStrLn IO.stderr $ "Invalid URL: " <> tshow url' <> ", " <> reason'
DQ.downloadFail
& do trap @UnsupportedUri \e -> do
CIO.hPutStrLn IO.stderr $ tshow e
DQ.downloadFail
CIO.putStrLn $ "Extracting: " <> AWS.toText existingArchiveFile
let tempArchiveFile = tempPath </> archiveBaseName
liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents
IO.extractTar tempArchiveFile storePath
& do trap @ArchiveError \(ArchiveError reason') -> do
CIO.putStrLn $ "Unable to extract tar at " <> tshow tempArchiveFile <> " because: " <> reason'
DQ.downloadFail
meta <- loadMetadata packageStorePath
oldStorePath <- pure (Map.lookup "store-path" meta)
& do onNothingM do
CIO.putStrLn "store-path is missing from Metadata"
DQ.downloadFail
let Z.Tagged conf _ = pInfo.confPath
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.copyFile tempConfPath theConfPath >> IO.removeFile tempConfPath
DQ.downloadSucceed
CIO.putStrLn "Recaching package database"
liftIO $ GhcPkg.recache compilerContext storeCompilerPackageDbPath
failures <- liftIO $ STM.atomically $ STM.readTVar downloadQueue.tFailures
forM_ failures $ \packageId -> CIO.hPutStrLn IO.stderr $ "Failed to download: " <> packageId
ensureStorePathCleanup :: ()
=> r <: Error DQ.DownloadStatus
=> r <: IOE
=> FilePath
-> Eff r a
-> Eff r a
ensureStorePathCleanup packageStorePath =
trapIn @DQ.DownloadStatus \downloadStatus -> do
case downloadStatus of
DQ.DownloadFailure -> M.cleanupStorePath packageStorePath
DQ.DownloadSuccess ->
CIO.hPutStrLn IO.stdout $ "Successfully cleaned up store path: " <> tshow packageStorePath
throw downloadStatus
optsSyncFromArchive :: Parser SyncFromArchiveOptions
optsSyncFromArchive = SyncFromArchiveOptions
<$> OA.option (OA.auto <|> text)
( OA.long "region"
<> OA.metavar "AWS_REGION"
<> OA.showDefault
<> OA.value AWS.Oregon
<> OA.help "The AWS region in which to operate"
)
<*> some1
( OA.option (OA.maybeReader (toLocation . T.pack))
( OA.long "archive-uri"
<> OA.help "Archive URI to sync to"
<> OA.metavar "S3_URI"
)
)
<*> OA.strOption
( OA.long "path"
<> OA.help "Path to cabal project directory. Defaults to \".\""
<> OA.metavar "DIRECTORY"
<> OA.value AS.path
)
<*> OA.strOption
( OA.long "build-path"
<> OA.help ("Path to cabal build directory. Defaults to " <> show AS.buildPath)
<> OA.metavar "DIRECTORY"
<> OA.value AS.buildPath
)
<*> OA.strOption
( OA.long "store-path"
<> OA.help ("Path to cabal store. Defaults to " <> show AS.cabalStoreDirectory)
<> OA.metavar "DIRECTORY"
<> OA.value AS.cabalStoreDirectory
)
<*> optional
( OA.strOption
( OA.long "store-path-hash"
<> OA.help "Store path hash (do not use)"
<> OA.metavar "HASH"
)
)
<*> OA.option OA.auto
( OA.long "threads"
<> OA.help "Number of concurrent threads"
<> OA.metavar "NUM_THREADS"
<> OA.value 4
)
<*> optional
( OA.option (OA.eitherReader (AWS.fromText . T.pack))
( OA.long "aws-log-level"
<> OA.help "AWS Log Level. One of (Error, Info, Debug, Trace)"
<> OA.metavar "AWS_LOG_LEVEL"
)
)
<*> optional parseEndpoint
<*> OA.option OA.auto
( OA.long "max-retries"
<> OA.help "Max retries for S3 requests"
<> OA.metavar "NUM_RETRIES"
<> OA.value 3
)
<*> optsPackageIds
parseEndpoint :: Parser (ByteString, Int, Bool)
parseEndpoint =
(,,)
<$> OA.option (OA.eitherReader (AWS.fromText . T.pack))
( OA.long "host-name-override"
<> OA.help "Override the host name (default: s3.amazonaws.com)"
<> OA.metavar "HOST_NAME"
)
<*> OA.option OA.auto
( OA.long "host-port-override"
<> OA.help "Override the host port"
<> OA.metavar "HOST_PORT"
)
<*> OA.option OA.auto
( OA.long "host-ssl-override"
<> OA.help "Override the host SSL"
<> OA.metavar "HOST_SSL"
)
cmdSyncFromArchive :: Mod CommandFields (IO ())
cmdSyncFromArchive = OA.command "sync-from-archive" $ flip OA.info OA.idm $ runSyncFromArchive <$> optsSyncFromArchive