@@ -1,3 +1,4 @@
1+{-# LANGUAGE PatternGuards #-}
1-- | Review the upload log and compare against a locally kept list of allowed
2-- | Review the upload log and compare against a locally kept list of allowed
2-- uploaders.
3-- uploaders.
3module Stackage.Uploads
4module Stackage.Uploads
@@ -6,6 +7,7 @@ module Stackage.Uploads
6 , filterForbidden
7 , filterForbidden
10+import Control.Arrow (second)
9import Control.Exception (assert, evaluate)
11import Control.Exception (assert, evaluate)
10import Control.Monad (forM_, unless)
12import Control.Monad (forM_, unless)
11import Data.Map (Map)
13import Data.Map (Map)
@@ -68,9 +70,16 @@ type PackageName = String
69type PackageHistory = Map Version (UserName, UTCTime)
71type PackageHistory = Map Version (UserName, UTCTime)
70type UploadLog = MonoidMap PackageName PackageHistory
72type UploadLog = MonoidMap PackageName PackageHistory
71−type Allowed = MonoidMap PackageName (Set UserName)
73+type Allowed = MonoidMap PackageName (Map UserName AllowedVersions)
72type Forbidden = UploadLog
74type Forbidden = UploadLog
76+data AllowedVersions = AllVersions | SpecificVersions (Set Version)
77+instance Monoid AllowedVersions where
78+ mempty = SpecificVersions mempty
79+ AllVersions `mappend` _ = AllVersions
80+ _ `mappend` AllVersions = AllVersions
81+ SpecificVersions x `mappend` SpecificVersions y = SpecificVersions (x `mappend` y)
74getUploadLog :: IO UploadLog
83getUploadLog :: IO UploadLog
75getUploadLog = do
84getUploadLog = do
76 rsp <- simpleHTTP $ getRequest logURL
85 rsp <- simpleHTTP $ getRequest logURL
@@ -101,7 +110,13 @@ readAllowed fp = do
101 go :: String -> Allowed
110 go :: String -> Allowed
102 go s = fromMaybe mempty $ do
111 go s = fromMaybe mempty $ do
103 pkg:users <- Just $ words s
112 pkg:users <- Just $ words s
104− Just $ msingleton pkg $ Set.fromList users
113+ Just $ msingleton pkg $ Map.unionsWith mappend $ map parseUserAllowed users
115+ parseUserAllowed s =
116+ case break (== '-') s of
117+ (user, '-':version) ->
118+ Map.singleton user $ SpecificVersions $ Set.singleton version
119+ _ -> Map.singleton s AllVersions
106updateAllowed :: UploadLog -> Allowed -> (Allowed, Forbidden)
121updateAllowed :: UploadLog -> Allowed -> (Allowed, Forbidden)
107updateAllowed uploads allowed =
122updateAllowed uploads allowed =
@@ -125,19 +140,30 @@ updateAllowed uploads allowed =
125 | otherwise = msingleton pkg fval
140 | otherwise = msingleton pkg fval
126 in (mempty, forbidden)
141 in (mempty, forbidden)
128− getAllUsers :: PackageHistory -> Set UserName
143+ getAllUsers :: PackageHistory -> Map UserName AllowedVersions
129− getAllUsers = Set.fromList . map fst . Map.elems
144+ getAllUsers = Map.fromList . map (second $ const AllVersions) . Map.elems
146+ check :: Map UserName AllowedVersions
147+ -> (Version, (UserName, UTCTime))
131− check :: Set UserName -> (Version, (UserName, UTCTime)) -> Map Version (UserName, UTCTime)
148+ -> Map Version (UserName, UTCTime)
132− check allowed' (ver, (user, time))
149+ check allowed' (ver, (user, time)) = maybe (Map.singleton ver (user, time)) (const Map.empty) $ do
133− | user `Set.member` allowed' = Map.empty
150+ versions <- Map.lookup user allowed'
134− | otherwise = Map.singleton ver (user, time)
151+ case versions of
152+ AllVersions -> return ()
154+ | ver `Set.member` vs -> return ()
155+ | otherwise -> Nothing
136writeAllowed :: FilePath -> Allowed -> IO ()
157writeAllowed :: FilePath -> Allowed -> IO ()
137writeAllowed fp =
158writeAllowed fp =
138 writeFile fp . unlines . map go . Map.toList . unMonoidMap
159 writeFile fp . unlines . map go . Map.toList . unMonoidMap
140− go (pkg, users) = unwords $ pkg : Set.toList users
161+ go (pkg, users) = unwords $ pkg : concatMap toStr (Map.toList users)
162+ toStr (user, AllVersions) = [user]
163+ toStr (user, SpecificVersions vs) =
164+ map helper $ Set.toList vs
166+ helper v = concat [user, "-", v]
142printForbidden :: Forbidden -> IO ()
168printForbidden :: Forbidden -> IO ()
143printForbidden (MonoidMap forbidden) = unless (Map.null forbidden) $ do
169printForbidden (MonoidMap forbidden) = unless (Map.null forbidden) $ do