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