cabal-cache 0.2.0.2 → 1.0.0.0

raw patch · 16 files changed

+455/−176 lines, 16 filesdep +containersdep +cryptonitePVP ok

version bump matches the API change (PVP)

Dependencies added: containers, cryptonite

API changes (from Hackage documentation)

Files

• README.md +157/−0
• cabal-cache.cabal +8/−4
• src/App/Commands/Options/Parser.hs +16/−2
• src/App/Commands/Options/Types.hs +10/−8
• src/App/Commands/SyncFromArchive.hs +68/−44
• src/App/Commands/SyncToArchive.hs +54/−49
• src/HaskellWorks/Ci/Assist/Core.hs +3/−10
• src/HaskellWorks/Ci/Assist/Hash.hs +10/−0
• src/HaskellWorks/Ci/Assist/IO/Error.hs +12/−4
• src/HaskellWorks/Ci/Assist/IO/File.hs +9/−0
• src/HaskellWorks/Ci/Assist/IO/Lazy.hs +57/−6
• src/HaskellWorks/Ci/Assist/IO/Tar.hs +3/−2
• src/HaskellWorks/Ci/Assist/Metadata.hs +40/−0
• src/HaskellWorks/Ci/Assist/PackageConfig.hs +0/−20
• src/HaskellWorks/Ci/Assist/Tar.hs +0/−27
• src/HaskellWorks/Ci/Assist/Version.hs +8/−0

@@ -1,2 +1,159 @@ # cabal-cache+[![master](https://circleci.com/gh/haskell-works/cabal-cache/tree/master.svg?style=svg)](https://circleci.com/gh/haskell-works/cabal-cache/tree/master)+ Tool for caching built cabal new-build packages.++The tool is useful in development when you want to share your build haskell package dependencies of+of a particular project with another developer and also in CI where caching is useful for reducing+build times.++`cabal-cache` supports syncing to an archive directory or to an S3 bucket.++## Installation++Several installation methods are available.++### From source++```bash+cabal new-install cabal-cache+```++### Ubuntu binaries++Dowload Ubuntu binaries from https://github.com/haskell-works/cabal-cache/releases++### Using Homebrew on Mac OS X++```bash+brew tap haskell-works/homebrew-haskell-works git@github.com:haskell-works/homebrew-haskell-works.git+brew update+brew install cabal-cache+```++## Example usage++Syncing built packages with S3 requires you have an S3 bucket with AWS+credentials stored in the `AWS_ACCESS_KEY_ID` and `AWS_SECRET_ACCESS_KEY` environent variables.+You should also know the AWS region the bucket was created in.++### Sync to archive++Change into your project directory.++Build the project with `cabal v2-build`.  This will ensure your dependencies are built and+will produce a `plan.json` file that is required for the `cabal-cache` tool to know which built+packages to sync up.++Run the following command to sync to S3.++```bash+cabal-cache sync-to-archive --threads 16 --archive-uri s3://my-cabal-cache-bucket/archive --region Sydney+```++Run the following command to sync to archive directory.++```bash+cabal-cache sync-to-archive --threads 16 --archive-uri archive --region Sydney+```++### Sync from S3++Change into your project directory.++Build the project with `cabal v2-configure`.  This will product a `plan.json` file that is required+for the `cabal-cache` tool to know which built packages to sync down.++Run the following command to sync from S3.++```bash+cabal-cache sync-from-archive --threads 16 --archive-uri s3://my-cabal-cache-bucket/archive --region Sydney+```++Run the following command to sync from archive directory.++```bash+cabal-cache sync-from-archive --threads 16 --archive-uri archive --region Sydney+```++## The archive++### Archive tarball format++Built packages are stored in tarballs which contain the following files:++```bash+x ${compiler_id}/${package_id}/_CC_METADATA/store-path+x ${compiler_id}/lib/libHS${package_id}-*.dylib+x ${compiler_id}/${package_id}+x ${compiler_id}/package.db/${package_id}.conf+```++Aside from the files in the `_CC_METADATA` directory, everything else is copied verbatim from cabal+store from the corresponding location.  This includes the `conf` file which may contain absolute paths+that would cause the built package to be non-relocatable.++As a work-around, the tarball also inclues the `_CC_METADATA/store-path`+file which stores the cabal store path from which the cached package was derived.++Upon unpacking, `cabal-cache` will rewrite the `conf` file to contain the new store path using the+information store in the `_CC_METADATA/store-path` file.  `_CC_METADATA` directory and its contents+will be additionally unpacked making it easy to recognise packages that have been restored using+`cabal-cache`.++### Archive directory structure++The archive contains files in the following locations:++```bash+/Users/jky/moo-archive/${archive_version}/${compiler_id}/${package_id}.tar.gz+/Users/jky/moo-archive/${archive_version}/${store_hash}/${compiler_id}/${package_id}.tar.gz+```++Both tarballs are identical.  If they both exist then the first may be a symlink to the second+when store on the filesystem.++The direct subdirectories of the archive is the `${archive_verson}`, for example `v1`.  This is the+version of the archive format.  This corresponds to the major version of the `cabal-cache` package.++The next directory may be the `${store_hash}` or the `${compiler_id}`.  If it is the `${store_hash}`+then the `${compiler_id}` will be a subdirectory of that.++The `${store_hash}` is the hash of the store path from which the cached package originally came.++`cabal-cache` will preferentially restore using this version if it is available and the `${store_hash}`+matches the cabal store path that is being restore to.++If the package matching the `${store_hash}` cannot be found, `cabal-cache` will fallback to the version+without the `${store_hash}`.++A version without a `${store-hash}` may not exist.  See [Caveats](#caveats) for more information.++## Caveats++### Packages that use absolute paths to the cabal store++Packages sometimes do things that cause their built artefacts to contain absolute paths to the cabal+store.  This unfortunately makes such built packages non-relocatable.++It is recommended that you use a fixed cabal store path rather than the default `$HOME/.cabal/store`+to avoid any potential issues.++See https://github.com/haskell/cabal/issues/4097 for more information.++Following are examples of how this might happen:++#### Paths_$pkgname++`Paths_$pkgname` modules have embedded within them the absolute path to the package in the cabal store+which means that packages that use some features of this module are not relocatable depending on what+they do.++Packages may query this module to get access to the package's cabal store `share` directory which+contains data files that the package can read at runtime.  Using `cabal-cache` for such packages+could mean that the package will be unable to find such data files.++To protect against this, `cabal-cache` will by default not sync packages down from the archive+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.

@@ -1,7 +1,7 @@ cabal-version:          2.2  name:                   cabal-cache-version:                0.2.0.2+version:                1.0.0.0 synopsis:               CI Assistant for Haskell projects description:            CI Assistant for Haskell projects.  Implements package caching. homepage:               https://github.com/haskell-works/cabal-cache@@ -27,6 +27,8 @@ common antiope-s3           { build-depends: antiope-s3           >= 7.0.0      && < 8      } common bytestring           { build-depends: bytestring           >= 0.10.8.2   && < 0.11   } common conduit-extra        { build-depends: conduit-extra        >= 1.3.1.1    && < 1.4    }+common cryptonite           { build-depends: cryptonite           >= 0.25       && < 1      }+common containers           { build-depends: containers           >= 0.6.0.1    && < 0.7    } common deepseq              { build-depends: deepseq              >= 1.4.4.0    && < 1.5    } common directory            { build-depends: directory            >= 1.3.3.0    && < 1.4    } common exceptions           { build-depends: exceptions           >= 0.10.1     && < 0.11   }@@ -65,6 +67,8 @@           , antiope-s3           , bytestring           , conduit-extra+          , cryptonite+          , containers           , deepseq           , directory           , exceptions@@ -72,7 +76,6 @@           , generic-lens           , http-types           , lens-          , lens           , mtl           , optparse-applicative           , process@@ -97,6 +100,7 @@       App.Commands.Version       App.Static       HaskellWorks.Ci.Assist.Core+      HaskellWorks.Ci.Assist.Hash       HaskellWorks.Ci.Assist.IO.Console       HaskellWorks.Ci.Assist.GhcPkg       HaskellWorks.Ci.Assist.IO.Error@@ -104,12 +108,12 @@       HaskellWorks.Ci.Assist.IO.Lazy       HaskellWorks.Ci.Assist.IO.Tar       HaskellWorks.Ci.Assist.Location+      HaskellWorks.Ci.Assist.Metadata       HaskellWorks.Ci.Assist.Options-      HaskellWorks.Ci.Assist.PackageConfig       HaskellWorks.Ci.Assist.Show-      HaskellWorks.Ci.Assist.Tar       HaskellWorks.Ci.Assist.Text       HaskellWorks.Ci.Assist.Types+      HaskellWorks.Ci.Assist.Version  executable cabal-cache   import:   base, config

@@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}-module App.Commands.Options.Parser-where+module App.Commands.Options.Parser where  import Antiope.Core                    (FromText, Region (..), fromText) import App.Commands.Options.Types      (SyncFromArchiveOptions (..), SyncToArchiveOptions (..), VersionOptions (..)) import App.Static                      (homeDirectory)+import Control.Applicative import HaskellWorks.Ci.Assist.Location (Location (..), toLocation, (</>)) import Options.Applicative @@ -30,6 +30,13 @@       <>  metavar "DIRECTORY"       <>  value (homeDirectory </> ".cabal" </> "store")       )+  <*> optional+      ( strOption+        (   long "store-path-hash"+        <>  help "Store path hash (do not use)"+        <>  metavar "HASH"+        )+      )   <*> option auto       (   long "threads"       <>  help "Number of concurrent threads"@@ -56,6 +63,13 @@       <>  help "Path to cabal store"       <>  metavar "DIRECTORY"       <>  value (homeDirectory </> ".cabal" </> "store")+      )+  <*> optional+      ( strOption+        (   long "store-path-hash"+        <>  help "Store path hash (do not use)"+        <>  metavar "HASH"+        )       )   <*> option auto       (   long "threads"

@@ -11,17 +11,19 @@ import Network.AWS.Types               (Region)  data SyncToArchiveOptions = SyncToArchiveOptions-  { region     :: Region-  , archiveUri :: Location-  , storePath  :: FilePath-  , threads    :: Int+  { region        :: Region+  , archiveUri    :: Location+  , storePath     :: FilePath+  , storePathHash :: Maybe String+  , threads       :: Int   } deriving (Eq, Show, Generic)  data SyncFromArchiveOptions = SyncFromArchiveOptions-  { region     :: Region-  , archiveUri :: Location-  , storePath  :: FilePath-  , threads    :: Int+  { region        :: Region+  , archiveUri    :: Location+  , storePath     :: FilePath+  , storePathHash :: Maybe String+  , threads       :: Int   } deriving (Eq, Show, Generic)  data VersionOptions = VersionOptions deriving (Eq, Show, Generic)

@@ -7,33 +7,40 @@   ( cmdSyncFromArchive   ) where -import Antiope.Core                         (runResAws, toText)-import Antiope.Env                          (LogLevel, mkEnv)-import App.Commands.Options.Parser          (optsSyncFromArchive)-import App.Static                           (homeDirectory)-import Control.Lens                         hiding ((<.>))-import Control.Monad                        (unless, void, when)+import Antiope.Core                    (runResAws, toText)+import Antiope.Env                     (LogLevel, mkEnv)+import App.Commands.Options.Parser     (optsSyncFromArchive)+import App.Static                      (homeDirectory)+import Control.Lens                    hiding ((<.>))+import Control.Monad                   (unless, void, when) import Control.Monad.Except-import Control.Monad.IO.Class               (liftIO)-import Control.Monad.Trans.Resource         (runResourceT)-import Data.Generics.Product.Any            (the)-import Data.Semigroup                       ((<>))-import Data.Text                            (Text)-import HaskellWorks.Ci.Assist.Core          (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan)-import HaskellWorks.Ci.Assist.Location      ((<.>), (</>))-import HaskellWorks.Ci.Assist.PackageConfig (unTemplateConfig)+import Control.Monad.IO.Class          (liftIO)+import Control.Monad.Trans.Resource    (runResourceT)+import Data.ByteString.Lazy.Search     (replace)+import Data.Generics.Product.Any       (the)+import Data.Maybe+import Data.Semigroup                  ((<>))+import Data.Text                       (Text)+import HaskellWorks.Ci.Assist.Core     (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan)+import HaskellWorks.Ci.Assist.IO.Error (exceptWarn, maybeToExcept, maybeToExceptM)+import HaskellWorks.Ci.Assist.Location ((<.>), (</>))+import HaskellWorks.Ci.Assist.Metadata (deleteMetadata, loadMetadata) import HaskellWorks.Ci.Assist.Show-import HaskellWorks.Ci.Assist.Tar           (mapEntriesWith)-import Network.AWS.Types                    (Region (Oregon))-import Options.Applicative                  hiding (columns)-import System.Directory                     (createDirectoryIfMissing, doesDirectoryExist)+import HaskellWorks.Ci.Assist.Version  (archiveVersion)+import Network.AWS.Types               (Region (Oregon))+import Options.Applicative             hiding (columns)+import System.Directory                (createDirectoryIfMissing, doesDirectoryExist)  import qualified App.Commands.Options.Types        as Z import qualified Codec.Archive.Tar                 as F import qualified Codec.Compression.GZip            as F+import qualified Data.ByteString                   as BS+import qualified Data.ByteString.Char8             as C8 import qualified Data.ByteString.Lazy              as LBS+import qualified Data.Map.Strict                   as Map import qualified Data.Text                         as T import qualified HaskellWorks.Ci.Assist.GhcPkg     as GhcPkg+import qualified HaskellWorks.Ci.Assist.Hash       as H import qualified HaskellWorks.Ci.Assist.IO.Console as CIO import qualified HaskellWorks.Ci.Assist.IO.Lazy    as IO import qualified HaskellWorks.Ci.Assist.IO.Tar     as IO@@ -48,29 +55,36 @@  runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO () runSyncFromArchive opts = do-  let storePath   = opts ^. the @"storePath"-  let archiveUri  = opts ^. the @"archiveUri"-  let threads     = opts ^. the @"threads"+  let storePath           = opts ^. the @"storePath"+  let archiveUri          = opts ^. the @"archiveUri"+  let threads             = opts ^. the @"threads"+  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 $ "Archive URI: "  <> toText archiveUri-  CIO.putStrLn $ "Threads: "      <> tshow threads+  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    GhcPkg.testAvailability    mbPlan <- loadPlan   case mbPlan of     Right planJson -> do-      env <- mkEnv (opts ^. the @"region") (\_ _ -> pure ())+      envAws <- mkEnv (opts ^. the @"region") (\_ _ -> pure ())       let compilerId                  = planJson ^. the @"compilerId"-      let archivePath                 = archiveUri </> compilerId-      let baseDir                     = opts ^. the @"storePath"-      let storeCompilerPath           = baseDir </> T.unpack compilerId+      let archivePath                 = versionedArchiveUri </> compilerId+      let storeCompilerPath           = storePath </> T.unpack compilerId+      -- xx let scopedArchivePath           = scopedArchiveUri </> compilerId+      -- xx let baseDir                     = opts ^. the @"storePath"+      -- xx let storeCompilerPath           = baseDir </> T.unpack compilerId       let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db"       let storeCompilerLibPath        = storeCompilerPath </> "lib"        CIO.putStrLn "Creating store directories"-      createDirectoryIfMissing True baseDir+      createDirectoryIfMissing True storePath       createDirectoryIfMissing True storeCompilerPath       createDirectoryIfMissing True storeCompilerLibPath @@ -80,29 +94,34 @@         CIO.putStrLn "Package DB missing. Creating Package DB"         GhcPkg.init storeCompilerPackageDbPath -      packages <- getPackages baseDir planJson+      packages <- getPackages storePath planJson        IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do         IO.createDirectoryIfMissing True (tempPath </> T.unpack compilerId </> "package.db")          IO.pooledForConcurrentlyN_ threads packages $ \pInfo -> do-          let archiveBaseName = packageDir pInfo <.> ".tar.gz"-          let archiveFile = archiveUri </> T.pack archiveBaseName-          let packageStorePath = baseDir </> packageDir pInfo+          let archiveBaseName   = packageDir pInfo <.> ".tar.gz"+          let archiveFile       = versionedArchiveUri </> T.pack archiveBaseName+          let scopedArchiveFile = scopedArchiveUri </> T.pack archiveBaseName+          let packageStorePath  = storePath </> packageDir pInfo           storeDirectoryExists <- doesDirectoryExist packageStorePath           unless storeDirectoryExists $ do-            arhiveFileExists <- runResourceT $ IO.resourceExists env archiveFile-            when arhiveFileExists $ do-              CIO.putStrLn $ "Extracting: " <> T.pack archiveBaseName-              runResAws env $ do-                maybeArchiveFileContents <- IO.readResource env archiveFile+            maybeExistingArchiveFile <- IO.firstExistingResource envAws [scopedArchiveFile, archiveFile]+            forM_ maybeExistingArchiveFile $ \existingArchiveFile -> do+              CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile+              void $ runResAws envAws $ onErrorClean packageStorePath $ do+                maybeArchiveFileContents <- IO.readResource envAws existingArchiveFile                  case maybeArchiveFileContents of                   Just archiveFileContents -> do-                    let tempArchiveFile = tempPath </> archiveBaseName :: FilePath-                    liftIO $ LBS.writeFile tempArchiveFile archiveFileContents-                    liftIO $ runExceptT $ IO.extractTar tempArchiveFile storePath+                    existingArchiveFileContents <- IO.readResource envAws existingArchiveFile & maybeToExceptM ("Archive unavailable: " <> show (toText archiveFile))+                    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 confPath pInfo of                       Tagged conf _ -> do                         let theConfPath = storePath </> conf@@ -110,12 +129,13 @@                         confPathExists <- liftIO $ IO.doesFileExist theConfPath                         when confPathExists $ do                           confContents <- liftIO $ LBS.readFile theConfPath-                          liftIO $ LBS.writeFile tempConfPath (unTemplateConfig baseDir confContents)+                          liftIO $ LBS.writeFile tempConfPath (replace (LBS.toStrict oldStorePath) (C8.pack storePath) confContents)                           liftIO $ IO.renamePath tempConfPath theConfPath-                   Nothing -> do-                    CIO.putStrLn $ "Archive unavailable: " <> toText archiveFile+                    CIO.putStrLn $ "Archive unavailable: " <> toText existingArchiveFile +                    deleteMetadata packageStorePath+       CIO.putStrLn "Recaching package database"       GhcPkg.recache storeCompilerPackageDbPath @@ -123,6 +143,10 @@       CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> T.pack errorMessage    return ()++onErrorClean :: MonadIO m => FilePath -> ExceptT String m () -> m ()+onErrorClean pkgStorePath f =+  void $ runExceptT $ exceptWarn f `catchError` (\e -> liftIO $ IO.removeDirectoryRecursive pkgStorePath)  cmdSyncFromArchive :: Mod CommandFields (IO ()) cmdSyncFromArchive = command "sync-from-archive"  $ flip info idm $ runSyncFromArchive <$> optsSyncFromArchive

@@ -7,31 +7,34 @@   ( cmdSyncToArchive   ) where -import Antiope.Core                         (toText)-import Antiope.Env                          (LogLevel, mkEnv)-import App.Commands.Options.Parser          (optsSyncToArchive)-import App.Static                           (homeDirectory)-import Control.Lens                         hiding ((<.>))-import Control.Monad                        (unless, when)+import Antiope.Core                    (toText)+import Antiope.Env                     (LogLevel, mkEnv)+import App.Commands.Options.Parser     (optsSyncToArchive)+import App.Static                      (homeDirectory)+import Control.Lens                    hiding ((<.>))+import Control.Monad                   (unless, when) import Control.Monad.Except-import Control.Monad.Trans.Resource         (runResourceT)-import Data.Generics.Product.Any            (the)-import Data.List                            (isSuffixOf)-import Data.Semigroup                       ((<>))-import HaskellWorks.Ci.Assist.Core          (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan, relativePaths, relativePaths2)-import HaskellWorks.Ci.Assist.Location      ((<.>), (</>))-import HaskellWorks.Ci.Assist.PackageConfig (templateConfig)+import Control.Monad.Trans.Resource    (runResourceT)+import Data.Generics.Product.Any       (the)+import Data.List                       (isSuffixOf, (\\))+import Data.Maybe+import Data.Semigroup                  ((<>))+import HaskellWorks.Ci.Assist.Core     (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan, relativePaths)+import HaskellWorks.Ci.Assist.Location ((<.>), (</>))+import HaskellWorks.Ci.Assist.Metadata (createMetadata) import HaskellWorks.Ci.Assist.Show-import HaskellWorks.Ci.Assist.Tar           (updateEntryWith)-import Options.Applicative                  hiding (columns)-import System.Directory                     (createDirectoryIfMissing, doesDirectoryExist)+import HaskellWorks.Ci.Assist.Version  (archiveVersion)+import Options.Applicative             hiding (columns)+import System.Directory                (createDirectoryIfMissing, doesDirectoryExist)  import qualified App.Commands.Options.Types        as Z import qualified Codec.Archive.Tar                 as F import qualified Codec.Compression.GZip            as F import qualified Data.ByteString.Lazy              as LBS+import qualified Data.ByteString.Lazy.Char8        as LC8 import qualified Data.Text                         as T import qualified HaskellWorks.Ci.Assist.GhcPkg     as GhcPkg+import qualified HaskellWorks.Ci.Assist.Hash       as H import qualified HaskellWorks.Ci.Assist.IO.Console as CIO import qualified HaskellWorks.Ci.Assist.IO.Error   as IO import qualified HaskellWorks.Ci.Assist.IO.File    as IO@@ -39,6 +42,7 @@ import qualified HaskellWorks.Ci.Assist.IO.Tar     as IO import qualified HaskellWorks.Ci.Assist.Types      as Z import qualified System.Directory                  as IO+import qualified System.FilePath.Posix             as FP import qualified System.IO                         as IO import qualified System.IO.Temp                    as IO import qualified UnliftIO.Async                    as IO@@ -48,27 +52,33 @@  runSyncToArchive :: Z.SyncToArchiveOptions -> IO () runSyncToArchive opts = do-  let storePath   = opts ^. the @"storePath"-  let archiveUri  = opts ^. the @"archiveUri"-  let threads     = opts ^. the @"threads"+  let storePath           = opts ^. the @"storePath"+  let archiveUri          = opts ^. the @"archiveUri"+  let threads             = opts ^. the @"threads"+  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 $ "Archive URI: "  <> toText archiveUri-  CIO.putStrLn $ "Threads: "      <> tshow threads+  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    mbPlan <- loadPlan   case mbPlan of     Right planJson -> do       let compilerId = planJson ^. the @"compilerId"       envAws <- mkEnv (opts ^. the @"region") (\_ _ -> pure ())-      let archivePath = archiveUri </> compilerId+      let archivePath       = versionedArchiveUri </> compilerId+      let scopedArchivePath = scopedArchiveUri </> compilerId       IO.createLocalDirectoryIfMissing archivePath-      let baseDir = opts ^. the @"storePath"+      IO.createLocalDirectoryIfMissing scopedArchivePath       CIO.putStrLn "Extracting package list" -      packages <- getPackages baseDir planJson+      packages <- getPackages storePath planJson -      let storeCompilerPath           = baseDir </> T.unpack compilerId+      let storeCompilerPath           = storePath </> T.unpack compilerId       let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db"        storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath@@ -81,40 +91,35 @@       IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do         CIO.putStrLn $ "Temp path: " <> tshow tempPath -        CIO.putStrLn "Copying package.db directory for transformation"-        let workingStoreCompilerPath = tempPath </> T.unpack compilerId-        let workingStoreCompilerPackageDbPath = tempPath </> T.unpack compilerId </> "package.db"--        runExceptT $ IO.exceptFatal "Fatal error" $ do-          liftIO $ IO.createDirectoryIfMissing True workingStoreCompilerPackageDbPath--        packageDbFiles <- IO.listDirectory storeCompilerPackageDbPath-        let confFiles = filter (isSuffixOf ".conf") packageDbFiles--        forM_ confFiles $ \confFile -> do-          stream <- LBS.readFile (storeCompilerPackageDbPath </> confFile)-          LBS.writeFile (workingStoreCompilerPackageDbPath </> confFile) (templateConfig baseDir stream)-         IO.pooledForConcurrentlyN_ (opts ^. the @"threads") packages $ \pInfo -> do           let archiveFileBasename = packageDir pInfo <.> ".tar.gz"-          let archiveFile = archiveUri </> T.pack archiveFileBasename-          let packageStorePath = baseDir </> packageDir pInfo-          archiveFileExists <- runResourceT $ IO.resourceExists envAws archiveFile+          let archiveFile         = versionedArchiveUri </> T.pack archiveFileBasename+          let scopedArchiveFile   = versionedArchiveUri </> T.pack storePathHash </> T.pack archiveFileBasename+          let packageStorePath    = storePath </> packageDir pInfo+          let packageSharePath    = packageStorePath </> "share"+          archiveFileExists <- runResourceT $ IO.resourceExists envAws scopedArchiveFile            unless archiveFileExists $ do             packageStorePathExists <- doesDirectoryExist packageStorePath -            when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn "Warning" $ do-              let rp2 = relativePaths2 storePath tempPath pInfo-              CIO.putStrLn $ "Creating " <> toText archiveFile+            when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn $ do+              let workingStorePackagePath = tempPath </> packageDir pInfo+              liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath +              let rp2 = relativePaths storePath pInfo+              CIO.putStrLn $ "Creating " <> toText scopedArchiveFile+               let tempArchiveFile = tempPath </> archiveFileBasename -              IO.createTar tempArchiveFile rp2+              metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)] -              liftIO (LBS.readFile tempArchiveFile >>= IO.writeResource envAws archiveFile)+              IO.createTar tempArchiveFile (metas:rp2) -              return ()+              liftIO (LBS.readFile tempArchiveFile >>= IO.writeResource envAws scopedArchiveFile)++              shareEntries <- (\\ ["doc"]) <$> IO.listMaybeDirectory packageSharePath++              when (null shareEntries) $ IO.linkOrCopyResource envAws scopedArchiveFile archiveFile      Left errorMessage -> do       CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> T.pack errorMessage

@@ -11,7 +11,6 @@   , Presence(..)   , getPackages   , relativePaths-  , relativePaths2   , loadPlan   ) where @@ -55,20 +54,14 @@   , libs       :: [Library]   } deriving (Show, Eq, Generic, NFData) -relativePaths2 :: FilePath -> FilePath -> PackageInfo -> [IO.TarGroup]-relativePaths2 basePath tmpPath pInfo =+relativePaths :: FilePath -> PackageInfo -> [IO.TarGroup]+relativePaths basePath pInfo =   [ IO.TarGroup basePath $ mempty       <> (pInfo ^. the @"libs")       <> [packageDir pInfo]-  , IO.TarGroup tmpPath $ mempty+  , IO.TarGroup basePath $ mempty       <> ([pInfo ^. the @"confPath"] & filter ((== Present) . (^. the @"tag")) <&> (^. the @"value"))   ]--relativePaths :: PackageInfo -> [FilePath]-relativePaths pInfo = mempty-  <>  ([pInfo ^. the @"confPath"] & filter ((== Present) . (^. the @"tag")) <&> (^. the @"value"))-  <>  [packageDir pInfo]-  <>  (pInfo ^. the @"libs")  getPackages :: FilePath -> Z.PlanJson -> IO [PackageInfo] getPackages basePath planJson = forM packages (mkPackageInfo basePath compilerId)

@@ -0,0 +1,10 @@+module HaskellWorks.Ci.Assist.Hash+  ( hashStorePath+  ) where++import qualified Crypto.Hash        as CH+import qualified Data.Text          as T+import qualified Data.Text.Encoding as T++hashStorePath :: String -> String+hashStorePath = take 10 . show . CH.hashWith CH.SHA256 . T.encodeUtf8 . T.pack

@@ -3,6 +3,8 @@ module HaskellWorks.Ci.Assist.IO.Error   ( exceptFatal   , exceptWarn+  , maybeToExcept+  , maybeToExceptM   ) where  import Control.Monad.Except@@ -13,15 +15,21 @@ import qualified System.Exit                       as IO import qualified System.IO                         as IO -exceptFatal :: MonadIO m => String -> ExceptT String m a -> ExceptT String m a-exceptFatal message f = catchError f handler+exceptFatal :: MonadIO m => ExceptT String m a -> ExceptT String m a+exceptFatal f = catchError f handler   where handler e = do           liftIO . CIO.hPutStrLn IO.stderr . T.pack $ "Fatal Error: " <> e           liftIO IO.exitFailure           throwError e -exceptWarn :: MonadIO m => String -> ExceptT String m a -> ExceptT String m a-exceptWarn message f = catchError f handler+exceptWarn :: MonadIO m => ExceptT String m a -> ExceptT String m a+exceptWarn f = catchError f handler   where handler e = do           liftIO . CIO.hPutStrLn IO.stderr . T.pack $ "Warning: " <> e           throwError e++maybeToExcept :: Monad m => String -> Maybe a -> ExceptT String m a+maybeToExcept message = maybe (throwError message) pure++maybeToExceptM :: Monad m => String -> m (Maybe a) -> ExceptT String m a+maybeToExceptM message = ExceptT . fmap (maybe (Left message) Right)

@@ -2,6 +2,7 @@  module HaskellWorks.Ci.Assist.IO.File   ( copyDirectoryRecursive+  , listMaybeDirectory   ) where  import Control.Monad.Except@@ -9,6 +10,7 @@  import qualified Data.Text                         as T import qualified HaskellWorks.Ci.Assist.IO.Console as CIO+import qualified System.Directory                  as IO import qualified System.Exit                       as IO import qualified System.IO                         as IO import qualified System.Process                    as IO@@ -21,3 +23,10 @@   case exitCode of     IO.ExitSuccess   -> return ()     IO.ExitFailure n -> throwError ""++listMaybeDirectory :: MonadIO m => FilePath -> ExceptT String m [FilePath]+listMaybeDirectory filepath = do+  exists <- liftIO $ IO.doesDirectoryExist filepath+  if exists+    then liftIO $ IO.listDirectory filepath+    else return []

@@ -4,9 +4,11 @@ module HaskellWorks.Ci.Assist.IO.Lazy   ( readResource   , resourceExists+  , firstExistingResource   , headS3Uri   , writeResource   , createLocalDirectoryIfMissing+  , linkOrCopyResource   ) where  import Antiope.Core@@ -21,6 +23,7 @@ import Data.Either                     (isRight) import Data.Text                       (Text) import HaskellWorks.Ci.Assist.Location (Location (..))+import HaskellWorks.Ci.Assist.Show import Network.AWS                     (MonadAWS, chunkedFile) import Network.AWS.Data.Body           (_streamBody) @@ -32,11 +35,14 @@ import qualified HaskellWorks.Ci.Assist.IO.Console as CIO import qualified Network.AWS                       as AWS import qualified Network.AWS.Data                  as AWS+import qualified Network.AWS.S3.CopyObject         as AWS import qualified Network.AWS.S3.HeadObject         as AWS import qualified Network.AWS.S3.PutObject          as AWS import qualified Network.HTTP.Types                as HTTP import qualified System.Directory                  as IO+import qualified System.FilePath.Posix             as FP import qualified System.IO                         as IO+import qualified System.IO.Error                   as IO  {-# ANN module ("HLint: ignore Redundant do"        :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}@@ -47,11 +53,36 @@   S3 s3Uri    -> runAws envAws $ AWS.downloadFromS3Uri s3Uri   Local path  -> liftIO $ Just <$> LBS.readFile path -resourceExists :: (MonadResource m, MonadCatch m, MonadIO m) => AWS.Env -> Location -> m Bool+safePathIsSymbolLink :: FilePath -> IO Bool+safePathIsSymbolLink filePath = catch (IO.pathIsSymbolicLink filePath) handler+  where handler :: IOError -> IO Bool+        handler e = if IO.isDoesNotExistError e+          then return False+          else return True++resourceExists :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> Location -> m Bool resourceExists envAws = \case-  S3 s3Uri    -> isRight <$> headS3Uri envAws s3Uri-  Local path  -> liftIO $ IO.doesFileExist path+  S3 s3Uri    -> isRight <$> runResourceT (headS3Uri envAws s3Uri)+  Local path  -> do+    fileExists <- liftIO $ IO.doesFileExist path+    if fileExists+      then return True+      else do+        symbolicLinkExists <- liftIO $ safePathIsSymbolLink path+        if symbolicLinkExists+          then do+            target <- liftIO $ IO.getSymbolicLinkTarget path+            resourceExists envAws (Local target)+          else return False +firstExistingResource :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> [Location] -> m (Maybe Location)+firstExistingResource envAws [] = return Nothing+firstExistingResource envAws (a:as) = do+  exists <- resourceExists envAws a+  if exists+    then return (Just a)+    else firstExistingResource envAws as+ headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either String AWS.HeadObjectResponse) headS3Uri envAws (AWS.S3Uri b k) =   catch (Right <$> runAws envAws (AWS.send (AWS.headObject b k))) $ \(e :: AWS.Error) ->@@ -62,18 +93,38 @@ chunkSize :: AWS.ChunkSize chunkSize = AWS.ChunkSize (1024 * 1024) -uploadeToS3 :: MonadUnliftIO m => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m ()-uploadeToS3 envAws (AWS.S3Uri b k) lbs = do+uploadToS3 :: MonadUnliftIO m => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m ()+uploadToS3 envAws (AWS.S3Uri b k) lbs = do   let req = AWS.toBody lbs   let po  = AWS.putObject b k req   void $ runResAws envAws $ AWS.send po  writeResource :: MonadUnliftIO m => AWS.Env -> Location -> LBS.ByteString -> m () writeResource envAws loc lbs = case loc of-  S3 s3Uri   -> uploadeToS3 envAws s3Uri lbs+  S3 s3Uri   -> uploadToS3 envAws s3Uri lbs   Local path -> liftIO $ LBS.writeFile path lbs  createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m () createLocalDirectoryIfMissing = \case   S3 s3Uri   -> return ()   Local path -> liftIO $ IO.createDirectoryIfMissing True path++copyS3Uri :: MonadUnliftIO m => AWS.Env -> AWS.S3Uri -> AWS.S3Uri -> ExceptT String m ()+copyS3Uri envAws (AWS.S3Uri sourceBucket sourceObjectKey) (AWS.S3Uri targetBucket targetObjectKey) = ExceptT $ do+  response <- runResourceT $ runAws envAws $ AWS.send (AWS.copyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey)+  let responseCode = response ^. AWS.corsResponseStatus+  if 200 <= responseCode && responseCode < 300+    then return (Right ())+    else return (Left "")++linkOrCopyResource :: MonadUnliftIO m => AWS.Env -> Location -> Location -> ExceptT String m ()+linkOrCopyResource envAws source target = case source of+  S3 sourceS3Uri -> case target of+    S3 targetS3Uri -> do copyS3Uri envAws sourceS3Uri targetS3Uri+    Local _        -> throwError "Can't copy between different file backends"+  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

@@ -13,6 +13,7 @@ import Control.DeepSeq             (NFData) import Control.Lens import Control.Monad.Except+import Control.Monad.IO.Class      (MonadIO, liftIO) import Data.Generics.Product.Any import Data.List import GHC.Generics@@ -29,7 +30,7 @@   , entryPaths :: [FilePath]   } deriving (Show, Eq, Generic, NFData) -createTar :: FilePath -> [TarGroup] -> ExceptT String IO ()+createTar :: MonadIO m => FilePath -> [TarGroup] -> ExceptT String m () createTar tarFile groups = do   let args = ["-zcf", tarFile] <> foldMap tarGroupToArgs groups   process <- liftIO $ IO.spawnProcess "tar" args@@ -38,7 +39,7 @@     IO.ExitSuccess   -> return ()     IO.ExitFailure n -> throwError "" -extractTar :: FilePath -> FilePath -> ExceptT String IO ()+extractTar :: MonadIO m => FilePath -> FilePath -> ExceptT String m () extractTar tarFile targetPath = do   process <- liftIO $ IO.spawnProcess "tar" ["-C", targetPath, "-zxf", tarFile]   exitCode <- liftIO $ IO.waitForProcess process

@@ -0,0 +1,40 @@+{-# LANGUAGE TupleSections #-}+module HaskellWorks.Ci.Assist.Metadata+where++import Control.Lens                  ((<&>))+import Control.Monad                 (forM_)+import Control.Monad.IO.Class        (MonadIO, liftIO)+import HaskellWorks.Ci.Assist.Core   (PackageInfo (..))+import HaskellWorks.Ci.Assist.IO.Tar (TarGroup (..))+import System.FilePath               (makeRelative, takeFileName, (<.>), (</>))++import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map.Strict      as Map+import qualified Data.Text            as T+import qualified System.Directory     as IO++metaDir :: String+metaDir = "_CC_METADATA"++createMetadata :: MonadIO m => FilePath -> PackageInfo -> [(T.Text, LBS.ByteString)] -> m TarGroup+createMetadata storePath pkg values = liftIO $ do+  let pkgMetaPath = storePath </> packageDir pkg </> metaDir+  IO.createDirectoryIfMissing True pkgMetaPath+  forM_ values $ \(k, v) -> LBS.writeFile (pkgMetaPath </> T.unpack k) v+  pure $ TarGroup storePath [packageDir pkg </> metaDir]++loadMetadata :: MonadIO m => FilePath -> m (Map.Map T.Text LBS.ByteString)+loadMetadata pkgStorePath = liftIO $ do+  let pkgMetaPath = pkgStorePath </> metaDir+  exists <- IO.doesDirectoryExist pkgMetaPath+  if not exists+    then pure Map.empty+    else IO.listDirectory pkgMetaPath+          <&> fmap (pkgMetaPath </>)+          >>= traverse (\mfile -> (T.pack (takeFileName mfile),) <$> LBS.readFile mfile)+          <&> Map.fromList++deleteMetadata :: MonadIO m => FilePath -> m ()+deleteMetadata pkgStorePath =+  liftIO $ IO.removeDirectoryRecursive (pkgStorePath </> metaDir)

@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module HaskellWorks.Ci.Assist.PackageConfig-where---import Data.ByteString.Char8       (pack)-import Data.ByteString.Lazy.Search (replace)-import HaskellWorks.Ci.Assist.Tar--import qualified Data.ByteString      as BS-import qualified Data.ByteString.Lazy as LBS--storePathMacro :: BS.ByteString-storePathMacro = "${STORE_PATH}"--templateConfig :: FilePath -> LBS.ByteString -> LBS.ByteString-templateConfig storePath = replace (pack storePath) storePathMacro--unTemplateConfig :: FilePath -> LBS.ByteString -> LBS.ByteString-unTemplateConfig storePath = replace storePathMacro (pack storePath)

@@ -1,27 +0,0 @@-module HaskellWorks.Ci.Assist.Tar-where--import Codec.Archive.Tar-import Codec.Archive.Tar.Entry--import qualified Data.ByteString.Lazy as LBS--updateEntryWith :: (FilePath -> Bool)-  -> (LBS.ByteString -> LBS.ByteString)-  -> Entry-  -> Entry-updateEntryWith pred transform entry =-  if pred (entryPath entry)-    then case entryContent entry of-        NormalFile bs size ->-          let bs' = transform bs-          in entry { entryContent = NormalFile bs' (LBS.length bs') }-        _ -> entry-    else entry--mapEntriesWith :: (FilePath -> Bool)-  -> (LBS.ByteString -> LBS.ByteString)-  -> Entries e-  -> Entries e-mapEntriesWith pred transform =-  mapEntriesNoFail (updateEntryWith pred transform)

@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Ci.Assist.Version where++import Data.String++archiveVersion :: IsString s => s+archiveVersion = "v1"