cabal-cache 1.0.4.0 → 1.0.5.0
raw patch · 8 files changed
+67/−31 lines, 8 files
Files
- app/App/Commands/Options/Types.hs +4/−1
- app/App/Commands/Plan.hs +7/−1
- app/App/Commands/SyncFromArchive.hs +22/−11
- app/App/Commands/SyncToArchive.hs +7/−1
- app/App/Static.hs +8/−1
- cabal-cache.cabal +7/−8
- src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs +10/−7
- src/HaskellWorks/CabalCache/Core.hs +2/−1
app/App/Commands/Options/Types.hs view
@@ -13,6 +13,7 @@ data SyncToArchiveOptions = SyncToArchiveOptions { region :: Region , archiveUri :: Location+ , path :: FilePath , buildPath :: FilePath , storePath :: FilePath , storePathHash :: Maybe String@@ -22,7 +23,8 @@ } deriving (Eq, Show, Generic) data PlanOptions = PlanOptions- { buildPath :: FilePath+ { path :: FilePath+ , buildPath :: FilePath , storePath :: FilePath , storePathHash :: Maybe String , outputFile :: FilePath@@ -31,6 +33,7 @@ data SyncFromArchiveOptions = SyncFromArchiveOptions { region :: Region , archiveUris :: [Location]+ , path :: FilePath , buildPath :: FilePath , storePath :: FilePath , storePathHash :: Maybe String
app/App/Commands/Plan.hs view
@@ -51,7 +51,7 @@ tEarlyExit <- STM.newTVarIO False - mbPlan <- Z.loadPlan $ opts ^. the @"buildPath"+ mbPlan <- Z.loadPlan $ opts ^. the @"path" </> opts ^. the @"buildPath" case mbPlan of Right planJson -> do@@ -78,6 +78,12 @@ optsPlan :: Parser PlanOptions optsPlan = PlanOptions <$> strOption+ ( long "path"+ <> help "Path to cabal project. Defaults to \".\""+ <> metavar "DIRECTORY"+ <> value AS.path+ )+ <*> strOption ( long "build-path" <> help ("Path to cabal build directory. Defaults to " <> show AS.buildPath) <> metavar "DIRECTORY"
app/App/Commands/SyncFromArchive.hs view
@@ -15,9 +15,9 @@ 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 Control.Monad.Trans.AWS (envOverride, setEndpoint, AWST', Env)+import Control.Monad.Trans.Resource (ResourceT) import Data.ByteString (ByteString) import Data.ByteString.Lazy.Search (replace) import Data.Generics.Product.Any (the)@@ -28,6 +28,7 @@ import HaskellWorks.CabalCache.Location (toLocation, (<.>), (</>)) import HaskellWorks.CabalCache.Metadata (loadMetadata) import HaskellWorks.CabalCache.Show+import HaskellWorks.CabalCache.Types (PackageId) import HaskellWorks.CabalCache.Version (archiveVersion) import Options.Applicative hiding (columns) import System.Directory (createDirectoryIfMissing, doesDirectoryExist)@@ -83,7 +84,7 @@ CIO.putStrLn $ "Threads: " <> tshow threads CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel - mbPlan <- Z.loadPlan $ opts ^. the @"buildPath"+ mbPlan <- Z.loadPlan $ opts ^. the @"path" </> opts ^. the @"buildPath" case mbPlan of Right planJson -> do@@ -145,14 +146,14 @@ case maybePackage of Nothing -> do CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageId- return True+ return DQ.DownloadSuccess Just package -> if skippable package then do CIO.putStrLn $ "Skipping: " <> packageId- return True+ return DQ.DownloadSuccess else if storeDirectoryExists- then return True- else runResAws envAws $ onError (cleanupStorePath packageStorePath packageId) False $ do+ then return DQ.DownloadSuccess+ else runResAws envAws $ onError (cleanupStorePath packageStorePath packageId) DQ.DownloadFailure $ do (existingArchiveFileContents, existingArchiveFile) <- ExceptT $ IO.readFirstAvailableResource envAws (foldMap L.tuple2ToList (L.zip archiveFiles scopedArchiveFiles)) CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile @@ -173,10 +174,10 @@ liftIO $ LBS.writeFile tempConfPath (replace (LBS.toStrict oldStorePath) (C8.pack storePath) confContents) liftIO $ IO.copyFile tempConfPath theConfPath >> IO.removeFile tempConfPath - return True+ return DQ.DownloadSuccess Nothing -> do CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId- return True+ return DQ.DownloadSuccess CIO.putStrLn "Recaching package database" GhcPkg.recache compilerContext storeCompilerPackageDbPath@@ -190,13 +191,17 @@ return () -cleanupStorePath :: (MonadIO m, MonadCatch m) => FilePath -> Z.PackageId -> AppError -> m ()+cleanupStorePath :: FilePath -> PackageId -> AppError -> AWST' Env (ResourceT IO) () 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 :: ()+ => (AppError -> AWST' Env (ResourceT IO) ())+ -> DQ.DownloadStatus+ -> ExceptT AppError (AWST' Env (ResourceT IO)) DQ.DownloadStatus+ -> AWST' Env (ResourceT IO) DQ.DownloadStatus onError h failureValue f = do result <- runExceptT $ catchError (exceptWarn f) handler case result of@@ -218,6 +223,12 @@ <> help "Archive URI to sync to" <> metavar "S3_URI" )+ )+ <*> strOption+ ( long "path"+ <> help "Path to cabal project directory. Defaults to \".\""+ <> metavar "DIRECTORY"+ <> value AS.path ) <*> strOption ( long "build-path"
app/App/Commands/SyncToArchive.hs view
@@ -80,7 +80,7 @@ tEarlyExit <- STM.newTVarIO False - mbPlan <- Z.loadPlan $ opts ^. the @"buildPath"+ mbPlan <- Z.loadPlan $ opts ^. the @"path" </> opts ^. the @"buildPath" case mbPlan of Right planJson -> do@@ -181,6 +181,12 @@ <> help "Archive URI to sync to" <> metavar "S3_URI" <> value (Local $ AS.cabalDirectory </> "archive")+ )+ <*> strOption+ ( long "path"+ <> help "Path to cabal project directory. Defaults to \".\""+ <> metavar "DIRECTORY"+ <> value AS.buildPath ) <*> strOption ( long "build-path"
app/App/Static.hs view
@@ -1,4 +1,8 @@-module App.Static where+module App.Static+ ( cabalDirectory+ , buildPath+ , path+ ) where import qualified App.Static.Base as S import qualified App.Static.Posix as P@@ -9,3 +13,6 @@ buildPath :: FilePath buildPath = "dist-newstyle"++path :: FilePath+path = "."
cabal-cache.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: cabal-cache-version: 1.0.4.0+version: 1.0.5.0 synopsis: CI Assistant for Haskell projects description: CI Assistant for Haskell projects. Implements package caching. homepage: https://github.com/haskell-works/cabal-cache@@ -19,7 +19,7 @@ common base { build-depends: base >= 4.7 && < 5 } -common aeson { build-depends: aeson >= 1.4.2.0 && < 1.6 }+common aeson { build-depends: aeson >= 1.4.2.0 && < 2.1 } 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 }@@ -35,7 +35,7 @@ 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.3 }-common hedgehog { build-depends: hedgehog >= 1.0 && < 1.1 }+common hedgehog { build-depends: hedgehog >= 1.0 && < 1.2 } common hspec { build-depends: hspec >= 2.4 && < 3 } 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 }@@ -45,18 +45,18 @@ 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 optparse-applicative { build-depends: optparse-applicative >= 0.14 && < 0.18 } 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.5 }+common selective { build-depends: selective >= 0.1.0 && < 0.6 } 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 } common temporary { build-depends: temporary >= 1.3 && < 1.4 }-common text { build-depends: text >= 1.2.3.1 && < 1.3 }-common time { build-depends: time >= 1.4 && < 1.10 }+common text { build-depends: text >= 1.2.3.1 && < 2.1 }+common time { build-depends: time >= 1.4 && < 1.13 } 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 }@@ -139,7 +139,6 @@ , bytestring , containers , directory- , exceptions , generic-lens , http-types , lens
src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs view
@@ -3,7 +3,8 @@ {-# LANGUAGE RecordWildCards #-} module HaskellWorks.CabalCache.Concurrent.DownloadQueue- ( createDownloadQueue+ ( DownloadStatus(..)+ , createDownloadQueue , anchor , runQueue ) where@@ -17,6 +18,8 @@ import qualified Data.Set as S import qualified HaskellWorks.CabalCache.Concurrent.Type as Z +data DownloadStatus = DownloadSuccess | DownloadFailure deriving (Eq, Show)+ anchor :: Z.PackageId -> M.Map Z.ConsumerId Z.ProviderId -> M.Map Z.ConsumerId Z.ProviderId anchor root dependencies = M.union dependencies $ M.singleton root (mconcat (M.elems dependencies)) @@ -59,16 +62,16 @@ STM.writeTVar tUploading $ S.delete packageId uploading STM.writeTVar tFailures $ S.insert packageId failures -runQueue :: MonadIO m => Z.DownloadQueue -> (Z.PackageId -> m Bool) -> m ()-runQueue downloadQueue@Z.DownloadQueue {..} f = do+runQueue :: MonadIO m => Z.DownloadQueue -> (Z.PackageId -> m DownloadStatus) -> m ()+runQueue downloadQueue f = do maybePackageId <- liftIO $ STM.atomically $ takeReady downloadQueue case maybePackageId of Just packageId -> do- success <- f packageId- if success- then liftIO $ STM.atomically $ commit downloadQueue packageId- else liftIO $ STM.atomically $ failDownload downloadQueue packageId+ downloadStatus <- f packageId+ case downloadStatus of+ DownloadSuccess -> liftIO $ STM.atomically $ commit downloadQueue packageId+ DownloadFailure -> liftIO $ STM.atomically $ failDownload downloadQueue packageId runQueue downloadQueue f Nothing -> do
src/HaskellWorks/CabalCache/Core.hs view
@@ -106,7 +106,8 @@ packages = planJson ^. the @"installPlan" loadPlan :: FilePath -> IO (Either AppError Z.PlanJson)-loadPlan buildPath = first fromString . eitherDecode <$> LBS.readFile (buildPath </> "cache" </> "plan.json")+loadPlan resolvedBuildPath =+ first fromString . eitherDecode <$> LBS.readFile (resolvedBuildPath </> "cache" </> "plan.json") ------------------------------------------------------------------------------- mkPackageInfo :: FilePath -> Z.CompilerId -> Z.Package -> IO PackageInfo