mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-12 07:18:31 +01:00
Remove unneeded upload code
This commit is contained in:
Michael Snoyman
parent
48f5629dd8
commit
58cd68ff7e
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user