@@ -1,3 +1,4 @@
1+{-# LANGUAGE PatternGuards #-}
12-- | Review the upload log and compare against a locally kept list of allowed
23-- uploaders.
34module Stackage.Uploads
@@ -6,6 +7,7 @@ module Stackage.Uploads
67 , filterForbidden
78 ) where
89
10+import Control.Arrow (second)
911import Control.Exception (assert, evaluate)
1012import Control.Monad (forM_, unless)
1113import Data.Map (Map)
@@ -68,9 +70,16 @@ type PackageName = String
6870
6971type PackageHistory = Map Version (UserName, UTCTime)
7072type UploadLog = MonoidMap PackageName PackageHistory
71−type Allowed = MonoidMap PackageName (Set UserName)
73+type Allowed = MonoidMap PackageName (Map UserName AllowedVersions)
7274type Forbidden = UploadLog
7375
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)
82+
7483getUploadLog :: IO UploadLog
7584getUploadLog = do
7685 rsp <- simpleHTTP $ getRequest logURL
@@ -101,7 +110,13 @@ readAllowed fp = do
101110 go :: String -> Allowed
102111 go s = fromMaybe mempty $ do
103112 pkg:users <- Just $ words s
104− Just $ msingleton pkg $ Set.fromList users
113+ Just $ msingleton pkg $ Map.unionsWith mappend $ map parseUserAllowed users
114+
115+ parseUserAllowed s =
116+ case break (== '-') s of
117+ (user, '-':version) ->
118+ Map.singleton user $ SpecificVersions $ Set.singleton version
119+ _ -> Map.singleton s AllVersions
105120
106121updateAllowed :: UploadLog -> Allowed -> (Allowed, Forbidden)
107122updateAllowed uploads allowed =
@@ -125,19 +140,30 @@ updateAllowed uploads allowed =
125140 | otherwise = msingleton pkg fval
126141 in (mempty, forbidden)
127142
128− getAllUsers :: PackageHistory -> Set UserName
129− getAllUsers = Set.fromList . map fst . Map.elems
143+ getAllUsers :: PackageHistory -> Map UserName AllowedVersions
144+ getAllUsers = Map.fromList . map (second $ const AllVersions) . Map.elems
130145
131− check :: Set UserName -> (Version, (UserName, UTCTime)) -> Map Version (UserName, UTCTime)
132− check allowed' (ver, (user, time))
133− | user `Set.member` allowed' = Map.empty
134− | otherwise = Map.singleton ver (user, time)
146+ check :: Map UserName AllowedVersions
147+ -> (Version, (UserName, UTCTime))
148+ -> Map Version (UserName, UTCTime)
149+ check allowed' (ver, (user, time)) = maybe (Map.singleton ver (user, time)) (const Map.empty) $ do
150+ versions <- Map.lookup user allowed'
151+ case versions of
152+ AllVersions -> return ()
153+ SpecificVersions vs
154+ | ver `Set.member` vs -> return ()
155+ | otherwise -> Nothing
135156
136157writeAllowed :: FilePath -> Allowed -> IO ()
137158writeAllowed fp =
138159 writeFile fp . unlines . map go . Map.toList . unMonoidMap
139160 where
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
165+ where
166+ helper v = concat [user, "-", v]
141167
142168printForbidden :: Forbidden -> IO ()
143169printForbidden (MonoidMap forbidden) = unless (Map.null forbidden) $ do