diff --git a/Stackage/Uploads.hs b/Stackage/Uploads.hs index a6e15114..6847ccf2 100644 --- a/Stackage/Uploads.hs +++ b/Stackage/Uploads.hs @@ -2,6 +2,8 @@ -- uploaders. module Stackage.Uploads ( checkUploads + , printForbidden + , filterForbidden ) where import Control.Exception (assert, evaluate) @@ -14,13 +16,14 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Time (UTCTime, parseTime) import Network.HTTP (getRequest, getResponseBody, simpleHTTP) +import qualified Stackage.Types as ST import System.Directory (doesFileExist) import System.Exit (exitFailure) import System.Locale checkUploads :: FilePath -- ^ allowed -> FilePath -- ^ new allowed - -> IO () + -> IO Forbidden checkUploads allowedFP newAllowedFP = do putStrLn "Getting upload log" uploadLog <- getUploadLog @@ -37,7 +40,7 @@ checkUploads allowedFP newAllowedFP = do putStrLn $ "Newly uploaded packages detected, writing to " ++ newAllowedFP writeAllowed newAllowedFP allowed' - printForbidden forbidden + return forbidden -- Define a Map newtype wrapper with a proper Monoid instance. newtype MonoidMap k v = MonoidMap { unMonoidMap :: Map k v } @@ -151,3 +154,15 @@ printForbidden (MonoidMap forbidden) = unless (Map.null forbidden) $ do , show time ] exitFailure + +filterForbidden :: ST.BuildPlan + -> Forbidden + -> Forbidden +filterForbidden bp = + MonoidMap . Map.filterWithKey isIncluded . unMonoidMap + where + isIncluded pn _ = ST.PackageName pn `Set.member` allPackages + allPackages = + Map.keysSet (ST.bpPackages bp) `Set.union` + ST.bpCore bp `Set.union` + Map.keysSet (ST.bpOptionalCore bp) diff --git a/app/stackage.hs b/app/stackage.hs index 0a8e002e..636ae8cd 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -9,7 +9,7 @@ import Stackage.Select (defaultSelectSettings, select) import Stackage.Tarballs (makeTarballs) import Stackage.Test (runTestSuites) import Stackage.Types -import Stackage.Uploads (checkUploads) +import Stackage.Uploads (checkUploads, printForbidden) import Stackage.Util (allowPermissive) import System.Environment (getArgs, getProgName) import System.IO (hFlush, stdout) @@ -85,7 +85,7 @@ main :: IO () main = do args <- getArgs case args of - ["uploads"] -> checkUploads "allowed.txt" "new-allowed.txt" + ["uploads"] -> checkUploads "allowed.txt" "new-allowed.txt" >>= printForbidden "select":rest -> do SelectArgs {..} <- parseSelectArgs rest ghcVersion <- getGhcVersion