Commit 6cef5716 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Switch to using some Utils from the Cabal lib

Remove local copies. Also fixes a bug recently introduced
in the writeFileAtomic function, spotted by Peter Robinson.
parent 1be1b949
......@@ -37,8 +37,6 @@ import Distribution.Client.IndexUtils as IndexUtils
, getInstalledPackages )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.HttpUtils (getHTTP, isOldHackageURI)
import Distribution.Client.Utils
( writeFileAtomic )
import Distribution.Package
( PackageIdentifier, packageName, packageVersion, Dependency(..) )
......@@ -49,7 +47,7 @@ import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Utils
( die, notice, info, debug, setupMessage
, copyFileVerbose )
, copyFileVerbose, writeFileAtomic )
import Distribution.System
( buildPlatform )
import Distribution.Text
......@@ -58,6 +56,7 @@ import Distribution.Verbosity
( Verbosity )
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy.Char8 as BS
import Control.Monad
( when, filterM )
import System.Directory
......@@ -88,7 +87,7 @@ downloadURI verbosity path uri = do
Right rsp
| rspCode rsp == (2,0,0)
-> do info verbosity ("Downloaded to " ++ path)
writeFileAtomic path (rspBody rsp)
writeFileAtomic path (BS.unpack $ rspBody rsp)
--FIXME: check the content-length header matches the body length.
--TODO: stream the download into the file rather than buffering the whole
-- thing in memory.
......
......@@ -116,9 +116,9 @@ import Distribution.PackageDescription.Configuration
import Distribution.Version
( Version, VersionRange, anyVersion, thisVersion )
import Distribution.Simple.Utils as Utils
( notice, info, warn, die, intercalate )
( notice, info, warn, die, intercalate, withTempDirectory )
import Distribution.Client.Utils
( inDir, mergeBy, MergeResult(..), withTempDirectory )
( inDir, mergeBy, MergeResult(..) )
import Distribution.System
( Platform, buildPlatform, OS(Windows), buildOS )
import Distribution.Text
......@@ -623,7 +623,7 @@ installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg =
pkgPath <- fetchPackage verbosity repo pkgid
onFailure UnpackFailed $ do
tmp <- getTemporaryDirectory
withTempDirectory tmp (display pkgid) $ \tmpDirPath -> do
withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> do
info verbosity $ "Extracting " ++ pkgPath
++ " to " ++ tmpDirPath ++ "..."
let relUnpackedPath = display pkgid
......
......@@ -55,9 +55,9 @@ import Distribution.Client.IndexUtils
( getInstalledPackages )
import Distribution.Simple.Utils
( die, debug, info, cabalVersion, findPackageDesc, comparing
, createDirectoryIfMissingVerbose )
, createDirectoryIfMissingVerbose, rewriteFile )
import Distribution.Client.Utils
( moreRecentFile, rewriteFile, inDir )
( moreRecentFile, inDir )
import Distribution.Text
( display )
import Distribution.Verbosity
......
......@@ -17,9 +17,7 @@ import Distribution.PackageDescription.Parse
( readPackageDescription )
import Distribution.Simple.Utils
( defaultPackageDesc, warn, notice, setupMessage
, createDirectoryIfMissingVerbose )
import Distribution.Client.Utils
( withTempDirectory )
, createDirectoryIfMissingVerbose, withTempDirectory )
import Distribution.Simple.Setup (SDistFlags(..), fromFlag)
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.PreProcess (knownSuffixHandlers)
......@@ -50,7 +48,7 @@ sdist flags = do
warn verbosity "Cannot run preprocessors. Run 'configure' command first."
createDirectoryIfMissingVerbose verbosity True tmpTargetDir
withTempDirectory tmpTargetDir "sdist." $ \tmpDir -> do
withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
date <- toCalendarTime =<< getClockTime
let pkg' | snapshot = snapshotPackage date pkg
......
......@@ -18,8 +18,6 @@ import Distribution.Client.Types
( Repo(..), RemoteRepo(..), LocalRepo(..), AvailablePackageDb(..) )
import Distribution.Client.Fetch
( downloadIndex )
import qualified Distribution.Client.Utils as BS
( writeFileAtomic )
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.IndexUtils
( getAvailablePackages )
......@@ -31,11 +29,11 @@ import Distribution.Package
import Distribution.Version
( anyVersion, withinRange )
import Distribution.Simple.Utils
( warn, notice )
( warn, notice, writeFileAtomic )
import Distribution.Verbosity
( Verbosity )
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Codec.Compression.GZip as GZip (decompress)
import qualified Data.Map as Map
import System.FilePath (dropExtension)
......@@ -58,8 +56,9 @@ updateRepo verbosity repo = case repoKind repo of
notice verbosity $ "Downloading the latest package list from "
++ remoteRepoName remoteRepo
indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo)
BS.writeFileAtomic (dropExtension indexPath) . GZip.decompress
=<< BS.readFile indexPath
writeFileAtomic (dropExtension indexPath) . BS.unpack
. GZip.decompress
=<< BS.readFile indexPath
checkForSelfUpgrade :: Verbosity -> [Repo] -> IO ()
checkForSelfUpgrade verbosity repos = do
......
......@@ -2,24 +2,12 @@ module Distribution.Client.Utils where
import Data.List
( sortBy, groupBy )
import qualified Data.ByteString.Lazy as BS
import System.FilePath
( (<.>), splitFileName )
import Control.Monad
( unless )
import System.IO
( openBinaryTempFile, hClose )
import System.IO.Error
( isDoesNotExistError )
import System.Directory
( removeFile, renameFile, doesFileExist, getModificationTime
, getCurrentDirectory, setCurrentDirectory, removeDirectoryRecursive )
import Distribution.Compat.TempFile
( createTempDirectory )
( doesFileExist, getModificationTime
, getCurrentDirectory, setCurrentDirectory )
import qualified Control.Exception as Exception
( evaluate, finally, bracket )
import qualified Distribution.Compat.Exception as Exception
( onException )
( finally )
-- | Generic merging utility. For sorted input lists this is a full outer join.
--
-- * The result list never contains @(Nothing, Nothing)@.
......@@ -49,22 +37,6 @@ duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
moreThanOne (_:_:_) = True
moreThanOne _ = False
writeFileAtomic :: FilePath -> BS.ByteString -> IO ()
writeFileAtomic targetFile content = do
(tmpFile, tmpHandle) <- openBinaryTempFile targetDir template
Exception.onException (do hClose tmpHandle
removeFile tmpFile) $ do
BS.hPut tmpHandle content
hClose tmpHandle
renameFile tmpFile targetFile
where
template = targetName <.> "tmp"
targetDir | null targetDir_ = "."
| otherwise = targetDir_
--TODO: remove this when takeDirectory/splitFileName is fixed
-- to always return a valid dir
(targetDir_,targetName) = splitFileName targetFile
-- | Compare the modification times of two files to see if the first is newer
-- than the second. The first file must exist but the second need not.
-- The expected use case is when the second file is generated using the first.
......@@ -79,28 +51,6 @@ moreRecentFile a b = do
ta <- getModificationTime a
return (ta > tb)
-- | Write a file but only if it would have new content. If we would be writing
-- the same as the existing content then leave the file as is so that we do not
-- update the file's modification time.
--
rewriteFile :: FilePath -> String -> IO ()
rewriteFile path newContent =
flip catch mightNotExist $ do
existingContent <- readFile path
Exception.evaluate (length existingContent)
unless (existingContent == newContent) $
writeFile path newContent
where
mightNotExist e | isDoesNotExistError e = writeFile path newContent
| otherwise = ioError e
--TODO: replace with function from Cabal utils in next version
withTempDirectory :: FilePath -> String -> (FilePath -> IO a) -> IO a
withTempDirectory targetDir template =
Exception.bracket
(createTempDirectory targetDir template)
(removeDirectoryRecursive)
-- | Executes the action in the specified directory.
inDir :: Maybe FilePath -> IO () -> IO ()
inDir Nothing m = m
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment