diff --git a/app/App/Commands/Options/Types.hs b/app/App/Commands/Options/Types.hs --- a/app/App/Commands/Options/Types.hs +++ b/app/App/Commands/Options/Types.hs @@ -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 diff --git a/app/App/Commands/Plan.hs b/app/App/Commands/Plan.hs --- a/app/App/Commands/Plan.hs +++ b/app/App/Commands/Plan.hs @@ -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" diff --git a/app/App/Commands/SyncFromArchive.hs b/app/App/Commands/SyncFromArchive.hs --- a/app/App/Commands/SyncFromArchive.hs +++ b/app/App/Commands/SyncFromArchive.hs @@ -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" diff --git a/app/App/Commands/SyncToArchive.hs b/app/App/Commands/SyncToArchive.hs --- a/app/App/Commands/SyncToArchive.hs +++ b/app/App/Commands/SyncToArchive.hs @@ -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" diff --git a/app/App/Static.hs b/app/App/Static.hs --- a/app/App/Static.hs +++ b/app/App/Static.hs @@ -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 = "." 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.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 diff --git a/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs b/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs --- a/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs +++ b/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/Core.hs b/src/HaskellWorks/CabalCache/Core.hs --- a/src/HaskellWorks/CabalCache/Core.hs +++ b/src/HaskellWorks/CabalCache/Core.hs @@ -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