mega-sdist 0.3.1 → 0.3.2
raw patch · 3 files changed
+130/−99 lines, 3 filesdep +conduitdep +riodep −classy-prelude-conduitdep −directorydep −filepathdep ~http-conduit
Dependencies added: conduit, rio
Dependencies removed: classy-prelude-conduit, directory, filepath, temporary, text, typed-process
Dependency ranges changed: http-conduit
Files
- ChangeLog.md +4/−0
- mega-sdist.cabal +6/−10
- mega-sdist.hs +120/−89
ChangeLog.md view
@@ -1,3 +1,7 @@+## 0.3.2++* Switch to rio and LTS 11+ ## 0.3.1 * Switch to tar-conduit 0.2
mega-sdist.cabal view
@@ -1,11 +1,11 @@--- This file has been generated from package.yaml by hpack version 0.20.0.+-- This file has been generated from package.yaml by hpack version 0.21.2. -- -- see: https://github.com/sol/hpack ----- hash: 7988c08ce3d45cc7ce8d0342ded6262c3f38ed97dfe2e46ad3fa4b911d3e7546+-- hash: 407ba429efdb65a7f336e889a0aeccf043f834c4c3c040efca8216c42587a55e name: mega-sdist-version: 0.3.1+version: 0.3.2 synopsis: Handles uploading to Hackage from mega repos description: Please see the description on Github at <https://github.com/snoyberg/mega-sdist#readme> category: Distribution@@ -31,16 +31,12 @@ build-depends: base >=4 && <5 , bytestring- , classy-prelude-conduit >=1.2+ , conduit >=1.3 , conduit-extra- , directory- , filepath- , http-conduit >=2.2.3+ , http-conduit >=2.3 , optparse-simple+ , rio , tar-conduit >=0.2.1- , temporary- , text- , typed-process , yaml other-modules: Paths_mega_sdist
mega-sdist.hs view
@@ -3,28 +3,41 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}-import ClassyPrelude.Conduit-import System.Directory+import RIO+import Conduit+import RIO.Directory+import RIO.FilePath+import qualified RIO.Map as Map+import qualified RIO.HashMap as HM import Network.HTTP.Simple import Data.Conduit.Tar import Data.Conduit.Zlib (ungzip)-import System.Process.Typed-import System.FilePath+import RIO.Process import Data.Conduit.Binary (sinkFileCautious) import Data.Yaml (Value (..), decodeEither') import Options.Applicative.Simple hiding (header, value) import qualified Paths_mega_sdist as Paths (version)-import System.IO (hIsTerminalDevice)-import System.IO.Temp (withSystemTempDirectory)-import qualified Data.ByteString.Lazy as L+import qualified RIO.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Semigroup (Max (..), Option (..)) import qualified Data.Version import Text.ParserCombinators.ReadP (readP_to_S)-import qualified Data.Text as T+import qualified RIO.Text as T+import qualified RIO.List as L+import RIO.Text.Partial (splitOn) -getUrlHackage :: Package -> IO Request+data App = App+ { appLogFunc :: !LogFunc+ , appProcessContext :: !ProcessContext+ }+instance HasLogFunc App where+ logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y })+instance HasProcessContext App where+ processContextL = lens appProcessContext (\x y -> x { appProcessContext = y })++getUrlHackage :: MonadIO m => Package -> m Request getUrlHackage (Package _fp (PackageName a) (Version b)) =- parseRequest $ unpack $ concat+ liftIO $ parseRequest $ T.unpack $ mconcat [ "https://s3.amazonaws.com/hackage.fpcomplete.com/package/" , a , "-"@@ -32,24 +45,25 @@ , ".tar.gz" ] -getPaths :: Value -> IO [FilePath]+getPaths :: MonadIO m => Value -> m [FilePath] getPaths value = maybe (error $ "getPaths failed: " ++ show value) return $ do Object top <- return value- Object locals <- lookup "locals" top+ Object locals <- HM.lookup "locals" top forM (toList locals) $ \l -> do Object o <- return l- String path <- lookup "path" o- return $ unpack path+ String path <- HM.lookup "path" o+ return $ T.unpack path data Args = Args { toTag :: !Bool , getDiffs :: !Bool , rawDirs :: ![FilePath]+ , verbose :: !Bool } main :: IO () main = do- (Args {..}, ()) <- simpleOptions+ (args@Args {..}, ()) <- simpleOptions $(simpleVersion Paths.version) "Check Haskell cabal package versions in a mega-repo" "Determines if the code present in this repo is the most current with Hackage"@@ -65,12 +79,27 @@ <*> many ( strArgument (metavar "DIR") )+ <*> switch+ ( long "verbose"+ <> help "Enable verbose output"+ ) ) empty - (queryBS, _) <- readProcess_ $ proc "stack" ["query"]+ lo <- logOptionsHandle stdout verbose+ pc <- mkDefaultProcessContext+ withLogFunc lo $ \lf -> do+ let app = App+ { appLogFunc = lf+ , appProcessContext = pc+ }+ runRIO app $ main2 args++main2 :: Args -> RIO App ()+main2 Args {..} = do+ (queryBS, _) <- proc "stack" ["query"] readProcess_ queryValue <-- case decodeEither' (toStrict queryBS) of+ case decodeEither' (BL.toStrict queryBS) of Left e -> error $ "Could not parse 'stack query': " ++ show e Right x -> return x allDirs <- getPaths queryValue@@ -79,60 +108,60 @@ then return allDirs else do myPaths <- mapM (fmap addTrailingPathSeparator . canonicalizePath) rawDirs- return $ filter (\y -> any (\x -> (x `isPrefixOf` y)) myPaths) (map addTrailingPathSeparator allDirs)+ return $ filter (\y -> any (\x -> (x `L.isPrefixOf` y)) myPaths) (map addTrailingPathSeparator allDirs) whenM (doesDirectoryExist "tarballs") $ removeDirectoryRecursive "tarballs" createDirectoryIfMissing True "tarballs" tarballs <- forM dirs $ \dir -> do- (_, output) <- readProcess_ $ proc "stack" ["sdist", dir]- case lastMay $ map unpack $ words $ decodeUtf8 output of- Just fp -> do+ output <- proc "stack" ["sdist", dir] readProcessStderr_+ case decodeUtf8' $ BL.toStrict output of+ Left e -> error $ "Invalid non-UTF8 output: " ++ show e+ Right text -> case reverse $ map T.unpack $ T.words text of+ fp:_ -> do let dest = "tarballs" </> takeFileName fp renameFile fp dest return dest- Nothing -> error $ "Unexpected 'stack sdist' output in dir: " ++ dir+ [] -> error $ "Unexpected 'stack sdist' output in dir: " ++ dir - m <- unionsWith mappend <$> mapM (go getDiffs) tarballs+ m <- Map.unionsWith mappend <$> mapM (go getDiffs) tarballs - case lookup NoChanges m of+ case Map.lookup NoChanges m of Nothing -> return () Just s -> do- say "The following packages from Hackage have not changed:"- mapM_ sayPackage $ keys s- mapM_ (removeFile . packageFile) $ keys s+ logInfo "The following packages from Hackage have not changed:"+ mapM_ sayPackage $ Map.keys s+ mapM_ (removeFile . packageFile) $ Map.keys s toColor <- hIsTerminalDevice stdout - case lookup DoesNotExist m of+ case Map.lookup DoesNotExist m of Nothing -> return () Just s -> do- say "\nThe following new packages exist locally:"- forM_ (mapToList s) $ \(name, mdiff) -> do+ logInfo "\nThe following new packages exist locally:"+ forM_ (Map.toList s) $ \(name, mdiff) -> do sayPackage name sayDiff toColor mdiff - case lookup NeedsVersionBump m of+ case Map.lookup NeedsVersionBump m of Nothing -> do- say "\nNo version bumps required, good to go!"- when toTag $ do- let pcs = fmap mkProcess- $ maybe [] keys $ lookup DoesNotExist m- mkProcess (Package _fp (PackageName name) (Version version)) =- let ident = concat [name, "-", version]- msg = "Release: " ++ ident- in proc "git" ["tag", "-s", unpack ident, "-m", unpack msg]- mapM_ sayShow pcs- mapM_ runProcess_ pcs+ logInfo "\nNo version bumps required, good to go!"+ when toTag $ forM_ (maybe [] Map.keys $ Map.lookup DoesNotExist m)+ $ \(Package _fp (PackageName name) (Version version)) ->+ let ident = T.unpack $ mconcat [name, "-", version]+ msg = "Release: " <> ident+ in proc "git" ["tag", "-s", ident, "-m", msg] $ \pc -> do+ logInfo $ displayShow pc+ runProcess_ pc Just s -> do- say "\nThe following packages require a version bump:"- forM_ (mapToList s) $ \(name, mdiff) -> do+ logInfo "\nThe following packages require a version bump:"+ forM_ (Map.toList s) $ \(name, mdiff) -> do sayPackage name sayDiff toColor mdiff sayDiff :: Bool -- ^ use color?- -> Maybe Diff -> IO ()-sayDiff toColor = mapM_ $ L.hPut stdout . (if toColor then colorize else id)+ -> Maybe Diff -> RIO App ()+sayDiff toColor = mapM_ $ BL.hPut stdout . (if toColor then colorize else id) data Status = DoesNotExist | NoChanges | NeedsVersionBump deriving (Show, Eq, Ord)@@ -141,12 +170,13 @@ go :: Bool -- ^ get diffs -> FilePath- -> IO (Map Status (Map Package (Maybe Diff)))+ -> RIO App (Map Status (Map Package (Maybe Diff))) go getDiffs fp = do package <- parsePackage fp- localFileHackage <- liftIO $ getHackageFile package- localFileExists <- liftIO $ doesFileExist localFileHackage- let handleFile = do+ localFileHackage <- getHackageFile package+ localFileExists <- doesFileExist localFileHackage+ let handleFile :: RIO App (Status, Maybe Diff)+ handleFile = do let v = packageVersion package (isDiff, mdiff) <- compareTGZ getDiffs (packageName package) localFileHackage v fp v return $ if isDiff then (NeedsVersionBump, mdiff) else (NoChanges, Nothing)@@ -166,7 +196,7 @@ case mlatest of Nothing -> return Nothing Just (latest, latestv) -> do- (isDiff, mdiff) <- liftIO $ compareTGZ getDiffs (packageName package) latest latestv fp (packageVersion package)+ (isDiff, mdiff) <- lift $ lift $ compareTGZ getDiffs (packageName package) latest latestv fp (packageVersion package) return $ if isDiff then mdiff else Nothing else return Nothing return (DoesNotExist, mdiff)@@ -174,9 +204,9 @@ | getResponseStatusCode resH == 200 -> do liftIO $ createDirectoryIfMissing True $ takeDirectory localFileHackage sinkFileCautious localFileHackage- liftIO handleFile+ lift $ lift handleFile | otherwise -> error $ "Invalid status code: " ++ show (getResponseStatus resH)- return $ singletonMap status $ singletonMap package mdiff+ return $ Map.singleton status $ Map.singleton package mdiff -- | Get the filepath for the latest version of a package from -- Hackage, if it exists at all.@@ -193,8 +223,8 @@ Option Nothing -> return Nothing Option (Just (Max version)) -> do let p = Package "" name $ toTextVersion version- fp <- liftIO $ getHackageFile p- req <- liftIO $ getUrlHackage p+ fp <- getHackageFile p+ req <- getUrlHackage p runResourceT $ httpSink req $ \res -> if getResponseStatusCode res == 200 then do@@ -215,45 +245,46 @@ deriving (Show, Eq, Ord) toTextVersion :: Data.Version.Version -> Version-toTextVersion = Version . pack . Data.Version.showVersion+toTextVersion = Version . T.pack . Data.Version.showVersion parseVersionNumber :: PackageName -- ^ target package we care about -> Header -> Option (Max Data.Version.Version) parseVersionNumber pn header = Option $ fmap Max $ do- [name, version, dotcabal] <- Just $ T.splitOn "/" $ pack fp+ [name, version, dotcabal] <- Just $ splitOn "/" $ T.pack fp guard $ PackageName name == pn- guard $ name ++ ".cabal" == dotcabal+ guard $ name <> ".cabal" == dotcabal listToMaybe $ map fst $ filter (null . snd) $ readP_to_S Data.Version.parseVersion- $ unpack version+ $ T.unpack version where fp = headerFilePath header parsePackage :: MonadThrow m => FilePath -> m Package parsePackage fp =- case stripSuffix ".tar.gz" $ pack $ takeFileName fp of- Nothing -> error $ "Does not end with .tar.gz: " ++ unpack fp+ case T.stripSuffix ".tar.gz" $ T.pack $ takeFileName fp of+ Nothing -> error $ "Does not end with .tar.gz: " ++ fp Just s -> do- let s' = reverse s- (b', a') = break (== '-') s'- a = reverse $ drop 1 a'- b = reverse b'+ let s' = T.reverse s+ (b', a') = T.break (== '-') s'+ a = T.reverse $ T.drop 1 a'+ b = T.reverse b' return $ Package fp (PackageName a) (Version b) -sayPackage :: MonadIO m => Package -> m ()-sayPackage (Package _ (PackageName name) (Version version)) = say $ concat [name, "-", version]+sayPackage :: Package -> RIO App ()+sayPackage (Package _ (PackageName name) (Version version)) =+ logInfo $ display name <> "-" <> display version -getHackageFile :: Package -> IO FilePath-getHackageFile (Package _fp (PackageName a') (Version b')) = do+getHackageFile :: MonadIO m => Package -> m FilePath+getHackageFile (Package _fp (PackageName a') (Version b')) = liftIO $ do stack <- getAppUserDataDirectory "stack" return $ stack </> "indices" </> "Hackage" </> "packages" </> a </> b </> concat [a, "-", b, ".tar.gz"] where- a = unpack a'- b = unpack b'+ a = T.unpack a'+ b = T.unpack b' compareTGZ :: Bool -- ^ get diffs? -> PackageName@@ -265,7 +296,7 @@ -- ^ new tarball -> Version -- ^ new version- -> IO (Bool, Maybe Diff)+ -> RIO App (Bool, Maybe Diff) compareTGZ getDiffs pn a av b bv = do a' <- getContents a b' <- getContents b@@ -273,27 +304,28 @@ mdiff <- if getDiffs && isDiff then withSystemTempDirectory "diff" $ \diff -> do- let fill dir x = forM_ (mapToList (asMap x)) $ \(fp, bs) -> do+ let fill dir x = forM_ (Map.toList x) $ \(fp, bs) -> do let fp' = dir </> fp createDirectoryIfMissing True $ takeDirectory fp'- L.writeFile fp' bs+ BL.writeFile fp' bs fill (diff </> "old") a' fill (diff </> "new") b'- let toNV v = concat- [ unpack (unPackageName pn)+ let toNV v = T.unpack $ mconcat+ [ unPackageName pn , "-"- , unpack (unVersion v)+ , unVersion v ]- (_, out, _) <- readProcess $ setWorkingDir diff $ proc "diff"+ (_, out) <- withWorkingDir diff $ proc "diff" [ "-ruN" , "old" </> toNV av , "new" </> toNV bv ]+ readProcessStdout return $ Just out else return Nothing return (a' /= b', mdiff) where- getContents :: FilePath -> IO (Map FilePath LByteString)+ getContents :: FilePath -> RIO App (Map FilePath LByteString) getContents fp = handleAny (onErr fp) $ runConduitRes $ sourceFile fp .| ungzip@@ -302,34 +334,33 @@ .| foldC onErr fp e = do- say $ concat- [ "Error opening tarball: "- , pack fp- , ", "- , tshow e- ]- return mempty+ logInfo $+ "Error opening tarball: " <>+ fromString fp <>+ ", " <>+ displayShow e+ return mempty addEntry header | headerFileType header == FTNormal = do lbs <- sinkLazy- yield $ asMap $ singletonMap (headerFilePath header) lbs+ yield $ Map.singleton (headerFilePath header) lbs | otherwise = return () colorize :: LByteString -> LByteString colorize =- intercalate "\n" . map colorLine . L.split 10+ BL.intercalate "\n" . map colorLine . BL.split 10 where colorLine :: LByteString -> LByteString colorLine l =- case (toEnum . fromEnum) <$> headMay l of+ case fst <$> BL8.uncons l of Just '-' -> add "31" l Just '+' -> add "32" l Just '@' -> add "34" l _ -> l add :: LByteString -> LByteString -> LByteString- add color l = concat+ add color l = mconcat [ "\x1b[" , color , "m"