Merge pull request #1296 from 23Skidoo/add-source-snapshot

Implement 'sandbox add-source --snapshot'.

Author: 23Skidoo

cabal-install/Distribution/Client/Sandbox.hs

@@ -11,6 +11,7 @@ module Distribution.Client.Sandbox (
     sandboxInit,
     sandboxDelete,
     sandboxAddSource,
+    sandboxAddSourceSnapshot,
     sandboxDeleteSource,
     sandboxListSources,
     sandboxHcPkg,
@@ -59,36 +60,54 @@ import Distribution.Client.Targets            ( UserTarget(..)
                                               , readUserTargets
                                               , resolveUserTargets )
 import Distribution.Client.Types              ( SourcePackageDb(..) )
-import Distribution.Client.Utils              ( tryCanonicalizePath )
+import Distribution.Client.Utils              ( inDir, tryCanonicalizePath )
+import Distribution.PackageDescription.Configuration
+                                              ( flattenPackageDescription )
+import Distribution.PackageDescription.Parse  ( readPackageDescription )
 import Distribution.Simple.Compiler           ( Compiler(..), PackageDB(..)
                                               , PackageDBStack )
 import Distribution.Simple.Configure          ( configCompilerAux
                                               , interpretPackageDbFlags )
+import Distribution.Simple.PreProcess         ( knownSuffixHandlers )
 import Distribution.Simple.Program            ( ProgramConfiguration )
 import Distribution.Simple.Setup              ( Flag(..)
                                               , fromFlag, fromFlagOrDefault )
+import Distribution.Simple.SrcDist            ( prepareTree )
 import Distribution.Simple.Utils              ( die, debug, notice, info
-                                              , debugNoWrap
+                                              , debugNoWrap, defaultPackageDesc
                                               , intercalate
                                               , createDirectoryIfMissingVerbose )
+import Distribution.Package                   ( Package(..) )
 import Distribution.System                    ( Platform )
+import Distribution.Text                      ( display )
 import Distribution.Verbosity                 ( Verbosity, lessVerbose )
 import Distribution.Compat.Env                ( lookupEnv, setEnv )
 import qualified Distribution.Client.Sandbox.Index as Index
 import qualified Distribution.Simple.Register      as Register
 import Control.Exception                      ( assert, bracket_ )
-import Control.Monad                          ( unless, when )
+import Control.Monad                          ( forM, unless, when )
 import Data.IORef                             ( newIORef, writeIORef, readIORef )
 import Data.List                              ( (\\), delete )
 import Data.Monoid                            ( mempty, mappend )
-import System.Directory                       ( doesDirectoryExist
+import System.Directory                       ( createDirectory
+                                              , doesDirectoryExist
                                               , getCurrentDirectory
                                               , removeDirectoryRecursive
-                                              , removeFile )
+                                              , removeFile
+                                              , renameDirectory )
 import System.FilePath                        ( (</>), getSearchPath
                                               , searchPathSeparator )
 
 
+--
+-- * Constants
+--
+
+-- | The name of the sandbox subdirectory where we keep snapshots of add-source
+-- dependencies.
+snapshotDirectoryName :: FilePath
+snapshotDirectoryName = "snapshots"
+
 --
 -- * Basic sandbox functions.
 --
@@ -220,12 +239,9 @@ sandboxDelete verbosity _sandboxFlags globalFlags = do
       notice verbosity $ "Deleting the sandbox located at " ++ sandboxDir
       removeDirectoryRecursive sandboxDir
 
--- | Entry point for the 'cabal sandbox add-source' command.
-sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags
-                    -> IO ()
-sandboxAddSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
-  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity
-                          (globalConfigFile globalFlags)
+-- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'.
+doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment -> IO ()
+doAddSource verbosity buildTreeRefs sandboxDir pkgEnv = do
   let savedConfig       = pkgEnvSavedConfig pkgEnv
   indexFile            <- tryGetIndexFilePath savedConfig
 
@@ -241,6 +257,63 @@ sandboxAddSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
     Index.addBuildTreeRefs verbosity indexFile buildTreeRefs'
     return buildTreeRefs'
 
+-- | Entry point for the 'cabal sandbox add-source' command.
+sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags
+                    -> IO ()
+sandboxAddSource verbosity buildTreeRefs sandboxFlags globalFlags = do
+  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity
+                          (globalConfigFile globalFlags)
+
+  if fromFlagOrDefault False (sandboxSnapshot sandboxFlags)
+    then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv
+    else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv
+
+-- | Entry point for the 'cabal sandbox add-source --snapshot' command.
+sandboxAddSourceSnapshot :: Verbosity -> [FilePath] -> FilePath
+                            -> PackageEnvironment
+                            -> IO ()
+sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv = do
+  let snapshotDir = sandboxDir </> snapshotDirectoryName
+
+  -- Use 'D.S.SrcDist.prepareTree' to copy each package's files to our private
+  -- location.
+  createDirectoryIfMissingVerbose verbosity True snapshotDir
+
+  -- Collect the package descriptions first, so that if some path does not refer
+  -- to a cabal package, we fail immediately.
+  pkgs      <- forM buildTreeRefs $ \buildTreeRef ->
+    inDir (Just buildTreeRef) $
+    return . flattenPackageDescription
+            =<< readPackageDescription verbosity
+            =<< defaultPackageDesc     verbosity
+
+  -- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If
+  -- 'prepareTree' throws an error at any point, the old snapshots will still be
+  -- in consistent state.
+  tmpDirs <- forM (zip buildTreeRefs pkgs) $ \(buildTreeRef, pkg) ->
+    inDir (Just buildTreeRef) $ do
+      let targetDir    = snapshotDir </> (display . packageId $ pkg)
+          targetTmpDir = targetDir ++ "-tmp"
+      dirExists <- doesDirectoryExist targetTmpDir
+      when dirExists $
+        removeDirectoryRecursive targetDir
+      createDirectory targetTmpDir
+      prepareTree verbosity pkg Nothing buildTreeRef targetTmpDir
+        knownSuffixHandlers
+      return (targetTmpDir, targetDir)
+
+  -- Now rename the "snapshots/$PKGNAME-$VERSION-tmp" dirs to
+  -- "snapshots/$PKGNAME-$VERSION".
+  snapshots <- forM tmpDirs $ \(targetTmpDir, targetDir) -> do
+    dirExists <- doesDirectoryExist targetDir
+    when dirExists $
+      removeDirectoryRecursive targetDir
+    renameDirectory targetTmpDir targetDir
+    return targetDir
+
+  -- Once the packages are copied, just 'add-source' them as usual.
+  doAddSource verbosity snapshots sandboxDir pkgEnv
+
 -- | Entry point for the 'cabal sandbox delete-source' command.
 sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags
                        -> IO ()

cabal-install/Distribution/Client/Sandbox/Timestamp.hs

@@ -38,13 +38,13 @@ import Distribution.Simple.SrcDist                   (allSourcesBuildInfo,
                                                       findMainExeFile,
                                                       findSetupFile)
 import Distribution.Simple.Utils                     (defaultPackageDesc, die,
-                                                      findPackageDesc,
+                                                      debug, findPackageDesc,
                                                       matchFileGlob, warn)
 import Distribution.System                           (Platform)
 import Distribution.Text                             (display)
 import Distribution.Verbosity                        (Verbosity)
 
-import Distribution.Client.Utils                     (inDir)
+import Distribution.Client.Utils                     (inDir, tryCanonicalizePath)
 import Distribution.Client.Sandbox.Index             (listBuildTreeRefs)
 
 import Distribution.Compat.Exception                 (catchIO)
@@ -238,7 +238,8 @@ allPackageSourceFiles verbosity packageDir = inDir (Just packageDir) $ do
   mSetupFile <- findSetupFile
   descFile   <- defaultPackageDesc verbosity
 
-  return . map (packageDir </>) $ descFile : (maybeToList mSetupFile)
+  mapM tryCanonicalizePath . map (packageDir </>) $
+    descFile : (maybeToList mSetupFile)
     ++ incFiles ++ (concat extraSrcs) ++ (concat dataFs)
     ++ (concat exeSources) ++ libSources
 
@@ -266,7 +267,11 @@ isDepModified verbosity now (packageDir, timestamp) = do
       when (modTime > now) $
         warn verbosity $ "File '" ++ dep
                          ++ "' has a modification time that is in the future."
-      if modTime >= timestamp then return True else go rest
+      if modTime > timestamp
+        then do
+          debug verbosity ("Dependency has a modified source file: " ++ dep)
+          return True
+        else go rest
 
 -- | Given an IO action, feed to it the list of modified add-source deps and
 -- set their timestamps to the current time in the timestamps file.

cabal-install/Distribution/Client/Setup.hs

@@ -1259,6 +1259,8 @@ instance Monoid Win32SelfUpgradeFlags where
 
 data SandboxFlags = SandboxFlags {
   sandboxVerbosity :: Flag Verbosity,
+  sandboxSnapshot  :: Flag Bool, -- FIXME: this should be an 'add-source'-only
+                                 -- flag.
   sandboxLocation  :: Flag FilePath
 }
 
@@ -1268,6 +1270,7 @@ defaultSandboxLocation = ".cabal-sandbox"
 defaultSandboxFlags :: SandboxFlags
 defaultSandboxFlags = SandboxFlags {
   sandboxVerbosity = toFlag normal,
+  sandboxSnapshot  = toFlag False,
   sandboxLocation  = toFlag defaultSandboxLocation
   }
 
@@ -1289,6 +1292,11 @@ sandboxCommand = CommandUI {
     [ optionVerbosity sandboxVerbosity
       (\v flags -> flags { sandboxVerbosity = v })
 
+    , option [] ["snapshot"]
+      "Take a snapshot instead of creating a link (only applies to 'add-source')"
+      sandboxSnapshot (\v flags -> flags { sandboxSnapshot = v })
+      trueArg
+
     , option [] ["sandbox"]
       "Sandbox location (default: './.cabal-sandbox')."
       sandboxLocation (\v flags -> flags { sandboxLocation = v })
@@ -1299,10 +1307,12 @@ sandboxCommand = CommandUI {
 instance Monoid SandboxFlags where
   mempty = SandboxFlags {
     sandboxVerbosity = mempty,
+    sandboxSnapshot  = mempty,
     sandboxLocation  = mempty
     }
   mappend a b = SandboxFlags {
     sandboxVerbosity = combine sandboxVerbosity,
+    sandboxSnapshot  = combine sandboxSnapshot,
     sandboxLocation  = combine sandboxLocation
     }
     where combine field = field a `mappend` field b