@@ -1,198 +0,0 @@
1−{-# LANGUAGE PatternGuards #-}
2−-- | Review the upload log and compare against a locally kept list of allowed
4−module Stackage.Uploads
10−import Control.Arrow (second)
11−import Control.Exception (assert, evaluate)
12−import Control.Monad (forM_, unless)
14−import qualified Data.Map as Map
15−import Data.Maybe (fromMaybe)
16−import Data.Monoid (Monoid (..))
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)
27−checkUploads :: FilePath -- ^ allowed
28− -> FilePath -- ^ new allowed
30−checkUploads allowedFP newAllowedFP = do
31− putStrLn "Getting upload log"
32− uploadLog <- getUploadLog
34− putStrLn "Reading allowed uploaders list"
35− allowed <- readAllowed allowedFP
37− putStrLn "Computing new and forbidden uploaders"
38− let (allowed', forbidden) = updateAllowed uploadLog allowed
39− _ <- evaluate $ msize allowed'
40− _ <- evaluate $ msize forbidden
42− unless (Map.null $ unMonoidMap allowed') $ do
43− putStrLn $ "Newly uploaded packages detected, writing to " ++ newAllowedFP
44− writeAllowed newAllowedFP allowed'
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
54−-- And some helper functions.
55−mlookup :: Ord k => k -> MonoidMap k v -> Maybe v
56−mlookup k = Map.lookup k . unMonoidMap
58−msingleton :: k -> v -> MonoidMap k v
59−msingleton k = MonoidMap . Map.singleton k
61−mkeys :: MonoidMap k v -> [k]
62−mkeys = Map.keys . unMonoidMap
64−msize :: MonoidMap k v -> Int
65−msize = Map.size . unMonoidMap
68−type UserName = String
69−type PackageName = String
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
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)
83−getUploadLog :: IO UploadLog
85− rsp <- simpleHTTP $ getRequest logURL
86− body <- getResponseBody rsp
87− return $ mconcat $ map go $ lines body
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)
96− logURL = "http://hackage.haskell.org/packages/archive/log"
99− fmtStr = "%a %b %e %T %Z %Y"
101−readAllowed :: FilePath -> IO Allowed
103− exists <- doesFileExist fp
107− return $ mconcat $ map go $ lines s
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
115− parseUserAllowed s =
116− case break (== '-') s of
117− (user, '-':version) ->
118− Map.singleton user $ SpecificVersions $ Set.singleton version
119− _ -> Map.singleton s AllVersions
121−updateAllowed :: UploadLog -> Allowed -> (Allowed, Forbidden)
122−updateAllowed uploads allowed =
123− mconcat $ map go $ Set.toList allPackages
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)
130− go :: PackageName -> (Allowed, Forbidden)
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)
137− let fval = mconcat $ map (check a) $ Map.toList u
139− | Map.null fval = mempty
140− | otherwise = msingleton pkg fval
141− in (mempty, forbidden)
143− getAllUsers :: PackageHistory -> Map UserName AllowedVersions
144− getAllUsers = Map.fromList . map (second $ const AllVersions) . Map.elems
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'
152− AllVersions -> return ()
154− | ver `Set.member` vs -> return ()
155− | otherwise -> Nothing
157−writeAllowed :: FilePath -> Allowed -> IO ()
159− writeFile fp . unlines . map go . Map.toList . unMonoidMap
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]
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
174− forM_ (Map.toList cases) $ \(version, (user, time)) ->
185−filterForbidden :: ST.BuildPlan
189− MonoidMap . Map.mapMaybeWithKey isIncluded . unMonoidMap
191− isIncluded :: PackageName
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