cabal-dev-0.8: src/Distribution/Dev/AddSource.hs
{- Copyright (c) 2010 Galois, Inc. -}
{-|
add-source command
Puts local source packages into a repository readable by cabal-install
-}
{-# LANGUAGE CPP #-}
module Distribution.Dev.AddSource
( actions
)
where
#ifndef MIN_VERSION_Cabal
#define MIN_VERSION_Cabal(a,b,c) 1
#endif
import Control.Applicative ( (<$>), (<*>) )
import Control.Arrow ( right )
import Control.Exception ( bracket )
import Control.Monad ( guard, (<=<), forM_ )
import Control.Monad.Error ( runErrorT, throwError )
import Control.Monad.Trans ( liftIO )
import Data.List ( isPrefixOf )
import Distribution.PackageDescription ( PackageDescription(buildType), BuildType(Custom)
, packageDescription, package )
import Distribution.Package ( PackageIdentifier(..) )
#if MIN_VERSION_Cabal(1,6,0)
import Distribution.PackageDescription.Parse ( ParseResult(ParseOk), readPackageDescription
, parsePackageDescription )
import Distribution.Package ( PackageName(..) )
#elif MIN_VERSION_Cabal(1,4,0)
import Distribution.PackageDescription ( ParseResult(ParseOk), readPackageDescription
, parsePackageDescription )
#else
#error Unsupported Cabal version
#endif
import Distribution.Text ( simpleParse, display )
import Network.HTTP ( mkRequest, RequestMethod(GET)
, rspBody, simpleHTTP
)
import Network.URI ( parseURI, uriScheme, URI
, uriPath )
import System.Cmd ( rawSystem )
import System.Console.GetOpt ( OptDescr(..) )
import System.Directory ( getDirectoryContents
, renameFile, copyFile
, getCurrentDirectory
, setCurrentDirectory
, createDirectoryIfMissing
, getTemporaryDirectory
)
import System.Exit ( ExitCode(..) )
import System.FilePath ( takeExtension, takeBaseName
, splitDirectories, (<.>), (</>)
, splitExtension
)
import System.IO ( withBinaryFile, IOMode(..), hClose
, openTempFile, hFlush, hSetBinaryMode
)
import System.IO.Error ( isDoesNotExistError )
import qualified Codec.Archive.Tar as T
import qualified Codec.Archive.Tar.Entry as T
import qualified Codec.Compression.GZip as Z
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8 ( unpack )
import qualified Distribution.Verbosity as V
import Distribution.Dev.Command ( CommandActions(..), CommandResult(..) )
import Distribution.Dev.Flags ( Config, getVerbosity )
import Distribution.Dev.Sandbox ( resolveSandbox, localRepoPath
, Sandbox, indexTar, indexTarBase
)
import Distribution.Simple.Utils ( debug, notice )
actions :: CommandActions
actions = CommandActions
{ cmdDesc = "Add packages to a local cabal install repository"
, cmdRun = \cfg _ -> addSources cfg
, cmdOpts = [] :: [OptDescr ()]
, cmdPassFlags = False
}
addSources :: Config -> [String] -> IO CommandResult
addSources _ [] = return $ CommandError "No package locations supplied"
addSources flgs fns = do
sandbox <- resolveSandbox flgs
let v = getVerbosity flgs
debug v $ "Making a cabal repo in " ++ localRepoPath sandbox ++
" out of " ++ show fns
results <- mapM (processLocalSource v) fns
let errs = [e | Left e <- results]
srcs = [s | Right s <- results]
if not $ null errs
then return $ CommandError $ unlines $
"Errors finding cabal files:":map (showString " ") errs
else do
let (sources, newEntries) = unzip srcs
res <- readExistingIndex sandbox
case res of
Left err -> return $
CommandError $ "Error reading existing index: " ++ err
Right existingIndex ->
do let newIndex = mergeIndices existingIndex newEntries
-- Now we have the new index ready and have
-- sanity-checked all of the package locations
-- to be sure that they contain a cabal package
-- (or at least a .cabal file)
--
-- Now to install the tarballs for the
-- directories:
forM_ sources $ \(src, pkgId, pkgDesc) ->
installTarball flgs sandbox src pkgId pkgDesc
-- and now that the tarballs are in place,
-- write out the updated index
writeIndex sandbox newIndex
return CommandOk
-- |Atomically write an index tarball in the supplied directory
writeIndex :: Sandbox a -- ^The local repository path
-> [T.Entry] -- ^The index entries
-> IO ()
writeIndex sandbox ents =
do newIndexName <- withTmpIndex $ \(fn, h) -> do
hSetBinaryMode h True
L.hPut h (T.write ents)
hFlush h
return fn
renameFile newIndexName $ indexTar sandbox
where
pth = localRepoPath sandbox
withTmpIndex = bracket (openTempFile pth indexTarBase) (hClose . snd)
-- |Merge two lists of tar entries, filtering out the entries from the
-- original list that will be duplicated by the second list of
-- entries
mergeIndices :: [T.Entry] -> [T.Entry] -> [T.Entry]
mergeIndices old new = filter notInNew old ++ new
where
newPaths = map T.entryTarPath new
notInNew e = not $ T.entryTarPath e `elem` newPaths
-- |Create a tar entry for the package identifier and cabal file contents
toIndexEntry :: PackageIdentifier -> L.ByteString -> Either String T.Entry
toIndexEntry pkgId c = right toEnt $ T.toTarPath False (indexName pkgId)
where
toEnt p = T.fileEntry p c
-- |Read an existing index tarball from the local repository, if one
-- exists. If the file does not exist, behave as if the index has no
-- entries.
readExistingIndex :: Sandbox a -> IO (Either String [T.Entry])
readExistingIndex sandbox =
readIndexFile `catch` \e ->
if isDoesNotExistError e
then return $ Right []
else ioError e
where
readIndexFile = withBinaryFile (indexTar sandbox) ReadMode $
(forceEntries . T.read <=< L.hGetContents)
forceEntries es =
let step _ l@(Left _) = l
step x (Right xs) = Right (x:xs)
es' = T.foldEntries step (Right []) Left es
in either (const 0) length es' `seq` return es'
-- |What kind of package source is this?
data LocalSource = DirPkg FilePath | TarPkg FilePath deriving Show
-- |Determine if this filename looks like a tarball (otherwise, it
-- assumes that it's a directory and treats it as such)
classifyLocalSource :: String -> Either URI LocalSource
classifyLocalSource fn =
case parseURI fn of
Just u | isHttpUri u && isTarGzUri u -> Left u
_ | isTarball fn -> Right $ TarPkg fn
| otherwise -> Right $ DirPkg fn
where
isHttpUri = (`elem` ["http:", "https:"]) . uriScheme
isTarGzUri = (reverse ".tar.gz" `isPrefixOf`) . reverse . uriPath
-- |Put the tarball for this package in the local repository
installTarball :: Config
-> Sandbox a -- ^Location of the local repository
-> LocalSource -- ^What kind of package source
-> PackageIdentifier
-> PackageDescription -- ^Package description
-> IO (Either String ())
installTarball flgs sandbox src pkgId pkgDesc =
do createDirectoryIfMissing True $ localRepoPath sandbox </> repoDir pkgId
case src of
TarPkg fn -> do copyFile fn dest
return $ Right ()
DirPkg fn -> do
res <- makeSDist fn
case res of
Left err -> return $ Left err
Right tarFn -> do
renameFile tarFn dest
return $ Right ()
where
dest = localRepoPath sandbox </> tarballName pkgId
makeSDist fn = do
debug (getVerbosity flgs) $ "Running cabal sdist in " ++ fn
bracket getCurrentDirectory setCurrentDirectory $ \_ -> do
setCurrentDirectory fn
-- If the build-type is custom, run 'configure'
-- and invoke the generated setup program.
-- Otherwise, just run plain sdist. We do this to
-- work around
-- http://hackage.haskell.org/trac/hackage/ticket/410
cabalRes <- case buildType pkgDesc of
Just Custom -> do
-- We run configure without args
-- first to compile the Setup
-- program. We do this to work
-- around a different bug in Cabal
-- (http://hackage.haskell.org/trac/hackage/ticket/731)
_ <- rawSystem "cabal" ["configure"]
rawSystem "dist/setup/setup" ["sdist"]
_ -> rawSystem "cabal" ["sdist"]
case cabalRes of
ExitSuccess ->
do here <- getCurrentDirectory
return $ Right $ here </> "dist" </>
display pkgId <.> "tar" <.> "gz"
ExitFailure code ->
return $ Left $
"cabal sdist failed with " ++ show code
downloadTarball :: URI -> IO (Either String FilePath)
downloadTarball u = do
tmpLoc <- getTemporaryDirectory
bracket (openTempFile tmpLoc "package-.tar.gz") (hClose . snd) $ \(fn, h) ->
do httpRes <- simpleHTTP $ mkRequest GET u
case httpRes of
Left err -> return $ Left $ show err
Right resp ->
do L.hPut h $ rspBody resp
return $ Right fn
-- |Extract the index information from the supplied path, either as a
-- tarball or as a local package directory
processLocalSource :: V.Verbosity -> FilePath
-> IO (Either String ((LocalSource, PackageIdentifier, PackageDescription), T.Entry))
processLocalSource v fn =
runErrorT $ do
let cls = classifyLocalSource fn
src <- case cls of
Left u -> do
liftIO $ notice v $ "Downloading " ++ show u
TarPkg `fmap` eitherErrorIO (downloadTarball u)
Right s -> return s
(pkgId, c, pkgDesc) <- eitherErrorIO $
case src of
TarPkg x -> processTarball x
DirPkg x -> processDirectory v x
ent <- eitherError $ toIndexEntry pkgId c
return ((src, pkgId, pkgDesc), ent)
where
eitherError = either throwError return
eitherErrorIO = eitherError <=< liftIO
-- |Extract the index information from a tarball
processTarball :: FilePath
-> IO (Either String (PackageIdentifier, L.ByteString, PackageDescription))
processTarball fn =
withBinaryFile fn ReadMode $ \h ->
do ents <- T.read . Z.decompress <$> L.hGetContents h
case extractCabalFile ents of
Nothing -> return $ Left "No cabal file found"
-- Force reading the cabal file before we exit withFile
Just res@(_, bs, _) -> do
forceBS bs
return (Right res)
#if MIN_VERSION_Cabal(1,6,0)
mkPackageName :: String -> PackageName
mkPackageName = PackageName
displayPackageName :: PackageName -> String
displayPackageName = display
#elif MIN_VERSION_Cabal(1,4,0)
mkPackageName :: String -> String
mkPackageName = id
displayPackageName :: String -> String
displayPackageName = id
#else
#error Unsupported cabal version
#endif
-- |Extract the index information from a directory containing a cabal
-- file
processDirectory :: V.Verbosity -> FilePath
-> IO (Either String (PackageIdentifier, L.ByteString, PackageDescription))
processDirectory v d = go `catch` \e ->
if expected e
then return $ Left $ show e
else ioError e
where
expected e = any ($ e) [ isDoesNotExistError
]
go = do
debug v =<< getCurrentDirectory
fns <- getDirectoryContents d
case filter isCabalFile fns of
[c] -> processCabalFile c
[] -> return $ Left "No cabal file found"
_ -> return $ Left "More than one cabal file present"
processCabalFile c = do
let fn = d </> c
pkgDesc <- packageDescription <$>
readPackageDescription V.normal fn
let pkgId = package pkgDesc
if mkPackageName (takeBaseName c) == pkgName pkgId
then do
notice v $ "Building source dist at " ++ d ++ " for " ++ display pkgId
cabalFile <- withBinaryFile fn ReadMode $
forcedBS <=< L.hGetContents
return $ Right (pkgId, cabalFile, pkgDesc)
else
return $ Left $ unlines $
[ "Package name does not match cabal file name:"
, " filename = " ++ fn
, " package name 1 = " ++ show (mkPackageName (takeBaseName c))
, " package name 2 = " ++ show (pkgName pkgId)
]
-- |Force a lazy ByteString to be read
forceBS :: L.ByteString -> IO ()
forceBS bs = L.length bs `seq` return ()
-- |Force a lazy ByteString to be read, and pass it on to the next action
forcedBS :: L.ByteString -> IO L.ByteString
forcedBS bs = forceBS bs >> return bs
-- |Extract a cabal file from a package tarball
extractCabalFile :: T.Entries -> Maybe (PackageIdentifier, L.ByteString, PackageDescription)
extractCabalFile = T.foldEntries step Nothing (const Nothing)
where
step ent Nothing = (,,) <$> entPackageId ent <*> entBytes ent <*> (parseDesc $ entBytes ent)
step _ ans = ans
parseDesc bs = do
str <- L8.unpack <$> bs
let result = parsePackageDescription str
case result of
ParseOk _ pkg -> return $ packageDescription pkg
_ -> Nothing
entPackageId ent =
case splitDirectories $ T.entryPath ent of
[d, f] ->
do i <- simpleParse d
let cabalName = mkPackageName $ takeBaseName f
guard $ isCabalFile f && cabalName == pkgName i
return i
_ -> Nothing
entBytes ent = case T.entryContent ent of
T.NormalFile x _ -> return x
_ -> Nothing
-- | Does this filename look like a cabal file?
isCabalFile :: FilePath -> Bool
isCabalFile = (== ".cabal") . takeExtension
-- |Does this filename look like a gzipped tarball?
isTarball :: FilePath -> Bool
isTarball fn = (ext2, ext1) == (".tar", ".gz")
where
(fn1, ext1) = splitExtension fn
(_, ext2) = splitExtension fn1
-- |The path to the .cabal file in the 00-index.tar file
indexName :: PackageIdentifier -> FilePath
indexName pkgId = repoDir pkgId </>
(displayPackageName (pkgName pkgId) <.> "cabal")
-- |The path to the tarball in the local repository
tarballName :: PackageIdentifier -> FilePath
tarballName pkgId = repoDir pkgId </> (display pkgId <.> "tar" <.> "gz")
repoDir :: PackageIdentifier -> FilePath
repoDir pkgId = displayPackageName (pkgName pkgId) </>
display (pkgVersion pkgId)