mega-sdist 0.3.0 → 0.3.0.2
raw patch · 3 files changed
+87/−23 lines, 3 filesdep +bytestringdep +optparse-simpledep +temporary
Dependencies added: bytestring, optparse-simple, temporary
Files
- ChangeLog.md +9/−0
- mega-sdist.cabal +5/−1
- mega-sdist.hs +73/−22
ChangeLog.md view
@@ -1,3 +1,12 @@+## 0.3.0.2++* Switch to optparse-simple+* Add `--get-diffs`++## 0.3.0.1++* Correctly handle megarepos with matching prefixes+ ## 0.3.0 * Revived from cabal-src
mega-sdist.cabal view
@@ -1,5 +1,5 @@ Name: mega-sdist-Version: 0.3.0+Version: 0.3.0.2 Synopsis: Handles uploading to Hackage from mega repos Description: See README.md Homepage: https://github.com/snoyberg/mega-sdist@@ -14,6 +14,7 @@ Executable mega-sdist Main-is: mega-sdist.hs+ other-modules: Paths_mega_sdist Build-depends: base >= 4 && < 5 , classy-prelude-conduit >= 1.2 , conduit-extra@@ -23,6 +24,9 @@ , filepath , typed-process , yaml+ , optparse-simple+ , temporary+ , bytestring source-repository head type: git
mega-sdist.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} import ClassyPrelude.Conduit import System.Directory import Network.HTTP.Simple@@ -10,6 +12,10 @@ import System.FilePath import Data.Conduit.Binary (sinkFileCautious) import Data.Yaml (Value (..), decodeEither')+import Options.Applicative.Simple+import Paths_mega_sdist (version)+import System.IO.Temp (withSystemTempDirectory)+import qualified Data.ByteString.Lazy as L getUrlHackage :: Package -> IO Request getUrlHackage (Package _fp (PackageName a) (Version b)) =@@ -30,11 +36,32 @@ String path <- lookup "path" o return $ unpack path +data Args = Args+ { toTag :: !Bool+ , getDiffs :: !Bool+ , rawDirs :: ![FilePath]+ }+ main :: IO () main = do- args <- getArgs-- let toTag = "--gittag" `elem` args+ (Args {..}, ()) <- simpleOptions+ $(simpleVersion version)+ "Check Haskell cabal package versions in a mega-repo"+ "Determines if the code present in this repo is the most current with Hackage"+ (Args+ <$> switch+ ( long "gittag"+ <> help "Call 'git tag' if all versions are ready for release"+ )+ <*> switch+ ( long "get-diffs"+ <> help "Display the diffs between old and new version"+ )+ <*> many+ ( strArgument (metavar "DIR")+ )+ )+ empty (queryBS, _) <- readProcess_ $ proc "stack" ["query"] queryValue <-@@ -42,8 +69,12 @@ Left e -> error $ "Could not parse 'stack query': " ++ show e Right x -> return x allDirs <- getPaths queryValue- myPath <- canonicalizePath "."- let dirs = filter (myPath `isPrefixOf`) allDirs+ dirs <-+ if null rawDirs+ then return allDirs+ else do+ myPaths <- mapM (fmap addTrailingPathSeparator . canonicalizePath) rawDirs+ return $ filter (\y -> any (\x -> (x `isPrefixOf` y)) myPaths) (map addTrailingPathSeparator allDirs) whenM (doesDirectoryExist "tarballs") $ removeDirectoryRecursive "tarballs" createDirectoryIfMissing True "tarballs"@@ -57,47 +88,53 @@ return dest Nothing -> error $ "Unexpected 'stack sdist' output in dir: " ++ dir - m <- unionsWith mappend <$> mapM go tarballs+ m <- unionsWith mappend <$> mapM (go getDiffs) tarballs case lookup NoChanges m of Nothing -> return () Just s -> do say "The following packages from Hackage have not changed:"- mapM_ sayPackage s- mapM_ (removeFile . packageFile) s+ mapM_ sayPackage $ keys s+ mapM_ (removeFile . packageFile) $ keys s case lookup DoesNotExist m of Nothing -> return () Just s -> do say "\nThe following new packages exist locally:"- mapM_ sayPackage s+ mapM_ sayPackage $ keys s case lookup NeedsVersionBump m of Nothing -> do say "\nNo version bumps required, good to go!" when toTag $ do let pcs = fmap mkProcess- $ maybe [] toList $ lookup DoesNotExist m+ $ maybe [] keys $ lookup DoesNotExist m mkProcess (Package _fp (PackageName name) (Version version)) = proc "git" ["tag", unpack $ concat [name, "/", version]] mapM_ sayShow pcs mapM_ runProcess_ pcs Just s -> do say "\nThe following packages require a version bump:"- mapM_ sayPackage s+ forM_ (mapToList s) $ \(name, mdiff) -> do+ sayPackage name+ forM_ mdiff (L.hPut stdout) data Status = DoesNotExist | NoChanges | NeedsVersionBump deriving (Show, Eq, Ord) -go :: FilePath -> IO (Map Status (Set Package))-go fp = do+type Diff = LByteString++go :: Bool -- ^ get diffs+ -> FilePath+ -> IO (Map Status (Map Package (Maybe Diff)))+go getDiffs fp = do package <- parsePackage fp localFileHackage <- liftIO $ getHackageFile package fh <- liftIO $ doesFileExist localFileHackage let handleFile localFile noChanges = do- isDiff <- compareTGZ localFile fp- return $ if isDiff then NeedsVersionBump else noChanges- status <-+ (isDiff, mdiff) <- compareTGZ getDiffs localFile fp+ return $ if isDiff then (NeedsVersionBump, mdiff) else (noChanges, Nothing)+ (status, mdiff) <- case () of () | fh -> handleFile localFileHackage NoChanges@@ -106,14 +143,14 @@ runResourceT $ httpSink reqH $ \resH -> do case () of ()- | getResponseStatusCode resH == 404 -> return DoesNotExist- | getResponseStatusCode resH == 403 -> return DoesNotExist+ | getResponseStatusCode resH == 404 -> return (DoesNotExist, Nothing)+ | getResponseStatusCode resH == 403 -> return (DoesNotExist, Nothing) | getResponseStatusCode resH == 200 -> do liftIO $ createDirectoryIfMissing True $ takeDirectory localFileHackage sinkFileCautious localFileHackage liftIO $ handleFile localFileHackage NoChanges | otherwise -> error $ "Invalid status code: " ++ show (getResponseStatus resH)- return $ singletonMap status $ singletonSet package+ return $ singletonMap status $ singletonMap package mdiff newtype PackageName = PackageName Text deriving (Show, Eq, Ord)@@ -149,11 +186,25 @@ a = unpack a' b = unpack b' -compareTGZ :: FilePath -> FilePath -> IO Bool-compareTGZ a b = do+compareTGZ :: Bool -- ^ get diffs?+ -> FilePath -> FilePath -> IO (Bool, Maybe Diff)+compareTGZ getDiffs a b = do a' <- getContents a b' <- getContents b- return $ a' /= b'+ let isDiff = a' /= b'+ mdiff <-+ if getDiffs && isDiff+ then withSystemTempDirectory "diff" $ \diff -> do+ let fill dir x = forM_ (mapToList (asMap x)) $ \(fp, bs) -> do+ let fp' = dir </> fp+ createDirectoryIfMissing True $ takeDirectory fp'+ L.writeFile fp' bs+ fill (diff </> "old") a'+ fill (diff </> "new") b'+ (_, out, _) <- readProcess $ setWorkingDir diff $ proc "diff" ["-r", "old", "new"]+ return $ Just out+ else return Nothing+ return (a' /= b', mdiff) where getContents :: FilePath -> IO (Map FilePath LByteString) getContents fp = handleAny (onErr fp) $ runConduitRes