git.iko.soy/stackage
on 6ba9699 help sign in
stackage/Stackage/Uploads.hs
153 lines 5.3 kB history raw
1-- | Review the upload log and compare against a locally kept list of allowed
2-- uploaders.
3module Stackage.Uploads
4 ( checkUploads
5 ) where
7import Control.Exception (assert, evaluate)
8import Control.Monad (forM_, unless)
9import Data.Map (Map)
10import qualified Data.Map as Map
11import Data.Maybe (fromMaybe)
12import Data.Monoid (Monoid (..))
13import Data.Set (Set)
14import qualified Data.Set as Set
15import Data.Time (UTCTime, parseTime)
16import Network.HTTP (getRequest, getResponseBody, simpleHTTP)
17import System.Directory (doesFileExist)
18import System.Exit (exitFailure)
19import System.Locale
21checkUploads :: FilePath -- ^ allowed
22 -> FilePath -- ^ new allowed
23 -> IO ()
24checkUploads allowedFP newAllowedFP = do
25 putStrLn "Getting upload log"
26 uploadLog <- getUploadLog
28 putStrLn "Reading allowed uploaders list"
29 allowed <- readAllowed allowedFP
31 putStrLn "Computing new and forbidden uploaders"
32 let (allowed', forbidden) = updateAllowed uploadLog allowed
33 _ <- evaluate $ msize allowed'
34 _ <- evaluate $ msize forbidden
36 unless (Map.null $ unMonoidMap allowed') $ do
37 putStrLn $ "Newly uploaded packages detected, writing to " ++ newAllowedFP
38 writeAllowed newAllowedFP allowed'
40 printForbidden forbidden
42-- Define a Map newtype wrapper with a proper Monoid instance.
43newtype MonoidMap k v = MonoidMap { unMonoidMap :: Map k v }
44instance (Ord k, Monoid v) => Monoid (MonoidMap k v) where
45 mempty = MonoidMap mempty
46 MonoidMap x `mappend` MonoidMap y = MonoidMap $ Map.unionWith mappend x y
48-- And some helper functions.
49mlookup :: Ord k => k -> MonoidMap k v -> Maybe v
50mlookup k = Map.lookup k . unMonoidMap
52msingleton :: k -> v -> MonoidMap k v
53msingleton k = MonoidMap . Map.singleton k
55mkeys :: MonoidMap k v -> [k]
56mkeys = Map.keys . unMonoidMap
58msize :: MonoidMap k v -> Int
59msize = Map.size . unMonoidMap
61type Version = String
62type UserName = String
63type PackageName = String
65type PackageHistory = Map Version (UserName, UTCTime)
66type UploadLog = MonoidMap PackageName PackageHistory
67type Allowed = MonoidMap PackageName (Set UserName)
68type Forbidden = UploadLog
70getUploadLog :: IO UploadLog
71getUploadLog = do
72 rsp <- simpleHTTP $ getRequest logURL
73 body <- getResponseBody rsp
74 return $ mconcat $ map go $ lines body
75 where
76 go :: String -> UploadLog
77 go s = fromMaybe mempty $ do
78 ver:pkg:user:date' <- Just $ reverse $ words s
79 t <- parseTime defaultTimeLocale fmtStr $ unwords $ reverse date'
80 Just $ msingleton pkg $ Map.singleton ver (user, t)
82 logURL :: String
83 logURL = "http://hackage.haskell.org/packages/archive/log"
85 fmtStr :: String
86 fmtStr = "%a %b %e %T %Z %Y"
88readAllowed :: FilePath -> IO Allowed
89readAllowed fp = do
90 exists <- doesFileExist fp
91 if exists
92 then do
93 s <- readFile fp
94 return $ mconcat $ map go $ lines s
95 else return mempty
96 where
97 go :: String -> Allowed
98 go s = fromMaybe mempty $ do
99 pkg:users <- Just $ words s
100 Just $ msingleton pkg $ Set.fromList users
102updateAllowed :: UploadLog -> Allowed -> (Allowed, Forbidden)
103updateAllowed uploads allowed =
104 mconcat $ map go $ Set.toList allPackages
105 where
106 -- Map.keys uploads should be sufficient, but being redundant to ensure we
107 -- never lose any data from allowed.
108 allPackages = Set.fromList (mkeys uploads) `Set.union`
109 Set.fromList (mkeys allowed)
111 go :: PackageName -> (Allowed, Forbidden)
112 go pkg =
113 case (mlookup pkg uploads, mlookup pkg allowed) of
114 (Nothing, Nothing) -> assert False (mempty, mempty)
115 (Nothing, Just _) -> (mempty, mempty)
116 (Just u, Nothing) -> (msingleton pkg $ getAllUsers u, mempty)
117 (Just u, Just a) ->
118 let fval = mconcat $ map (check a) $ Map.toList u
119 forbidden
120 | Map.null fval = mempty
121 | otherwise = msingleton pkg fval
122 in (mempty, forbidden)
124 getAllUsers :: PackageHistory -> Set UserName
125 getAllUsers = Set.fromList . map fst . Map.elems
127 check :: Set UserName -> (Version, (UserName, UTCTime)) -> Map Version (UserName, UTCTime)
128 check allowed' (ver, (user, time))
129 | user `Set.member` allowed' = Map.empty
130 | otherwise = Map.singleton ver (user, time)
132writeAllowed :: FilePath -> Allowed -> IO ()
133writeAllowed fp =
134 writeFile fp . unlines . map go . Map.toList . unMonoidMap
135 where
136 go (pkg, users) = unwords $ pkg : Set.toList users
138printForbidden :: Forbidden -> IO ()
139printForbidden (MonoidMap forbidden) = unless (Map.null forbidden) $ do
140 putStrLn $ "Following uploads were forbidden:"
141 forM_ (Map.toList forbidden) $ \(pkg, cases) -> do
142 putStrLn ""
143 putStrLn pkg
144 forM_ (Map.toList cases) $ \(version, (user, time)) ->
145 putStrLn $ concat
146 [ "Version "
147 , version
148 , " by "
149 , user
150 , " at "
151 , show time
152 ]
153 exitFailure