diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/mega-sdist.cabal b/mega-sdist.cabal --- a/mega-sdist.cabal +++ b/mega-sdist.cabal @@ -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 diff --git a/mega-sdist.hs b/mega-sdist.hs --- a/mega-sdist.hs +++ b/mega-sdist.hs @@ -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