diff --git a/README.md b/README.md index 8163127..d3c6424 100644 --- a/README.md +++ b/README.md @@ -56,3 +56,15 @@ and finally production quality in short order. All feedback is welcome! Simply replace a call to "cabal install" with a call to "cabal-src-install". If you would like to only install the source tarball without actually installing the binary package, run it with "cabal-src-install --src-only". + +## mega-sdist + +This package now also includes the mega-sdist util, which handles uploading to +Hackage from mega repos. + +Compares local code against version on Hackage. Accepts the following options: + +* __--gittag__: Automatically tag as well. +* __--test__: Automatically run cabal tests + +Uses sources.txt to determine which packages to build. diff --git a/cabal-src.cabal b/cabal-src.cabal index fb00081..386f94e 100644 --- a/cabal-src.cabal +++ b/cabal-src.cabal @@ -1,5 +1,5 @@ Name: cabal-src -Version: 0.2.1 +Version: 0.2.2 Synopsis: Alternative install procedure to avoid the diamond dependency issue. Description: Please see the README.md file on Github for more information: . License: BSD3 @@ -21,6 +21,24 @@ Executable cabal-src-install , process , filepath +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 + , directory + source-repository head type: git location: git://github.com/yesodweb/cabal-src.git diff --git a/mega-sdist.hs b/mega-sdist.hs new file mode 100644 index 0000000..0d0334b --- /dev/null +++ b/mega-sdist.hs @@ -0,0 +1,207 @@ +{-# 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 +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 +#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 + , "/" + , a + , "-" + , b + , ".tar.gz" + ] + +main :: IO () +main = withSocketsDo $ do + manager <- newManager +#if MIN_VERSION_http_conduit(2, 0 ,0) + conduitManagerSettings +#else + def +#endif + 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") >>= 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 + + 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", 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 +#if MIN_VERSION_http_conduit(1, 9, 0) + { checkStatus = \_ _ _ -> Nothing +#else + { checkStatus = \_ _ -> Nothing +#endif + } 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