Upload user checking

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

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]"

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