From 58cd68ff7ef05cc732bd5c9193a9ef1e530d7fa7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 15 Oct 2013 18:01:18 +0300 Subject: [PATCH] Remove unneeded upload code --- Stackage/Uploads.hs | 198 -------------------------------------------- app/stackage.hs | 2 - stackage.cabal | 2 - 3 files changed, 202 deletions(-) delete mode 100644 Stackage/Uploads.hs diff --git a/Stackage/Uploads.hs b/Stackage/Uploads.hs deleted file mode 100644 index 40d43480..00000000 --- a/Stackage/Uploads.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE PatternGuards #-} --- | Review the upload log and compare against a locally kept list of allowed --- uploaders. -module Stackage.Uploads - ( checkUploads - , printForbidden - , filterForbidden - ) where - -import Control.Arrow (second) -import Control.Exception (assert, evaluate) -import Control.Monad (forM_, unless) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid (..)) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Time (UTCTime, parseTime) -import Distribution.Text (display) -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 Forbidden -checkUploads allowedFP newAllowedFP = do - putStrLn "Getting upload log" - uploadLog <- getUploadLog - - putStrLn "Reading allowed uploaders list" - allowed <- readAllowed allowedFP - - putStrLn "Computing new and forbidden uploaders" - let (allowed', forbidden) = updateAllowed uploadLog allowed - _ <- evaluate $ msize allowed' - _ <- evaluate $ msize forbidden - - unless (Map.null $ unMonoidMap allowed') $ do - putStrLn $ "Newly uploaded packages detected, writing to " ++ newAllowedFP - writeAllowed newAllowedFP allowed' - - return forbidden - --- Define a Map newtype wrapper with a proper Monoid instance. -newtype MonoidMap k v = MonoidMap { unMonoidMap :: Map k v } -instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where - mempty = MonoidMap mempty - MonoidMap x `mappend` MonoidMap y = MonoidMap $ Map.unionWith mappend x y - --- And some helper functions. -mlookup :: Ord k => k -> MonoidMap k v -> Maybe v -mlookup k = Map.lookup k . unMonoidMap - -msingleton :: k -> v -> MonoidMap k v -msingleton k = MonoidMap . Map.singleton k - -mkeys :: MonoidMap k v -> [k] -mkeys = Map.keys . unMonoidMap - -msize :: MonoidMap k v -> Int -msize = Map.size . unMonoidMap - -type Version = String -type UserName = String -type PackageName = String - -type PackageHistory = Map Version (UserName, UTCTime) -type UploadLog = MonoidMap PackageName PackageHistory -type Allowed = MonoidMap PackageName (Map UserName AllowedVersions) -type Forbidden = UploadLog - -data AllowedVersions = AllVersions | SpecificVersions (Set Version) -instance Monoid AllowedVersions where - mempty = SpecificVersions mempty - AllVersions `mappend` _ = AllVersions - _ `mappend` AllVersions = AllVersions - SpecificVersions x `mappend` SpecificVersions y = SpecificVersions (x `mappend` y) - -getUploadLog :: IO UploadLog -getUploadLog = do - rsp <- simpleHTTP $ getRequest logURL - body <- getResponseBody rsp - return $ mconcat $ map go $ lines body - where - go :: String -> UploadLog - go s = fromMaybe mempty $ do - ver:pkg:user:date' <- Just $ reverse $ words s - t <- parseTime defaultTimeLocale fmtStr $ unwords $ reverse date' - Just $ msingleton pkg $ Map.singleton ver (user, t) - - logURL :: String - logURL = "http://hackage.haskell.org/packages/archive/log" - - fmtStr :: String - fmtStr = "%a %b %e %T %Z %Y" - -readAllowed :: FilePath -> IO Allowed -readAllowed fp = do - exists <- doesFileExist fp - if exists - then do - s <- readFile fp - return $ mconcat $ map go $ lines s - else return mempty - where - go :: String -> Allowed - go s = fromMaybe mempty $ do - pkg:users <- Just $ words s - Just $ msingleton pkg $ Map.unionsWith mappend $ map parseUserAllowed users - - parseUserAllowed s = - case break (== '-') s of - (user, '-':version) -> - Map.singleton user $ SpecificVersions $ Set.singleton version - _ -> Map.singleton s AllVersions - -updateAllowed :: UploadLog -> Allowed -> (Allowed, Forbidden) -updateAllowed uploads allowed = - mconcat $ map go $ Set.toList allPackages - where - -- Map.keys uploads should be sufficient, but being redundant to ensure we - -- never lose any data from allowed. - allPackages = Set.fromList (mkeys uploads) `Set.union` - Set.fromList (mkeys allowed) - - go :: PackageName -> (Allowed, Forbidden) - go pkg = - case (mlookup pkg uploads, mlookup pkg allowed) of - (Nothing, Nothing) -> assert False (mempty, mempty) - (Nothing, Just _) -> (mempty, mempty) - (Just u, Nothing) -> (msingleton pkg $ getAllUsers u, mempty) - (Just u, Just a) -> - let fval = mconcat $ map (check a) $ Map.toList u - forbidden - | Map.null fval = mempty - | otherwise = msingleton pkg fval - in (mempty, forbidden) - - getAllUsers :: PackageHistory -> Map UserName AllowedVersions - getAllUsers = Map.fromList . map (second $ const AllVersions) . Map.elems - - check :: Map UserName AllowedVersions - -> (Version, (UserName, UTCTime)) - -> Map Version (UserName, UTCTime) - check allowed' (ver, (user, time)) = maybe (Map.singleton ver (user, time)) (const Map.empty) $ do - versions <- Map.lookup user allowed' - case versions of - AllVersions -> return () - SpecificVersions vs - | ver `Set.member` vs -> return () - | otherwise -> Nothing - -writeAllowed :: FilePath -> Allowed -> IO () -writeAllowed fp = - writeFile fp . unlines . map go . Map.toList . unMonoidMap - where - go (pkg, users) = unwords $ pkg : concatMap toStr (Map.toList users) - toStr (user, AllVersions) = [user] - toStr (user, SpecificVersions vs) = - map helper $ Set.toList vs - where - helper v = concat [user, "-", v] - -printForbidden :: Forbidden -> IO () -printForbidden (MonoidMap forbidden) = unless (Map.null forbidden) $ do - putStrLn $ "Following uploads were forbidden:" - forM_ (Map.toList forbidden) $ \(pkg, cases) -> do - putStrLn "" - putStrLn pkg - forM_ (Map.toList cases) $ \(version, (user, time)) -> - putStrLn $ concat - [ "Version " - , version - , " by " - , user - , " at " - , show time - ] - exitFailure - -filterForbidden :: ST.BuildPlan - -> Forbidden - -> Forbidden -filterForbidden bp = - MonoidMap . Map.mapMaybeWithKey isIncluded . unMonoidMap - where - isIncluded :: PackageName - -> PackageHistory - -> Maybe PackageHistory - isIncluded pn ph = do - spi <- Map.lookup (ST.PackageName pn) $ ST.bpPackages bp - let version = display $ ST.spiVersion spi - tuple <- Map.lookup version ph - Just $ Map.singleton version tuple diff --git a/app/stackage.hs b/app/stackage.hs index 5bb27ef4..af664540 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -9,7 +9,6 @@ import Stackage.Select (defaultSelectSettings, select) import Stackage.Tarballs (makeTarballs) import Stackage.Test (runTestSuites) import Stackage.Types -import Stackage.Uploads (checkUploads, printForbidden) import Stackage.Util (allowPermissive) import System.Environment (getArgs, getProgName) import System.IO (hFlush, stdout) @@ -85,7 +84,6 @@ main :: IO () main = do args <- getArgs case args of - ["uploads"] -> checkUploads "allowed.txt" "new-allowed.txt" >>= printForbidden "select":rest -> do SelectArgs {..} <- parseSelectArgs rest ghcVersion <- getGhcVersion diff --git a/stackage.cabal b/stackage.cabal index e6d643d8..42d8d517 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -28,7 +28,6 @@ library Stackage.CheckCabalVersion Stackage.Select Stackage.GhcPkg - Stackage.Uploads build-depends: base >= 4 && < 5 , containers , Cabal @@ -40,7 +39,6 @@ library , transformers , process , old-locale - , HTTP , time , utf8-string