Permalink
Browse files

Include mega-sdist

  • Loading branch information...
1 parent 40b8075 commit df1172f50308010fec10870c0d250f0380a04012 @snoyberg snoyberg committed Mar 20, 2014
Showing with 238 additions and 1 deletion.
  1. +12 −0 README.md
  2. +19 −1 cabal-src.cabal
  3. +207 −0 mega-sdist.hs
View
12 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.
View
20 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: <https://github.com/yesodweb/cabal-src/blob/master/README.md>.
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
View
207 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

0 comments on commit df1172f

Please sign in to comment.