Browse Source

Upload user checking

fpco
Michael Snoyman 9 years ago
parent
commit
a3b0d8d411
  1. 147
      Stackage/Uploads.hs
  2. 3
      app/stackage.hs
  3. 4
      stackage.cabal

147
Stackage/Uploads.hs

@ -0,0 +1,147 @@
-- | Review the upload log and compare against a locally kept list of allowed
-- uploaders.
module Stackage.Uploads
( checkUploads
) where
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 Network.HTTP (getRequest, getResponseBody, simpleHTTP)
import System.Directory (doesFileExist)
import System.Exit (exitFailure)
import System.Locale
checkUploads :: FilePath -- ^ allowed
-> FilePath -- ^ new allowed
-> IO ()
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
let fp = "new-allowed.txt"
putStrLn $ "Newly uploaded packages detected, writing to " ++ newAllowedFP
writeAllowed newAllowedFP allowed'
printForbidden 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 k = Map.lookup k . unMonoidMap
msingleton k = MonoidMap . Map.singleton k
mkeys = Map.keys . unMonoidMap
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 (Set UserName)
type Forbidden = UploadLog
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 $ Set.fromList users
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 a) -> (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 -> Set UserName
getAllUsers = Set.fromList . map fst . Map.elems
check :: Set UserName -> (Version, (UserName, UTCTime)) -> Map Version (UserName, UTCTime)
check allowed (ver, (user, time))
| user `Set.member` allowed = Map.empty
| otherwise = Map.singleton ver (user, time)
writeAllowed :: FilePath -> Allowed -> IO ()
writeAllowed fp =
writeFile fp . unlines . map go . Map.toList . unMonoidMap
where
go (pkg, users) = unwords $ pkg : Set.toList users
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

3
app/stackage.hs

@ -8,6 +8,7 @@ import Stackage.Select (defaultSelectSettings, select)
import Stackage.Tarballs (makeTarballs)
import Stackage.Test (runTestSuites)
import Stackage.Types
import Stackage.Uploads (checkUploads)
import Stackage.Util (allowPermissive)
import System.Environment (getArgs, getProgName)
import System.IO (hFlush, stdout)
@ -82,6 +83,7 @@ main :: IO ()
main = do
args <- getArgs
case args of
["uploads"] -> checkUploads "allowed.txt" "new-allowed.txt"
"select":rest -> do
SelectArgs {..} <- parseSelectArgs rest
bp <- select
@ -115,6 +117,7 @@ main = do
putStrLn "Available commands:"
--putStrLn " update Download updated Stackage databases. Automatically calls init."
--putStrLn " init Initialize your cabal file to use Stackage"
putStrLn " uploads"
putStrLn " select [--no-clean] [--no-platform] [--exclude package...] [--only-permissive] [--allow package] [--build-plan file]"
putStrLn " check [--build-plan file] [--sandbox rootdir] [--arg cabal-arg]"
putStrLn " build [--build-plan file] [--sandbox rootdir] [--arg cabal-arg]"

4
stackage.cabal

@ -28,6 +28,7 @@ library
Stackage.CheckCabalVersion
Stackage.Select
Stackage.GhcPkg
Stackage.Uploads
build-depends: base >= 4 && < 5
, containers
, Cabal
@ -37,6 +38,9 @@ library
, filepath
, transformers
, process
, old-locale
, HTTP
, time
executable stackage
hs-source-dirs: app

Loading…
Cancel
Save