mega-sdist (empty) → 0.1
raw patch · 4 files changed
+238/−0 lines, 4 filesdep +basedep +bytestringdep +conduitsetup-changed
Dependencies added: base, bytestring, conduit, containers, http-conduit, http-types, shelly, system-fileio, system-filepath, tar, text, transformers, zlib-conduit
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- mega-sdist.cabal +32/−0
- mega-sdist.hs +184/−0
+ LICENSE view
@@ -0,0 +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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ mega-sdist.cabal view
@@ -0,0 +1,32 @@+Name: mega-sdist+Version: 0.1+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.7 && < 0.8+ , conduit >= 0.4 && < 0.5+ , zlib-conduit >= 0.4 && < 0.5+ , http-conduit >= 1.4 && < 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
+ mega-sdist.hs view
@@ -0,0 +1,184 @@+{-# 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+ parseUrl url+ 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++ dirs <- fmap lines $ Prelude.readFile "sources.txt"+ 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"]+ 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