mega-sdist 0.2.10.4 → 0.3.0
raw patch · 5 files changed
+156/−174 lines, 5 filesdep +classy-prelude-conduitdep +conduit-extradep +filepathdep −bytestringdep −conduitdep −containersdep ~http-conduit
Dependencies added: classy-prelude-conduit, conduit-extra, filepath, tar-conduit, typed-process, yaml
Dependencies removed: bytestring, conduit, containers, http-types, network, shelly, system-fileio, system-filepath, tar, text, transformers, zlib-conduit
Dependency ranges changed: http-conduit
Files
- ChangeLog.md +4/−0
- LICENSE +1/−1
- README.md +11/−0
- mega-sdist.cabal +11/−16
- mega-sdist.hs +129/−157
+ ChangeLog.md view
@@ -0,0 +1,4 @@+## 0.3.0++* Revived from cabal-src+* Use Stack internally
LICENSE view
@@ -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
+ README.md view
@@ -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.
mega-sdist.cabal view
@@ -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
mega-sdist.hs view
@@ -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 ()