diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,9 +19,9 @@ cabal new-install cabal-cache ``` -### Ubuntu binaries +### Binaries -Dowload Ubuntu binaries from https://github.com/haskell-works/cabal-cache/releases +Dowload binaries from https://github.com/haskell-works/cabal-cache/releases ### Using Homebrew on Mac OS X 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 @@ -93,7 +93,7 @@ ( long "store-path" <> help "Path to cabal store" <> metavar "DIRECTORY" - <> value (AS.cabalDirectory "store") + <> value AS.cabalStoreDirectory ) <*> optional ( strOption 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 @@ -238,9 +238,9 @@ ) <*> strOption ( long "store-path" - <> help ("Path to cabal store. Defaults to " <> show AS.cabalDirectory) + <> help ("Path to cabal store. Defaults to " <> show AS.cabalStoreDirectory) <> metavar "DIRECTORY" - <> value (AS.cabalDirectory "store") + <> value AS.cabalStoreDirectory ) <*> optional ( strOption 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 @@ -32,6 +32,7 @@ import HaskellWorks.CabalCache.Version (archiveVersion) import Options.Applicative hiding (columns) import System.Directory (doesDirectoryExist) +import System.FilePath (takeDirectory) import qualified App.Commands.Options.Types as Z import qualified App.Static as AS @@ -180,7 +181,7 @@ ( long "archive-uri" <> help "Archive URI to sync to" <> metavar "S3_URI" - <> value (Local $ AS.cabalDirectory "archive") + <> value (Local $ takeDirectory AS.cabalStoreDirectory "archive") ) <*> strOption ( long "path" @@ -198,7 +199,7 @@ ( long "store-path" <> help "Path to cabal store" <> metavar "DIRECTORY" - <> value (AS.cabalDirectory "store") + <> value AS.cabalStoreDirectory ) <*> optional ( strOption diff --git a/app/App/Static.hs b/app/App/Static.hs --- a/app/App/Static.hs +++ b/app/App/Static.hs @@ -1,15 +1,28 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module App.Static - ( cabalDirectory + ( cabalStoreDirectory , buildPath , path ) where +import Control.Monad.Catch +import Control.Exception (IOException) +import Control.Monad.Identity (Identity(..)) + import qualified App.Static.Base as S import qualified App.Static.Posix as P import qualified App.Static.Windows as W +import qualified Cabal.Config as CC +import qualified System.IO.Unsafe as IO -cabalDirectory :: FilePath -cabalDirectory = if S.isPosix then P.cabalDirectory else W.cabalDirectory + +{-# NOINLINE cabalStoreDirectory #-} +cabalStoreDirectory :: FilePath +cabalStoreDirectory = IO.unsafePerformIO $ handle' $ + runIdentity . CC.cfgStoreDir <$> CC.readConfig + where + handle' = handle (\(_ :: IOException) -> return $ if S.isPosix then P.cabalDirectory else W.cabalDirectory) buildPath :: FilePath buildPath = "dist-newstyle" 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.5.1 +version: 1.0.5.2 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 && < 2.1 } +common aeson { build-depends: aeson >= 1.4.2.0 && < 2.2 } 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 } @@ -27,6 +27,7 @@ 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.12 } +common cabal-install-parsers { build-depends: cabal-install-parsers >= 0.4 && < 0.6 } 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 } @@ -35,7 +36,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.2 } +common hedgehog { build-depends: hedgehog >= 1.0 && < 1.3 } 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 } @@ -43,13 +44,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 && < 6 } -common mtl { build-depends: mtl >= 2.2.2 && < 2.3 } +common mtl { build-depends: mtl >= 2.2.2 && < 2.4 } common network-uri { build-depends: network-uri >= 2.6.4.1 && < 2.8 } 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 resourcet { build-depends: resourcet >= 1.2.2 && < 1.4 } 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 } @@ -137,8 +138,11 @@ , antiope-core , antiope-optparse-applicative , bytestring + , cabal-install-parsers , containers , directory + , exceptions + , filepath , 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -5,24 +6,23 @@ module HaskellWorks.CabalCache.Concurrent.DownloadQueue ( DownloadStatus(..) , createDownloadQueue - , anchor , runQueue ) where -import Control.Monad.IO.Class +import Control.Monad.Catch (MonadMask(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Function ((&)) import Data.Set ((\\)) import qualified Control.Concurrent.STM as STM -import qualified Data.Map as M +import qualified Control.Monad.Catch as CMC import qualified Data.Relation as R import qualified Data.Set as S import qualified HaskellWorks.CabalCache.Concurrent.Type as Z +import qualified System.IO as IO 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)) - createDownloadQueue :: [(Z.ProviderId, Z.ConsumerId)] -> STM.STM Z.DownloadQueue createDownloadQueue dependencies = do tDependencies <- STM.newTVar (R.fromList dependencies) @@ -62,17 +62,20 @@ STM.writeTVar tUploading $ S.delete packageId uploading STM.writeTVar tFailures $ S.insert packageId failures -runQueue :: MonadIO m => Z.DownloadQueue -> (Z.PackageId -> m DownloadStatus) -> m () +runQueue :: (MonadIO m, MonadMask m) => Z.DownloadQueue -> (Z.PackageId -> m DownloadStatus) -> m () runQueue downloadQueue f = do - maybePackageId <- liftIO $ STM.atomically $ takeReady downloadQueue + maybePackageId <- (liftIO $ STM.atomically $ takeReady downloadQueue) case maybePackageId of Just packageId -> do downloadStatus <- f packageId + & CMC.handleAll \e -> do + liftIO $ IO.hPutStrLn IO.stderr $ "Exception during download: " <> show e + liftIO $ IO.hFlush IO.stderr + CMC.throwM e case downloadStatus of - DownloadSuccess -> liftIO $ STM.atomically $ commit downloadQueue packageId - DownloadFailure -> liftIO $ STM.atomically $ failDownload downloadQueue packageId + DownloadSuccess -> do liftIO $ STM.atomically $ commit downloadQueue packageId + DownloadFailure -> do liftIO $ STM.atomically $ failDownload downloadQueue packageId runQueue downloadQueue f - Nothing -> do - return () + Nothing -> return () diff --git a/src/HaskellWorks/CabalCache/Concurrent/Fork.hs b/src/HaskellWorks/CabalCache/Concurrent/Fork.hs --- a/src/HaskellWorks/CabalCache/Concurrent/Fork.hs +++ b/src/HaskellWorks/CabalCache/Concurrent/Fork.hs @@ -1,5 +1,6 @@ module HaskellWorks.CabalCache.Concurrent.Fork where +import Control.Exception (finally) import Control.Monad import qualified Control.Concurrent as IO @@ -9,8 +10,7 @@ forkThreadsWait n f = do tDone <- STM.atomically $ STM.newTVar (0 :: Int) forM_ [1 .. n] $ \_ -> IO.forkIO $ do - f - STM.atomically $ STM.modifyTVar tDone (+1) + f `finally` (STM.atomically $ STM.modifyTVar tDone (+1)) STM.atomically $ do done <- STM.readTVar tDone 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 @@ -40,6 +40,7 @@ import qualified HaskellWorks.CabalCache.Types as Z import qualified System.Directory as IO import qualified System.Process as IO +import qualified System.Info as I {- HLINT ignore "Monoid law, left identity" -} @@ -65,6 +66,22 @@ (<||>) :: Monad m => ExceptT e m a -> ExceptT e m a -> ExceptT e m a (<||>) f g = f `catchError` const g + +isPosix :: Bool +isPosix = I.os /= "mingw32" +{-# NOINLINE isPosix #-} + +exeExt :: String +exeExt + | isPosix = "" + | otherwise = ".exe" + +withExeExt :: FilePath -> FilePath +withExeExt = (<.> exeExt) + +withExeExt' :: Text -> Text +withExeExt' = T.pack . withExeExt . T.unpack + findExecutable :: MonadIO m => Text -> ExceptT Text m Text findExecutable exe = fmap T.pack $ liftIO (IO.findExecutable (T.unpack exe)) >>= nothingToError (exe <> " is not in path") @@ -85,8 +102,8 @@ compilerVersion <- T.stripPrefix "ghc-" (plan ^. the @"compilerId") & nothingToError "No compiler version available in plan" let versionedGhcPkgCmd = "ghc-pkg-" <> compilerVersion ghcPkgCmdPath <- - (findExecutable versionedGhcPkgCmd >>= verifyGhcPkgVersion compilerVersion) - <||> (findExecutable "ghc-pkg" >>= verifyGhcPkgVersion compilerVersion) + (findExecutable (withExeExt' versionedGhcPkgCmd) >>= verifyGhcPkgVersion compilerVersion) + <||> (findExecutable (withExeExt' "ghc-pkg" ) >>= verifyGhcPkgVersion compilerVersion) return (Z.CompilerContext [T.unpack ghcPkgCmdPath]) relativePaths :: FilePath -> PackageInfo -> [IO.TarGroup] 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 @@ -47,6 +47,9 @@ import qualified System.FilePath.Posix as FP import qualified System.IO as IO import qualified System.IO.Error as IO +import System.Environment (lookupEnv) +import Text.Read (readMaybe) +import Data.Maybe (fromMaybe) {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -} @@ -59,16 +62,16 @@ (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status 301 _) _ _ _ _)) -> return (Left (AwsAppError s)) _ -> throwM e -handleHttpError :: (MonadCatch m, MonadIO m) => m a -> m (Either AppError a) -handleHttpError f = catch (Right <$> f) $ \(e :: HTTP.HttpException) -> +handleHttpError :: (MonadCatch m, MonadIO m) => m a -> ExceptT AppError m a +handleHttpError f = catch (lift f) $ \(e :: HTTP.HttpException) -> case e of (HTTP.HttpExceptionRequest _ e') -> case e' of - HTTP.StatusCodeException resp _ -> return (Left (HttpAppError (resp & HTTP.responseStatus))) - _ -> return (Left (GenericAppError (tshow e'))) - _ -> throwM e + HTTP.StatusCodeException resp _ -> throwE (HttpAppError (resp & HTTP.responseStatus)) + _ -> throwE (GenericAppError (tshow e')) + _ -> liftIO $ throwM e -getS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> URI -> m (Either AppError LBS.ByteString) -getS3Uri envAws uri = runExceptT $ do +getS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> URI -> ExceptT AppError m LBS.ByteString +getS3Uri envAws uri = do AWS.S3Uri b k <- except $ uriToS3Uri (reslashUri uri) ExceptT . handleAwsError $ runAws envAws $ AWS.unsafeDownload b k @@ -84,11 +87,11 @@ if fileExists then Right <$> LBS.readFile path else pure (Left NotFound) - Uri uri -> case uri ^. the @"uriScheme" of + Uri uri -> runExceptT $ retryS3 $ 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))) + "http:" -> readHttpUri (reslashUri uri) + "https:" -> readHttpUri (reslashUri uri) + scheme -> throwE (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")) @@ -122,7 +125,7 @@ else return False Uri uri -> case uri ^. the @"uriScheme" of "s3:" -> isRight <$> runResourceT (headS3Uri envAws (reslashUri uri)) - "http:" -> isRight <$> headHttpUri (reslashUri uri) + "http:" -> isRight <$> runExceptT (headHttpUri (reslashUri uri)) _scheme -> return False firstExistingResource :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> [Location] -> m (Maybe Location) @@ -138,8 +141,8 @@ AWS.S3Uri b k <- except $ uriToS3Uri (reslashUri uri) ExceptT . handleAwsError $ runAws envAws $ AWS.send $ AWS.headObject b k -uploadToS3 :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> URI -> LBS.ByteString -> m (Either AppError ()) -uploadToS3 envAws uri lbs = runExceptT $ do +uploadToS3 :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> URI -> LBS.ByteString -> ExceptT AppError m () +uploadToS3 envAws uri lbs = do AWS.S3Uri b k <- except $ uriToS3Uri (reslashUri uri) let req = AWS.toBody lbs let po = AWS.putObject b k req @@ -154,10 +157,10 @@ writeResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> LBS.ByteString -> ExceptT AppError m () writeResource envAws loc lbs = ExceptT $ case loc of Local path -> liftIO (LBS.writeFile path lbs) >> return (Right ()) - Uri uri -> case uri ^. the @"uriScheme" of + Uri uri -> runExceptT $ retryS3 $ 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))) + "http:" -> throwE (GenericAppError "HTTP PUT method not supported") + scheme -> throwE (GenericAppError ("Unrecognised uri scheme: " <> T.pack scheme)) createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m () createLocalDirectoryIfMissing = \case @@ -184,22 +187,35 @@ return (Left RetriesFailedAppError) Left msg -> return (Left msg) -retry :: (Show e, MonadIO m) => Int -> ExceptT e m () -> ExceptT e m () -retry = retryWhen (const True) - -retryWhen :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m () +retryWhen :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m a -> ExceptT e m a retryWhen p n f = catchError f $ \exception -> if n > 0 then do - liftIO $ CIO.hPutStrLn IO.stderr $ "WARNING: " <> tshow exception <> " (retrying)" - liftIO $ IO.threadDelay 1000000 - if (p exception ) - then retry (n - 1) f + if (p exception) + then do + liftIO $ CIO.hPutStrLn IO.stderr $ "WARNING: " <> tshow exception <> " (retrying)" + liftIO $ IO.threadDelay 1000000 + retryWhen p (n - 1) f else throwError exception else throwError exception -retryUnless :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m () -> ExceptT e m () +retryUnless :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m a -> ExceptT e m a retryUnless p = retryWhen (not . p) +retryS3 :: MonadIO m => ExceptT AppError m a -> ExceptT AppError m a +retryS3 a = do + retries <- (fromMaybe 3 . join) <$> liftIO (lookupEnv "CABAL_CACHE_RETRY" >>= \s -> return (readMaybe @Int <$> s)) + retryUnless (\appe -> case appErrorStatus appe of + Just 402 -> False + Just 408 -> False + Just 410 -> False + Just 425 -> False + Just 429 -> False + Just i + | i >= 500 + , i < 600 -> False + Just _ -> True + Nothing -> True) retries a + linkOrCopyResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> Location -> ExceptT AppError m () linkOrCopyResource envAws source target = case source of Local sourcePath -> case target of @@ -215,7 +231,7 @@ ("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) => URI -> m (Either AppError LBS.ByteString) +readHttpUri :: (MonadIO m, MonadCatch m) => URI -> ExceptT AppError m LBS.ByteString readHttpUri httpUri = handleHttpError $ do manager <- liftIO $ HTTP.newManager HTTPS.tlsManagerSettings request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("GET " <> tshow (reslashUri httpUri))) @@ -223,7 +239,7 @@ return $ HTTP.responseBody response -headHttpUri :: (MonadIO m, MonadCatch m) => URI -> m (Either AppError LBS.ByteString) +headHttpUri :: (MonadIO m, MonadCatch m) => URI -> ExceptT AppError m LBS.ByteString headHttpUri httpUri = handleHttpError $ do manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("HEAD " <> tshow (reslashUri httpUri)))