From a3b0d8d4118319ca251780993bb32c1b4b269d68 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 20 May 2013 15:57:59 +0300 Subject: [PATCH] Upload user checking --- Stackage/Uploads.hs | 147 ++++++++++++++++++++++++++++++++++++++++++++ app/stackage.hs | 3 + stackage.cabal | 4 ++ 3 files changed, 154 insertions(+) create mode 100644 Stackage/Uploads.hs diff --git a/Stackage/Uploads.hs b/Stackage/Uploads.hs new file mode 100644 index 00000000..2ce9846d --- /dev/null +++ b/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 diff --git a/app/stackage.hs b/app/stackage.hs index 41f64dc8..95e5ebcb 100644 --- a/app/stackage.hs +++ b/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]" diff --git a/stackage.cabal b/stackage.cabal index 53ad982c..eef1f011 100644 --- a/stackage.cabal +++ b/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