cabal-cache 1.0.5.1 → 1.0.5.2
raw patch · 10 files changed
+113/−59 lines, 10 filesdep +cabal-install-parsersdep ~aesondep ~hedgehogdep ~mtl
Dependencies added: cabal-install-parsers
Dependency ranges changed: aeson, hedgehog, mtl, resourcet
Files
- README.md +2/−2
- app/App/Commands/Plan.hs +1/−1
- app/App/Commands/SyncFromArchive.hs +2/−2
- app/App/Commands/SyncToArchive.hs +3/−2
- app/App/Static.hs +16/−3
- cabal-cache.cabal +9/−5
- src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs +15/−12
- src/HaskellWorks/CabalCache/Concurrent/Fork.hs +2/−2
- src/HaskellWorks/CabalCache/Core.hs +19/−2
- src/HaskellWorks/CabalCache/IO/Lazy.hs +44/−28
README.md view
@@ -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
app/App/Commands/Plan.hs view
@@ -93,7 +93,7 @@ ( long "store-path" <> help "Path to cabal store" <> metavar "DIRECTORY"- <> value (AS.cabalDirectory </> "store")+ <> value AS.cabalStoreDirectory ) <*> optional ( strOption
app/App/Commands/SyncFromArchive.hs view
@@ -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
app/App/Commands/SyncToArchive.hs view
@@ -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
app/App/Static.hs view
@@ -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"
cabal-cache.cabal view
@@ -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
src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs view
@@ -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 ()
src/HaskellWorks/CabalCache/Concurrent/Fork.hs view
@@ -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
src/HaskellWorks/CabalCache/Core.hs view
@@ -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]
src/HaskellWorks/CabalCache/IO/Lazy.hs view
@@ -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)))