@@ -1,198 +0,0 @@
1−{-# LANGUAGE PatternGuards #-}
2−-- | Review the upload log and compare against a locally kept list of allowed
3−-- uploaders.
4−module Stackage.Uploads
5− ( checkUploads
6− , printForbidden
7− , filterForbidden
8− ) where
9−
10−import Control.Arrow (second)
11−import Control.Exception (assert, evaluate)
12−import Control.Monad (forM_, unless)
13−import Data.Map (Map)
14−import qualified Data.Map as Map
15−import Data.Maybe (fromMaybe)
16−import Data.Monoid (Monoid (..))
17−import Data.Set (Set)
18−import qualified Data.Set as Set
19−import Data.Time (UTCTime, parseTime)
20−import Distribution.Text (display)
21−import Network.HTTP (getRequest, getResponseBody, simpleHTTP)
22−import qualified Stackage.Types as ST
23−import System.Directory (doesFileExist)
24−import System.Exit (exitFailure)
25−import System.Locale
26−
27−checkUploads :: FilePath -- ^ allowed
28− -> FilePath -- ^ new allowed
29− -> IO Forbidden
30−checkUploads allowedFP newAllowedFP = do
31− putStrLn "Getting upload log"
32− uploadLog <- getUploadLog
33−
34− putStrLn "Reading allowed uploaders list"
35− allowed <- readAllowed allowedFP
36−
37− putStrLn "Computing new and forbidden uploaders"
38− let (allowed', forbidden) = updateAllowed uploadLog allowed
39− _ <- evaluate $ msize allowed'
40− _ <- evaluate $ msize forbidden
41−
42− unless (Map.null $ unMonoidMap allowed') $ do
43− putStrLn $ "Newly uploaded packages detected, writing to " ++ newAllowedFP
44− writeAllowed newAllowedFP allowed'
45−
46− return forbidden
47−
48−-- Define a Map newtype wrapper with a proper Monoid instance.
49−newtype MonoidMap k v = MonoidMap { unMonoidMap :: Map k v }
50−instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
51− mempty = MonoidMap mempty
52− MonoidMap x `mappend` MonoidMap y = MonoidMap $ Map.unionWith mappend x y
53−
54−-- And some helper functions.
55−mlookup :: Ord k => k -> MonoidMap k v -> Maybe v
56−mlookup k = Map.lookup k . unMonoidMap
57−
58−msingleton :: k -> v -> MonoidMap k v
59−msingleton k = MonoidMap . Map.singleton k
60−
61−mkeys :: MonoidMap k v -> [k]
62−mkeys = Map.keys . unMonoidMap
63−
64−msize :: MonoidMap k v -> Int
65−msize = Map.size . unMonoidMap
66−
67−type Version = String
68−type UserName = String
69−type PackageName = String
70−
71−type PackageHistory = Map Version (UserName, UTCTime)
72−type UploadLog = MonoidMap PackageName PackageHistory
73−type Allowed = MonoidMap PackageName (Map UserName AllowedVersions)
74−type Forbidden = UploadLog
75−
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−
83−getUploadLog :: IO UploadLog
84−getUploadLog = do
85− rsp <- simpleHTTP $ getRequest logURL
86− body <- getResponseBody rsp
87− return $ mconcat $ map go $ lines body
88− where
89− go :: String -> UploadLog
90− go s = fromMaybe mempty $ do
91− ver:pkg:user:date' <- Just $ reverse $ words s
92− t <- parseTime defaultTimeLocale fmtStr $ unwords $ reverse date'
93− Just $ msingleton pkg $ Map.singleton ver (user, t)
94−
95− logURL :: String
96− logURL = "http://hackage.haskell.org/packages/archive/log"
97−
98− fmtStr :: String
99− fmtStr = "%a %b %e %T %Z %Y"
100−
101−readAllowed :: FilePath -> IO Allowed
102−readAllowed fp = do
103− exists <- doesFileExist fp
104− if exists
105− then do
106− s <- readFile fp
107− return $ mconcat $ map go $ lines s
108− else return mempty
109− where
110− go :: String -> Allowed
111− go s = fromMaybe mempty $ do
112− pkg:users <- Just $ words s
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
120−
121−updateAllowed :: UploadLog -> Allowed -> (Allowed, Forbidden)
122−updateAllowed uploads allowed =
123− mconcat $ map go $ Set.toList allPackages
124− where
125− -- Map.keys uploads should be sufficient, but being redundant to ensure we
126− -- never lose any data from allowed.
127− allPackages = Set.fromList (mkeys uploads) `Set.union`
128− Set.fromList (mkeys allowed)
129−
130− go :: PackageName -> (Allowed, Forbidden)
131− go pkg =
132− case (mlookup pkg uploads, mlookup pkg allowed) of
133− (Nothing, Nothing) -> assert False (mempty, mempty)
134− (Nothing, Just _) -> (mempty, mempty)
135− (Just u, Nothing) -> (msingleton pkg $ getAllUsers u, mempty)
136− (Just u, Just a) ->
137− let fval = mconcat $ map (check a) $ Map.toList u
138− forbidden
139− | Map.null fval = mempty
140− | otherwise = msingleton pkg fval
141− in (mempty, forbidden)
142−
143− getAllUsers :: PackageHistory -> Map UserName AllowedVersions
144− getAllUsers = Map.fromList . map (second $ const AllVersions) . Map.elems
145−
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
156−
157−writeAllowed :: FilePath -> Allowed -> IO ()
158−writeAllowed fp =
159− writeFile fp . unlines . map go . Map.toList . unMonoidMap
160− where
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]
167−
168−printForbidden :: Forbidden -> IO ()
169−printForbidden (MonoidMap forbidden) = unless (Map.null forbidden) $ do
170− putStrLn $ "Following uploads were forbidden:"
171− forM_ (Map.toList forbidden) $ \(pkg, cases) -> do
172− putStrLn ""
173− putStrLn pkg
174− forM_ (Map.toList cases) $ \(version, (user, time)) ->
175− putStrLn $ concat
176− [ "Version "
177− , version
178− , " by "
179− , user
180− , " at "
181− , show time
182− ]
183− exitFailure
184−
185−filterForbidden :: ST.BuildPlan
186− -> Forbidden
187− -> Forbidden
188−filterForbidden bp =
189− MonoidMap . Map.mapMaybeWithKey isIncluded . unMonoidMap
190− where
191− isIncluded :: PackageName
192− -> PackageHistory
193− -> Maybe PackageHistory
194− isIncluded pn ph = do
195− spi <- Map.lookup (ST.PackageName pn) $ ST.bpPackages bp
196− let version = display $ ST.spiVersion spi
197− tuple <- Map.lookup version ph
198− Just $ Map.singleton version tuple