diff --git a/src/Path/IO.hs b/src/Path/IO.hs index 5c99f1c033..101ac1f02a 100644 --- a/src/Path/IO.hs +++ b/src/Path/IO.hs @@ -4,6 +4,9 @@ module Path.IO (getWorkingDir + ,makeAbsolute + ,parseRelAsAbsDir + ,parseRelAsAbsFile ,listDirectory ,resolveDir ,resolveFile @@ -58,6 +61,28 @@ instance Show ResolveException where getWorkingDir :: (MonadIO m) => m (Path Abs Dir) getWorkingDir = liftIO (D.canonicalizePath "." >>= parseAbsDir) +-- | Take a relative path and base it off the working directory, +-- yielding an absolute path. +makeAbsolute :: MonadIO m => Path Rel a -> m (Path Abs a) +makeAbsolute rel = liftM ( rel) getWorkingDir + +-- | Parse a directory path. If the path is absolute, it's directly +-- yielded. If it's relative, then 'makeAbsolute' is used to base it +-- off the working directory. +parseRelAsAbsDir :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs Dir) +parseRelAsAbsDir "." = getWorkingDir +parseRelAsAbsDir fp + | FP.isAbsolute fp = parseAbsDir fp + | otherwise = makeAbsolute =<< parseRelDir fp + +-- | Parse a file path. If the path is absolute, it's directly yielded. +-- If it's relative, then 'makeAbsolute' is used to base it off the +-- working directory. +parseRelAsAbsFile :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs File) +parseRelAsAbsFile fp + | FP.isAbsolute fp = parseAbsFile fp + | otherwise = makeAbsolute =<< parseRelFile fp + -- | Appends a stringly-typed relative path to an absolute path, and then -- canonicalizes it. resolveDir :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs Dir) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 9fb93f476c..554b4e9978 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -9,10 +9,14 @@ module Stack.Build.Execute ( printPlan , preFetch , executePlan + , getSDistTarball -- TESTING , compareTestsComponents ) where +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Compression.GZip as GZip import Control.Applicative ((<$>), (<*>)) import Control.Concurrent.Lifted (fork) import Control.Concurrent.Execute @@ -29,9 +33,11 @@ import Control.Monad.Trans.Resource import qualified Data.ByteString as S import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL +import Data.Either (partitionEithers) import Data.Foldable (forM_) import Data.Function import Data.List @@ -184,7 +190,6 @@ data ExecuteEnv = ExecuteEnv , eeGhcPkgIds :: !(TVar (Map PackageIdentifier Installed)) , eeTempDir :: !(Path Abs Dir) , eeSetupHs :: !(Path Abs File) - , eeCabalPkgVer :: !Version , eeTotalWanted :: !Int , eeWanted :: !(Set PackageName) , eeLocals :: ![LocalPackage] @@ -207,9 +212,7 @@ executePlan menv bopts baseConfigOpts locals sourceMap plan = do configLock <- newMVar () installLock <- newMVar () idMap <- liftIO $ newTVarIO Map.empty - let setupHs = tmpdir' $(mkRelFile "Setup.hs") - liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain" - cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) + setupHs <- liftIO $ writeSetupHs tmpdir' globalDB <- getGlobalDB menv executePlan' plan ExecuteEnv { eeEnvOverride = menv @@ -224,7 +227,6 @@ executePlan menv bopts baseConfigOpts locals sourceMap plan = do , eeGhcPkgIds = idMap , eeTempDir = tmpdir' , eeSetupHs = setupHs - , eeCabalPkgVer = cabalPkgVer , eeTotalWanted = length $ filter lpWanted locals , eeWanted = wantedLocalPackages locals , eeLocals = locals @@ -484,7 +486,7 @@ withSingleContext :: M env m -> Maybe (Path Abs File, Handle) -> m a) -> m a -withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} inner0 = +withSingleContext ActionContext {..} ee@ExecuteEnv {..} task@Task {..} inner0 = withPackage $ \package cabalfp pkgDir -> withLogFile package $ \mlogFile -> withCabal package pkgDir mlogFile $ \cabal -> @@ -532,97 +534,114 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} inner0 = $ \h -> inner (Just (logPath, h)) withCabal package pkgDir mlogFile inner = do - config <- asks getConfig - menv <- liftIO $ configEnvOverride config EnvSettings - { esIncludeLocals = taskLocation task == Local - , esIncludeGhcPackagePath = False - , esStackExe = False - } - exeName <- liftIO $ join $ findExecutable menv "runhaskell" - distRelativeDir' <- distRelativeDir - msetuphs <- - -- Avoid broken Setup.hs files causing problems for simple build - -- types, see: - -- https://github.com/commercialhaskell/stack/issues/370 - if packageSimpleType package - then return Nothing - else liftIO $ getSetupHs pkgDir - let setuphs = fromMaybe eeSetupHs msetuphs - inner $ \stripTHLoading args -> do - let fullArgs = - ("-package=" ++ - packageIdentifierString - (PackageIdentifier cabalPackageName - eeCabalPkgVer)) - : "-clear-package-db" - : "-global-package-db" - - -- This next line is debatable. It adds access to the - -- snapshot package database for Cabal. There are two - -- possible objections: - -- - -- 1. This doesn't isolate the build enough; arbitrary - -- other packages available could cause the build to - -- succeed or fail. - -- - -- 2. This doesn't provide enough packages: we should also - -- include the local database when building local packages. - -- - -- One possible solution to these points would be to use - -- -hide-all-packages and explicitly list which packages - -- can be used by Setup.hs, and have that based on the - -- dependencies of the package itself. - : ("-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts)) - - : toFilePath setuphs - : ("--builddir=" ++ toFilePath distRelativeDir') - : args - cp0 = proc (toFilePath exeName) fullArgs - cp = cp0 - { cwd = Just $ toFilePath pkgDir - , Process.env = envHelper menv - , std_in = CreatePipe - , std_out = - case mlogFile of - Nothing -> CreatePipe - Just (_, h) -> UseHandle h - , std_err = - case mlogFile of - Nothing -> CreatePipe - Just (_, h) -> UseHandle h - } - $logProcessRun (toFilePath exeName) fullArgs - - -- Use createProcess_ to avoid the log file being closed afterwards - (Just inH, moutH, merrH, ph) <- liftIO $ createProcess_ "singleBuild" cp - liftIO $ hClose inH - maybePrintBuildOutput stripTHLoading LevelInfo mlogFile moutH - maybePrintBuildOutput stripTHLoading LevelWarn mlogFile merrH - ec <- liftIO $ waitForProcess ph - case ec of - ExitSuccess -> return () - _ -> do - bs <- liftIO $ - case mlogFile of - Nothing -> return "" - Just (logFile, h) -> do - hClose h - S.readFile $ toFilePath logFile - throwM $ CabalExitedUnsuccessfully - ec - taskProvides - exeName - fullArgs - (fmap fst mlogFile) - bs - - maybePrintBuildOutput stripTHLoading level mlogFile mh = - case mh of - Just h -> - case mlogFile of - Just{} -> return () - Nothing -> printBuildOutput stripTHLoading level h - Nothing -> return () + cabal <- getRunCabalSetup package + pkgDir + mlogFile + (taskLocation task == Local) + taskProvides + eeSetupHs + (bcoSnapDB eeBaseConfigOpts) + inner cabal + +getRunCabalSetup :: M env m + => Package + -> Path Abs Dir + -> Maybe (Path Abs File, Handle) + -> Bool + -> PackageIdentifier + -> Path Abs File + -> Path Abs Dir + -> m (Bool -> [String] -> m ()) +getRunCabalSetup package pkgDir mlogFile includeLocals provides defaultSetupHs snapDB = do + config <- asks getConfig + cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) + menv <- liftIO $ configEnvOverride config EnvSettings + { esIncludeLocals = includeLocals + , esIncludeGhcPackagePath = False + , esStackExe = False + } + exeName <- liftIO $ join $ findExecutable menv "runhaskell" + distRelativeDir' <- distRelativeDir + msetuphs <- + -- Avoid broken Setup.hs files causing problems for simple build + -- types, see: + -- https://github.com/commercialhaskell/stack/issues/370 + if packageSimpleType package + then return Nothing + else liftIO $ getSetupHs pkgDir + let setuphs = fromMaybe defaultSetupHs msetuphs + return $ \stripTHLoading args -> do + let fullArgs = + ("-package=" ++ + packageIdentifierString + (PackageIdentifier cabalPackageName + cabalPkgVer)) + : "-clear-package-db" + : "-global-package-db" + + -- This next line is debatable. It adds access to the + -- snapshot package database for Cabal. There are two + -- possible objections: + -- + -- 1. This doesn't isolate the build enough; arbitrary + -- other packages available could cause the build to + -- succeed or fail. + -- + -- 2. This doesn't provide enough packages: we should also + -- include the local database when building local packages. + -- + -- One possible solution to these points would be to use + -- -hide-all-packages and explicitly list which packages + -- can be used by Setup.hs, and have that based on the + -- dependencies of the package itself. + : ("-package-db=" ++ toFilePath snapDB) + + : toFilePath setuphs + : ("--builddir=" ++ toFilePath distRelativeDir') + : args + cp0 = proc (toFilePath exeName) fullArgs + cp = cp0 + { cwd = Just $ toFilePath pkgDir + , Process.env = envHelper menv + , std_in = CreatePipe + , std_out = + case mlogFile of + Nothing -> CreatePipe + Just (_, h) -> UseHandle h + , std_err = + case mlogFile of + Nothing -> CreatePipe + Just (_, h) -> UseHandle h + } + maybePrintBuildOutput level mh = + case (mh, mlogFile) of + (Just h, Nothing) -> printBuildOutput stripTHLoading level h + _ -> return () + + $logProcessRun (toFilePath exeName) fullArgs + + -- Use createProcess_ to avoid the log file being closed afterwards + (Just inH, moutH, merrH, ph) <- liftIO $ createProcess_ "singleBuild" cp + liftIO $ hClose inH + maybePrintBuildOutput LevelInfo moutH + maybePrintBuildOutput LevelWarn merrH + ec <- liftIO $ waitForProcess ph + case ec of + ExitSuccess -> return () + _ -> do + bs <- liftIO $ + case mlogFile of + Nothing -> return "" + Just (logFile, h) -> do + hClose h + S.readFile $ toFilePath logFile + throwM $ CabalExitedUnsuccessfully + ec + provides + exeName + fullArgs + (fmap fst mlogFile) + bs singleBuild :: M env m => ActionContext @@ -920,6 +939,84 @@ singleBench beopts ac ee task = announce "benchmarks" cabal False ("bench" : args) +-- | Given the path to a local package, creates its source +-- distribution tarball. Note that the resulting lazy bytestring uses +-- lazy IO, so the source files will only be read when their portion +-- of the .tar.gz is being outputted. +getSDistTarball :: M env m => FilePath -> m L.ByteString +getSDistTarball pkgDir = do + pkgDir' <- parseRelAsAbsDir pkgDir + rawDistFiles <- runSDistList pkgDir' + let (outsideDir, files) = partitionEithers (map pathToEither rawDistFiles) + pathToEither fp = maybe (Left fp) Right (normalizePath fp) + --TODO: consider whether erroring out is better - otherwise the + --user might upload an incomplete tar? + when (not (null outsideDir)) $ + $logWarn $ T.concat + [ "Warning: These files are outside of the package directory, and will be omitted from the tarball: " + , T.pack (show outsideDir)] + let packWith f isDir fp = + f (pkgDir FP. fp) + (either error id (Tar.toTarPath isDir fp)) + liftIO $ do + -- NOTE: Could make this use lazy I/O to only read files as needed + -- for upload (both GZip.compress and Tar.write are lazy). + -- However, it seems less error prone and more predictable to read + -- everything in at once, so that's what we're doing for now: + dirEntries <- mapM (packWith Tar.packDirectoryEntry True) (getDirsFromFiles files) + fileEntries <- mapM (packWith Tar.packFileEntry False) files + return $ GZip.compress (Tar.write (dirEntries ++ fileEntries)) + +getDirsFromFiles :: [FilePath] -> [FilePath] +getDirsFromFiles dirs = Set.toAscList (Set.delete "." results) + where + results = foldl' (\s -> go s . FP.takeDirectory) Set.empty dirs + go s x + | Set.member x s = s + | otherwise = go (Set.insert x s) (FP.takeDirectory x) + +normalizePath :: FilePath -> Maybe FilePath +normalizePath = fmap FP.joinPath . go . FP.splitDirectories . FP.normalise + where + go [] = Just [] + go ("..":_) = Nothing + go (_:"..":xs) = go xs + go (x:xs) = (x :) <$> go xs + +runSDistList :: M env m => Path Abs Dir -> m [FilePath] +runSDistList pkgDir = do + econfig <- asks getEnvConfig + bconfig <- asks getBuildConfig + cabalfp <- getCabalFileName pkgDir + name <- parsePackageNameFromFilePath cabalfp + let config = PackageConfig + { packageConfigEnableTests = False + , packageConfigEnableBenchmarks = False + , packageConfigFlags = localFlags Map.empty bconfig name + , packageConfigGhcVersion = envConfigGhcVersion econfig + , packageConfigPlatform = configPlatform $ getConfig bconfig + } + package <- readPackage config cabalfp + runSDistList' package pkgDir + +runSDistList' :: M env m => Package -> Path Abs Dir -> m [FilePath] +runSDistList' package pkgDir = do + withSystemTempDirectory stackProgName $ \tmpdir -> do + tmpdir' <- parseAbsDir tmpdir + setupHs <- liftIO $ writeSetupHs tmpdir' + let provides = packageIdentifier package + snapDB <- packageDatabaseDeps + cabal <- getRunCabalSetup package + pkgDir + Nothing + True + provides + setupHs + snapDB + let outFile = tmpdir FP. "source-files-list" + cabal False ["sdist", "--list-sources", outFile] + lines <$> liftIO (readFile outFile) + -- | Grab all output from the given @Handle@ and print it to stdout, stripping -- Template Haskell "Loading package" lines. Does work in a separate thread. printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) @@ -949,8 +1046,7 @@ taskLocation task = TTLocal _ -> Local TTUpstream _ loc -> loc --- | Ensure Setup.hs exists in the given directory. Returns an action --- to remove it later. +-- | Get Setup.hs from package directory. Returns 'Nothing' if it doesn't exist. getSetupHs :: Path Abs Dir -- ^ project directory -> IO (Maybe (Path Abs File)) getSetupHs dir = do @@ -966,6 +1062,17 @@ getSetupHs dir = do fp1 = dir $(mkRelFile "Setup.hs") fp2 = dir $(mkRelFile "Setup.lhs") +-- | Write a default Setup.hs to some directory. Usually this shouldn't +-- be the user's package directory, because their file would be +-- overwritten. +writeSetupHs :: Path Abs Dir -> IO (Path Abs File) +writeSetupHs dir = do + let setupHs = dir $(mkRelFile "Setup.hs") + writeFile (toFilePath setupHs) + "import Distribution.Simple\nmain = defaultMain" + return setupHs + + extraBuildOptions :: M env m => m [String] extraBuildOptions = do hpcIndexDir <- toFilePath . ( dotHpc) <$> hpcRelativeDir diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs index ed24525141..246db3a2f5 100644 --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -7,6 +7,7 @@ module Stack.Upload mkUploader , Uploader , upload + , uploadBytes , UploadSettings , defaultUploadSettings , setUploadUrl @@ -51,7 +52,7 @@ import Network.HTTP.Client (BodyReader, Manager, responseBody, responseStatus, withResponse) -import Network.HTTP.Client.MultipartFormData (formDataBody, partFile) +import Network.HTTP.Client.MultipartFormData (formDataBody, partLBS) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types (statusCode) import Path (toFilePath) @@ -202,14 +203,14 @@ mkUploader config us = do , checkStatus = \_ _ _ -> Nothing } return Uploader - { upload_ = \fp0 -> withTarball fp0 $ \fp -> do - let formData = [partFile "package" fp] + { upload_ = \uploadName bytes -> do + let formData = [partLBS "package" bytes] req2 <- formDataBody formData req1 let req3 = applyBasicAuth (encodeUtf8 $ hcUsername creds) (encodeUtf8 $ hcPassword creds) req2 - putStr $ "Uploading " ++ fp ++ "... " + putStr $ "Uploading " ++ uploadName ++ "... " hFlush stdout withResponse req3 manager $ \res -> case statusCode $ responseStatus res of @@ -232,39 +233,9 @@ mkUploader config us = do code -> do putStrLn $ "unhandled status code: " ++ show code printBody res - error $ "Upload failed on " ++ fp + error $ "Upload failed on " ++ uploadName } --- | Given either a file, return it. Given a directory, run @cabal sdist@ and --- get the resulting tarball. -withTarball :: FilePath -> (FilePath -> IO a) -> IO a -withTarball fp0 inner = do - isFile <- doesFileExist fp0 - if isFile then inner fp0 else withSystemTempDirectory "stackage-upload-tarball" $ \dir -> do - isDir <- doesDirectoryExist fp0 - when (not isDir) $ error $ "Invalid argument: " ++ fp0 - - (Just h, Nothing, Nothing, ph) <- - -- The insanity: the Cabal library seems to sometimes generate tarballs - -- in the wrong format. For now, just falling back to cabal-install. - -- Sigh. - - createProcess $ (proc "cabal" - [ "sdist" - , "--builddir=" ++ dir - ]) - { cwd = Just fp0 - , std_in = CreatePipe - } - hClose h - ec <- waitForProcess ph - when (ec /= ExitSuccess) $ - error $ "Could not create tarball for " ++ fp0 - contents <- getDirectoryContents dir - case filter ((== ".gz") . takeExtension) contents of - [x] -> inner (dir x) - _ -> error $ "Unexpected directory contents after cabal sdist: " ++ show contents - printBody :: Response BodyReader -> IO () printBody res = loop @@ -281,14 +252,21 @@ printBody res = -- -- Since 0.1.0.0 data Uploader = Uploader - { upload_ :: !(FilePath -> IO ()) + { upload_ :: !(String -> L.ByteString -> IO ()) } -- | Upload a single tarball with the given @Uploader@. -- -- Since 0.1.0.0 upload :: Uploader -> FilePath -> IO () -upload = upload_ +upload uploader fp = upload_ uploader fp =<< L.readFile fp + +-- | Upload a single tarball with the given @Uploader@. Instead of +-- sending a file like 'upload', this sends a lazy bytestring. +-- +-- Since 0.1.2.1 +uploadBytes :: Uploader -> String -> L.ByteString -> IO () +uploadBytes = upload_ -- | Settings for creating an @Uploader@. -- diff --git a/src/main/Main.hs b/src/main/Main.hs index 064117bbc0..83f596a7b7 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -13,7 +13,7 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (ask) +import Control.Monad.Reader (ask, asks) import Data.Attoparsec.Args (withInterpreterArgs) import Data.List import qualified Data.List as List @@ -34,6 +34,7 @@ import qualified Paths_stack as Meta import Plugins import Prelude hiding (pi) import Stack.Build +import Stack.Build.Execute (getSDistTarball) import Stack.Build.Types import Stack.Config import Stack.Constants @@ -56,7 +57,7 @@ import Stack.Types.Internal import Stack.Types.StackT import Stack.Upgrade import qualified Stack.Upload as Upload -import System.Directory (canonicalizePath) +import System.Directory (canonicalizePath, doesFileExist, doesDirectoryExist) import System.Environment (getArgs, getProgName) import System.Exit import System.FilePath (dropTrailingPathSeparator) @@ -521,18 +522,36 @@ upgradeCmd fromGit go = withConfig go $ -- | Upload to Hackage uploadCmd :: [String] -> GlobalOpts -> IO () +uploadCmd [] _ = error "To upload the current project, please run 'stack upload .'" uploadCmd args go = do - (manager,lc) <- loadConfigWithOpts go - let config = lcConfig lc - if null args - then error "To upload the current project, please run 'stack upload .'" - else liftIO $ do - uploader <- Upload.mkUploader - config - $ Upload.setGetManager (return manager) - Upload.defaultUploadSettings - mapM_ (Upload.upload uploader) args - + let partitionM _ [] = return ([], []) + partitionM f (x:xs) = do + r <- f x + (as, bs) <- partitionM f xs + return $ if r then (x:as, bs) else (as, x:bs) + (files, nonFiles) <- partitionM doesFileExist args + (dirs, invalid) <- partitionM doesDirectoryExist nonFiles + when (not (null invalid)) $ error $ + "'stack upload expects a list sdist tarballs or cabal directories. Can't find " ++ + show invalid + let getUploader :: (HasStackRoot config, HasPlatform config, HasConfig config) => StackT config IO Upload.Uploader + getUploader = do + config <- asks getConfig + manager <- asks envManager + let uploadSettings = + Upload.setGetManager (return manager) $ + Upload.defaultUploadSettings + liftIO $ Upload.mkUploader config uploadSettings + if null dirs + then withConfig go $ do + uploader <- getUploader + liftIO $ forM_ files (Upload.upload uploader) + else withBuildConfig go ExecStrategy $ do + uploader <- getUploader + liftIO $ forM_ files (Upload.upload uploader) + forM_ dirs $ \dir -> do + tarball <- getSDistTarball dir + liftIO $ Upload.uploadBytes uploader dir tarball -- | Execute a command. execCmd :: ExecOpts -> GlobalOpts -> IO ()