git.iko.soy/stackage
on aaca23e help sign in
stackage/Stackage/Uploads.hs
198 lines 7.1 kB history raw
1{-# LANGUAGE PatternGuards #-}
2-- | Review the upload log and compare against a locally kept list of allowed
3-- uploaders.
4module Stackage.Uploads
5 ( checkUploads
6 , printForbidden
7 , filterForbidden
8 ) where
10import Control.Arrow (second)
11import Control.Exception (assert, evaluate)
12import Control.Monad (forM_, unless)
13import Data.Map (Map)
14import qualified Data.Map as Map
15import Data.Maybe (fromMaybe)
16import Data.Monoid (Monoid (..))
17import Data.Set (Set)
18import qualified Data.Set as Set
19import Data.Time (UTCTime, parseTime)
20import Distribution.Text (display)
21import Network.HTTP (getRequest, getResponseBody, simpleHTTP)
22import qualified Stackage.Types as ST
23import System.Directory (doesFileExist)
24import System.Exit (exitFailure)
25import System.Locale
27checkUploads :: FilePath -- ^ allowed
28 -> FilePath -- ^ new allowed
29 -> IO Forbidden
30checkUploads 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'
46 return forbidden
48-- Define a Map newtype wrapper with a proper Monoid instance.
49newtype MonoidMap k v = MonoidMap { unMonoidMap :: Map k v }
50instance (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.
55mlookup :: Ord k => k -> MonoidMap k v -> Maybe v
56mlookup k = Map.lookup k . unMonoidMap
58msingleton :: k -> v -> MonoidMap k v
59msingleton k = MonoidMap . Map.singleton k
61mkeys :: MonoidMap k v -> [k]
62mkeys = Map.keys . unMonoidMap
64msize :: MonoidMap k v -> Int
65msize = Map.size . unMonoidMap
67type Version = String
68type UserName = String
69type PackageName = String
71type PackageHistory = Map Version (UserName, UTCTime)
72type UploadLog = MonoidMap PackageName PackageHistory
73type Allowed = MonoidMap PackageName (Map UserName AllowedVersions)
74type Forbidden = UploadLog
76data AllowedVersions = AllVersions | SpecificVersions (Set Version)
77instance 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)
83getUploadLog :: IO UploadLog
84getUploadLog = 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)
95 logURL :: String
96 logURL = "http://hackage.haskell.org/packages/archive/log"
98 fmtStr :: String
99 fmtStr = "%a %b %e %T %Z %Y"
101readAllowed :: FilePath -> IO Allowed
102readAllowed 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
115 parseUserAllowed s =
116 case break (== '-') s of
117 (user, '-':version) ->
118 Map.singleton user $ SpecificVersions $ Set.singleton version
119 _ -> Map.singleton s AllVersions
121updateAllowed :: UploadLog -> Allowed -> (Allowed, Forbidden)
122updateAllowed 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)
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)
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'
151 case versions of
152 AllVersions -> return ()
153 SpecificVersions vs
154 | ver `Set.member` vs -> return ()
155 | otherwise -> Nothing
157writeAllowed :: FilePath -> Allowed -> IO ()
158writeAllowed 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]
168printForbidden :: Forbidden -> IO ()
169printForbidden (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
185filterForbidden :: ST.BuildPlan
186 -> Forbidden
187 -> Forbidden
188filterForbidden 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