Merge pull request #224 from haskell-works/newhoggy/ignore-packages-c…

…li-option

Ignore packages cli option

app/App/Commands/Options/Parser.hs

@@ -1,17 +1,40 @@
 module App.Commands.Options.Parser
   ( optsVersion,
+    optsPackageIds,
     text,
   ) where
 
 import App.Commands.Options.Types (VersionOptions (..))
+import Control.Applicative        (Alternative(..))
+import Control.Monad              (join)
+import Data.Set                   (Set)
+import Data.Text                  (Text)
 import Options.Applicative        (Parser, ReadM)
 
-import qualified Data.Text           as Text
-import qualified Network.AWS.Data    as AWS
-import qualified Options.Applicative as OA
+import qualified Data.Set                       as S
+import qualified Data.Text                      as T
+import qualified Data.Text                      as Text
+import qualified HaskellWorks.CabalCache.Types  as Z
+import qualified Network.AWS.Data               as AWS
+import qualified Options.Applicative            as OA
 
 optsVersion :: Parser VersionOptions
 optsVersion = pure VersionOptions
 
 text :: AWS.FromText a => ReadM a
 text = OA.eitherReader (AWS.fromText . Text.pack)
+
+optsPackageIds :: Parser (Set Z.PackageId)
+optsPackageIds =
+  S.fromList . join <$> many
+  ( OA.option packageIds
+    (   OA.long "ignore-packages"
+    <>  OA.help "Packages to ignore"
+    <>  OA.metavar "PACKAGE_LIST"
+    )
+  )
+
+packageIds :: ReadM [Text]
+packageIds = OA.eitherReader \case
+  "" -> pure []
+  s -> pure $ T.split (== ',') (T.pack s)

app/App/Commands/Options/Types.hs

@@ -10,12 +10,14 @@ module App.Commands.Options.Types
   ) where
 
 import Data.ByteString                  (ByteString)
+import Data.Set                         (Set)
 import GHC.Generics                     (Generic)
 import HaskellWorks.CabalCache.Location (Location)
+import HaskellWorks.CabalCache.Types    (PackageId)
 import Network.URI                      (URI)
 
-import qualified Data.List.NonEmpty as NEL
-import qualified Network.AWS        as AWS
+import qualified Data.List.NonEmpty             as NEL
+import qualified Network.AWS                    as AWS
 
 data CpOptions = CpOptions
   { region        :: AWS.Region
@@ -26,16 +28,17 @@ data CpOptions = CpOptions
   } deriving (Eq, Show, Generic)
 
 data SyncToArchiveOptions = SyncToArchiveOptions
-  { region        :: AWS.Region
-  , archiveUri    :: Location
-  , path          :: FilePath
-  , buildPath     :: FilePath
-  , storePath     :: FilePath
-  , storePathHash :: Maybe String
-  , threads       :: Int
-  , awsLogLevel   :: Maybe AWS.LogLevel
-  , hostEndpoint  :: Maybe (ByteString, Int, Bool)
-  , maxRetries    :: Int
+  { region          :: AWS.Region
+  , archiveUri      :: Location
+  , path            :: FilePath
+  , buildPath       :: FilePath
+  , storePath       :: FilePath
+  , storePathHash   :: Maybe String
+  , threads         :: Int
+  , awsLogLevel     :: Maybe AWS.LogLevel
+  , hostEndpoint    :: Maybe (ByteString, Int, Bool)
+  , maxRetries      :: Int
+  , ignorePackages  :: Set PackageId
   } deriving (Eq, Show, Generic)
 
 data PlanOptions = PlanOptions
@@ -47,16 +50,17 @@ data PlanOptions = PlanOptions
   } deriving (Eq, Show, Generic)
 
 data SyncFromArchiveOptions = SyncFromArchiveOptions
-  { region        :: AWS.Region
-  , archiveUris   :: NEL.NonEmpty Location
-  , path          :: FilePath
-  , buildPath     :: FilePath
-  , storePath     :: FilePath
-  , storePathHash :: Maybe String
-  , threads       :: Int
-  , awsLogLevel   :: Maybe AWS.LogLevel
-  , hostEndpoint  :: Maybe (ByteString, Int, Bool)
-  , maxRetries    :: Int
+  { region          :: AWS.Region
+  , archiveUris     :: NEL.NonEmpty Location
+  , path            :: FilePath
+  , buildPath       :: FilePath
+  , storePath       :: FilePath
+  , storePathHash   :: Maybe String
+  , threads         :: Int
+  , awsLogLevel     :: Maybe AWS.LogLevel
+  , hostEndpoint    :: Maybe (ByteString, Int, Bool)
+  , maxRetries      :: Int
+  , ignorePackages  :: Set PackageId
   } deriving (Eq, Show, Generic)
 
 data VersionOptions = VersionOptions deriving (Eq, Show, Generic)

app/App/Commands/SyncFromArchive.hs

@@ -7,7 +7,7 @@ module App.Commands.SyncFromArchive
   ( cmdSyncFromArchive,
   ) where
 
-import App.Commands.Options.Parser      (text)
+import App.Commands.Options.Parser      (optsPackageIds, text)
 import App.Commands.Options.Types       (SyncFromArchiveOptions (SyncFromArchiveOptions))
 import Control.Applicative              (optional, Alternative(..))
 import Control.Lens                     ((^..), (.~), (<&>), (%~), (&), (^.), Each(each))
@@ -47,6 +47,7 @@ import qualified Data.ByteString.Lazy                             as LBS
 import qualified Data.List.NonEmpty                               as NEL
 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
@@ -85,6 +86,7 @@ runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do
   let storePathHash         = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath)
   let scopedArchiveUris     = versionedArchiveUris & traverse1 %~ (</> T.pack storePathHash)
   let maxRetries            = opts ^. the @"maxRetries"
+  let ignorePackages        = opts ^. the @"ignorePackages"
 
   CIO.putStrLn $ "Store path: "       <> AWS.toText storePath
   CIO.putStrLn $ "Store path hash: "  <> T.pack storePathHash
@@ -157,18 +159,23 @@ runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do
           let archiveFiles        = versionedArchiveUris & traverse1 %~ (</> T.pack archiveBaseName)
           let scopedArchiveFiles  = scopedArchiveUris & traverse1 %~ (</> T.pack archiveBaseName)
           let packageStorePath    = storePath </> Z.packageDir pInfo
+          let packageName         = pInfo ^. the @"packageName"
 
           storeDirectoryExists <- liftIO $ doesDirectoryExist packageStorePath
 
           package <- pure (M.lookup packageId planPackages)
             & do OO.onNothing do
-                  CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageId
+                  CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageName
                   DQ.succeed
 
           when (skippable package) do
-            CIO.putStrLn $ "Skipping: " <> packageId
+            CIO.putStrLn $ "Skipping: " <> packageName
             DQ.succeed
 
+          when (packageName `S.member` ignorePackages) do
+            CIO.putStrLn $ "Ignoring: " <> packageName
+            DQ.fail
+
           when storeDirectoryExists DQ.succeed
 
           OO.suspend runResourceT $ ensureStorePathCleanup packageStorePath do
@@ -295,6 +302,7 @@ optsSyncFromArchive = SyncFromArchiveOptions
       <>  OA.metavar "NUM_RETRIES"
       <>  OA.value 3
       )
+  <*> optsPackageIds
 
 parseEndpoint :: Parser (ByteString, Int, Bool)
 parseEndpoint =

app/App/Commands/SyncToArchive.hs

@@ -6,12 +6,12 @@ module App.Commands.SyncToArchive
   ( cmdSyncToArchive,
   ) where
 
-import App.Commands.Options.Parser      (text)
+import App.Commands.Options.Parser      (optsPackageIds, text)
 import App.Commands.Options.Types       (SyncToArchiveOptions (SyncToArchiveOptions))
-import Control.Applicative              ( Alternative((<|>)), optional)
+import Control.Applicative              (Alternative(..), optional)
 import Control.Concurrent.STM           (TVar)
 import Control.Lens                     ((<&>), (&), (^..), (^.), (.~), Each(each))
-import Control.Monad                    (when, filterM, unless)
+import Control.Monad                    (filterM, when, unless)
 import Control.Monad.Except             (ExceptT)
 import Control.Monad.IO.Class           (MonadIO(..))
 import Control.Monad.Trans.AWS          (envOverride, setEndpoint)
@@ -39,6 +39,7 @@ import qualified Control.Concurrent.STM             as STM
 import qualified Control.Monad.Oops                 as OO
 import qualified Data.ByteString.Lazy               as LBS
 import qualified Data.ByteString.Lazy.Char8         as LC8
+import qualified Data.Set                           as S
 import qualified Data.Text                          as T
 import qualified Data.Text                          as Text
 import qualified HaskellWorks.CabalCache.AWS.Env    as AWS
@@ -79,6 +80,7 @@ runSyncToArchive opts = do
     let storePathHash       = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath)
     let scopedArchiveUri    = versionedArchiveUri </> T.pack storePathHash
     let maxRetries          = opts ^. the @"maxRetries"
+    let ignorePackages      = opts ^. the @"ignorePackages"
 
     CIO.putStrLn $ "Store path: "       <> AWS.toText storePath
     CIO.putStrLn $ "Store path hash: "  <> T.pack storePathHash
@@ -135,6 +137,11 @@ runSyncToArchive opts = do
           let archiveFile         = versionedArchiveUri </> T.pack archiveFileBasename
           let scopedArchiveFile   = versionedArchiveUri </> T.pack storePathHash </> T.pack archiveFileBasename
           let packageStorePath    = storePath </> Z.packageDir pInfo
+          let packageName         = pInfo ^. the @"packageName"
+
+          when (packageName `S.member` ignorePackages) do
+            CIO.hPutStrLn IO.stderr $ "Ignoring package: " <> packageName
+            OO.throw WorkSkipped
 
           -- either write "normal" package, or a user-specific one if the package cannot be shared
           let targetFile = if canShare planData (Z.packageId pInfo) then archiveFile else scopedArchiveFile
@@ -277,6 +284,7 @@ optsSyncToArchive = SyncToArchiveOptions
       <>  OA.metavar "NUM_RETRIES"
       <>  OA.value 3
       )
+  <*> optsPackageIds
 
 parseEndpoint :: Parser (ByteString, Int, Bool)
 parseEndpoint =

src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs

@@ -83,7 +83,7 @@ failDownload Z.DownloadQueue {..} packageId = do
 
 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

src/HaskellWorks/CabalCache/Core.hs

@@ -54,11 +54,12 @@ data Tagged a t = Tagged
   } deriving (Eq, Show, Generic, NFData)
 
 data PackageInfo = PackageInfo
-  { compilerId :: Z.CompilerId
-  , packageId  :: Z.PackageId
-  , packageDir :: PackageDir
-  , confPath   :: Tagged ConfPath Presence
-  , libs       :: [Library]
+  { compilerId  :: Z.CompilerId
+  , packageId   :: Z.PackageId
+  , packageName :: Z.PackageName
+  , packageDir  :: PackageDir
+  , confPath    :: Tagged ConfPath Presence
+  , libs        :: [Library]
   } deriving (Show, Eq, Generic, NFData)
 
 (<||>) :: Monad m => ExceptT e m a -> ExceptT e m a -> ExceptT e m a
@@ -170,6 +171,7 @@ mkPackageInfo basePath cid pkg = do
   return PackageInfo
     { compilerId  = cid
     , packageId   = pid
+    , packageName = pkg ^. the @"name"
     , packageDir  = T.unpack cid </> T.unpack pid
     , confPath    = Tagged relativeConfPath (bool Absent Present absoluteConfPathExists)
     , libs        = libFiles

src/HaskellWorks/CabalCache/Types.hs

@@ -7,6 +7,7 @@
 module HaskellWorks.CabalCache.Types
   ( CompilerId,
     PackageId,
+    PackageName,
     CompilerContext(..),
     Components(..),
     PlanJson(..),
@@ -21,8 +22,9 @@ import Prelude      hiding (id)
 
 import qualified Data.Aeson as J
 
-type CompilerId = Text
-type PackageId  = Text
+type CompilerId   = Text
+type PackageId    = Text
+type PackageName  = Text
 
 data PlanJson = PlanJson
   { compilerId  :: CompilerId