Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Include mega-sdist
  • Loading branch information
snoyberg committed Mar 20, 2014
1 parent 40b8075 commit df1172f
Show file tree
Hide file tree
Showing 3 changed files with 238 additions and 1 deletion.
12 changes: 12 additions & 0 deletions README.md
Expand Up @@ -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". 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 If you would like to only install the source tarball without actually
installing the binary package, run it with "cabal-src-install --src-only". 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.
20 changes: 19 additions & 1 deletion cabal-src.cabal
@@ -1,5 +1,5 @@
Name: cabal-src Name: cabal-src
Version: 0.2.1 Version: 0.2.2
Synopsis: Alternative install procedure to avoid the diamond dependency issue. 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>. Description: Please see the README.md file on Github for more information: <https://github.com/yesodweb/cabal-src/blob/master/README.md>.
License: BSD3 License: BSD3
Expand All @@ -21,6 +21,24 @@ Executable cabal-src-install
, process , process
, filepath , 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 source-repository head
type: git type: git
location: git://github.com/yesodweb/cabal-src.git location: git://github.com/yesodweb/cabal-src.git
207 changes: 207 additions & 0 deletions 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.