Remove unneeded upload code

Stackage/Uploads.hs

@@ -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

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

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