mega-sdist 0.2.0.6 → 0.2.0.7
raw patch · 4 files changed
+245/−245 lines, 4 filesdep ~conduitdep ~zlib-conduitsetup-changed
Dependency ranges changed: conduit, zlib-conduit
Files
- LICENSE +20/−20
- Setup.hs +2/−2
- mega-sdist.cabal +33/−33
- mega-sdist.hs +190/−190
LICENSE view
@@ -1,20 +1,20 @@-Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be -included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
mega-sdist.cabal view
@@ -1,33 +1,33 @@-Name: mega-sdist -Version: 0.2.0.6 -Synopsis: Handles uploading to Hackage from mega repos -Description: See README.md -Homepage: https://github.com/snoyberg/mega-sdist -License: MIT -License-file: LICENSE -Author: Michael Snoyman -Maintainer: michael@snoyman.com -Category: Distribution -Build-type: Simple -Cabal-version: >=1.8 - -Executable mega-sdist - Main-is: mega-sdist.hs - Build-depends: base >= 4 && < 5 - , shelly >= 0.13 - , conduit >= 0.5 && < 0.6 - , zlib-conduit >= 0.5 && < 0.6 - , http-conduit >= 1.5 - , system-filepath >= 0.4 && < 0.5 - , system-fileio >= 0.3 && < 0.4 - , http-types - , transformers - , tar - , bytestring - , containers - , text - , network - -source-repository head - type: git - location: git://github.com/snoyberg/mega-sdist.git +Name: mega-sdist+Version: 0.2.0.7+Synopsis: Handles uploading to Hackage from mega repos+Description: See README.md+Homepage: https://github.com/snoyberg/mega-sdist+License: MIT+License-file: LICENSE+Author: Michael Snoyman+Maintainer: michael@snoyman.com+Category: Distribution+Build-type: Simple+Cabal-version: >=1.8++Executable mega-sdist+ Main-is: mega-sdist.hs+ Build-depends: base >= 4 && < 5+ , shelly >= 0.13+ , 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++source-repository head+ type: git+ location: git://github.com/snoyberg/mega-sdist.git
mega-sdist.hs view
@@ -1,190 +1,190 @@-{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -import Prelude hiding (FilePath, getContents) -import System.Environment (getArgs) -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) -import qualified Data.ByteString.Lazy as L -import qualified Codec.Archive.Tar as 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 - -getUrlHackage :: Package -> IO (Request m) -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 - , "/" - , a - , "-" - , b - , ".tar.gz" - ] - -main :: IO () -main = withSocketsDo $ do - manager <- newManager def - args <- getArgs - - let toTest = "--test" `elem` args - toTag = "--gittag" `elem` args - - exists <- isFile "sources.txt" - dirs <- - if exists - then fmap lines $ Prelude.readFile "sources.txt" - 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 - - tarballs <- listDirectory "tarballs" - ss <- mapM (go manager) tarballs - let m = Map.unionsWith Set.union ss - let say = putStrLn . reverse . drop 7 . reverse . encodeString . filename - - case Map.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 - - case Map.lookup DoesNotExist m of - Nothing -> return () - Just s -> do - putStrLn "\nThe following new packages exist locally:" - mapM_ say $ Set.toList s - - case Map.lookup NeedsVersionBump m of - Nothing -> do - putStrLn "\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", TL.fromStrict tag] - Just s -> do - putStrLn "\nThe following packages require a version bump:" - mapM_ say $ Set.toList 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 - localFileHackage <- liftIO $ getHackageFile package - fh <- liftIO $ isFile localFileHackage - let handleFile localFile noChanges = do - debug $ "Comparing: " ++ show (fp, localFile) - isDiff <- compareTGZ localFile fp - return $ if isDiff then NeedsVersionBump else noChanges - status <- - case () of - () - | fh -> handleFile localFileHackage NoChanges - | otherwise -> do - reqH <- getUrlHackage package - resH <- C.runResourceT $ httpLbs reqH { rawBody = True, checkStatus = \_ _ -> Nothing } m - 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 - -data Package = Package String String - -parsePackage :: String -> Package -parsePackage s = - Package a b - where - s' = reverse s - (b', a') = break (== '-') s' - a = reverse $ drop 1 a' - b = reverse b' - -getHackageFile :: Package -> IO FilePath -getHackageFile (Package a b) = do - cache <- getAppCacheDirectory "sdist-check" - return $ cache </> "hackage" </> decodeString (concat [a, "-", b, ".tar.gz"]) - -compareTGZ :: FilePath -> FilePath -> IO Bool -compareTGZ a b = {- FIXME catcher $ -} 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 +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+import Prelude hiding (FilePath, getContents)+import System.Environment (getArgs)+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)+import qualified Data.ByteString.Lazy as L+import qualified Codec.Archive.Tar as 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++getUrlHackage :: Package -> IO (Request m)+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+ , "/"+ , a+ , "-"+ , b+ , ".tar.gz"+ ]++main :: IO ()+main = withSocketsDo $ do+ manager <- newManager def+ args <- getArgs++ let toTest = "--test" `elem` args+ toTag = "--gittag" `elem` args++ exists <- isFile "sources.txt"+ dirs <-+ if exists+ then fmap lines $ Prelude.readFile "sources.txt"+ 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++ tarballs <- listDirectory "tarballs"+ ss <- mapM (go manager) tarballs+ let m = Map.unionsWith Set.union ss+ let say = putStrLn . reverse . drop 7 . reverse . encodeString . filename++ case Map.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++ case Map.lookup DoesNotExist m of+ Nothing -> return ()+ Just s -> do+ putStrLn "\nThe following new packages exist locally:"+ mapM_ say $ Set.toList s++ case Map.lookup NeedsVersionBump m of+ Nothing -> do+ putStrLn "\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", TL.fromStrict tag]+ Just s -> do+ putStrLn "\nThe following packages require a version bump:"+ mapM_ say $ Set.toList 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+ localFileHackage <- liftIO $ getHackageFile package+ fh <- liftIO $ isFile localFileHackage+ let handleFile localFile noChanges = do+ debug $ "Comparing: " ++ show (fp, localFile)+ isDiff <- compareTGZ localFile fp+ return $ if isDiff then NeedsVersionBump else noChanges+ status <-+ case () of+ ()+ | fh -> handleFile localFileHackage NoChanges+ | otherwise -> do+ reqH <- getUrlHackage package+ resH <- C.runResourceT $ httpLbs reqH { rawBody = True, checkStatus = \_ _ -> Nothing } m+ 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++data Package = Package String String++parsePackage :: String -> Package+parsePackage s =+ Package a b+ where+ s' = reverse s+ (b', a') = break (== '-') s'+ a = reverse $ drop 1 a'+ b = reverse b'++getHackageFile :: Package -> IO FilePath+getHackageFile (Package a b) = do+ cache <- getAppCacheDirectory "sdist-check"+ return $ cache </> "hackage" </> decodeString (concat [a, "-", b, ".tar.gz"])++compareTGZ :: FilePath -> FilePath -> IO Bool+compareTGZ a b = {- FIXME catcher $ -} 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