diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mega-sdist.cabal b/mega-sdist.cabal new file mode 100644 --- /dev/null +++ b/mega-sdist.cabal @@ -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 diff --git a/mega-sdist.hs b/mega-sdist.hs new file mode 100644 --- /dev/null +++ b/mega-sdist.hs @@ -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