mega-sdist 0.2.0.5 → 0.2.0.6
raw patch · 4 files changed
+245/−243 lines, 4 filesdep +networksetup-changed
Dependencies added: network
Files
- LICENSE +20/−20
- Setup.hs +2/−2
- mega-sdist.cabal +33/−32
- mega-sdist.hs +190/−189
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,32 +1,33 @@-Name: mega-sdist-Version: 0.2.0.5-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--source-repository head- type: git- location: git://github.com/snoyberg/mega-sdist.git+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
mega-sdist.hs view
@@ -1,189 +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)--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 = 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