cabal-cache 1.0.0.2 → 1.0.0.3

raw patch · 11 files changed

+299/−96 lines, 11 filesdep +topographPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: topograph

API changes (from Hackage documentation)

Files

• cabal-cache.cabal +6/−2
• src/App/Commands/SyncFromArchive.hs +120/−57
• src/App/Commands/SyncToArchive.hs +13/−5
• src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs +28/−8
• src/HaskellWorks/CabalCache/Concurrent/Fork.hs +17/−0
• src/HaskellWorks/CabalCache/Concurrent/Type.hs +1/−0
• src/HaskellWorks/CabalCache/Core.hs +5/−7
• src/HaskellWorks/CabalCache/IO/File.hs +1/−1
• src/HaskellWorks/CabalCache/Topology.hs +62/−0
• src/HaskellWorks/CabalCache/Types.hs +39/−12
• test/HaskellWorks/CabalCache/QuerySpec.hs +7/−4

@@ -1,7 +1,7 @@ cabal-version:          2.2  name:                   cabal-cache-version:                1.0.0.2+version:                1.0.0.3 synopsis:               CI Assistant for Haskell projects description:            CI Assistant for Haskell projects.  Implements package caching. homepage:               https://github.com/haskell-works/cabal-cache@@ -54,6 +54,7 @@ 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 topograph                      { build-depends: topograph                      >= 1          && < 2      } common unliftio                       { build-depends: unliftio                       >= 0.2.10     && < 0.3    } common zlib                           { build-depends: zlib                           >= 0.6.2      && < 0.7    } @@ -92,6 +93,7 @@           , temporary           , text           , time+          , topograph           , unliftio           , zlib   other-modules:        Paths_cabal_cache@@ -107,6 +109,7 @@       App.Static       HaskellWorks.CabalCache.AWS.Env       HaskellWorks.CabalCache.Concurrent.DownloadQueue+      HaskellWorks.CabalCache.Concurrent.Fork       HaskellWorks.CabalCache.Concurrent.Type       HaskellWorks.CabalCache.Core       HaskellWorks.CabalCache.Data.Relation@@ -123,6 +126,7 @@       HaskellWorks.CabalCache.Options       HaskellWorks.CabalCache.Show       HaskellWorks.CabalCache.Text+      HaskellWorks.CabalCache.Topology       HaskellWorks.CabalCache.Types       HaskellWorks.CabalCache.Version @@ -150,7 +154,7 @@           , lens           , raw-strings-qq           , text-        +   type:                 exitcode-stdio-1.0   main-is:              Spec.hs   build-depends:        cabal-cache

@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-} {-# LANGUAGE TypeApplications    #-}  module App.Commands.SyncFromArchive@@ -18,6 +19,7 @@ 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)@@ -26,34 +28,45 @@ import HaskellWorks.CabalCache.Location ((<.>), (</>)) import HaskellWorks.CabalCache.Metadata (deleteMetadata, 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 Data.ByteString                    as BS-import qualified Data.ByteString.Char8              as C8-import qualified Data.ByteString.Lazy               as LBS-import qualified Data.Map.Strict                    as Map-import qualified Data.Text                          as T-import qualified HaskellWorks.CabalCache.AWS.Env    as AWS-import qualified HaskellWorks.CabalCache.GhcPkg     as GhcPkg-import qualified HaskellWorks.CabalCache.Hash       as H-import qualified HaskellWorks.CabalCache.IO.Console as CIO-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 System.Directory                   as IO-import qualified System.IO                          as IO-import qualified System.IO.Temp                     as IO-import qualified UnliftIO.Async                     as IO+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.GhcPkg                   as GhcPkg+import qualified HaskellWorks.CabalCache.Hash                     as H+import qualified HaskellWorks.CabalCache.IO.Console               as CIO+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 System.Directory                                 as IO+import qualified System.IO                                        as IO+import qualified System.IO.Temp                                   as IO+import qualified UnliftIO.Async                                   as IO  {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-} {-# ANN module ("HLint: ignore Redundant do"        :: String) #-} +skippable :: Z.Package -> Bool+skippable package = (package ^. the @"packageType" == "pre-existing")+ runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO () runSyncFromArchive opts = do   let storePath           = opts ^. the @"storePath"@@ -80,9 +93,6 @@       let compilerId                  = planJson ^. the @"compilerId"       let archivePath                 = versionedArchiveUri </> compilerId       let storeCompilerPath           = storePath </> T.unpack compilerId-      -- xx let scopedArchivePath           = scopedArchiveUri </> compilerId-      -- xx let baseDir                     = opts ^. the @"storePath"-      -- xx let storeCompilerPath           = baseDir </> T.unpack compilerId       let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db"       let storeCompilerLibPath        = storeCompilerPath </> "lib" @@ -99,57 +109,110 @@        packages <- 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")+            <> (p ^.. the @"components" . each . the @"lib" . each . the @"depends"    . each)+            <> (p ^.. the @"components" . each . the @"lib" . each . the @"exeDepends" . each)+      let planDeps  = planDeps0 <> fmap (\p -> ("[universe]", p ^. the @"id")) installPlan++      downloadQueue <- STM.atomically $ DQ.createDownloadQueue planDeps++      let pInfos = M.fromList $ fmap (\p -> (p ^. the @"packageId", p)) packages++      -- forM_ planDeps $ \(a, b) -> do+      --   let maybeName = M.lookup a planPackages <&> (^. the @"name")+      --   case maybeName of+      --     Just name -> CIO.putStrLn $ name <> " " <> a <> " -> " <> b+      --     Nothing   -> CIO.putStrLn $ "*********" <> a <> " -> " <> b+       IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do         IO.createDirectoryIfMissing True (tempPath </> T.unpack compilerId </> "package.db") -        IO.pooledForConcurrentlyN_ threads packages $ \pInfo -> do-          let archiveBaseName   = packageDir pInfo <.> ".tar.gz"-          let archiveFile       = versionedArchiveUri </> T.pack archiveBaseName-          let scopedArchiveFile = scopedArchiveUri </> T.pack archiveBaseName-          let packageStorePath  = storePath </> packageDir pInfo-          storeDirectoryExists <- doesDirectoryExist packageStorePath-          unless storeDirectoryExists $ do-            maybeExistingArchiveFile <- IO.firstExistingResource envAws [scopedArchiveFile, archiveFile]-            forM_ maybeExistingArchiveFile $ \existingArchiveFile -> do-              CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile-              void $ runResAws envAws $ onErrorClean packageStorePath $ do-                maybeArchiveFileContents <- IO.readResource envAws existingArchiveFile+        IO.forkThreadsWait threads $ DQ.runQueue downloadQueue $ \packageId -> case M.lookup packageId pInfos of+          Just pInfo -> do+            let archiveBaseName   = packageDir pInfo <.> ".tar.gz"+            let archiveFile       = versionedArchiveUri </> T.pack archiveBaseName+            let scopedArchiveFile = scopedArchiveUri </> T.pack archiveBaseName+            let packageStorePath  = storePath </> packageDir pInfo+            storeDirectoryExists <- doesDirectoryExist packageStorePath+            let maybePackage = M.lookup packageId planPackages -                case maybeArchiveFileContents of-                  Just archiveFileContents -> do-                    existingArchiveFileContents <- IO.readResource envAws existingArchiveFile & maybeToExceptM ("Archive unavailable: " <> show (toText archiveFile))-                    let tempArchiveFile = tempPath </> archiveBaseName-                    liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents-                    IO.extractTar tempArchiveFile storePath+            case maybePackage of+              Nothing -> do+                CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageId+                return True+              Just package -> if skippable package+                then do+                  CIO.putStrLn $ "Skipping: " <> packageId+                  return True+                else if storeDirectoryExists+                  then return True+                  else do+                    maybeExistingArchiveFile <- IO.firstExistingResource envAws [scopedArchiveFile, archiveFile]+                    case maybeExistingArchiveFile of+                      Just existingArchiveFile -> do+                        CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile+                        runResAws envAws $ onErrorClean packageStorePath False $ do+                          maybeArchiveFileContents <- IO.readResource envAws existingArchiveFile -                    meta <- loadMetadata packageStorePath-                    oldStorePath <- maybeToExcept "store-path is missing from Metadata" (Map.lookup "store-path" meta)+                          case maybeArchiveFileContents of+                            Just archiveFileContents -> do+                              existingArchiveFileContents <- IO.readResource envAws existingArchiveFile & maybeToExceptM ("Archive unavailable: " <> show (toText archiveFile))+                              let tempArchiveFile = tempPath </> archiveBaseName+                              liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents+                              IO.extractTar tempArchiveFile storePath -                    case confPath pInfo of-                      Tagged conf _ -> do-                        let theConfPath = storePath </> conf-                        let tempConfPath = tempPath </> conf-                        confPathExists <- liftIO $ IO.doesFileExist theConfPath-                        when confPathExists $ do-                          confContents <- liftIO $ LBS.readFile theConfPath-                          liftIO $ LBS.writeFile tempConfPath (replace (LBS.toStrict oldStorePath) (C8.pack storePath) confContents)-                          liftIO $ IO.renamePath tempConfPath theConfPath-                  Nothing -> do-                    CIO.putStrLn $ "Archive unavailable: " <> toText existingArchiveFile+                              meta <- loadMetadata packageStorePath+                              oldStorePath <- maybeToExcept "store-path is missing from Metadata" (Map.lookup "store-path" meta) -                    deleteMetadata packageStorePath+                              case confPath pInfo of+                                Tagged conf _ -> do+                                  let theConfPath = storePath </> conf+                                  let tempConfPath = tempPath </> conf+                                  confPathExists <- liftIO $ IO.doesFileExist theConfPath+                                  when confPathExists $ do+                                    confContents <- liftIO $ LBS.readFile theConfPath+                                    liftIO $ LBS.writeFile tempConfPath (replace (LBS.toStrict oldStorePath) (C8.pack storePath) confContents)+                                    liftIO $ IO.renamePath tempConfPath theConfPath+                                  return True+                            Nothing -> do+                              CIO.putStrLn $ "Archive unavailable: " <> toText existingArchiveFile+                              deleteMetadata packageStorePath+                              return False+                      Nothing -> do+                        CIO.hPutStrLn IO.stderr $ "Warning: Sync failure: " <> packageId+                        return False+          Nothing -> do+            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 +      failures <- STM.atomically $ STM.readTVar $ downloadQueue ^. the @"tFailures"++      forM_ failures $ \packageId -> CIO.hPutStrLn IO.stderr $ "Failed to download: " <> packageId+     Left errorMessage -> do       CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> T.pack errorMessage    return () -onErrorClean :: MonadIO m => FilePath -> ExceptT String m () -> m ()-onErrorClean pkgStorePath f =-  void $ runExceptT $ exceptWarn f `catchError` (\e -> liftIO $ IO.removeDirectoryRecursive pkgStorePath)+onErrorClean :: MonadIO m => FilePath -> a -> ExceptT String m a -> m a+onErrorClean pkgStorePath failureValue f = do+  result <- runExceptT $ catchError (exceptWarn f) handler+  case result of+    Left a  -> return failureValue+    Right a -> return a+  where handler e = liftIO (IO.removeDirectoryRecursive pkgStorePath) >> return failureValue  cmdSyncFromArchive :: Mod CommandFields (IO ()) cmdSyncFromArchive = command "sync-from-archive"  $ flip info idm $ runSyncFromArchive <$> optsSyncFromArchive

@@ -12,7 +12,7 @@ import App.Commands.Options.Parser      (optsSyncToArchive) import App.Static                       (homeDirectory) import Control.Lens                     hiding ((<.>))-import Control.Monad                    (unless, when)+import Control.Monad                    (filterM, unless, when) import Control.Monad.Except import Control.Monad.Trans.Resource     (runResourceT) import Data.Generics.Product.Any        (the)@@ -23,6 +23,7 @@ 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)@@ -32,6 +33,7 @@ import qualified Codec.Compression.GZip             as F 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@@ -80,7 +82,9 @@       IO.createLocalDirectoryIfMissing scopedArchivePath       CIO.putStrLn "Extracting package list" -      packages <- getPackages storePath planJson+      packages     <- getPackages storePath planJson+      nonShareable <- packages & filterM (fmap not . isShareable storePath)+      let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId")        let storeCompilerPath           = storePath </> T.unpack compilerId       let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db"@@ -121,14 +125,18 @@                liftIO (LBS.readFile tempArchiveFile >>= IO.writeResource envAws scopedArchiveFile) -              shareEntries <- (\\ ["doc"]) <$> IO.listMaybeDirectory packageSharePath--              when (null shareEntries) $ IO.linkOrCopyResource envAws scopedArchiveFile archiveFile+              when (canShare planData (packageId pInfo)) $+                IO.linkOrCopyResource envAws scopedArchiveFile archiveFile      Left errorMessage -> do       CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> T.pack errorMessage    return ()++isShareable :: MonadIO m => FilePath -> PackageInfo -> m Bool+isShareable storePath pkg =+  let packageSharePath = storePath </> packageDir pkg </> "share"+  in IO.listMaybeDirectory packageSharePath <&> (\\ ["doc"]) <&> null  cmdSyncToArchive :: Mod CommandFields (IO ()) cmdSyncToArchive = command "sync-to-archive"  $ flip info idm $ runSyncToArchive <$> optsSyncToArchive

@@ -1,9 +1,11 @@-{-# LANGUAGE DataKinds       #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}  module HaskellWorks.CabalCache.Concurrent.DownloadQueue   ( createDownloadQueue   , anchor+  , runQueue   ) where  import Control.Lens@@ -18,6 +20,7 @@ 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))@@ -26,20 +29,24 @@ createDownloadQueue dependencies = do   tDependencies <- STM.newTVar (R.fromList dependencies)   tUploading    <- STM.newTVar S.empty+  tFailures     <- STM.newTVar S.empty   return Z.DownloadQueue {..}  takeReady :: Z.DownloadQueue -> STM.STM (Maybe Z.PackageId) takeReady Z.DownloadQueue {..} = do   dependencies  <- STM.readTVar tDependencies   uploading     <- STM.readTVar tUploading+  failures      <- STM.readTVar tFailures -  let ready = R.range dependencies \\ R.domain dependencies \\ uploading+  let ready = R.range dependencies \\ R.domain dependencies \\ uploading \\ failures    case S.lookupMin ready of     Just packageId -> do       STM.writeTVar tUploading (S.insert packageId uploading)       return (Just packageId)-    Nothing -> return Nothing+    Nothing -> if S.null (R.range dependencies \\ R.domain dependencies \\ failures)+      then return Nothing+      else STM.retry  commit :: Z.DownloadQueue -> Z.PackageId -> STM.STM () commit Z.DownloadQueue {..} packageId = do@@ -49,12 +56,25 @@   STM.writeTVar tUploading    $ S.delete packageId uploading   STM.writeTVar tDependencies $ R.withoutRange (S.singleton packageId) dependencies -runQueue :: MonadIO m => Z.DownloadQueue -> (Z.PackageId -> m ()) -> m ()+failDownload :: Z.DownloadQueue -> Z.PackageId -> STM.STM ()+failDownload Z.DownloadQueue {..} packageId = do+  uploading <- STM.readTVar tUploading+  failures  <- STM.readTVar tFailures++  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   maybePackageId <- liftIO $ STM.atomically $ takeReady downloadQueue    case maybePackageId of     Just packageId -> do-      f packageId-      liftIO $ STM.atomically $ commit downloadQueue packageId-    Nothing -> return ()+      success <- f packageId+      if success+        then liftIO $ STM.atomically $ commit downloadQueue packageId+        else liftIO $ STM.atomically $ failDownload downloadQueue packageId+      runQueue downloadQueue f++    Nothing -> do+      return ()

@@ -0,0 +1,17 @@+module HaskellWorks.CabalCache.Concurrent.Fork where++import Control.Monad++import qualified Control.Concurrent     as IO+import qualified Control.Concurrent.STM as STM++forkThreadsWait :: Int -> IO () -> IO ()+forkThreadsWait n f = do+  tDone <- STM.atomically $ STM.newTVar (0 :: Int)+  threads <- forM [1 .. n] $ \_ -> IO.forkIO $ do+    f+    STM.atomically $ STM.modifyTVar tDone (+1)++  STM.atomically $ do+    done <- STM.readTVar tDone+    when (done < n) STM.retry

@@ -24,4 +24,5 @@ data DownloadQueue = DownloadQueue   { tDependencies :: STM.TVar (R.Relation ConsumerId ProviderId)   , tUploading    :: STM.TVar (S.Set PackageId)+  , tFailures     :: STM.TVar (S.Set PackageId)   } deriving Generic

@@ -33,8 +33,6 @@ import qualified HaskellWorks.CabalCache.Types  as Z import qualified System.Directory               as IO -type CompilerId = Text-type PackageId  = Text type PackageDir = FilePath type ConfPath   = FilePath type Library    = FilePath@@ -47,8 +45,8 @@   } deriving (Eq, Show, Generic, NFData)  data PackageInfo = PackageInfo-  { compilerId :: CompilerId-  , packageId  :: PackageId+  { compilerId :: Z.CompilerId+  , packageId  :: Z.PackageId   , packageDir :: PackageDir   , confPath   :: Tagged ConfPath Presence   , libs       :: [Library]@@ -68,16 +66,16 @@   where compilerId :: Text         compilerId = planJson ^. the @"compilerId"         packages :: [Z.Package]-        packages = planJson ^.. the @"installPlan" . each . filtered predicate+        packages = planJson ^. the @"installPlan"         predicate :: Z.Package -> Bool-        predicate package = package ^. the @"packageType" /= "pre-existing" && package ^. the @"style" == Just "global"+        predicate package = True  loadPlan :: IO (Either String Z.PlanJson) loadPlan =   eitherDecode <$> LBS.readFile ("dist-newstyle" </> "cache" </> "plan.json")  --------------------------------------------------------------------------------mkPackageInfo :: FilePath -> CompilerId -> Z.Package -> IO PackageInfo+mkPackageInfo :: FilePath -> Z.CompilerId -> Z.Package -> IO PackageInfo mkPackageInfo basePath cid pkg = do   let pid               = pkg ^. the @"id"   let compilerPath      = basePath </> T.unpack cid

@@ -24,7 +24,7 @@     IO.ExitSuccess   -> return ()     IO.ExitFailure n -> throwError "" -listMaybeDirectory :: MonadIO m => FilePath -> ExceptT String m [FilePath]+listMaybeDirectory :: MonadIO m => FilePath -> m [FilePath] listMaybeDirectory filepath = do   exists <- liftIO $ IO.doesDirectoryExist filepath   if exists

@@ -0,0 +1,62 @@+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE DeriveGeneric    #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}++module HaskellWorks.CabalCache.Topology+  ( PlanData(..)+  , buildPlanData+  , canShare+  ) where++import Control.Arrow                 ((&&&))+import Control.Lens                  (each, set, 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.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++newtype PlanData = PlanData+  { nonShareable :: Set PackageId+  } deriving Generic++buildPlanData :: PlanJson   -- ^ The original plan+  -> [PackageId]            -- ^ Packages that are known to be non-shareable+  -> PlanData               -- ^ Updated plan+buildPlanData plan nonShareablePkgs =+  let dm = dependenciesMap (plan ^. the @"installPlan")+  in buildPlanData' dm nonShareablePkgs++canShare :: PlanData -> PackageId -> Bool+canShare planData pkgId = S.notMember pkgId (nonShareable planData)++-------------------------------------------------------------------------------++dependenciesMap :: [Package] -> Map PackageId (Set PackageId)+dependenciesMap plan = plan+  <&> (view (the @"id") &&& view (the @"depends"))+  <&> fmap S.fromList & M.fromList++buildPlanData' :: Map PackageId (Set PackageId) -- ^ Dependencies map+  -> [PackageId]                                -- ^ Packages to exclude+  -> PlanData                                   -- ^ All package ids to exclude+buildPlanData' plan knownNonShareable =+  fromRight (error "Could not process dependencies") $+    TG.runG plan $ \g ->+      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

@@ -1,41 +1,68 @@+{-# LANGUAGE ApplicativeDo         #-} {-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}  module HaskellWorks.CabalCache.Types where  import Data.Aeson+import Data.Maybe   (fromMaybe) import Data.Text    (Text) import GHC.Generics -type PackageId = Text+type CompilerId = Text+type PackageId  = Text  data PlanJson = PlanJson-  { compilerId  :: Text+  { compilerId  :: CompilerId   , installPlan :: [Package]   } deriving (Eq, Show, Generic)  data Package = Package   { packageType   :: Text-  , id            :: Text+  , id            :: PackageId   , name          :: Text   , version       :: Text   , style         :: Maybe Text   , componentName :: Maybe Text-  , depends       :: Maybe [PackageId]+  , components    :: Maybe Components+  , depends       :: [Text]+  , exeDepends    :: [Text]   } deriving (Eq, Show, Generic) +newtype Components = Components+  { lib :: Maybe Lib+  } deriving (Eq, Show, Generic)++data Lib = Lib+  { depends    :: [Text]+  , exeDepends :: [Text]+  } deriving (Eq, Show, Generic)+ instance FromJSON PlanJson where   parseJSON = withObject "PlanJson" $ \v -> PlanJson     <$> v .: "compiler-id"     <*> v .: "install-plan"  instance FromJSON Package where-  parseJSON = withObject "Package" $ \v -> Package-    <$> v .:  "type"-    <*> v .:  "id"-    <*> v .:  "pkg-name"-    <*> v .:  "pkg-version"-    <*> v .:? "style"-    <*> v .:? "component-name"-    <*> v .:? "depends"+  parseJSON = withObject "Package" $ \v -> do+    packageType   <- v .:  "type"+    id            <- v .:  "id"+    name          <- v .:  "pkg-name"+    version       <- v .:  "pkg-version"+    style         <- v .:? "style"+    componentName <- v .:? "component-name"+    components    <- v .:? "components"+    depends       <- v .:? "depends"     .!= []+    exeDepends    <- v .:? "exe-depends" .!= []+    return Package {..}++instance FromJSON Components where+  parseJSON = withObject "Components" $ \v -> Components+    <$> v .:? "lib"++instance FromJSON Lib where+  parseJSON = withObject "Lib" $ \v -> Lib+    <$> v .:? "depends"     .!= []+    <*> v .:? "exe-depends" .!= []

@@ -1,6 +1,7 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE QuasiQuotes           #-}  module HaskellWorks.CabalCache.QuerySpec   ( spec@@ -35,10 +36,12 @@           , Z.version       = "2.4.0.1"           , Z.style         = Nothing           , Z.componentName = Nothing-          , Z.depends       = Just+          , Z.components    = Nothing+          , Z.depends       =             [ "array-0.5.3.0"             , "base-4.12.0.0"             ]+          , Z.exeDepends    = []           }         ]       }