diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +## 0.3.0 + +* Revived from cabal-src +* Use Stack internally diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ +Copyright (c) 2017 Michael Snoyman Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# mega-sdist + +Handles uploading to Hackage from Stack mega repos. + +Compares local code against version on Hackage. Accepts the following options: + +* __--gittag__: Automatically tag as well. + +Uses `stack.yaml` if present to determine which packages to +build. Only takes directories which are a subdirectory of the current +directory. diff --git a/mega-sdist.cabal b/mega-sdist.cabal --- a/mega-sdist.cabal +++ b/mega-sdist.cabal @@ -1,6 +1,6 @@ Name: mega-sdist -Version: 0.2.10.4 -Synopsis: Handles uploading to Hackage from mega repos (deprecated) +Version: 0.3.0 +Synopsis: Handles uploading to Hackage from mega repos Description: See README.md Homepage: https://github.com/snoyberg/mega-sdist License: MIT @@ -10,25 +10,20 @@ Category: Distribution Build-type: Simple Cabal-version: >=1.8 +extra-source-files: README.md ChangeLog.md Executable mega-sdist Main-is: mega-sdist.hs Build-depends: base >= 4 && < 5 - , shelly >= 1.3.1 - , conduit >= 0.5 - , zlib-conduit >= 0.5 - , http-conduit >= 1.5 - , system-filepath >= 0.4 && < 0.5 - , system-fileio >= 0.3 && < 0.4 - , http-types - , transformers - , tar - , bytestring - , containers - , text - , network + , classy-prelude-conduit >= 1.2 + , conduit-extra + , http-conduit >= 2.2.3 + , tar-conduit , directory + , filepath + , typed-process + , yaml source-repository head type: git - location: git://github.com/snoyberg/mega-sdist.git + location: https://github.com/snoyberg/mega-sdist.git diff --git a/mega-sdist.hs b/mega-sdist.hs --- a/mega-sdist.hs +++ b/mega-sdist.hs @@ -1,136 +1,100 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -import Prelude hiding (FilePath, getContents) -import System.Environment (getArgs) -import System.Directory (doesDirectoryExist) -import Network.HTTP.Conduit -import Network.HTTP.Types (status200, status404, status502) -import Filesystem -import Filesystem.Path.CurrentOS hiding (concat) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Map as Map -import qualified Data.Set as Set -import Control.Monad (when, forM_, forM, filterM) -import qualified Data.ByteString.Lazy as L -import qualified Codec.Archive.Tar as Tar +{-# LANGUAGE NoImplicitPrelude #-} +import ClassyPrelude.Conduit +import System.Directory +import Network.HTTP.Simple +import Data.Conduit.Tar import Data.Conduit.Zlib (ungzip) -import qualified Data.Conduit as C -import qualified Data.Conduit.List as CL -import Control.Exception (try, SomeException (..)) -import Control.Monad.IO.Class (liftIO) -import Shelly hiding (()) -import Data.Maybe (mapMaybe, fromMaybe) -import Network (withSocketsDo) - -debug :: String -> IO () -#ifdef DEBUG -debug = putStrLn -#else -debug = const $ return () -#endif +import System.Process.Typed +import System.FilePath +import Data.Conduit.Binary (sinkFileCautious) +import Data.Yaml (Value (..), decodeEither') -getUrlHackage :: Package -#if MIN_VERSION_http_conduit(2, 0, 0) - -> IO Request -#else - -> IO (Request m) -#endif -getUrlHackage (Package a b) = do - debug url - req <- parseUrl url - return req { responseTimeout = Nothing } - where - url = concat - [ "http://hackage.haskell.org/packages/archive/" - , a - , "/" - , b - , "/" +getUrlHackage :: Package -> IO Request +getUrlHackage (Package _fp (PackageName a) (Version b)) = + parseRequest $ unpack $ concat + [ "https://s3.amazonaws.com/hackage.fpcomplete.com/package/" , a , "-" , b , ".tar.gz" ] +getPaths :: Value -> IO [FilePath] +getPaths value = maybe (error $ "getPaths failed: " ++ show value) return $ do + Object top <- return value + Object locals <- lookup "locals" top + forM (toList locals) $ \l -> do + Object o <- return l + String path <- lookup "path" o + return $ unpack path + main :: IO () -main = withSocketsDo $ do - manager <- newManager -#if MIN_VERSION_http_conduit(2, 0 ,0) - conduitManagerSettings -#else - def -#endif +main = do args <- getArgs - let toTest = "--test" `elem` args - toTag = "--gittag" `elem` args + let toTag = "--gittag" `elem` args - exists <- isFile "sources.txt" - dirs <- - if exists - then fmap lines (Prelude.readFile "sources.txt") >>= filterM doesDirectoryExist - else return ["."] - shelly $ do - rm_rf "tarballs" - mkdir "tarballs" - files' <- forM dirs $ \dir -> do - chdir (decodeString dir) $ do - rm_rf "dist" - when toTest $ do - run_ "cabal" ["configure", "--enable-tests", "-ftest_export"] - run_ "cabal" ["build"] - run_ "cabal" ["test"] - run_ "cabal" ["sdist"] - ls "dist" >>= mapM absPath . filter (flip hasExtension "gz") - forM_ (concat files') $ \file -> mv file $ "tarballs" filename file + (queryBS, _) <- readProcess_ $ proc "stack" ["query"] + queryValue <- + case decodeEither' (toStrict queryBS) of + 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 - tarballs <- listDirectory "tarballs" - ss <- mapM (go manager) tarballs - let m = Map.unionsWith Set.union ss - let say = putStrLn . reverse . drop 7 . reverse . encodeString . filename + whenM (doesDirectoryExist "tarballs") $ removeDirectoryRecursive "tarballs" + createDirectoryIfMissing True "tarballs" - case Map.lookup NoChanges m of + tarballs <- forM dirs $ \dir -> do + (_, output) <- readProcess_ $ proc "stack" ["sdist", dir] + case lastMay $ map unpack $ words $ decodeUtf8 output of + Just fp -> do + let dest = "tarballs" takeFileName fp + renameFile fp dest + return dest + Nothing -> error $ "Unexpected 'stack sdist' output in dir: " ++ dir + + m <- unionsWith mappend <$> mapM go tarballs + + case lookup NoChanges m of Nothing -> return () Just s -> do - putStrLn "The following packages from Hackage have not changed:" - mapM_ say $ Set.toList s - mapM_ removeFile $ Set.toList s + say "The following packages from Hackage have not changed:" + mapM_ sayPackage s + mapM_ (removeFile . packageFile) s - case Map.lookup DoesNotExist m of + case lookup DoesNotExist m of Nothing -> return () Just s -> do - putStrLn "\nThe following new packages exist locally:" - mapM_ say $ Set.toList s + say "\nThe following new packages exist locally:" + mapM_ sayPackage s - case Map.lookup NeedsVersionBump m of + case lookup NeedsVersionBump m of Nothing -> do - putStrLn "\nNo version bumps required, good to go!" + say "\nNo version bumps required, good to go!" when toTag $ do - let tags = mapMaybe (mkTag . either id id . toText . filename) $ Set.toList $ fromMaybe Set.empty $ Map.lookup DoesNotExist m - mkTag t = do - base <- T.stripSuffix ".tar.gz" t - let (x', y) = T.breakOnEnd "-" base - x <- T.stripSuffix "-" x' - return $ T.concat [x, "/", y] - forM_ tags $ \tag -> putStrLn $ "git tag " ++ T.unpack tag - shelly $ forM_ tags $ \tag -> run_ "git" ["tag", tag] + let pcs = fmap mkProcess + $ maybe [] toList $ 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 - putStrLn "\nThe following packages require a version bump:" - mapM_ say $ Set.toList s + say "\nThe following packages require a version bump:" + mapM_ sayPackage s data Status = DoesNotExist | NoChanges | NeedsVersionBump deriving (Show, Eq, Ord) -go :: Manager -> FilePath -> IO (Map.Map Status (Set.Set FilePath)) -go m fp = do - let base = T.reverse $ T.drop 7 $ T.reverse $ either id id $ toText $ filename fp - let package = parsePackage $ T.unpack base +go :: FilePath -> IO (Map Status (Set Package)) +go fp = do + package <- parsePackage fp localFileHackage <- liftIO $ getHackageFile package - fh <- liftIO $ isFile localFileHackage + fh <- liftIO $ doesFileExist localFileHackage let handleFile localFile noChanges = do - debug $ "Comparing: " ++ show (fp, localFile) isDiff <- compareTGZ localFile fp return $ if isDiff then NeedsVersionBump else noChanges status <- @@ -139,69 +103,77 @@ | fh -> handleFile localFileHackage NoChanges | otherwise -> do reqH <- getUrlHackage package - resH <- C.runResourceT $ httpLbs reqH -#if MIN_VERSION_http_conduit(1, 9, 0) - { checkStatus = \_ _ _ -> Nothing -#else - { checkStatus = \_ _ -> Nothing -#endif - } m + runResourceT $ httpSink reqH $ \resH -> do case () of - () - | responseStatus resH == status404 || L.length (responseBody resH) == 0 -> do - liftIO $ debug $ "Not found on Hackage: " ++ show fp - return DoesNotExist - | responseStatus resH == status200 -> do - createTree $ directory localFileHackage - L.writeFile (encodeString localFileHackage) $ responseBody resH - handleFile localFileHackage NoChanges - | otherwise -> error $ "Invalid status code: " ++ show (responseStatus resH) - return $ Map.singleton status $ Set.singleton fp + () + | getResponseStatusCode resH == 404 -> return DoesNotExist + | getResponseStatusCode resH == 403 -> return DoesNotExist + | 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 -data Package = Package String String +newtype PackageName = PackageName Text + deriving (Show, Eq, Ord) +newtype Version = Version Text + deriving (Show, Eq, Ord) +data Package = Package + { packageFile :: !FilePath + , _packageName :: !PackageName + , _packageVersion :: !Version + } + deriving (Show, Eq, Ord) -parsePackage :: String -> Package -parsePackage s = - Package a b - where - s' = reverse s - (b', a') = break (== '-') s' - a = reverse $ drop 1 a' - b = reverse b' +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 + Just s -> do + let s' = reverse s + (b', a') = break (== '-') s' + a = reverse $ drop 1 a' + b = reverse b' + return $ Package fp (PackageName a) (Version b) +sayPackage :: MonadIO m => Package -> m () +sayPackage (Package _ (PackageName name) (Version version)) = say $ concat [name, "-", version] + getHackageFile :: Package -> IO FilePath -getHackageFile (Package a b) = do - cache <- getAppCacheDirectory "sdist-check" - return $ cache "hackage" decodeString (concat [a, "-", b, ".tar.gz"]) +getHackageFile (Package _fp (PackageName a') (Version b')) = do + stack <- getAppUserDataDirectory "stack" + return $ stack "indices" "Hackage" "packages" a b + concat [a, "-", b, ".tar.gz"] + where + a = unpack a' + b = unpack b' compareTGZ :: FilePath -> FilePath -> IO Bool -compareTGZ a b = {- FIXME catcher $ -} do +compareTGZ a b = do a' <- getContents a b' <- getContents b return $ a' /= b' where - -- catcher = handle (\SomeException{} -> debug (show ("compareTGZ" :: String, a, b)) >> return True) - getContents fp = do - lbs <- L.readFile (encodeString fp) - ebss <- try $ C.runResourceT $ CL.sourceList (L.toChunks lbs) C.$$ ungzip C.=$ CL.consume - case ebss of - Left (e :: SomeException) -> do - putStrLn $ concat - [ "Error opening tarball: " - , encodeString fp - , ", " - , show e - ] - return Map.empty - Right bss -> do - l <- toList $ Tar.read $ L.fromChunks bss - return $ Map.unions $ map go' l - toList (Tar.Next e es) = do - l <- toList es - return $ e : l - toList Tar.Done = return [] - toList (Tar.Fail s) = error $ show s - go' e = - case Tar.entryContent e of - Tar.NormalFile lbs _ -> Map.singleton (Tar.entryPath e) lbs - _ -> Map.empty + getContents :: FilePath -> IO (Map FilePath LByteString) + getContents fp = handleAny (onErr fp) $ runConduitRes + $ sourceFile fp + .| ungzip + .| untar + .| withEntries addEntry + .| foldC + + onErr fp e = do + say $ concat + [ "Error opening tarball: " + , pack fp + , ", " + , tshow e + ] + return mempty + + addEntry header + | headerFileType header == FTNormal = do + lbs <- sinkLazy + yield $ asMap $ singletonMap (headerFilePath header) lbs + | otherwise = return ()