Use Setup.hs to get sdist list + add tar.gz code #313

src/Path/IO.hs

@@ -4,6 +4,8 @@
 
 module Path.IO
   (getWorkingDir
+  ,parseRelAsAbsDir
+  ,parseRelAsAbsFile
   ,listDirectory
   ,resolveDir
   ,resolveFile
@@ -58,6 +60,16 @@ instance Show ResolveException where
 getWorkingDir :: (MonadIO m) => m (Path Abs Dir)
 getWorkingDir = liftIO (D.canonicalizePath "." >>= parseAbsDir)
 
+-- | Parse a directory path. If it's relative, then the absolute version
+-- is yielded, based off the working directory.
+parseRelAsAbsDir :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs Dir)
+parseRelAsAbsDir fp = parseAbsDir =<< liftIO (D.canonicalizePath fp)
+
+-- | Parse a file path. If it's relative, then the absolute version is
+-- yielded, based off the working directory.
+parseRelAsAbsFile :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs File)
+parseRelAsAbsFile fp = parseAbsFile =<< liftIO (D.canonicalizePath 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)

src/Stack/Build.hs

@@ -15,7 +15,8 @@
 module Stack.Build
   (build
   ,clean
-  ,withLoadPackage)
+  ,withLoadPackage
+  ,mkBaseConfigOpts)
   where
 
 import           Control.Monad

src/Stack/Build/Execute.hs

@@ -9,7 +9,11 @@ module Stack.Build.Execute
     ( printPlan
     , preFetch
     , executePlan
-    -- TESTING
+    -- * Running Setup.hs
+    , ExecuteEnv
+    , withExecuteEnv
+    , withSingleContext
+    -- * Testing
     , compareTestsComponents
     ) where
 
@@ -194,16 +198,15 @@ data ExecuteEnv = ExecuteEnv
     , eeGlobalDB       :: !(Path Abs Dir)
     }
 
--- | Perform the actual plan
-executePlan :: M env m
-            => EnvOverride
-            -> BuildOpts
-            -> BaseConfigOpts
-            -> [LocalPackage]
-            -> SourceMap
-            -> Plan
-            -> m ()
-executePlan menv bopts baseConfigOpts locals sourceMap plan = do
+withExecuteEnv :: M env m
+               => EnvOverride
+               -> BuildOpts
+               -> BaseConfigOpts
+               -> [LocalPackage]
+               -> SourceMap
+               -> (ExecuteEnv -> m a)
+               -> m a
+withExecuteEnv menv bopts baseConfigOpts locals sourceMap inner = do
     withSystemTempDirectory stackProgName $ \tmpdir -> do
         tmpdir' <- parseAbsDir tmpdir
         configLock <- newMVar ()
@@ -213,7 +216,7 @@ executePlan menv bopts baseConfigOpts locals sourceMap plan = do
         liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"
         cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
         globalDB <- getGlobalDB menv
-        executePlan' plan ExecuteEnv
+        inner ExecuteEnv
             { eeEnvOverride = menv
             , eeBuildOpts = bopts
              -- Uncertain as to why we cannot run configures in parallel. This appears
@@ -234,6 +237,18 @@ executePlan menv bopts baseConfigOpts locals sourceMap plan = do
             , eeGlobalDB = globalDB
             }
 
+-- | Perform the actual plan
+executePlan :: M env m
+            => EnvOverride
+            -> BuildOpts
+            -> BaseConfigOpts
+            -> [LocalPackage]
+            -> SourceMap
+            -> Plan
+            -> m ()
+executePlan menv bopts baseConfigOpts locals sourceMap plan = do
+    withExecuteEnv menv bopts baseConfigOpts locals sourceMap (executePlan' plan)
+
     unless (Map.null $ planInstallExes plan) $ do
         snapBin <- (</> bindirSuffix) `liftM` installationRootDeps
         localBin <- (</> bindirSuffix) `liftM` installationRootLocal

src/Stack/SDist.hs

@@ -0,0 +1,157 @@
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TemplateHaskell       #-}
+-- Create a source distribution tarball
+module Stack.SDist
+    ( getSDistTarball
+    ) 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.Execute (ActionContext(..))
+import           Control.Monad (when)
+import           Control.Monad.Catch (MonadCatch, MonadMask)
+import           Control.Monad.IO.Class
+import           Control.Monad.Logger
+import           Control.Monad.Reader (MonadReader, asks)
+import           Control.Monad.Trans.Resource
+import qualified Data.ByteString.Lazy as L
+import           Data.Either (partitionEithers)
+import           Data.List
+import qualified Data.Map.Strict as Map
+import           Data.Monoid ((<>))
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import           Network.HTTP.Client.Conduit (HasHttpManager)
+import           Path
+import           Path.IO
+import           Stack.Build (mkBaseConfigOpts)
+import           Stack.Build.Execute
+import           Stack.Build.Source (loadSourceMap, localFlags)
+import           Stack.Build.Types
+import           Stack.Constants
+import           Stack.Package
+import           Stack.Types
+import           Stack.Types.Internal
+import qualified System.FilePath as FP
+import           System.IO.Temp (withSystemTempDirectory)
+
+type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
+
+-- | Given the path to a local package, creates its source
+-- distribution tarball.
+--
+-- While this yields a 'FilePath', the name of the tarball, this
+-- tarball is not written to the disk and instead yielded as a lazy
+-- bytestring.
+getSDistTarball :: M env m => FilePath -> m (FilePath, L.ByteString)
+getSDistTarball pkgDir = do
+    pkgDir' <- parseRelAsAbsDir pkgDir
+    lp <- readLocalPackage pkgDir'
+    $logInfo $ "Getting file list for " <> T.pack pkgDir
+    fileList <-  getSDistFileList lp
+    $logInfo $ "Building sdist tarball for " <> T.pack pkgDir
+    files <- normalizeTarballPaths (lines fileList)
+    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:
+        let packWith f isDir fp =
+               f (pkgDir FP.</> fp)
+                 (either error id (Tar.toTarPath isDir (pkgId FP.</> fp)))
+            tarName = pkgId FP.<.> "tar.gz"
+            pkgId = packageIdentifierString (packageIdentifier (lpPackage lp))
+        dirEntries <- mapM (packWith Tar.packDirectoryEntry True) (dirsFromFiles files)
+        fileEntries <- mapM (packWith Tar.packFileEntry False) files
+        return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)))
+
+-- Read in a 'LocalPackage' config.  This makes some default decisions
+-- about 'LocalPackage' fields that might not be appropriate for other
+-- usecases.
+--
+-- TODO: Dedupe with similar code in "Stack.Build.Source".
+readLocalPackage :: M env m => Path Abs Dir -> m LocalPackage
+readLocalPackage 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
+    return LocalPackage
+        { lpPackage = package
+        , lpWanted = False -- HACK: makes it so that sdist output goes to a log instead of a file.
+        , lpDir = pkgDir
+        , lpCabalFile = cabalfp
+        -- NOTE: these aren't the 'correct values, but aren't used in
+        -- the usage of this function in this module.
+        , lpPackageFinal = package
+        , lpDirtyFiles = True
+        , lpNewBuildCache = Map.empty
+        , lpFiles = Set.empty
+        , lpComponents = Set.empty
+        }
+
+getSDistFileList :: M env m => LocalPackage -> m String
+getSDistFileList lp =
+    withSystemTempDirectory (stackProgName <> "-sdist") $ \tmpdir -> do
+        menv <- getMinimalEnvOverride
+        let bopts = defaultBuildOpts
+        baseConfigOpts <- mkBaseConfigOpts bopts
+        (_mbp, locals, _extraToBuild, sourceMap) <- loadSourceMap bopts
+        withExecuteEnv menv bopts baseConfigOpts locals sourceMap $ \ee -> do
+            withSingleContext ac ee task (Just "sdist") $ \_package _cabalfp _pkgDir cabal _announce _console _mlogFile -> do
+                let outFile = tmpdir FP.</> "source-files-list"
+                cabal False ["sdist", "--list-sources", outFile]
+                liftIO (readFile outFile)
+  where
+    package = lpPackage lp
+    ac = ActionContext Set.empty
+    task = Task
+        { taskProvides = PackageIdentifier (packageName package) (packageVersion package)
+        , taskType = TTLocal lp
+        , taskConfigOpts = TaskConfigOpts
+            { tcoMissing = Set.empty
+            , tcoOpts = \_ -> []
+            }
+        , taskPresent = Set.empty
+        }
+
+normalizeTarballPaths :: M env m => [FilePath] -> m [FilePath]
+normalizeTarballPaths fps = do
+    --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)]
+    return files
+  where
+    (outsideDir, files) = partitionEithers (map pathToEither fps)
+    pathToEither fp = maybe (Left fp) Right (normalizePath fp)
+
+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
+
+dirsFromFiles :: [FilePath] -> [FilePath]
+dirsFromFiles 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)

src/Stack/Upload.hs

@@ -7,6 +7,7 @@ module Stack.Upload
       mkUploader
     , Uploader
     , upload
+    , uploadBytes
     , UploadSettings
     , defaultUploadSettings
     , setUploadUrl
@@ -44,33 +45,24 @@ import qualified Data.Text.IO                          as TIO
 import           Data.Typeable                         (Typeable)
 import           Network.HTTP.Client                   (BodyReader, Manager,
                                                         Response,
+                                                        RequestBody(RequestBodyLBS),
                                                         applyBasicAuth, brRead,
                                                         checkStatus, newManager,
                                                         parseUrl,
                                                         requestHeaders,
                                                         responseBody,
                                                         responseStatus,
                                                         withResponse)
-import           Network.HTTP.Client.MultipartFormData (formDataBody, partFile)
+import           Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody)
 import           Network.HTTP.Client.TLS               (tlsManagerSettings)
 import           Network.HTTP.Types                    (statusCode)
 import           Path                                  (toFilePath)
 import           Stack.Types
 import           System.Directory                      (createDirectoryIfMissing,
-                                                        doesDirectoryExist,
-                                                        doesFileExist,
-                                                        getDirectoryContents,
                                                         removeFile)
-import           System.Exit                           (ExitCode (ExitSuccess))
-import           System.FilePath                       (takeExtension, (</>))
-import           System.IO                             (hClose, hFlush,
-                                                        hGetEcho, hSetEcho,
+import           System.FilePath                       ((</>))
+import           System.IO                             (hFlush, hGetEcho, hSetEcho,
                                                         stdin, stdout)
-import           System.IO.Temp                        (withSystemTempDirectory)
-import           System.Process                        (StdStream (CreatePipe),
-                                                        createProcess, cwd,
-                                                        proc, std_in,
-                                                        waitForProcess)
 
 -- | Username and password to log into Hackage.
 --
@@ -202,14 +194,14 @@ mkUploader config us = do
             , checkStatus = \_ _ _ -> Nothing
             }
     return Uploader
-        { upload_ = \fp0 -> withTarball fp0 $ \fp -> do
-            let formData = [partFile "package" fp]
+        { upload_ = \tarName bytes -> do
+            let formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)]
             req2 <- formDataBody formData req1
             let req3 = applyBasicAuth
                     (encodeUtf8 $ hcUsername creds)
                     (encodeUtf8 $ hcPassword creds)
                     req2
-            putStr $ "Uploading " ++ fp ++ "... "
+            putStr $ "Uploading " ++ tarName ++ "... "
             hFlush stdout
             withResponse req3 manager $ \res ->
                 case statusCode $ responseStatus res of
@@ -232,39 +224,9 @@ mkUploader config us = do
                     code -> do
                         putStrLn $ "unhandled status code: " ++ show code
                         printBody res
-                        error $ "Upload failed on " ++ fp
+                        error $ "Upload failed on " ++ tarName
         }
 
--- | 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 +243,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@.
 --