cabal-cache 1.0.0.8 → 1.0.0.9
raw patch · 27 files changed
+91/−180 lines, 27 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- cabal-cache.cabal +2/−1
- src/App/Commands/Options/Parser.hs +1/−2
- src/App/Commands/Options/Types.hs +0/−3
- src/App/Commands/SyncFromArchive.hs +12/−30
- src/App/Commands/SyncToArchive.hs +15/−23
- src/App/Commands/Version.hs +2/−6
- src/App/Static.hs +0/−3
- src/HaskellWorks/CabalCache/AppError.hs +3/−1
- src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs +1/−6
- src/HaskellWorks/CabalCache/Concurrent/Fork.hs +1/−1
- src/HaskellWorks/CabalCache/Concurrent/Type.hs +0/−3
- src/HaskellWorks/CabalCache/Core.hs +3/−7
- src/HaskellWorks/CabalCache/Data/Relation.hs +0/−1
- src/HaskellWorks/CabalCache/GhcPkg.hs +0/−2
- src/HaskellWorks/CabalCache/IO/Console.hs +0/−1
- src/HaskellWorks/CabalCache/IO/Error.hs +1/−3
- src/HaskellWorks/CabalCache/IO/File.hs +1/−3
- src/HaskellWorks/CabalCache/IO/Lazy.hs +15/−28
- src/HaskellWorks/CabalCache/IO/Tar.hs +4/−8
- src/HaskellWorks/CabalCache/Location.hs +1/−1
- src/HaskellWorks/CabalCache/Metadata.hs +1/−1
- src/HaskellWorks/CabalCache/Topology.hs +2/−6
- src/HaskellWorks/CabalCache/Types.hs +1/−1
- test/HaskellWorks/CabalCache/AwsSpec.hs +5/−12
- test/HaskellWorks/CabalCache/Data/RelationSpec.hs +0/−2
- test/HaskellWorks/CabalCache/LocationSpec.hs +0/−5
- test/HaskellWorks/CabalCache/QuerySpec.hs +20/−20
cabal-cache.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: cabal-cache-version: 1.0.0.8+version: 1.0.0.9 synopsis: CI Assistant for Haskell projects description: CI Assistant for Haskell projects. Implements package caching. homepage: https://github.com/haskell-works/cabal-cache@@ -60,6 +60,7 @@ common config default-language: Haskell2010+ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates library import: base, config
src/App/Commands/Options/Parser.hs view
@@ -10,8 +10,7 @@ import HaskellWorks.CabalCache.Location (Location (..), toLocation, (</>)) import Options.Applicative -import qualified Data.Text as Text-import qualified Network.AWS.Types as AWS+import qualified Data.Text as Text optsSyncFromArchive :: Parser SyncFromArchiveOptions optsSyncFromArchive = SyncFromArchiveOptions
src/App/Commands/Options/Types.hs view
@@ -4,11 +4,8 @@ module App.Commands.Options.Types where import Antiope.Env (Region)-import Data.Text (Text) import GHC.Generics-import GHC.Word (Word8) import HaskellWorks.CabalCache.Location-import Network.AWS.Types (Region) import qualified Antiope.Env as AWS
src/App/Commands/SyncFromArchive.hs view
@@ -9,49 +9,37 @@ ) where import Antiope.Core (runResAws, toText)-import Antiope.Env (LogLevel, mkEnv)+import Antiope.Env (mkEnv) import App.Commands.Options.Parser (optsSyncFromArchive)-import App.Static (homeDirectory) import Control.Lens hiding ((<.>)) import Control.Monad (unless, void, when) import Control.Monad.Catch (MonadCatch) import Control.Monad.Except 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.List (nub, sort) import Data.Maybe import Data.Semigroup ((<>))-import Data.Text (Text) import HaskellWorks.CabalCache.AppError-import HaskellWorks.CabalCache.Core (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan)-import HaskellWorks.CabalCache.IO.Error (exceptWarn, maybeToExcept, maybeToExceptM)+import HaskellWorks.CabalCache.IO.Error (exceptWarn, maybeToExcept) import HaskellWorks.CabalCache.Location ((<.>), (</>))-import HaskellWorks.CabalCache.Metadata (deleteMetadata, loadMetadata)+import HaskellWorks.CabalCache.Metadata (loadMetadata) import HaskellWorks.CabalCache.Show-import HaskellWorks.CabalCache.Topology (buildPlanData) import HaskellWorks.CabalCache.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 Control.Concurrent as IO import qualified Control.Concurrent.STM as STM-import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as M import qualified Data.Map.Strict as Map-import qualified Data.Set as S import qualified Data.Text as T import qualified HaskellWorks.CabalCache.AWS.Env as AWS import qualified HaskellWorks.CabalCache.Concurrent.DownloadQueue as DQ import qualified HaskellWorks.CabalCache.Concurrent.Fork as IO-import qualified HaskellWorks.CabalCache.Data.Relation as R+import qualified HaskellWorks.CabalCache.Core as Z import qualified HaskellWorks.CabalCache.GhcPkg as GhcPkg import qualified HaskellWorks.CabalCache.Hash as H import qualified HaskellWorks.CabalCache.IO.Console as CIO@@ -62,7 +50,6 @@ import qualified System.IO as IO import qualified System.IO.Temp as IO import qualified System.IO.Unsafe as IO-import qualified UnliftIO.Async as IO {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Redundant do" :: String) #-}@@ -89,12 +76,11 @@ GhcPkg.testAvailability - mbPlan <- loadPlan+ mbPlan <- Z.loadPlan case mbPlan of Right planJson -> do envAws <- IO.unsafeInterleaveIO $ mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel) let compilerId = planJson ^. the @"compilerId"- let archivePath = versionedArchiveUri </> compilerId let storeCompilerPath = storePath </> T.unpack compilerId let storeCompilerPackageDbPath = storeCompilerPath </> "package.db" let storeCompilerLibPath = storeCompilerPath </> "lib"@@ -110,13 +96,11 @@ CIO.putStrLn "Package DB missing. Creating Package DB" GhcPkg.init storeCompilerPackageDbPath - packages <- getPackages storePath planJson+ packages <- Z.getPackages storePath planJson let installPlan = planJson ^. the @"installPlan" let planPackages = M.fromList $ fmap (\p -> (p ^. the @"id", p)) installPlan - let planData = buildPlanData planJson (packages ^.. each . the @"packageId")- let planDeps0 = installPlan >>= \p -> fmap (p ^. the @"id", ) $ mempty <> (p ^. the @"depends") <> (p ^. the @"exeDepends")@@ -139,10 +123,10 @@ IO.forkThreadsWait threads $ DQ.runQueue downloadQueue $ \packageId -> case M.lookup packageId pInfos of Just pInfo -> do- let archiveBaseName = packageDir pInfo <.> ".tar.gz"+ let archiveBaseName = Z.packageDir pInfo <.> ".tar.gz" let archiveFile = versionedArchiveUri </> T.pack archiveBaseName let scopedArchiveFile = scopedArchiveUri </> T.pack archiveBaseName- let packageStorePath = storePath </> packageDir pInfo+ let packageStorePath = storePath </> Z.packageDir pInfo storeDirectoryExists <- doesDirectoryExist packageStorePath let maybePackage = M.lookup packageId planPackages @@ -167,8 +151,8 @@ meta <- loadMetadata packageStorePath oldStorePath <- maybeToExcept "store-path is missing from Metadata" (Map.lookup "store-path" meta) - case confPath pInfo of- Tagged conf _ -> do+ case Z.confPath pInfo of+ Z.Tagged conf _ -> do let theConfPath = storePath </> conf let tempConfPath = tempPath </> conf confPathExists <- liftIO $ IO.doesFileExist theConfPath@@ -181,8 +165,6 @@ CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId return True - dependenciesRemaining <- STM.atomically $ STM.readTVar (downloadQueue ^. the @"tDependencies")- CIO.putStrLn "Recaching package database" GhcPkg.recache storeCompilerPackageDbPath @@ -197,14 +179,14 @@ cleanupStorePath :: (MonadIO m, MonadCatch m) => FilePath -> Z.PackageId -> AppError -> m () cleanupStorePath packageStorePath packageId e = do- CIO.hPutStrLn IO.stderr $ "Warning: Sync failure: " <> packageId+ CIO.hPutStrLn IO.stderr $ "Warning: Sync failure: " <> packageId <> ", reason: " <> displayAppError e void $ IO.removePathRecursive packageStorePath onError :: MonadIO m => (AppError -> m ()) -> a -> ExceptT AppError m a -> m a onError h failureValue f = do result <- runExceptT $ catchError (exceptWarn f) handler case result of- Left a -> return failureValue+ Left _ -> return failureValue Right a -> return a where handler e = lift (h e) >> return failureValue
src/App/Commands/SyncToArchive.hs view
@@ -10,37 +10,32 @@ ) where import Antiope.Core (toText)-import Antiope.Env (LogLevel (..), mkEnv)+import Antiope.Env (mkEnv) import App.Commands.Options.Parser (optsSyncToArchive)-import App.Static (homeDirectory) import Control.Lens hiding ((<.>)) import Control.Monad (filterM, unless, when) import Control.Monad.Except import Control.Monad.Trans.Resource (runResourceT) import Data.Generics.Product.Any (the)-import Data.List (isSuffixOf, (\\))+import Data.List ((\\)) import Data.Maybe import Data.Semigroup ((<>)) import HaskellWorks.CabalCache.AppError-import HaskellWorks.CabalCache.Core (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan, relativePaths) import HaskellWorks.CabalCache.Location ((<.>), (</>)) import HaskellWorks.CabalCache.Metadata (createMetadata) import HaskellWorks.CabalCache.Show import HaskellWorks.CabalCache.Topology (buildPlanData, canShare) import HaskellWorks.CabalCache.Version (archiveVersion) import Options.Applicative hiding (columns)-import System.Directory (createDirectoryIfMissing, doesDirectoryExist)+import System.Directory (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 Control.Concurrent.STM as STM import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LC8-import qualified Data.Set as Set import qualified Data.Text as T-import qualified Data.Text.Encoding as T import qualified HaskellWorks.CabalCache.AWS.Env as AWS+import qualified HaskellWorks.CabalCache.Core as Z import qualified HaskellWorks.CabalCache.GhcPkg as GhcPkg import qualified HaskellWorks.CabalCache.Hash as H import qualified HaskellWorks.CabalCache.IO.Console as CIO@@ -48,10 +43,8 @@ import qualified HaskellWorks.CabalCache.IO.File as IO import qualified HaskellWorks.CabalCache.IO.Lazy as IO import qualified HaskellWorks.CabalCache.IO.Tar as IO-import qualified HaskellWorks.CabalCache.Types as Z 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.Temp as IO import qualified System.IO.Unsafe as IO@@ -79,7 +72,7 @@ tEarlyExit <- STM.newTVarIO False - mbPlan <- loadPlan+ mbPlan <- Z.loadPlan case mbPlan of Right planJson -> do let compilerId = planJson ^. the @"compilerId"@@ -89,7 +82,7 @@ IO.createLocalDirectoryIfMissing archivePath IO.createLocalDirectoryIfMissing scopedArchivePath - packages <- getPackages storePath planJson+ packages <- Z.getPackages storePath planJson nonShareable <- packages & filterM (fmap not . isShareable storePath) let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId") @@ -109,21 +102,20 @@ IO.pooledForConcurrentlyN_ (opts ^. the @"threads") packages $ \pInfo -> do earlyExit <- STM.readTVarIO tEarlyExit unless earlyExit $ do- let archiveFileBasename = packageDir pInfo <.> ".tar.gz"+ let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz" let archiveFile = versionedArchiveUri </> T.pack archiveFileBasename let scopedArchiveFile = versionedArchiveUri </> T.pack storePathHash </> T.pack archiveFileBasename- let packageStorePath = storePath </> packageDir pInfo- let packageSharePath = packageStorePath </> "share"+ let packageStorePath = storePath </> Z.packageDir pInfo archiveFileExists <- runResourceT $ IO.resourceExists envAws scopedArchiveFile unless archiveFileExists $ do packageStorePathExists <- doesDirectoryExist packageStorePath when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn $ do- let workingStorePackagePath = tempPath </> packageDir pInfo+ let workingStorePackagePath = tempPath </> Z.packageDir pInfo liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath - let rp2 = relativePaths storePath pInfo+ let rp2 = Z.relativePaths storePath pInfo CIO.putStrLn $ "Creating " <> toText scopedArchiveFile let tempArchiveFile = tempPath </> archiveFileBasename@@ -132,10 +124,10 @@ IO.createTar tempArchiveFile (metas:rp2) - liftIO (LBS.readFile tempArchiveFile >>= IO.writeResource envAws scopedArchiveFile)+ void $ liftIO (LBS.readFile tempArchiveFile >>= IO.writeResource envAws scopedArchiveFile) - when (canShare planData (packageId pInfo)) $ do- copyResult <- catchError (IO.linkOrCopyResource envAws scopedArchiveFile archiveFile) $ \case+ when (canShare planData (Z.packageId pInfo)) $ do+ void $ catchError (IO.linkOrCopyResource envAws scopedArchiveFile archiveFile) $ \case e@(AwsAppError (HTTP.Status 301 _)) -> do liftIO $ STM.atomically $ STM.writeTVar tEarlyExit True CIO.hPutStrLn IO.stderr $ mempty@@ -154,9 +146,9 @@ when earlyExit $ CIO.hPutStrLn IO.stderr $ "Early exit due to error" -isShareable :: MonadIO m => FilePath -> PackageInfo -> m Bool+isShareable :: MonadIO m => FilePath -> Z.PackageInfo -> m Bool isShareable storePath pkg =- let packageSharePath = storePath </> packageDir pkg </> "share"+ let packageSharePath = storePath </> Z.packageDir pkg </> "share" in IO.listMaybeDirectory packageSharePath <&> (\\ ["doc"]) <&> null cmdSyncToArchive :: Mod CommandFields (IO ())
src/App/Commands/Version.hs view
@@ -8,26 +8,22 @@ ) where import App.Commands.Options.Parser (optsVersion)-import App.Static (homeDirectory)-import Control.Lens hiding ((<.>))-import Control.Monad (unless, when)-import Data.Generics.Product.Any (the) import Data.List import Data.Semigroup ((<>)) import Options.Applicative hiding (columns)-import Paths_cabal_cache import qualified App.Commands.Options.Types as Z import qualified Data.Text as T import qualified Data.Version as V import qualified HaskellWorks.CabalCache.IO.Console as CIO+import qualified Paths_cabal_cache as P {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Redundant do" :: String) #-} runVersion :: Z.VersionOptions -> IO () runVersion _ = do- let V.Version {..} = Paths_cabal_cache.version+ let V.Version {..} = P.version let version = intercalate "." $ fmap show versionBranch
src/App/Static.hs view
@@ -1,8 +1,5 @@ module App.Static where -import Data.Text (Text)--import qualified Data.Text as T import qualified System.Directory as IO import qualified System.IO.Unsafe as IO
src/HaskellWorks/CabalCache/AppError.hs view
@@ -31,8 +31,10 @@ fromString = GenericAppError . T.pack displayAppError :: AppError -> Text-displayAppError (AwsAppError status) = tshow status+displayAppError (AwsAppError s) = tshow s+displayAppError (HttpAppError s) = tshow s displayAppError RetriesFailedAppError = "Multiple retries failed"+displayAppError NotFound = "Not found" displayAppError (GenericAppError msg) = msg appErrorStatus :: AppError -> Maybe Int
src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs view
@@ -8,19 +8,14 @@ , runQueue ) where -import Control.Lens-import Control.Monad import Control.Monad.IO.Class-import Data.Generics.Product.Any-import Data.Set ((\\))+import Data.Set ((\\)) import qualified Control.Concurrent.STM as STM import qualified Data.Map as M import qualified Data.Set as S-import qualified Data.Text as T import qualified HaskellWorks.CabalCache.Concurrent.Type as Z import qualified HaskellWorks.CabalCache.Data.Relation as R-import qualified HaskellWorks.CabalCache.IO.Console as CIO 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))
src/HaskellWorks/CabalCache/Concurrent/Fork.hs view
@@ -8,7 +8,7 @@ forkThreadsWait :: Int -> IO () -> IO () forkThreadsWait n f = do tDone <- STM.atomically $ STM.newTVar (0 :: Int)- threads <- forM [1 .. n] $ \_ -> IO.forkIO $ do+ forM_ [1 .. n] $ \_ -> IO.forkIO $ do f STM.atomically $ STM.modifyTVar tDone (+1)
src/HaskellWorks/CabalCache/Concurrent/Type.hs view
@@ -8,14 +8,11 @@ , PackageId ) where -import Data.Text (Text) import GHC.Generics import HaskellWorks.CabalCache.Types (PackageId) import qualified Control.Concurrent.STM as STM-import qualified Data.Map as M import qualified Data.Set as S-import qualified Data.Text as T import qualified HaskellWorks.CabalCache.Data.Relation as R type ConsumerId = PackageId
src/HaskellWorks/CabalCache/Core.hs view
@@ -21,7 +21,6 @@ import Data.Bifunctor (first) import Data.Bool (bool) import Data.Generics.Product.Any (the)-import Data.Maybe (maybeToList) import Data.Semigroup ((<>)) import Data.String import Data.Text (Text)@@ -65,13 +64,11 @@ ] getPackages :: FilePath -> Z.PlanJson -> IO [PackageInfo]-getPackages basePath planJson = forM packages (mkPackageInfo basePath compilerId)- where compilerId :: Text- compilerId = planJson ^. the @"compilerId"+getPackages basePath planJson = forM packages (mkPackageInfo basePath compilerId')+ where compilerId' :: Text+ compilerId' = planJson ^. the @"compilerId" packages :: [Z.Package] packages = planJson ^. the @"installPlan"- predicate :: Z.Package -> Bool- predicate package = True loadPlan :: IO (Either AppError Z.PlanJson) loadPlan = (first fromString . eitherDecode) <$> LBS.readFile ("dist-newstyle" </> "cache" </> "plan.json")@@ -87,7 +84,6 @@ let relativeLibPath = T.unpack cid </> "lib" let libPrefix = "libHS" <> pid absoluteConfPathExists <- IO.doesFileExist absoluteConfPath- libPathExists <- IO.doesDirectoryExist libPath libFiles <- getLibFiles relativeLibPath libPath libPrefix return PackageInfo { compilerId = cid
src/HaskellWorks/CabalCache/Data/Relation.hs view
@@ -15,7 +15,6 @@ , withoutRange ) where -import GHC.Generics import HaskellWorks.CabalCache.Data.Relation.Type (Relation (Relation)) import Prelude hiding (null)
src/HaskellWorks/CabalCache/GhcPkg.hs view
@@ -1,10 +1,8 @@ module HaskellWorks.CabalCache.GhcPkg where -import Data.Text (Text) import System.Exit (ExitCode (..), exitWith) import System.Process (spawnProcess, waitForProcess) -import qualified Data.Text as Text import qualified System.IO as IO runGhcPkg :: [String] -> IO ()
src/HaskellWorks/CabalCache/IO/Console.hs view
@@ -11,7 +11,6 @@ import Prelude (IO, Show (..), ($), (.)) import qualified Control.Concurrent.QSem as IO-import qualified Data.Text as T import qualified Data.Text.IO as T import qualified System.IO as IO import qualified System.IO.Unsafe as IO
src/HaskellWorks/CabalCache/IO/Error.hs view
@@ -9,10 +9,8 @@ ) where import Control.Monad.Except-import Control.Monad.IO.Class import HaskellWorks.CabalCache.AppError -import qualified Data.Text as T import qualified HaskellWorks.CabalCache.IO.Console as CIO import qualified System.Exit as IO import qualified System.IO as IO@@ -21,7 +19,7 @@ exceptFatal f = catchError f handler where handler e = do liftIO . CIO.hPutStrLn IO.stderr $ "Fatal Error: " <> displayAppError e- liftIO IO.exitFailure+ void $ liftIO IO.exitFailure throwError e exceptWarn :: MonadIO m => ExceptT AppError m a -> ExceptT AppError m a
src/HaskellWorks/CabalCache/IO/File.hs view
@@ -6,13 +6,11 @@ ) where import Control.Monad.Except-import Control.Monad.IO.Class import qualified Data.Text as T import qualified HaskellWorks.CabalCache.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 copyDirectoryRecursive :: MonadIO m => FilePath -> FilePath -> ExceptT String m ()@@ -22,7 +20,7 @@ exitCode <- liftIO $ IO.waitForProcess process case exitCode of IO.ExitSuccess -> return ()- IO.ExitFailure n -> throwError ""+ IO.ExitFailure n -> throwError $ "cp exited with " <> show n listMaybeDirectory :: MonadIO m => FilePath -> m [FilePath] listMaybeDirectory filepath = do
src/HaskellWorks/CabalCache/IO/Lazy.hs view
@@ -15,32 +15,24 @@ ) where import Antiope.Core-import Antiope.S3.Lazy import Control.Lens import Control.Monad (void) import Control.Monad.Catch import Control.Monad.Except-import Control.Monad.IO.Class import Control.Monad.Trans.Resource-import Data.Conduit.Lazy (lazyConsume) import Data.Either (isRight) import Data.Text (Text) import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.Location (Location (..)) import HaskellWorks.CabalCache.Show-import Network.AWS (MonadAWS, chunkedFile)-import Network.AWS.Data.Body (_streamBody)-import Network.HTTP.Types.Status (statusCode) import qualified Antiope.S3.Lazy as AWS import qualified Antiope.S3.Types as AWS import qualified Control.Concurrent as IO import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T-import qualified Data.Text.IO as T import qualified HaskellWorks.CabalCache.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@@ -55,23 +47,19 @@ {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} -rightToMaybe :: Either e a -> Maybe a-rightToMaybe (Right a) = Just a-rightToMaybe _ = Nothing- handleAwsError :: MonadCatch m => m a -> m (Either AppError a) handleAwsError f = catch (Right <$> f) $ \(e :: AWS.Error) -> case e of- (AWS.ServiceError (AWS.ServiceError' _ status@(HTTP.Status 404 _) _ _ _ _)) -> return (Left (AwsAppError status))- (AWS.ServiceError (AWS.ServiceError' _ status@(HTTP.Status 301 _) _ _ _ _)) -> return (Left (AwsAppError status))- _ -> throwM e+ (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status 404 _) _ _ _ _)) -> return (Left (AwsAppError s))+ (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) -> case e of- (HTTP.HttpExceptionRequest _ e) -> case e of+ (HTTP.HttpExceptionRequest _ e') -> case e' of HTTP.StatusCodeException resp _ -> return (Left (HttpAppError (resp & HTTP.responseStatus)))- _ -> return (Left (GenericAppError (tshow e)))+ _ -> return (Left (GenericAppError (tshow e'))) _ -> throwM e getS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either AppError LBS.ByteString)@@ -84,7 +72,7 @@ HttpUri httpUri -> liftIO $ readHttpUri httpUri readFirstAvailableResource :: (MonadResource m, MonadCatch m) => AWS.Env -> [Location] -> m (Either AppError (LBS.ByteString, Location))-readFirstAvailableResource envAws [] = return (Left (GenericAppError "No resources specified in read"))+readFirstAvailableResource _ [] = return (Left (GenericAppError "No resources specified in read")) readFirstAvailableResource envAws (a:as) = do result <- readResource envAws a case result of@@ -117,7 +105,7 @@ else return False firstExistingResource :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> [Location] -> m (Maybe Location)-firstExistingResource envAws [] = return Nothing+firstExistingResource _ [] = return Nothing firstExistingResource envAws (a:as) = do exists <- resourceExists envAws a if exists@@ -127,9 +115,6 @@ headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either AppError AWS.HeadObjectResponse) headS3Uri envAws (AWS.S3Uri b k) = handleAwsError $ runAws envAws $ AWS.send $ AWS.headObject b k -chunkSize :: AWS.ChunkSize-chunkSize = AWS.ChunkSize (1024 * 1024)- uploadToS3 :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m (Either AppError ()) uploadToS3 envAws (AWS.S3Uri b k) lbs = do let req = AWS.toBody lbs@@ -138,15 +123,15 @@ writeResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> LBS.ByteString -> m (Either AppError ()) writeResource envAws loc lbs = case loc of- S3 s3Uri -> uploadToS3 envAws s3Uri lbs- Local path -> liftIO (LBS.writeFile path lbs) >> return (Right ())- HttpUri uri -> return (Left (GenericAppError "HTTP PUT method not supported"))+ S3 s3Uri -> uploadToS3 envAws s3Uri lbs+ Local path -> liftIO (LBS.writeFile path lbs) >> return (Right ())+ HttpUri _ -> return (Left (GenericAppError "HTTP PUT method not supported")) createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m () createLocalDirectoryIfMissing = \case- S3 s3Uri -> return ()+ S3 _ -> return () Local path -> liftIO $ IO.createDirectoryIfMissing True path- HttpUri uri -> return ()+ HttpUri _ -> return () copyS3Uri :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> AWS.S3Uri -> ExceptT AppError m () copyS3Uri envAws (AWS.S3Uri sourceBucket sourceObjectKey) (AWS.S3Uri targetBucket targetObjectKey) = ExceptT $ do@@ -183,13 +168,15 @@ S3 sourceS3Uri -> case target of S3 targetS3Uri -> retryUnless ((== Just 301) . appErrorStatus) 3 (copyS3Uri envAws sourceS3Uri targetS3Uri) Local _ -> throwError "Can't copy between different file backends"+ HttpUri _ -> throwError "Link and copy unsupported for http backend" 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- HttpUri uri -> throwError "HTTP PUT method not supported"+ HttpUri _ -> throwError "Link and copy unsupported for http backend"+ HttpUri _ -> throwError "HTTP PUT method not supported" readHttpUri :: (MonadIO m, MonadCatch m) => Text -> m (Either AppError LBS.ByteString) readHttpUri httpUri = handleHttpError $ do
src/HaskellWorks/CabalCache/IO/Tar.hs view
@@ -15,16 +15,12 @@ import Control.Monad.Except import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Generics.Product.Any-import Data.List import GHC.Generics import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.Show -import qualified Data.Text as T-import qualified HaskellWorks.CabalCache.IO.Console as CIO-import qualified System.Exit as IO-import qualified System.IO as IO-import qualified System.Process as IO+import qualified System.Exit as IO+import qualified System.Process as IO data TarGroup = TarGroup { basePath :: FilePath@@ -38,7 +34,7 @@ exitCode <- liftIO $ IO.waitForProcess process case exitCode of IO.ExitSuccess -> return ()- IO.ExitFailure n -> throwError "Failed to create tar"+ IO.ExitFailure n -> throwError $ GenericAppError $ "Failed to create tar. Exit code: " <> tshow n extractTar :: MonadIO m => FilePath -> FilePath -> ExceptT AppError m () extractTar tarFile targetPath = do@@ -46,7 +42,7 @@ exitCode <- liftIO $ IO.waitForProcess process case exitCode of IO.ExitSuccess -> return ()- IO.ExitFailure n -> throwError "Failed to extract tar"+ IO.ExitFailure n -> throwError $ GenericAppError $ "Failed to extract tar. Exit code: " <> tshow n tarGroupToArgs :: TarGroup -> [String] tarGroupToArgs tarGroup = ["-C", tarGroup ^. the @"basePath"] <> tarGroup ^. the @"entryPaths"
src/HaskellWorks/CabalCache/Location.hs view
@@ -11,7 +11,7 @@ where import Antiope.Core (ToText (..), fromText)-import Antiope.S3 (BucketName, ObjectKey (..), S3Uri (..))+import Antiope.S3 (ObjectKey (..), S3Uri (..)) import Data.Maybe (fromMaybe) import Data.Text (Text) import GHC.Generics (Generic)
src/HaskellWorks/CabalCache/Metadata.hs view
@@ -7,7 +7,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import HaskellWorks.CabalCache.Core (PackageInfo (..)) import HaskellWorks.CabalCache.IO.Tar (TarGroup (..))-import System.FilePath (makeRelative, takeFileName, (<.>), (</>))+import System.FilePath (takeFileName, (</>)) import qualified Data.ByteString.Lazy as LBS import qualified Data.Map.Strict as Map
src/HaskellWorks/CabalCache/Topology.hs view
@@ -10,18 +10,16 @@ ) where import Control.Arrow ((&&&))-import Control.Lens (each, set, view, (&), (.~), (<&>), (^.), (^..))+import Control.Lens (view, (&), (<&>), (^.)) import Control.Monad (join) import Data.Either (fromRight) import Data.Generics.Product.Any (the) import Data.Map.Strict (Map)-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe (fromMaybe) import Data.Set (Set)-import Data.Text (Text) import GHC.Generics (Generic) import HaskellWorks.CabalCache.Types (Package, PackageId, PlanJson) -import qualified Data.List as L import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Topograph as TG@@ -56,7 +54,5 @@ let tg = TG.transpose g nsPaths = concatMap (fromMaybe [] . paths tg) knownNonShareable nsAll = S.fromList (join nsPaths)- dMap = TG.adjacencyMap (TG.reduction g)- rdMap = TG.adjacencyMap (TG.reduction tg) in PlanData { nonShareable = nsAll } where paths g x = (fmap . fmap . fmap) (TG.gFromVertex g) $ TG.dfs g <$> TG.gToVertex g x
src/HaskellWorks/CabalCache/Types.hs view
@@ -7,9 +7,9 @@ module HaskellWorks.CabalCache.Types where import Data.Aeson-import Data.Maybe (fromMaybe) import Data.Text (Text) import GHC.Generics+import Prelude hiding (id) type CompilerId = Text type PackageId = Text
test/HaskellWorks/CabalCache/AwsSpec.hs view
@@ -10,24 +10,17 @@ import Control.Lens import Control.Monad import Control.Monad.IO.Class-import Data.Generics.Product.Any-import Data.Maybe (fromJust, isJust)+import Data.Maybe (isJust) import HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.IO.Lazy import HaskellWorks.Hspec.Hedgehog import Hedgehog-import System.Environment (lookupEnv) import Test.Hspec-import Text.RawString.QQ -import qualified Antiope.S3.Lazy as LBS-import qualified Antiope.S3.Types as AWS-import qualified Data.Aeson as A-import qualified Data.ByteString.Lazy as LBS-import qualified Data.ByteString.Lazy.Char8 as LBSC-import qualified HaskellWorks.CabalCache.Types as Z-import qualified Network.HTTP.Types as HTTP-import qualified System.Environment as IO+import qualified Antiope.S3.Types as AWS+import qualified Data.ByteString.Lazy.Char8 as LBSC+import qualified Network.HTTP.Types as HTTP+import qualified System.Environment as IO {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
test/HaskellWorks/CabalCache/Data/RelationSpec.hs view
@@ -4,13 +4,11 @@ ( spec ) where -import HaskellWorks.CabalCache.Data.Relation (Relation (Relation)) import HaskellWorks.Hspec.Hedgehog import Hedgehog import Test.Hspec import qualified Data.List as L-import qualified Data.Map as M import qualified Data.Set as S import qualified HaskellWorks.CabalCache.Data.Relation as R import qualified Hedgehog.Gen as G
test/HaskellWorks/CabalCache/LocationSpec.hs view
@@ -6,7 +6,6 @@ import Antiope.Core (toText) import Antiope.S3 (BucketName (..), ObjectKey (..), S3Uri (..))-import Data.Text (Text) import HaskellWorks.CabalCache.Location import HaskellWorks.Hspec.Hedgehog@@ -37,10 +36,6 @@ parts <- Gen.list (Range.linear 1 5) partGen ext <- Gen.string (Range.linear 2 4) Gen.alphaNum pure $ "/" <> List.intercalate "/" parts <> "." <> ext--location :: MonadGen m => m Location-location =- Gen.choice [S3 <$> s3Uri, Local <$> localPath] spec :: Spec spec = describe "HaskellWorks.Assist.LocationSpec" $ do
test/HaskellWorks/CabalCache/QuerySpec.hs view
@@ -7,8 +7,6 @@ ( spec ) where -import Control.Lens-import Data.Generics.Product.Any import HaskellWorks.Hspec.Hedgehog import Hedgehog import Test.Hspec@@ -25,26 +23,28 @@ spec :: Spec spec = describe "HaskellWorks.Assist.QuerySpec" $ do it "stub" $ requireTest $ do- let Right planJson = A.eitherDecode exampleJson- planJson === Z.PlanJson- { Z.compilerId = "ghc-8.6.4"- , Z.installPlan =- [ Z.Package- { Z.packageType = "pre-existing"- , Z.id = "Cabal-2.4.0.1"- , Z.name = "Cabal"- , Z.version = "2.4.0.1"- , Z.style = Nothing- , Z.componentName = Nothing- , Z.components = Nothing- , Z.depends =- [ "array-0.5.3.0"- , "base-4.12.0.0"+ case A.eitherDecode exampleJson of+ Right planJson -> do+ planJson === Z.PlanJson+ { Z.compilerId = "ghc-8.6.4"+ , Z.installPlan =+ [ Z.Package+ { Z.packageType = "pre-existing"+ , Z.id = "Cabal-2.4.0.1"+ , Z.name = "Cabal"+ , Z.version = "2.4.0.1"+ , Z.style = Nothing+ , Z.componentName = Nothing+ , Z.components = Nothing+ , Z.depends =+ [ "array-0.5.3.0"+ , "base-4.12.0.0"+ ]+ , Z.exeDepends = []+ } ]- , Z.exeDepends = [] }- ]- }+ Left msg -> fail msg exampleJson :: LBS.ByteString exampleJson = [r|