diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for cabal-cache - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -76,6 +76,14 @@ cabal-cache sync-from-archive --threads 16 --archive-uri archive --region Sydney ``` +### Multicloud + +To run against a different service, use something like: + +```bash +cabal-cache sync-to-archive --threads 16 --archive-uri s3://my-cabal-cache-bucket/archive --host-name-override=s3.us-west.some-service.com --host-port-override=443 --host-ssl-override=True +``` + ## The archive ### Archive tarball format @@ -157,3 +165,4 @@ if the package's cabal store `share` directory contain unusual files or directories _unless_ the `${store_hash}` matches. Currently it only considers the `doc` subdirectory to be usual. More exceptions may be added later. + diff --git a/app/App/Commands.hs b/app/App/Commands.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands.hs @@ -0,0 +1,20 @@ +module App.Commands where + +import App.Commands.Plan +import App.Commands.SyncFromArchive +import App.Commands.SyncToArchive +import App.Commands.Version +import Options.Applicative + +{- HLINT ignore "Monoid law, left identity" -} + +commands :: Parser (IO ()) +commands = commandsGeneral + +commandsGeneral :: Parser (IO ()) +commandsGeneral = subparser $ mempty + <> commandGroup "Commands:" + <> cmdPlan + <> cmdSyncFromArchive + <> cmdSyncToArchive + <> cmdVersion diff --git a/app/App/Commands/Options/Parser.hs b/app/App/Commands/Options/Parser.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/Options/Parser.hs @@ -0,0 +1,13 @@ +module App.Commands.Options.Parser where + +import Antiope.Core (FromText, fromText) +import App.Commands.Options.Types (VersionOptions (..)) +import Options.Applicative + +import qualified Data.Text as Text + +optsVersion :: Parser VersionOptions +optsVersion = pure VersionOptions + +text :: FromText a => ReadM a +text = eitherReader (fromText . Text.pack) diff --git a/app/App/Commands/Options/Types.hs b/app/App/Commands/Options/Types.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/Options/Types.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module App.Commands.Options.Types where + +import Antiope.Env (Region) +import GHC.Generics +import Data.ByteString (ByteString) +import HaskellWorks.CabalCache.Location + +import qualified Antiope.Env as AWS + +data SyncToArchiveOptions = SyncToArchiveOptions + { region :: Region + , archiveUri :: Location + , buildPath :: FilePath + , storePath :: FilePath + , storePathHash :: Maybe String + , threads :: Int + , awsLogLevel :: Maybe AWS.LogLevel + , hostEndpoint :: Maybe (ByteString, Int, Bool) + } deriving (Eq, Show, Generic) + +data PlanOptions = PlanOptions + { buildPath :: FilePath + , storePath :: FilePath + , storePathHash :: Maybe String + , outputFile :: FilePath + } deriving (Eq, Show, Generic) + +data SyncFromArchiveOptions = SyncFromArchiveOptions + { region :: Region + , archiveUris :: [Location] + , buildPath :: FilePath + , storePath :: FilePath + , storePathHash :: Maybe String + , threads :: Int + , awsLogLevel :: Maybe AWS.LogLevel + , hostEndpoint :: Maybe (ByteString, Int, Bool) + } deriving (Eq, Show, Generic) + +data VersionOptions = VersionOptions deriving (Eq, Show, Generic) diff --git a/app/App/Commands/Plan.hs b/app/App/Commands/Plan.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/Plan.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module App.Commands.Plan + ( cmdPlan + ) where + +import Antiope.Core (toText) +import App.Commands.Options.Types (PlanOptions (PlanOptions)) +import Control.Applicative +import Control.Lens hiding ((<.>)) +import Control.Monad.Except +import Data.Generics.Product.Any (the) +import Data.Maybe +import HaskellWorks.CabalCache.AppError +import HaskellWorks.CabalCache.Location (Location (..), (<.>), ()) +import HaskellWorks.CabalCache.Show +import HaskellWorks.CabalCache.Version (archiveVersion) +import Options.Applicative hiding (columns) + +import qualified App.Commands.Options.Types as Z +import qualified App.Static as AS +import qualified Control.Concurrent.STM as STM +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified HaskellWorks.CabalCache.Core as Z +import qualified HaskellWorks.CabalCache.Hash as H +import qualified HaskellWorks.CabalCache.IO.Console as CIO +import qualified System.IO as IO + +{- HLINT ignore "Monoid law, left identity" -} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Reduce duplication" -} + +runPlan :: Z.PlanOptions -> IO () +runPlan opts = do + let storePath = opts ^. the @"storePath" + let archiveUris = [Local ""] + let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) + let versionedArchiveUris = archiveUris & each %~ ( archiveVersion) + let outputFile = opts ^. the @"outputFile" + + CIO.putStrLn $ "Store path: " <> toText storePath + CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash + CIO.putStrLn $ "Archive URIs: " <> tshow archiveUris + CIO.putStrLn $ "Archive version: " <> archiveVersion + + tEarlyExit <- STM.newTVarIO False + + mbPlan <- Z.loadPlan $ opts ^. the @"buildPath" + + case mbPlan of + Right planJson -> do + packages <- Z.getPackages storePath planJson + + plan <- forM packages $ \pInfo -> do + let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz" + let archiveFiles = versionedArchiveUris <&> ( T.pack archiveFileBasename) + let scopedArchiveFiles = versionedArchiveUris <&> ( T.pack storePathHash T.pack archiveFileBasename) + + return $ archiveFiles <> scopedArchiveFiles + + if outputFile == "-" + then LBS.putStr $ J.encode (fmap (fmap toText) plan) + else LBS.writeFile outputFile $ J.encode (fmap (fmap toText) plan) + + Left (appError :: AppError) -> do + CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError + + earlyExit <- STM.readTVarIO tEarlyExit + + when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error" + +optsPlan :: Parser PlanOptions +optsPlan = PlanOptions + <$> strOption + ( long "build-path" + <> help ("Path to cabal build directory. Defaults to " <> show AS.buildPath) + <> metavar "DIRECTORY" + <> value AS.buildPath + ) + <*> strOption + ( long "store-path" + <> help "Path to cabal store" + <> metavar "DIRECTORY" + <> value (AS.cabalDirectory "store") + ) + <*> optional + ( strOption + ( long "store-path-hash" + <> help "Store path hash (do not use)" + <> metavar "HASH" + ) + ) + <*> strOption + ( long "output-file" + <> help "Output file" + <> metavar "FILE" + <> value "-" + ) + +cmdPlan :: Mod CommandFields (IO ()) +cmdPlan = command "plan" $ flip info idm $ runPlan <$> optsPlan diff --git a/app/App/Commands/SyncFromArchive.hs b/app/App/Commands/SyncFromArchive.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/SyncFromArchive.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module App.Commands.SyncFromArchive + ( cmdSyncFromArchive + ) where + +import Antiope.Core (Region (..), runResAws, toText) +import Antiope.Env (mkEnv) +import Antiope.Options.Applicative +import App.Commands.Options.Parser (text) +import App.Commands.Options.Types (SyncFromArchiveOptions (SyncFromArchiveOptions)) +import Control.Applicative +import Control.Lens hiding ((<.>)) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Except +import Control.Monad.Trans.AWS (envOverride, setEndpoint) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy.Search (replace) +import Data.Generics.Product.Any (the) +import Data.Maybe +import Data.Monoid +import HaskellWorks.CabalCache.AppError +import HaskellWorks.CabalCache.IO.Error (exceptWarn, maybeToExcept) +import HaskellWorks.CabalCache.Location (toLocation, (<.>), ()) +import HaskellWorks.CabalCache.Metadata (loadMetadata) +import HaskellWorks.CabalCache.Show +import HaskellWorks.CabalCache.Version (archiveVersion) +import Options.Applicative hiding (columns) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist) + +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 as L +import qualified Data.Map as M +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import qualified HaskellWorks.CabalCache.AWS.Env as AWS +import qualified HaskellWorks.CabalCache.Concurrent.DownloadQueue as DQ +import qualified HaskellWorks.CabalCache.Concurrent.Fork as IO +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.Lazy as IO +import qualified HaskellWorks.CabalCache.IO.Tar as IO +import qualified HaskellWorks.CabalCache.Types as Z +import qualified System.Directory as IO +import qualified System.IO as IO +import qualified System.IO.Temp as IO +import qualified System.IO.Unsafe as IO + +{- HLINT ignore "Monoid law, left identity" -} +{- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Redundant do" -} + +skippable :: Z.Package -> Bool +skippable package = package ^. the @"packageType" == "pre-existing" + +runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO () +runSyncFromArchive opts = do + let hostEndpoint = opts ^. the @"hostEndpoint" + let storePath = opts ^. the @"storePath" + let archiveUris = opts ^. the @"archiveUris" + let threads = opts ^. the @"threads" + let awsLogLevel = opts ^. the @"awsLogLevel" + let versionedArchiveUris = archiveUris & each %~ ( archiveVersion) + let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) + let scopedArchiveUris = versionedArchiveUris & each %~ ( T.pack storePathHash) + + CIO.putStrLn $ "Store path: " <> toText storePath + CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash + forM_ archiveUris $ \archiveUri -> do + CIO.putStrLn $ "Archive URI: " <> toText archiveUri + CIO.putStrLn $ "Archive version: " <> archiveVersion + CIO.putStrLn $ "Threads: " <> tshow threads + CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel + + mbPlan <- Z.loadPlan $ opts ^. the @"buildPath" + + case mbPlan of + Right planJson -> do + compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson + + case compilerContextResult of + Right compilerContext -> do + GhcPkg.testAvailability compilerContext + + envAws <- IO.unsafeInterleaveIO $ (<&> envOverride .~ Dual (Endo $ \s -> case hostEndpoint of + Just (hostname, port, ssl) -> setEndpoint ssl hostname port s + Nothing -> s)) + $ 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" + + CIO.putStrLn "Creating store directories" + createDirectoryIfMissing True storePath + createDirectoryIfMissing True storeCompilerPath + createDirectoryIfMissing True storeCompilerLibPath + + storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath + + unless storeCompilerPackageDbPathExists $ do + CIO.putStrLn "Package DB missing. Creating Package DB" + GhcPkg.init compilerContext storeCompilerPackageDbPath + + packages <- Z.getPackages storePath planJson + + let installPlan = planJson ^. the @"installPlan" + let planPackages = M.fromList $ fmap (\p -> (p ^. the @"id", p)) installPlan + + 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 + + downloadQueue <- STM.atomically $ DQ.createDownloadQueue planDeps + + let pInfos = M.fromList $ fmap (\p -> (p ^. the @"packageId", p)) packages + + IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do + IO.createDirectoryIfMissing True (tempPath T.unpack compilerId "package.db") + + IO.forkThreadsWait threads $ DQ.runQueue downloadQueue $ \packageId -> case M.lookup packageId pInfos of + Just pInfo -> do + let archiveBaseName = Z.packageDir pInfo <.> ".tar.gz" + let archiveFiles = versionedArchiveUris & each %~ ( T.pack archiveBaseName) + let scopedArchiveFiles = scopedArchiveUris & each %~ ( T.pack archiveBaseName) + let packageStorePath = storePath Z.packageDir pInfo + let maybePackage = M.lookup packageId planPackages + + storeDirectoryExists <- doesDirectoryExist packageStorePath + + 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 (foldMap L.tuple2ToList (L.zip archiveFiles scopedArchiveFiles)) + CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile + + 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) + + 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 $ IO.copyFile tempConfPath theConfPath >> IO.removeFile tempConfPath + + return True + Nothing -> do + CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId + return True + + 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 + + return () + +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 + 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 + result <- runExceptT $ catchError (exceptWarn f) handler + case result of + 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" + ) + <*> some + ( option (maybeReader (toLocation . T.pack)) + ( long "archive-uri" + <> help "Archive URI to sync to" + <> metavar "S3_URI" + ) + ) + <*> strOption + ( long "build-path" + <> help ("Path to cabal build directory. Defaults to " <> show AS.buildPath) + <> metavar "DIRECTORY" + <> value AS.buildPath + ) + <*> strOption + ( long "store-path" + <> help ("Path to cabal store. Defaults to " <> show AS.cabalDirectory) + <> metavar "DIRECTORY" + <> value (AS.cabalDirectory "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" + ) + ) + <*> optional parseEndpoint + +parseEndpoint :: Parser (ByteString, Int, Bool) +parseEndpoint = + (,,) + <$> option autoText + ( long "host-name-override" + <> help "Override the host name (default: s3.amazonaws.com)" + <> metavar "HOST_NAME" + ) + <*> option auto + ( long "host-port-override" + <> help "Override the host port" + <> metavar "HOST_PORT" + ) + <*> option auto + ( long "host-ssl-override" + <> help "Override the host SSL" + <> metavar "HOST_SSL" + ) + +cmdSyncFromArchive :: Mod CommandFields (IO ()) +cmdSyncFromArchive = command "sync-from-archive" $ flip info idm $ runSyncFromArchive <$> optsSyncFromArchive diff --git a/app/App/Commands/SyncToArchive.hs b/app/App/Commands/SyncToArchive.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/SyncToArchive.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module App.Commands.SyncToArchive + ( cmdSyncToArchive + ) where + +import Antiope.Core (Region (..), toText) +import Antiope.Env (mkEnv) +import Antiope.Options.Applicative +import App.Commands.Options.Parser (text) +import App.Commands.Options.Types (SyncToArchiveOptions (SyncToArchiveOptions)) +import Control.Applicative +import Control.Lens hiding ((<.>)) +import Control.Monad.Except +import Control.Monad.Trans.Resource (runResourceT) +import Control.Monad.Trans.AWS (envOverride, setEndpoint) +import Data.ByteString (ByteString) +import Data.Generics.Product.Any (the) +import Data.List ((\\)) +import Data.Maybe +import Data.Monoid +import HaskellWorks.CabalCache.AppError +import HaskellWorks.CabalCache.Location (Location (..), toLocation, (<.>), ()) +import HaskellWorks.CabalCache.Metadata (createMetadata) +import HaskellWorks.CabalCache.Show +import HaskellWorks.CabalCache.Topology (buildPlanData, canShare) +import HaskellWorks.CabalCache.Version (archiveVersion) +import Options.Applicative hiding (columns) +import System.Directory (doesDirectoryExist) + +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.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LC8 +import qualified Data.Text as T +import qualified Data.Text as Text +import qualified HaskellWorks.CabalCache.AWS.Env as AWS +import qualified HaskellWorks.CabalCache.Core as Z +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.Error as IO +import qualified HaskellWorks.CabalCache.IO.File as IO +import qualified HaskellWorks.CabalCache.IO.Lazy as IO +import qualified HaskellWorks.CabalCache.IO.Tar as IO +import qualified Network.HTTP.Types as HTTP +import qualified System.Directory as IO +import qualified System.IO as IO +import qualified System.IO.Temp as IO +import qualified System.IO.Unsafe as IO +import qualified UnliftIO.Async as IO + +{- HLINT ignore "Monoid law, left identity" -} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Reduce duplication" -} + +runSyncToArchive :: Z.SyncToArchiveOptions -> IO () +runSyncToArchive opts = do + let hostEndpoint = opts ^. the @"hostEndpoint" + let storePath = opts ^. the @"storePath" + let archiveUri = opts ^. the @"archiveUri" + let threads = opts ^. the @"threads" + let awsLogLevel = opts ^. the @"awsLogLevel" + let versionedArchiveUri = archiveUri archiveVersion + let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) + let scopedArchiveUri = versionedArchiveUri T.pack storePathHash + + CIO.putStrLn $ "Store path: " <> toText storePath + CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash + CIO.putStrLn $ "Archive URI: " <> toText archiveUri + CIO.putStrLn $ "Archive version: " <> archiveVersion + CIO.putStrLn $ "Threads: " <> tshow threads + CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel + + tEarlyExit <- STM.newTVarIO False + + mbPlan <- Z.loadPlan $ opts ^. the @"buildPath" + + case mbPlan of + Right planJson -> do + compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson + + case compilerContextResult of + Right compilerContext -> do + let compilerId = planJson ^. the @"compilerId" + envAws <- IO.unsafeInterleaveIO $ (<&> envOverride .~ Dual (Endo $ \s -> case hostEndpoint of + Just (hostname, port, ssl) -> setEndpoint ssl hostname port s + Nothing -> s)) + $ mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel) + let archivePath = versionedArchiveUri compilerId + let scopedArchivePath = scopedArchiveUri compilerId + IO.createLocalDirectoryIfMissing archivePath + IO.createLocalDirectoryIfMissing scopedArchivePath + + packages <- Z.getPackages storePath planJson + nonShareable <- packages & filterM (fmap not . isShareable storePath) + let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId") + + let storeCompilerPath = storePath T.unpack compilerId + let storeCompilerPackageDbPath = storeCompilerPath "package.db" + + storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath + + unless storeCompilerPackageDbPathExists $ + GhcPkg.init compilerContext storeCompilerPackageDbPath + + CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages" + + IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do + CIO.putStrLn $ "Temp path: " <> tshow tempPath + + 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 + + -- 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 + + archiveFileExists <- runResourceT $ IO.resourceExists envAws targetFile + + unless archiveFileExists $ do + packageStorePathExists <- doesDirectoryExist packageStorePath + + when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn $ do + let workingStorePackagePath = tempPath Z.packageDir pInfo + liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath + + let rp2 = Z.relativePaths storePath pInfo + + CIO.putStrLn $ "Creating " <> toText targetFile + + let tempArchiveFile = tempPath archiveFileBasename + + metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)] + + IO.createTar tempArchiveFile (rp2 <> [metas]) + + 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 + + earlyExit <- STM.readTVarIO tEarlyExit + + when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error" + +isShareable :: MonadIO m => FilePath -> Z.PackageInfo -> m Bool +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 $ AS.cabalDirectory "archive") + ) + <*> strOption + ( long "build-path" + <> help ("Path to cabal build directory. Defaults to " <> show AS.buildPath) + <> metavar "DIRECTORY" + <> value AS.buildPath + ) + <*> strOption + ( long "store-path" + <> help "Path to cabal store" + <> metavar "DIRECTORY" + <> value (AS.cabalDirectory "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" + ) + ) + <*> optional parseEndpoint + +parseEndpoint :: Parser (ByteString, Int, Bool) +parseEndpoint = + (,,) + <$> option autoText + ( long "host-name-override" + <> help "Override the host name (default: s3.amazonaws.com)" + <> metavar "HOST_NAME" + ) + <*> option auto + ( long "host-port-override" + <> help "Override the host port" + <> metavar "HOST_PORT" + ) + <*> option auto + ( long "host-ssl-override" + <> help "Override the host SSL" + <> metavar "HOST_SSL" + ) + +cmdSyncToArchive :: Mod CommandFields (IO ()) +cmdSyncToArchive = command "sync-to-archive" $ flip info idm $ runSyncToArchive <$> optsSyncToArchive diff --git a/app/App/Commands/Version.hs b/app/App/Commands/Version.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/Version.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module App.Commands.Version + ( cmdVersion + ) where + +import App.Commands.Options.Parser (optsVersion) +import Data.List +import Options.Applicative hiding (columns) + +import qualified App.Commands.Options.Types as Z +import qualified Data.Text as T +import qualified Data.Version as V +import qualified HaskellWorks.CabalCache.IO.Console as CIO +import qualified Paths_cabal_cache as P + +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Reduce duplication" -} + +runVersion :: Z.VersionOptions -> IO () +runVersion _ = do + let V.Version {..} = P.version + + let version = intercalate "." $ fmap show versionBranch + + CIO.putStrLn $ "cabal-cache " <> T.pack version + +cmdVersion :: Mod CommandFields (IO ()) +cmdVersion = command "version" $ flip info idm $ runVersion <$> optsVersion diff --git a/app/App/Static.hs b/app/App/Static.hs new file mode 100644 --- /dev/null +++ b/app/App/Static.hs @@ -0,0 +1,11 @@ +module App.Static where + +import qualified App.Static.Base as S +import qualified App.Static.Posix as P +import qualified App.Static.Windows as W + +cabalDirectory :: FilePath +cabalDirectory = if S.isPosix then P.cabalDirectory else W.cabalDirectory + +buildPath :: FilePath +buildPath = "dist-newstyle" diff --git a/app/App/Static/Base.hs b/app/App/Static/Base.hs new file mode 100644 --- /dev/null +++ b/app/App/Static/Base.hs @@ -0,0 +1,13 @@ +module App.Static.Base where + +import qualified System.Directory as IO +import qualified System.IO.Unsafe as IO +import qualified System.Info as I + +homeDirectory :: FilePath +homeDirectory = IO.unsafePerformIO IO.getHomeDirectory +{-# NOINLINE homeDirectory #-} + +isPosix :: Bool +isPosix = I.os /= "mingw32" +{-# NOINLINE isPosix #-} diff --git a/app/App/Static/Posix.hs b/app/App/Static/Posix.hs new file mode 100644 --- /dev/null +++ b/app/App/Static/Posix.hs @@ -0,0 +1,8 @@ +module App.Static.Posix where + +import HaskellWorks.CabalCache.Location (()) + +import qualified App.Static.Base as S + +cabalDirectory :: FilePath +cabalDirectory = S.homeDirectory ".cabal" diff --git a/app/App/Static/Windows.hs b/app/App/Static/Windows.hs new file mode 100644 --- /dev/null +++ b/app/App/Static/Windows.hs @@ -0,0 +1,15 @@ +module App.Static.Windows where + +import Data.Maybe +import HaskellWorks.CabalCache.Location (()) + +import qualified App.Static.Base as S +import qualified System.Environment as IO +import qualified System.IO.Unsafe as IO + +appDataDirectory :: FilePath +appDataDirectory = IO.unsafePerformIO $ fmap (fromMaybe S.homeDirectory) (IO.lookupEnv "APPDATA") +{-# NOINLINE appDataDirectory #-} + +cabalDirectory :: FilePath +cabalDirectory = appDataDirectory "cabal" 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.3.0 +version: 1.0.4.0 synopsis: CI Assistant for Haskell projects description: CI Assistant for Haskell projects. Implements package caching. homepage: https://github.com/haskell-works/cabal-cache @@ -9,9 +9,9 @@ license-file: LICENSE author: John Ky maintainer: newhoggy@gmail.com -copyright: John Ky 2019-2020 +copyright: John Ky 2019-2021 category: Development -extra-source-files: CHANGELOG.md, README.md +extra-source-files: README.md source-repository head type: git @@ -19,14 +19,14 @@ common base { build-depends: base >= 4.7 && < 5 } -common aeson { build-depends: aeson >= 1.4.2.0 && < 1.5 } +common aeson { build-depends: aeson >= 1.4.2.0 && < 1.6 } common amazonka { build-depends: amazonka >= 1.6.1 && < 1.7 } common amazonka-core { build-depends: amazonka-core >= 1.6.1 && < 1.7 } common amazonka-s3 { build-depends: amazonka-s3 >= 1.6.1 && < 1.7 } common antiope-core { build-depends: antiope-core >= 7.4.4 && < 8 } common antiope-optparse-applicative { build-depends: antiope-optparse-applicative >= 7.4.4 && < 8 } common antiope-s3 { build-depends: antiope-s3 >= 7.4.4 && < 8 } -common bytestring { build-depends: bytestring >= 0.10.8.2 && < 0.11 } +common bytestring { build-depends: bytestring >= 0.10.8.2 && < 0.12 } common conduit-extra { build-depends: conduit-extra >= 1.3.1.1 && < 1.4 } common containers { build-depends: containers >= 0.6.0.1 && < 0.7 } common cryptonite { build-depends: cryptonite >= 0.25 && < 1 } @@ -34,21 +34,23 @@ common directory { build-depends: directory >= 1.3.3.0 && < 1.4 } common exceptions { build-depends: exceptions >= 0.10.1 && < 0.11 } common filepath { build-depends: filepath >= 1.3 && < 1.5 } -common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 2.1 } +common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 2.3 } common hedgehog { build-depends: hedgehog >= 1.0 && < 1.1 } common hspec { build-depends: hspec >= 2.4 && < 3 } -common http-client { build-depends: http-client >= 0.5.14 && < 0.7 } +common http-client { build-depends: http-client >= 0.5.14 && < 0.8 } +common http-client-tls { build-depends: http-client-tls >= 0.3 && < 0.4 } common http-types { build-depends: http-types >= 0.12.3 && < 0.13 } common hw-hedgehog { build-depends: hw-hedgehog >= 0.1.0.3 && < 0.2 } common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1.0.4 && < 0.2 } -common lens { build-depends: lens >= 4.17 && < 5 } +common lens { build-depends: lens >= 4.17 && < 6 } common mtl { build-depends: mtl >= 2.2.2 && < 2.3 } +common network-uri { build-depends: network-uri >= 2.6.4.1 && < 2.8 } common optparse-applicative { build-depends: optparse-applicative >= 0.14 && < 0.17 } common process { build-depends: process >= 1.6.5.0 && < 1.7 } common raw-strings-qq { build-depends: raw-strings-qq >= 1.1 && < 2 } common relation { build-depends: relation >= 0.5 && < 0.6 } common resourcet { build-depends: resourcet >= 1.2.2 && < 1.3 } -common selective { build-depends: selective >= 0.1.0 && < 0.2 } +common selective { build-depends: selective >= 0.1.0 && < 0.5 } common stm { build-depends: stm >= 2.5.0.0 && < 3 } common stringsearch { build-depends: stringsearch >= 0.3.6.6 && < 0.4 } common tar { build-depends: tar >= 0.5.1.0 && < 0.6 } @@ -56,114 +58,131 @@ common text { build-depends: text >= 1.2.3.1 && < 1.3 } common time { build-depends: time >= 1.4 && < 1.10 } common topograph { build-depends: topograph >= 1 && < 2 } +common transformers { build-depends: transformers >= 0.5.6.2 && < 0.7 } common unliftio { build-depends: unliftio >= 0.2.10 && < 0.3 } common zlib { build-depends: zlib >= 0.6.2 && < 0.7 } common config default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wtabs + if impl(ghc >= 8.10.1) + ghc-options: -Wunused-packages + library - import: base, config - , aeson - , amazonka - , amazonka-core - , amazonka-s3 - , antiope-core - , antiope-optparse-applicative - , antiope-s3 - , bytestring - , conduit-extra - , cryptonite - , containers - , deepseq - , directory - , exceptions - , filepath - , generic-lens - , http-client - , http-types - , lens - , mtl - , optparse-applicative - , process - , relation - , resourcet - , selective - , stm - , stringsearch - , tar - , temporary - , text - , time - , topograph - , unliftio - , zlib + import: base, config + , aeson + , amazonka + , amazonka-core + , amazonka-s3 + , antiope-core + , antiope-s3 + , bytestring + , containers + , cryptonite + , deepseq + , directory + , exceptions + , filepath + , generic-lens + , http-client + , http-client-tls + , http-types + , lens + , mtl + , network-uri + , optparse-applicative + , process + , relation + , resourcet + , stm + , text + , topograph + , transformers other-modules: Paths_cabal_cache autogen-modules: Paths_cabal_cache hs-source-dirs: src - exposed-modules: - App.Commands - App.Commands.Options.Parser - App.Commands.Options.Types - App.Commands.Plan - App.Commands.SyncFromArchive - App.Commands.SyncToArchive - App.Commands.Version - App.Static - App.Static.Base - App.Static.Posix - App.Static.Windows - HaskellWorks.CabalCache.AppError - HaskellWorks.CabalCache.AWS.Env - HaskellWorks.CabalCache.Concurrent.DownloadQueue - HaskellWorks.CabalCache.Concurrent.Fork - HaskellWorks.CabalCache.Concurrent.Type - HaskellWorks.CabalCache.Core - HaskellWorks.CabalCache.Data.List - HaskellWorks.CabalCache.Error - HaskellWorks.CabalCache.GhcPkg - HaskellWorks.CabalCache.Hash - HaskellWorks.CabalCache.IO.Console - HaskellWorks.CabalCache.IO.Error - HaskellWorks.CabalCache.IO.File - HaskellWorks.CabalCache.IO.Lazy - HaskellWorks.CabalCache.IO.Tar - HaskellWorks.CabalCache.Location - HaskellWorks.CabalCache.Metadata - HaskellWorks.CabalCache.Options - HaskellWorks.CabalCache.Show - HaskellWorks.CabalCache.Text - HaskellWorks.CabalCache.Topology - HaskellWorks.CabalCache.Types - HaskellWorks.CabalCache.Version + exposed-modules: HaskellWorks.CabalCache.AppError + HaskellWorks.CabalCache.AWS.Env + HaskellWorks.CabalCache.Concurrent.DownloadQueue + HaskellWorks.CabalCache.Concurrent.Fork + HaskellWorks.CabalCache.Concurrent.Type + HaskellWorks.CabalCache.Core + HaskellWorks.CabalCache.Data.List + HaskellWorks.CabalCache.Error + HaskellWorks.CabalCache.GhcPkg + HaskellWorks.CabalCache.Hash + HaskellWorks.CabalCache.IO.Console + HaskellWorks.CabalCache.IO.Error + HaskellWorks.CabalCache.IO.File + HaskellWorks.CabalCache.IO.Lazy + HaskellWorks.CabalCache.IO.Tar + HaskellWorks.CabalCache.Location + HaskellWorks.CabalCache.Metadata + HaskellWorks.CabalCache.Options + HaskellWorks.CabalCache.Show + HaskellWorks.CabalCache.Text + HaskellWorks.CabalCache.Topology + HaskellWorks.CabalCache.Types + HaskellWorks.CabalCache.Version executable cabal-cache - import: base, config - , optparse-applicative + import: base, config + , aeson + , amazonka + , amazonka-core + , antiope-core + , antiope-optparse-applicative + , bytestring + , containers + , directory + , exceptions + , generic-lens + , http-types + , lens + , mtl + , optparse-applicative + , resourcet + , stm + , stringsearch + , temporary + , text + , unliftio build-depends: cabal-cache main-is: Main.hs hs-source-dirs: app + other-modules: App.Commands + App.Commands.Options.Parser + App.Commands.Options.Types + App.Commands.Plan + App.Commands.SyncFromArchive + App.Commands.SyncToArchive + App.Commands.Version + App.Static + App.Static.Base + App.Static.Posix + App.Static.Windows + Paths_cabal_cache + autogen-modules: Paths_cabal_cache ghc-options: -threaded -rtsopts -with-rtsopts=-N test-suite cabal-cache-test - import: base, config - , aeson - , antiope-core - , antiope-s3 - , bytestring - , containers - , filepath - , generic-lens - , hedgehog - , hspec - , http-types - , hw-hedgehog - , hw-hspec-hedgehog - , lens - , raw-strings-qq - , relation - , text + import: base, config + , aeson + , antiope-core + , bytestring + , filepath + , hedgehog + , hspec + , http-types + , hw-hspec-hedgehog + , lens + , network-uri + , raw-strings-qq + , text type: exitcode-stdio-1.0 main-is: Spec.hs @@ -171,7 +190,6 @@ hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-tool-depends: hspec-discover:hspec-discover - other-modules: - HaskellWorks.CabalCache.AwsSpec - HaskellWorks.CabalCache.LocationSpec - HaskellWorks.CabalCache.QuerySpec + other-modules: HaskellWorks.CabalCache.AwsSpec + HaskellWorks.CabalCache.LocationSpec + HaskellWorks.CabalCache.QuerySpec diff --git a/src/App/Commands.hs b/src/App/Commands.hs deleted file mode 100644 --- a/src/App/Commands.hs +++ /dev/null @@ -1,20 +0,0 @@ -module App.Commands where - -import App.Commands.SyncFromArchive -import App.Commands.Plan -import App.Commands.SyncToArchive -import App.Commands.Version -import Options.Applicative - -{- HLINT ignore "Monoid law, left identity" -} - -commands :: Parser (IO ()) -commands = commandsGeneral - -commandsGeneral :: Parser (IO ()) -commandsGeneral = subparser $ mempty - <> commandGroup "Commands:" - <> cmdPlan - <> cmdSyncFromArchive - <> cmdSyncToArchive - <> cmdVersion diff --git a/src/App/Commands/Options/Parser.hs b/src/App/Commands/Options/Parser.hs deleted file mode 100644 --- a/src/App/Commands/Options/Parser.hs +++ /dev/null @@ -1,13 +0,0 @@ -module App.Commands.Options.Parser where - -import Antiope.Core (FromText, fromText) -import App.Commands.Options.Types (VersionOptions (..)) -import Options.Applicative - -import qualified Data.Text as Text - -optsVersion :: Parser VersionOptions -optsVersion = pure VersionOptions - -text :: FromText a => ReadM a -text = eitherReader (fromText . Text.pack) diff --git a/src/App/Commands/Options/Types.hs b/src/App/Commands/Options/Types.hs deleted file mode 100644 --- a/src/App/Commands/Options/Types.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} - -module App.Commands.Options.Types where - -import Antiope.Env (Region) -import GHC.Generics -import HaskellWorks.CabalCache.Location - -import qualified Antiope.Env as AWS - -data SyncToArchiveOptions = SyncToArchiveOptions - { region :: Region - , archiveUri :: Location - , buildPath :: FilePath - , storePath :: FilePath - , storePathHash :: Maybe String - , threads :: Int - , awsLogLevel :: Maybe AWS.LogLevel - } deriving (Eq, Show, Generic) - -data PlanOptions = PlanOptions - { buildPath :: FilePath - , storePath :: FilePath - , storePathHash :: Maybe String - , outputFile :: FilePath - } deriving (Eq, Show, Generic) - -data SyncFromArchiveOptions = SyncFromArchiveOptions - { region :: Region - , archiveUris :: [Location] - , buildPath :: FilePath - , storePath :: FilePath - , storePathHash :: Maybe String - , threads :: Int - , awsLogLevel :: Maybe AWS.LogLevel - } deriving (Eq, Show, Generic) - -data VersionOptions = VersionOptions deriving (Eq, Show, Generic) diff --git a/src/App/Commands/Plan.hs b/src/App/Commands/Plan.hs deleted file mode 100644 --- a/src/App/Commands/Plan.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module App.Commands.Plan - ( cmdPlan - ) where - -import Antiope.Core (toText) -import App.Commands.Options.Types (PlanOptions (PlanOptions)) -import Control.Applicative -import Control.Lens hiding ((<.>)) -import Control.Monad.Except -import Data.Generics.Product.Any (the) -import Data.Maybe -import HaskellWorks.CabalCache.AppError -import HaskellWorks.CabalCache.Location (Location (..), (<.>), ()) -import HaskellWorks.CabalCache.Show -import HaskellWorks.CabalCache.Version (archiveVersion) -import Options.Applicative hiding (columns) - -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.Lazy as LBS -import qualified Data.Text as T -import qualified HaskellWorks.CabalCache.Core as Z -import qualified HaskellWorks.CabalCache.Hash as H -import qualified HaskellWorks.CabalCache.IO.Console as CIO -import qualified System.IO as IO -import qualified Data.Aeson as J - -{- HLINT ignore "Monoid law, left identity" -} -{- HLINT ignore "Redundant do" -} -{- HLINT ignore "Reduce duplication" -} - -runPlan :: Z.PlanOptions -> IO () -runPlan opts = do - let storePath = opts ^. the @"storePath" - let archiveUris = [Local ""] - let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) - let versionedArchiveUris = archiveUris & each %~ ( archiveVersion) - let outputFile = opts ^. the @"outputFile" - - CIO.putStrLn $ "Store path: " <> toText storePath - CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash - CIO.putStrLn $ "Archive URIs: " <> tshow archiveUris - CIO.putStrLn $ "Archive version: " <> archiveVersion - - tEarlyExit <- STM.newTVarIO False - - mbPlan <- Z.loadPlan $ opts ^. the @"buildPath" - - case mbPlan of - Right planJson -> do - packages <- Z.getPackages storePath planJson - - plan <- forM packages $ \pInfo -> do - let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz" - let archiveFiles = versionedArchiveUris <&> ( T.pack archiveFileBasename) - let scopedArchiveFiles = versionedArchiveUris <&> ( T.pack storePathHash T.pack archiveFileBasename) - - return $ archiveFiles <> scopedArchiveFiles - - if outputFile == "-" - then LBS.putStr $ J.encode (fmap (fmap toText) plan) - else LBS.writeFile outputFile $ J.encode (fmap (fmap toText) plan) - - Left (appError :: AppError) -> do - CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError - - earlyExit <- STM.readTVarIO tEarlyExit - - when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error" - -optsPlan :: Parser PlanOptions -optsPlan = PlanOptions - <$> strOption - ( long "build-path" - <> help ("Path to cabal build directory. Defaults to " <> show AS.buildPath) - <> metavar "DIRECTORY" - <> value AS.buildPath - ) - <*> strOption - ( long "store-path" - <> help "Path to cabal store" - <> metavar "DIRECTORY" - <> value (AS.cabalDirectory "store") - ) - <*> optional - ( strOption - ( long "store-path-hash" - <> help "Store path hash (do not use)" - <> metavar "HASH" - ) - ) - <*> strOption - ( long "output-file" - <> help "Output file" - <> metavar "FILE" - <> value "-" - ) - -cmdPlan :: Mod CommandFields (IO ()) -cmdPlan = command "plan" $ flip info idm $ runPlan <$> optsPlan diff --git a/src/App/Commands/SyncFromArchive.hs b/src/App/Commands/SyncFromArchive.hs deleted file mode 100644 --- a/src/App/Commands/SyncFromArchive.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - -module App.Commands.SyncFromArchive - ( cmdSyncFromArchive - ) where - -import Antiope.Core (Region (..), runResAws, toText) -import Antiope.Env (mkEnv) -import Antiope.Options.Applicative -import App.Commands.Options.Parser (text) -import App.Commands.Options.Types (SyncFromArchiveOptions (SyncFromArchiveOptions)) -import Control.Applicative -import Control.Lens hiding ((<.>)) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Except -import Data.ByteString.Lazy.Search (replace) -import Data.Generics.Product.Any (the) -import Data.Maybe -import Foreign.C.Error (eXDEV) -import HaskellWorks.CabalCache.AppError -import HaskellWorks.CabalCache.IO.Error (catchErrno, exceptWarn, maybeToExcept) -import HaskellWorks.CabalCache.Location (toLocation, (<.>), ()) -import HaskellWorks.CabalCache.Metadata (loadMetadata) -import HaskellWorks.CabalCache.Show -import HaskellWorks.CabalCache.Version (archiveVersion) -import Options.Applicative hiding (columns) -import System.Directory (createDirectoryIfMissing, doesDirectoryExist) - -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 as L -import qualified Data.Map as M -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import qualified HaskellWorks.CabalCache.AWS.Env as AWS -import qualified HaskellWorks.CabalCache.Concurrent.DownloadQueue as DQ -import qualified HaskellWorks.CabalCache.Concurrent.Fork as IO -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.Lazy as IO -import qualified HaskellWorks.CabalCache.IO.Tar as IO -import qualified HaskellWorks.CabalCache.Types as Z -import qualified System.Directory as IO -import qualified System.IO as IO -import qualified System.IO.Temp as IO -import qualified System.IO.Unsafe as IO - -{- HLINT ignore "Monoid law, left identity" -} -{- HLINT ignore "Reduce duplication" -} -{- HLINT ignore "Redundant do" -} - -skippable :: Z.Package -> Bool -skippable package = package ^. the @"packageType" == "pre-existing" - -runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO () -runSyncFromArchive opts = do - let storePath = opts ^. the @"storePath" - let archiveUris = opts ^. the @"archiveUris" - let threads = opts ^. the @"threads" - let awsLogLevel = opts ^. the @"awsLogLevel" - let versionedArchiveUris = archiveUris & each %~ ( archiveVersion) - let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) - let scopedArchiveUris = versionedArchiveUris & each %~ ( T.pack storePathHash) - - CIO.putStrLn $ "Store path: " <> toText storePath - CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash - forM_ archiveUris $ \archiveUri -> do - CIO.putStrLn $ "Archive URI: " <> toText archiveUri - CIO.putStrLn $ "Archive version: " <> archiveVersion - CIO.putStrLn $ "Threads: " <> tshow threads - CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel - - mbPlan <- Z.loadPlan $ opts ^. the @"buildPath" - - case mbPlan of - Right planJson -> do - compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson - - case compilerContextResult of - Right compilerContext -> do - GhcPkg.testAvailability compilerContext - - 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" - - CIO.putStrLn "Creating store directories" - createDirectoryIfMissing True storePath - createDirectoryIfMissing True storeCompilerPath - createDirectoryIfMissing True storeCompilerLibPath - - storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath - - unless storeCompilerPackageDbPathExists $ do - CIO.putStrLn "Package DB missing. Creating Package DB" - GhcPkg.init compilerContext storeCompilerPackageDbPath - - packages <- Z.getPackages storePath planJson - - let installPlan = planJson ^. the @"installPlan" - let planPackages = M.fromList $ fmap (\p -> (p ^. the @"id", p)) installPlan - - 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 - - downloadQueue <- STM.atomically $ DQ.createDownloadQueue planDeps - - let pInfos = M.fromList $ fmap (\p -> (p ^. the @"packageId", p)) packages - - IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do - IO.createDirectoryIfMissing True (tempPath T.unpack compilerId "package.db") - - IO.forkThreadsWait threads $ DQ.runQueue downloadQueue $ \packageId -> case M.lookup packageId pInfos of - Just pInfo -> do - let archiveBaseName = Z.packageDir pInfo <.> ".tar.gz" - let archiveFiles = versionedArchiveUris & each %~ ( T.pack archiveBaseName) - let scopedArchiveFiles = scopedArchiveUris & each %~ ( T.pack archiveBaseName) - let packageStorePath = storePath Z.packageDir pInfo - let maybePackage = M.lookup packageId planPackages - - storeDirectoryExists <- doesDirectoryExist packageStorePath - - 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 (foldMap L.tuple2ToList (L.zip archiveFiles scopedArchiveFiles)) - CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile - - 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) - - 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) - - return True - Nothing -> do - CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId - return True - - 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 - - return () - -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 - 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 - result <- runExceptT $ catchError (exceptWarn f) handler - case result of - 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" - ) - <*> some - ( option (maybeReader (toLocation . T.pack)) - ( long "archive-uri" - <> help "Archive URI to sync to" - <> metavar "S3_URI" - ) - ) - <*> strOption - ( long "build-path" - <> help ("Path to cabal build directory. Defaults to " <> show AS.buildPath) - <> metavar "DIRECTORY" - <> value AS.buildPath - ) - <*> strOption - ( long "store-path" - <> help ("Path to cabal store. Defaults to " <> show AS.cabalDirectory) - <> metavar "DIRECTORY" - <> value (AS.cabalDirectory "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 deleted file mode 100644 --- a/src/App/Commands/SyncToArchive.hs +++ /dev/null @@ -1,212 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module App.Commands.SyncToArchive - ( cmdSyncToArchive - ) where - -import Antiope.Core (Region (..), toText) -import Antiope.Env (mkEnv) -import Antiope.Options.Applicative -import App.Commands.Options.Parser (text) -import App.Commands.Options.Types (SyncToArchiveOptions (SyncToArchiveOptions)) -import Control.Applicative -import Control.Lens hiding ((<.>)) -import Control.Monad.Except -import Control.Monad.Trans.Resource (runResourceT) -import Data.Generics.Product.Any (the) -import Data.List ((\\)) -import Data.Maybe -import HaskellWorks.CabalCache.AppError -import HaskellWorks.CabalCache.Location (Location (..), toLocation, (<.>), ()) -import HaskellWorks.CabalCache.Metadata (createMetadata) -import HaskellWorks.CabalCache.Show -import HaskellWorks.CabalCache.Topology (buildPlanData, canShare) -import HaskellWorks.CabalCache.Version (archiveVersion) -import Options.Applicative hiding (columns) -import System.Directory (doesDirectoryExist) - -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.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 -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.Error as IO -import qualified HaskellWorks.CabalCache.IO.File as IO -import qualified HaskellWorks.CabalCache.IO.Lazy as IO -import qualified HaskellWorks.CabalCache.IO.Tar as IO -import qualified Network.HTTP.Types as HTTP -import qualified System.Directory as IO -import qualified System.IO as IO -import qualified System.IO.Temp as IO -import qualified System.IO.Unsafe as IO -import qualified UnliftIO.Async as IO - -{- HLINT ignore "Monoid law, left identity" -} -{- HLINT ignore "Redundant do" -} -{- HLINT ignore "Reduce duplication" -} - -runSyncToArchive :: Z.SyncToArchiveOptions -> IO () -runSyncToArchive opts = do - let storePath = opts ^. the @"storePath" - let archiveUri = opts ^. the @"archiveUri" - let threads = opts ^. the @"threads" - let awsLogLevel = opts ^. the @"awsLogLevel" - let versionedArchiveUri = archiveUri archiveVersion - let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) - let scopedArchiveUri = versionedArchiveUri T.pack storePathHash - - CIO.putStrLn $ "Store path: " <> toText storePath - CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash - CIO.putStrLn $ "Archive URI: " <> toText archiveUri - CIO.putStrLn $ "Archive version: " <> archiveVersion - CIO.putStrLn $ "Threads: " <> tshow threads - CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel - - tEarlyExit <- STM.newTVarIO False - - mbPlan <- Z.loadPlan $ opts ^. the @"buildPath" - - case mbPlan of - Right planJson -> do - compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson - - 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 - - packages <- Z.getPackages storePath planJson - nonShareable <- packages & filterM (fmap not . isShareable storePath) - let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId") - - let storeCompilerPath = storePath T.unpack compilerId - let storeCompilerPackageDbPath = storeCompilerPath "package.db" - - storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath - - unless storeCompilerPackageDbPathExists $ - GhcPkg.init compilerContext storeCompilerPackageDbPath - - CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages" - - IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do - CIO.putStrLn $ "Temp path: " <> tshow tempPath - - 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 - - -- 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 - - archiveFileExists <- runResourceT $ IO.resourceExists envAws targetFile - - unless archiveFileExists $ do - packageStorePathExists <- doesDirectoryExist packageStorePath - - when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn $ do - let workingStorePackagePath = tempPath Z.packageDir pInfo - liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath - - let rp2 = Z.relativePaths storePath pInfo - - CIO.putStrLn $ "Creating " <> toText targetFile - - let tempArchiveFile = tempPath archiveFileBasename - - metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)] - - IO.createTar tempArchiveFile (rp2 <> [metas]) - - 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 - - earlyExit <- STM.readTVarIO tEarlyExit - - when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error" - -isShareable :: MonadIO m => FilePath -> Z.PackageInfo -> m Bool -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 $ AS.cabalDirectory "archive") - ) - <*> strOption - ( long "build-path" - <> help ("Path to cabal build directory. Defaults to " <> show AS.buildPath) - <> metavar "DIRECTORY" - <> value AS.buildPath - ) - <*> strOption - ( long "store-path" - <> help "Path to cabal store" - <> metavar "DIRECTORY" - <> value (AS.cabalDirectory "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/App/Commands/Version.hs b/src/App/Commands/Version.hs deleted file mode 100644 --- a/src/App/Commands/Version.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module App.Commands.Version - ( cmdVersion - ) where - -import App.Commands.Options.Parser (optsVersion) -import Data.List -import Options.Applicative hiding (columns) - -import qualified App.Commands.Options.Types as Z -import qualified Data.Text as T -import qualified Data.Version as V -import qualified HaskellWorks.CabalCache.IO.Console as CIO -import qualified Paths_cabal_cache as P - -{- HLINT ignore "Redundant do" -} -{- HLINT ignore "Reduce duplication" -} - -runVersion :: Z.VersionOptions -> IO () -runVersion _ = do - let V.Version {..} = P.version - - let version = intercalate "." $ fmap show versionBranch - - CIO.putStrLn $ "cabal-cache " <> T.pack version - -cmdVersion :: Mod CommandFields (IO ()) -cmdVersion = command "version" $ flip info idm $ runVersion <$> optsVersion diff --git a/src/App/Static.hs b/src/App/Static.hs deleted file mode 100644 --- a/src/App/Static.hs +++ /dev/null @@ -1,11 +0,0 @@ -module App.Static where - -import qualified App.Static.Base as S -import qualified App.Static.Posix as P -import qualified App.Static.Windows as W - -cabalDirectory :: FilePath -cabalDirectory = if S.isPosix then P.cabalDirectory else W.cabalDirectory - -buildPath :: FilePath -buildPath = "dist-newstyle" diff --git a/src/App/Static/Base.hs b/src/App/Static/Base.hs deleted file mode 100644 --- a/src/App/Static/Base.hs +++ /dev/null @@ -1,13 +0,0 @@ -module App.Static.Base where - -import qualified System.Directory as IO -import qualified System.Info as I -import qualified System.IO.Unsafe as IO - -homeDirectory :: FilePath -homeDirectory = IO.unsafePerformIO IO.getHomeDirectory -{-# NOINLINE homeDirectory #-} - -isPosix :: Bool -isPosix = I.os /= "mingw32" -{-# NOINLINE isPosix #-} diff --git a/src/App/Static/Posix.hs b/src/App/Static/Posix.hs deleted file mode 100644 --- a/src/App/Static/Posix.hs +++ /dev/null @@ -1,8 +0,0 @@ -module App.Static.Posix where - -import HaskellWorks.CabalCache.Location (()) - -import qualified App.Static.Base as S - -cabalDirectory :: FilePath -cabalDirectory = S.homeDirectory ".cabal" diff --git a/src/App/Static/Windows.hs b/src/App/Static/Windows.hs deleted file mode 100644 --- a/src/App/Static/Windows.hs +++ /dev/null @@ -1,15 +0,0 @@ -module App.Static.Windows where - -import Data.Maybe -import HaskellWorks.CabalCache.Location (()) - -import qualified App.Static.Base as S -import qualified System.Environment as IO -import qualified System.IO.Unsafe as IO - -appDataDirectory :: FilePath -appDataDirectory = IO.unsafePerformIO $ fmap (fromMaybe S.homeDirectory) (IO.lookupEnv "APPDATA") -{-# NOINLINE appDataDirectory #-} - -cabalDirectory :: FilePath -cabalDirectory = appDataDirectory "cabal" diff --git a/src/HaskellWorks/CabalCache/IO/Error.hs b/src/HaskellWorks/CabalCache/IO/Error.hs --- a/src/HaskellWorks/CabalCache/IO/Error.hs +++ b/src/HaskellWorks/CabalCache/IO/Error.hs @@ -10,16 +10,9 @@ ) where import Control.Monad.Except -import Foreign.C.Error - ( - getErrno - , Errno - ) +import Foreign.C.Error (Errno, getErrno) import HaskellWorks.CabalCache.AppError -import System.IO.Error - ( - catchIOError - ) +import System.IO.Error (catchIOError) import qualified HaskellWorks.CabalCache.IO.Console as CIO import qualified System.Exit as IO diff --git a/src/HaskellWorks/CabalCache/IO/Lazy.hs b/src/HaskellWorks/CabalCache/IO/Lazy.hs --- a/src/HaskellWorks/CabalCache/IO/Lazy.hs +++ b/src/HaskellWorks/CabalCache/IO/Lazy.hs @@ -22,12 +22,14 @@ import Control.Lens import Control.Monad.Catch import Control.Monad.Except +import Control.Monad.Trans.Except import Control.Monad.Trans.Resource import Data.Either (isRight) import Data.Generics.Product.Any import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.Location (Location (..)) import HaskellWorks.CabalCache.Show +import Network.URI (URI) import qualified Antiope.S3.Lazy as AWS import qualified Control.Concurrent as IO @@ -40,6 +42,7 @@ import qualified Network.AWS.S3.PutObject as AWS import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Client.TLS as HTTPS import qualified System.Directory as IO import qualified System.FilePath.Posix as FP import qualified System.IO as IO @@ -64,19 +67,28 @@ _ -> return (Left (GenericAppError (tshow e'))) _ -> throwM e -getS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either AppError LBS.ByteString) -getS3Uri envAws s3Uri = case reslashS3Uri s3Uri of - (AWS.S3Uri b k) -> handleAwsError $ runAws envAws $ AWS.unsafeDownload b k +getS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> URI -> m (Either AppError LBS.ByteString) +getS3Uri envAws uri = runExceptT $ do + AWS.S3Uri b k <- except $ uriToS3Uri (reslashUri uri) + ExceptT . handleAwsError $ runAws envAws $ AWS.unsafeDownload b k +uriToS3Uri :: URI -> Either AppError S3Uri +uriToS3Uri uri = case fromText @S3Uri (tshow uri) of + Right s3Uri -> Right s3Uri + Left msg -> Left . GenericAppError $ "Unable to parse URI" <> tshow msg + readResource :: (MonadResource m, MonadCatch m) => AWS.Env -> Location -> m (Either AppError LBS.ByteString) readResource envAws = \case - S3 s3Uri -> getS3Uri envAws (reslashS3Uri s3Uri) - Local path -> liftIO $ do + Local path -> liftIO $ do fileExists <- IO.doesFileExist path if fileExists then Right <$> LBS.readFile path else pure (Left NotFound) - HttpUri httpUri -> liftIO $ readHttpUri (reslashHttpUri httpUri) + Uri uri -> case uri ^. the @"uriScheme" of + "s3:" -> getS3Uri envAws (reslashUri uri) + "http:" -> liftIO $ readHttpUri (reslashUri uri) + "https:" -> liftIO $ readHttpUri (reslashUri uri) + scheme -> return (Left (GenericAppError ("Unrecognised uri scheme: " <> T.pack scheme))) readFirstAvailableResource :: (MonadResource m, MonadCatch m) => AWS.Env -> [Location] -> m (Either AppError (LBS.ByteString, Location)) readFirstAvailableResource _ [] = return (Left (GenericAppError "No resources specified in read")) @@ -97,8 +109,6 @@ resourceExists :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> Location -> m Bool resourceExists envAws = \case - S3 s3Uri -> isRight <$> runResourceT (headS3Uri envAws (reslashS3Uri s3Uri)) - HttpUri httpUri -> isRight <$> headHttpUri (reslashHttpUri httpUri) Local path -> do fileExists <- liftIO $ IO.doesFileExist path if fileExists @@ -110,6 +120,10 @@ target <- liftIO $ IO.getSymbolicLinkTarget path resourceExists envAws (Local target) else return False + Uri uri -> case uri ^. the @"uriScheme" of + "s3:" -> isRight <$> runResourceT (headS3Uri envAws (reslashUri uri)) + "http:" -> isRight <$> headHttpUri (reslashUri uri) + _scheme -> return False firstExistingResource :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> [Location] -> m (Maybe Location) firstExistingResource _ [] = return Nothing @@ -119,38 +133,45 @@ then return (Just a) else firstExistingResource envAws as -headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either AppError AWS.HeadObjectResponse) -headS3Uri envAws s3Uri = case reslashS3Uri s3Uri of - AWS.S3Uri b k -> handleAwsError $ runAws envAws $ AWS.send $ AWS.headObject b k - -uploadToS3 :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m (Either AppError ()) -uploadToS3 envAws s3Uri lbs = case reslashS3Uri s3Uri of - AWS.S3Uri b k -> do - let req = AWS.toBody lbs - let po = AWS.putObject b k req - handleAwsError $ void $ runResAws envAws $ AWS.send po +headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> URI -> m (Either AppError AWS.HeadObjectResponse) +headS3Uri envAws uri = runExceptT $ do + AWS.S3Uri b k <- except $ uriToS3Uri (reslashUri uri) + ExceptT . handleAwsError $ runAws envAws $ AWS.send $ AWS.headObject b k -reslashS3Uri :: S3Uri -> S3Uri -reslashS3Uri uri = uri & the @"objectKey" . the @1 %~ (T.replace "\\" "/") +uploadToS3 :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> URI -> LBS.ByteString -> m (Either AppError ()) +uploadToS3 envAws uri lbs = runExceptT $ do + AWS.S3Uri b k <- except $ uriToS3Uri (reslashUri uri) + let req = AWS.toBody lbs + let po = AWS.putObject b k req + ExceptT . handleAwsError $ void $ runResAws envAws $ AWS.send po -reslashHttpUri :: Text -> Text -reslashHttpUri = T.replace "\\" "/" +reslashUri :: URI -> URI +reslashUri uri = uri & the @"uriPath" %~ fmap reslashChar + where reslashChar :: Char -> Char + reslashChar '\\' = '/' + reslashChar c = c 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 (reslashS3Uri s3Uri) lbs Local path -> liftIO (LBS.writeFile path lbs) >> return (Right ()) - HttpUri _ -> return (Left (GenericAppError "HTTP PUT method not supported")) + Uri uri -> case uri ^. the @"uriScheme" of + "s3:" -> uploadToS3 envAws (reslashUri uri) lbs + "http:" -> return (Left (GenericAppError "HTTP PUT method not supported")) + scheme -> return (Left (GenericAppError ("Unrecognised uri scheme: " <> T.pack scheme))) createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m () createLocalDirectoryIfMissing = \case - S3 _ -> return () - Local path -> liftIO $ IO.createDirectoryIfMissing True path - HttpUri _ -> return () + Local path -> liftIO $ IO.createDirectoryIfMissing True path + Uri uri -> case uri ^. the @"uriScheme" of + "s3:" -> return () + "http:" -> return () + _scheme -> return () -copyS3Uri :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> AWS.S3Uri -> ExceptT AppError m () -copyS3Uri envAws source target = case (reslashS3Uri source, reslashS3Uri target) of - (AWS.S3Uri sourceBucket sourceObjectKey, AWS.S3Uri targetBucket targetObjectKey) -> ExceptT $ do +copyS3Uri :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> URI -> URI -> ExceptT AppError m () +copyS3Uri envAws source target = do + AWS.S3Uri sourceBucket sourceObjectKey <- except $ uriToS3Uri (reslashUri source) + AWS.S3Uri targetBucket targetObjectKey <- except $ uriToS3Uri (reslashUri target) + ExceptT $ do responseResult <- runResourceT $ handleAwsError $ runAws envAws $ AWS.send (AWS.copyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey) case responseResult of @@ -181,31 +202,31 @@ linkOrCopyResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> Location -> ExceptT AppError m () linkOrCopyResource envAws source target = case source of - S3 sourceS3Uri -> case target of - S3 targetS3Uri -> retryUnless ((== Just 301) . appErrorStatus) 3 (copyS3Uri envAws (reslashS3Uri sourceS3Uri) (reslashS3Uri targetS3Uri)) - Local _ -> throwError "Can't copy between different file backends" - HttpUri _ -> throwError "Link and copy unsupported for http backend" Local sourcePath -> case target of - S3 _ -> throwError "Can't copy between different file backends" Local targetPath -> do liftIO $ IO.createDirectoryIfMissing True (FP.takeDirectory targetPath) targetPathExists <- liftIO $ IO.doesFileExist targetPath unless targetPathExists $ liftIO $ IO.createFileLink sourcePath targetPath - HttpUri _ -> throwError "Link and copy unsupported for http backend" - HttpUri _ -> throwError "HTTP PUT method not supported" + Uri _ -> throwError "Can't copy between different file backends" + Uri sourceUri -> case target of + Local _targetPath -> throwError "Can't copy between different file backends" + Uri targetUri -> case (sourceUri ^. the @"uriScheme", targetUri ^. the @"uriScheme") of + ("s3:", "s3:") -> retryUnless ((== Just 301) . appErrorStatus) 3 (copyS3Uri envAws (reslashUri sourceUri) (reslashUri targetUri)) + ("http:", "http:") -> throwError "Link and copy unsupported for http backend" + (sourceScheme, targetScheme) -> throwError $ GenericAppError $ "Unsupported backend combination: " <> T.pack sourceScheme <> " to " <> T.pack targetScheme -readHttpUri :: (MonadIO m, MonadCatch m) => Text -> m (Either AppError LBS.ByteString) +readHttpUri :: (MonadIO m, MonadCatch m) => URI -> m (Either AppError LBS.ByteString) readHttpUri httpUri = handleHttpError $ do - manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings - request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("GET " <> reslashHttpUri httpUri)) + manager <- liftIO $ HTTP.newManager HTTPS.tlsManagerSettings + request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("GET " <> tshow (reslashUri httpUri))) response <- liftIO $ HTTP.httpLbs request manager return $ HTTP.responseBody response -headHttpUri :: (MonadIO m, MonadCatch m) => Text -> m (Either AppError LBS.ByteString) +headHttpUri :: (MonadIO m, MonadCatch m) => URI -> m (Either AppError LBS.ByteString) headHttpUri httpUri = handleHttpError $ do manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings - request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("HEAD " <> (reslashHttpUri httpUri))) + request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("HEAD " <> tshow (reslashUri httpUri))) response <- liftIO $ HTTP.httpLbs request manager return $ HTTP.responseBody response diff --git a/src/HaskellWorks/CabalCache/Location.hs b/src/HaskellWorks/CabalCache/Location.hs --- a/src/HaskellWorks/CabalCache/Location.hs +++ b/src/HaskellWorks/CabalCache/Location.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} + module HaskellWorks.CabalCache.Location ( IsPath(..) , Location(..) @@ -10,13 +13,18 @@ ) where -import Antiope.Core (ToText (..), fromText) -import Antiope.S3 (ObjectKey (..), S3Uri (..)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import GHC.Generics (Generic) +import Antiope.Core (ToText (..)) +import Antiope.S3 (ObjectKey (..), S3Uri (..)) +import Control.Lens hiding ((<.>)) +import Data.Generics.Product.Any +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import GHC.Generics (Generic) +import HaskellWorks.CabalCache.Show +import Network.URI (URI) import qualified Data.Text as T +import qualified Network.URI as URI import qualified System.FilePath as FP class IsPath a s | a -> s where @@ -27,29 +35,29 @@ infixr 7 <.> data Location - = S3 S3Uri + = Uri URI | Local FilePath - | HttpUri Text deriving (Show, Eq, Generic) instance ToText Location where - toText (S3 uri) = toText uri - toText (Local p) = T.pack p - toText (HttpUri uri) = uri + toText (Uri uri) = tshow uri + toText (Local p) = T.pack p instance IsPath Location Text where - (S3 b) p = S3 (b p) - (Local b) p = Local (b T.unpack p) - (HttpUri b) p = HttpUri (b p) + Uri b p = Uri (b p) + Local b p = Local (b T.unpack p) - (S3 b) <.> e = S3 (b <.> e) - (Local b) <.> e = Local (b <.> T.unpack e) - (HttpUri b) <.> e = HttpUri (b <.> e) + Uri b <.> e = Uri (b <.> e) + Local b <.> e = Local (b <.> T.unpack e) instance IsPath Text Text where b p = T.pack (T.unpack b FP. T.unpack p) b <.> e = T.pack (T.unpack b FP.<.> T.unpack e) +instance IsPath URI Text where + b p = b & the @"uriPath" %~ (<> "/" <> T.unpack p) + b <.> e = b & the @"uriPath" %~ (<> "." <> T.unpack e) + instance (a ~ Char) => IsPath [a] [a] where b p = b FP. p b <.> e = b FP.<.> e @@ -62,13 +70,9 @@ S3Uri b (ObjectKey (stripEnd "." k <> "." <> stripStart "." e)) toLocation :: Text -> Maybe Location -toLocation txt = if - | T.isPrefixOf "s3://" txt' -> either (const Nothing) (Just . S3) (fromText txt') - | T.isPrefixOf "file://" txt' -> Just (Local (T.unpack txt')) - | T.isPrefixOf "http://" txt' -> Just (HttpUri txt') - | T.isInfixOf "://" txt' -> Nothing - | otherwise -> Just (Local (T.unpack txt')) - where txt' = T.strip txt +toLocation t = case URI.parseURI (T.unpack t) of + Just uri -> Just (Uri uri) + Nothing -> Just (Local (T.unpack t)) ------------------------------------------------------------------------------- stripStart :: Text -> Text -> Text diff --git a/test/HaskellWorks/CabalCache/AwsSpec.hs b/test/HaskellWorks/CabalCache/AwsSpec.hs --- a/test/HaskellWorks/CabalCache/AwsSpec.hs +++ b/test/HaskellWorks/CabalCache/AwsSpec.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + module HaskellWorks.CabalCache.AwsSpec ( spec ) where @@ -16,9 +18,9 @@ import Hedgehog import Test.Hspec -import qualified Antiope.S3.Types as AWS import qualified Data.ByteString.Lazy.Char8 as LBSC import qualified Network.HTTP.Types as HTTP +import qualified Network.URI as URI import qualified System.Environment as IO {- HLINT ignore "Redundant do" -} @@ -31,7 +33,8 @@ ci <- liftIO $ IO.lookupEnv "CI" <&> isJust unless ci $ do envAws <- liftIO $ mkEnv Oregon (const LBSC.putStrLn) - result <- liftIO $ runResourceT $ headS3Uri envAws $ AWS.S3Uri "jky-mayhem" "hjddhd" + let Just uri = URI.parseURI "s3://jky-mayhem/hjddhd" + result <- liftIO $ runResourceT $ headS3Uri envAws uri result === Left AwsAppError { status = HTTP.Status { HTTP.statusCode = 404 , HTTP.statusMessage = "Not Found" } } diff --git a/test/HaskellWorks/CabalCache/LocationSpec.hs b/test/HaskellWorks/CabalCache/LocationSpec.hs --- a/test/HaskellWorks/CabalCache/LocationSpec.hs +++ b/test/HaskellWorks/CabalCache/LocationSpec.hs @@ -5,31 +5,33 @@ ) where import Antiope.Core (toText) -import Antiope.S3 (BucketName (..), ObjectKey (..), S3Uri (..)) import HaskellWorks.CabalCache.Location +import Data.Maybe (fromJust) import HaskellWorks.Hspec.Hedgehog import Hedgehog +import Network.URI (URI) import Test.Hspec +import qualified Data.List as L import qualified Data.List as List import qualified Data.Text as Text import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +import qualified Network.URI as URI import qualified System.FilePath as FP {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Redundant bracket" -} -s3Uri :: MonadGen m => m S3Uri +s3Uri :: MonadGen m => m URI s3Uri = do - let partGen = Gen.text (Range.linear 3 10) Gen.alphaNum + let partGen = Gen.string (Range.linear 3 10) Gen.alphaNum bkt <- partGen parts <- Gen.list (Range.linear 1 5) partGen - ext <- Gen.text (Range.linear 2 4) Gen.alphaNum - pure $ S3Uri (BucketName bkt) (ObjectKey (Text.intercalate "/" parts <> "." <> ext)) - + ext <- Gen.string (Range.linear 2 4) Gen.alphaNum + pure $ fromJust $ URI.parseURI $ "s3://" <> bkt <> "/" <> L.intercalate "/" parts <> "." <> ext localPath :: MonadGen m => m FilePath localPath = do let partGen = Gen.string (Range.linear 3 10) Gen.alphaNum @@ -39,24 +41,28 @@ spec :: Spec spec = describe "HaskellWorks.Assist.LocationSpec" $ do + it "URI bucket-only" $ requireTest $ do + fromJust (URI.parseURI "s3://bucket") "directory" === fromJust (URI.parseURI "s3://bucket/directory") + + it "Location bucket-only" $ requireTest $ do + fromJust (toLocation "s3://bucket") "directory" === fromJust (toLocation "s3://bucket/directory") + it "S3 should roundtrip from and to text" $ require $ property $ do uri <- forAll s3Uri - tripping (S3 uri) toText toLocation + tripping (Uri uri) toText toLocation it "LocalLocation should roundtrip from and to text" $ require $ property $ do path <- forAll localPath tripping (Local path) toText toLocation it "Should append s3 path" $ require $ property $ do - loc <- S3 <$> forAll s3Uri + loc <- Uri <$> forAll s3Uri part <- forAll $ Gen.text (Range.linear 3 10) Gen.alphaNum ext <- forAll $ Gen.text (Range.linear 2 4) Gen.alphaNum - toText (loc part <.> ext) === (toText loc) <> "/" <> part <> "." <> ext - toText (loc ("/" <> part) <.> ("." <> ext)) === (toText loc) <> "/" <> part <> "." <> ext + toText (loc part <.> ext) === toText loc <> "/" <> part <> "." <> ext it "Should append s3 path" $ require $ property $ do loc <- Local <$> forAll localPath part <- forAll $ Gen.string (Range.linear 3 10) Gen.alphaNum ext <- forAll $ Gen.string (Range.linear 2 4) Gen.alphaNum toText (loc Text.pack part <.> Text.pack ext) === Text.pack ((Text.unpack $ toText loc) FP. part FP.<.> ext) -