@@ -0,0 +1,147 @@
1+-- | Review the upload log and compare against a locally kept list of allowed
3+module Stackage.Uploads
7+import Control.Exception (assert, evaluate)
8+import Control.Monad (forM_, unless)
10+import qualified Data.Map as Map
11+import Data.Maybe (fromMaybe)
12+import Data.Monoid (Monoid (..))
14+import qualified Data.Set as Set
15+import Data.Time (UTCTime, parseTime)
16+import Network.HTTP (getRequest, getResponseBody, simpleHTTP)
17+import System.Directory (doesFileExist)
18+import System.Exit (exitFailure)
21+checkUploads :: FilePath -- ^ allowed
22+ -> FilePath -- ^ new allowed
24+checkUploads allowedFP newAllowedFP = do
25+ putStrLn "Getting upload log"
26+ uploadLog <- getUploadLog
28+ putStrLn "Reading allowed uploaders list"
29+ allowed <- readAllowed allowedFP
31+ putStrLn "Computing new and forbidden uploaders"
32+ let (allowed', forbidden) = updateAllowed uploadLog allowed
33+ _ <- evaluate $ msize allowed'
34+ _ <- evaluate $ msize forbidden
36+ unless (Map.null $ unMonoidMap allowed') $ do
37+ let fp = "new-allowed.txt"
38+ putStrLn $ "Newly uploaded packages detected, writing to " ++ newAllowedFP
39+ writeAllowed newAllowedFP allowed'
41+ printForbidden forbidden
43+-- Define a Map newtype wrapper with a proper Monoid instance.
44+newtype MonoidMap k v = MonoidMap { unMonoidMap :: Map k v }
45+instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
46+ mempty = MonoidMap mempty
47+ MonoidMap x `mappend` MonoidMap y = MonoidMap $ Map.unionWith mappend x y
49+-- And some helper functions.
50+mlookup k = Map.lookup k . unMonoidMap
51+msingleton k = MonoidMap . Map.singleton k
52+mkeys = Map.keys . unMonoidMap
53+msize = Map.size . unMonoidMap
56+type UserName = String
57+type PackageName = String
59+type PackageHistory = Map Version (UserName, UTCTime)
60+type UploadLog = MonoidMap PackageName PackageHistory
61+type Allowed = MonoidMap PackageName (Set UserName)
62+type Forbidden = UploadLog
64+getUploadLog :: IO UploadLog
66+ rsp <- simpleHTTP $ getRequest logURL
67+ body <- getResponseBody rsp
68+ return $ mconcat $ map go $ lines body
70+ go :: String -> UploadLog
71+ go s = fromMaybe mempty $ do
72+ ver:pkg:user:date' <- Just $ reverse $ words s
73+ t <- parseTime defaultTimeLocale fmtStr $ unwords $ reverse date'
74+ Just $ msingleton pkg $ Map.singleton ver (user, t)
77+ logURL = "http://hackage.haskell.org/packages/archive/log"
80+ fmtStr = "%a %b %e %T %Z %Y"
82+readAllowed :: FilePath -> IO Allowed
84+ exists <- doesFileExist fp
88+ return $ mconcat $ map go $ lines s
91+ go :: String -> Allowed
92+ go s = fromMaybe mempty $ do
93+ pkg:users <- Just $ words s
94+ Just $ msingleton pkg $ Set.fromList users
96+updateAllowed :: UploadLog -> Allowed -> (Allowed, Forbidden)
97+updateAllowed uploads allowed =
98+ mconcat $ map go $ Set.toList allPackages
100+ -- Map.keys uploads should be sufficient, but being redundant to ensure we
101+ -- never lose any data from allowed.
102+ allPackages = Set.fromList (mkeys uploads) `Set.union`
103+ Set.fromList (mkeys allowed)
105+ go :: PackageName -> (Allowed, Forbidden)
107+ case (mlookup pkg uploads, mlookup pkg allowed) of
108+ (Nothing, Nothing) -> assert False (mempty, mempty)
109+ (Nothing, Just a) -> (mempty, mempty)
110+ (Just u, Nothing) -> (msingleton pkg $ getAllUsers u, mempty)
112+ let fval = mconcat $ map (check a) $ Map.toList u
114+ | Map.null fval = mempty
115+ | otherwise = msingleton pkg fval
116+ in (mempty, forbidden)
118+ getAllUsers :: PackageHistory -> Set UserName
119+ getAllUsers = Set.fromList . map fst . Map.elems
121+ check :: Set UserName -> (Version, (UserName, UTCTime)) -> Map Version (UserName, UTCTime)
122+ check allowed (ver, (user, time))
123+ | user `Set.member` allowed = Map.empty
124+ | otherwise = Map.singleton ver (user, time)
126+writeAllowed :: FilePath -> Allowed -> IO ()
128+ writeFile fp . unlines . map go . Map.toList . unMonoidMap
130+ go (pkg, users) = unwords $ pkg : Set.toList users
132+printForbidden :: Forbidden -> IO ()
133+printForbidden (MonoidMap forbidden) = unless (Map.null forbidden) $ do
134+ putStrLn $ "Following uploads were forbidden:"
135+ forM_ (Map.toList forbidden) $ \(pkg, cases) -> do
138+ forM_ (Map.toList cases) $ \(version, (user, time)) ->