1----------------------------------------------------------------------------- 2-- | 3-- Module : Distribution.Client.Sandbox.Index 4-- Maintainer : cabal-devel@haskell.org 5-- Portability : portable 6-- 7-- Querying and modifying local build tree references in the package index. 8----------------------------------------------------------------------------- 9 10module Distribution.Client.Sandbox.Index ( 11 createEmpty, 12 addBuildTreeRefs, 13 removeBuildTreeRefs, 14 ListIgnoredBuildTreeRefs(..), RefTypesToList(..), 15 DeleteSourceError(..), 16 listBuildTreeRefs, 17 validateIndexPath, 18 19 defaultIndexFileName 20 ) where 21 22import qualified Codec.Archive.Tar as Tar 23import qualified Codec.Archive.Tar.Entry as Tar 24import qualified Codec.Archive.Tar.Index as Tar 25import qualified Distribution.Client.Tar as Tar 26import Distribution.Client.IndexUtils ( BuildTreeRefType(..) 27 , refTypeFromTypeCode 28 , typeCodeFromRefType 29 , updatePackageIndexCacheFile 30 , readCacheStrict 31 , Index(..) ) 32import qualified Distribution.Client.IndexUtils as IndexUtils 33import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString 34 , makeAbsoluteToCwd, tryCanonicalizePath 35 , tryFindAddSourcePackageDesc ) 36 37import Distribution.Simple.Utils ( die', debug ) 38import Distribution.Compat.Exception ( tryIO ) 39import Distribution.Verbosity ( Verbosity ) 40 41import qualified Data.ByteString.Lazy as BS 42import Control.DeepSeq ( NFData(rnf) ) 43import Control.Exception ( evaluate, throw, Exception ) 44import Control.Monad ( liftM, unless ) 45import Control.Monad.Writer.Lazy (WriterT(..), runWriterT, tell) 46import Data.List ( (\\), intersect, nub, find ) 47import Data.Maybe ( catMaybes ) 48import Data.Either (partitionEithers) 49import System.Directory ( createDirectoryIfMissing, 50 doesDirectoryExist, doesFileExist, 51 renameFile, canonicalizePath) 52import System.FilePath ( (</>), (<.>), takeDirectory, takeExtension ) 53import System.IO ( IOMode(..), withBinaryFile ) 54 55-- | A reference to a local build tree. 56data BuildTreeRef = BuildTreeRef { 57 buildTreeRefType :: !BuildTreeRefType, 58 buildTreePath :: !FilePath 59 } 60 61instance NFData BuildTreeRef where 62 rnf (BuildTreeRef _ fp) = rnf fp 63 64defaultIndexFileName :: FilePath 65defaultIndexFileName = "00-index.tar" 66 67-- | Given a path, ensure that it refers to a local build tree. 68buildTreeRefFromPath :: Verbosity -> BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef) 69buildTreeRefFromPath verbosity refType dir = do 70 dirExists <- doesDirectoryExist dir 71 unless dirExists $ 72 die' verbosity $ "directory '" ++ dir ++ "' does not exist" 73 _ <- tryFindAddSourcePackageDesc verbosity dir "Error adding source reference." 74 return . Just $ BuildTreeRef refType dir 75 76-- | Given a tar archive entry, try to parse it as a local build tree reference. 77readBuildTreeRef :: Tar.Entry -> Maybe BuildTreeRef 78readBuildTreeRef entry = case Tar.entryContent entry of 79 (Tar.OtherEntryType typeCode bs size) 80 | (Tar.isBuildTreeRefTypeCode typeCode) 81 && (size == BS.length bs) -> Just $! BuildTreeRef 82 (refTypeFromTypeCode typeCode) 83 (byteStringToFilePath bs) 84 | otherwise -> Nothing 85 _ -> Nothing 86 87-- | Given a sequence of tar archive entries, extract all references to local 88-- build trees. 89readBuildTreeRefs :: Exception e => Tar.Entries e -> [BuildTreeRef] 90readBuildTreeRefs = 91 catMaybes 92 . Tar.foldEntries (\e r -> readBuildTreeRef e : r) 93 [] throw 94 95-- | Given a path to a tar archive, extract all references to local build trees. 96readBuildTreeRefsFromFile :: FilePath -> IO [BuildTreeRef] 97readBuildTreeRefsFromFile = liftM (readBuildTreeRefs . Tar.read) . BS.readFile 98 99-- | Read build tree references from an index cache 100readBuildTreeRefsFromCache :: Verbosity -> FilePath -> IO [BuildTreeRef] 101readBuildTreeRefsFromCache verbosity indexPath = do 102 (mRefs, _prefs) <- readCacheStrict verbosity (SandboxIndex indexPath) buildTreeRef 103 return (catMaybes mRefs) 104 where 105 buildTreeRef pkgEntry = 106 case pkgEntry of 107 IndexUtils.NormalPackage _ _ _ _ -> Nothing 108 IndexUtils.BuildTreeRef typ _ _ path _ -> Just $ BuildTreeRef typ path 109 110-- | Given a local build tree ref, serialise it to a tar archive entry. 111writeBuildTreeRef :: BuildTreeRef -> Tar.Entry 112writeBuildTreeRef (BuildTreeRef refType path) = Tar.simpleEntry tarPath content 113 where 114 bs = filePathToByteString path 115 -- Provide a filename for tools that treat custom entries as ordinary files. 116 tarPath' = "local-build-tree-reference" 117 -- fromRight can't fail because the path is shorter than 255 characters. 118 tarPath = fromRight $ Tar.toTarPath True tarPath' 119 content = Tar.OtherEntryType (typeCodeFromRefType refType) bs (BS.length bs) 120 121 -- TODO: Move this to D.C.Utils? 122 fromRight (Left err) = error err 123 fromRight (Right a) = a 124 125-- | Check that the provided path is either an existing directory, or a tar 126-- archive in an existing directory. 127validateIndexPath :: Verbosity -> FilePath -> IO FilePath 128validateIndexPath verbosity path' = do 129 path <- makeAbsoluteToCwd path' 130 if (== ".tar") . takeExtension $ path 131 then return path 132 else do dirExists <- doesDirectoryExist path 133 unless dirExists $ 134 die' verbosity $ "directory does not exist: '" ++ path ++ "'" 135 return $ path </> defaultIndexFileName 136 137-- | Create an empty index file. 138createEmpty :: Verbosity -> FilePath -> IO () 139createEmpty verbosity path = do 140 indexExists <- doesFileExist path 141 if indexExists 142 then debug verbosity $ "Package index already exists: " ++ path 143 else do 144 debug verbosity $ "Creating the index file '" ++ path ++ "'" 145 createDirectoryIfMissing True (takeDirectory path) 146 -- Equivalent to 'tar cvf empty.tar --files-from /dev/null'. 147 let zeros = BS.replicate (512*20) 0 148 BS.writeFile path zeros 149 150-- | Add given local build tree references to the index. 151addBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> BuildTreeRefType 152 -> IO () 153addBuildTreeRefs _ _ [] _ = 154 error "Distribution.Client.Sandbox.Index.addBuildTreeRefs: unexpected" 155addBuildTreeRefs verbosity path l' refType = do 156 checkIndexExists verbosity path 157 l <- liftM nub . mapM tryCanonicalizePath $ l' 158 treesInIndex <- fmap (map buildTreePath) (readBuildTreeRefsFromFile path) 159 -- Add only those paths that aren't already in the index. 160 treesToAdd <- mapM (buildTreeRefFromPath verbosity refType) (l \\ treesInIndex) 161 let entries = map writeBuildTreeRef (catMaybes treesToAdd) 162 unless (null entries) $ do 163 withBinaryFile path ReadWriteMode $ \h -> do 164 block <- Tar.hSeekEndEntryOffset h Nothing 165 debug verbosity $ "Writing at tar block: " ++ show block 166 BS.hPut h (Tar.write entries) 167 debug verbosity $ "Successfully appended to '" ++ path ++ "'" 168 updatePackageIndexCacheFile verbosity $ SandboxIndex path 169 170data DeleteSourceError = ErrNonregisteredSource { nrPath :: FilePath } 171 | ErrNonexistentSource { nePath :: FilePath } deriving Show 172 173-- | Remove given local build tree references from the index. 174-- 175-- Returns a tuple with either removed build tree refs or errors and a function 176-- that converts from a provided build tree ref to corresponding full directory path. 177removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] 178 -> IO ([Either DeleteSourceError FilePath], 179 (FilePath -> FilePath)) 180removeBuildTreeRefs _ _ [] = 181 error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected" 182removeBuildTreeRefs verbosity indexPath l = do 183 checkIndexExists verbosity indexPath 184 let tmpFile = indexPath <.> "tmp" 185 186 canonRes <- mapM (\btr -> do res <- tryIO $ canonicalizePath btr 187 return $ case res of 188 Right pth -> Right (btr, pth) 189 Left _ -> Left $ ErrNonexistentSource btr) l 190 let (failures, convDict) = partitionEithers canonRes 191 allRefs = fmap snd convDict 192 193 -- Performance note: on my system, it takes 'index --remove-source' 194 -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be 195 -- much smaller. 196 removedRefs <- doRemove convDict tmpFile 197 198 renameFile tmpFile indexPath 199 debug verbosity $ "Successfully renamed '" ++ tmpFile 200 ++ "' to '" ++ indexPath ++ "'" 201 202 unless (null removedRefs) $ 203 updatePackageIndexCacheFile verbosity $ SandboxIndex indexPath 204 205 let results = fmap Right removedRefs 206 ++ fmap Left failures 207 ++ fmap (Left . ErrNonregisteredSource) 208 (fmap (convertWith convDict) (allRefs \\ removedRefs)) 209 210 return (results, convertWith convDict) 211 212 where 213 doRemove :: [(FilePath, FilePath)] -> FilePath -> IO [FilePath] 214 doRemove srcRefs tmpFile = do 215 (newIdx, changedPaths) <- 216 Tar.read `fmap` BS.readFile indexPath 217 >>= runWriterT . Tar.filterEntriesM (p $ fmap snd srcRefs) 218 BS.writeFile tmpFile . Tar.write . Tar.entriesToList $ newIdx 219 return changedPaths 220 221 p :: [FilePath] -> Tar.Entry -> WriterT [FilePath] IO Bool 222 p refs entry = case readBuildTreeRef entry of 223 Nothing -> return True 224 -- FIXME: removing snapshot deps is done with `delete-source 225 -- .cabal-sandbox/snapshots/$SNAPSHOT_NAME`. Perhaps we also want to 226 -- support removing snapshots by providing the original path. 227 (Just (BuildTreeRef _ pth)) -> if pth `elem` refs 228 then tell [pth] >> return False 229 else return True 230 231 convertWith dict pth = maybe pth fst $ find ((==pth) . snd) dict 232 233-- | A build tree ref can become ignored if the user later adds a build tree ref 234-- with the same package ID. We display ignored build tree refs when the user 235-- runs 'cabal sandbox list-sources', but do not look at their timestamps in 236-- 'reinstallAddSourceDeps'. 237data ListIgnoredBuildTreeRefs = ListIgnored | DontListIgnored 238 239-- | Which types of build tree refs should be listed? 240data RefTypesToList = OnlySnapshots | OnlyLinks | LinksAndSnapshots 241 242-- | List the local build trees that are referred to from the index. 243listBuildTreeRefs :: Verbosity -> ListIgnoredBuildTreeRefs -> RefTypesToList 244 -> FilePath 245 -> IO [FilePath] 246listBuildTreeRefs verbosity listIgnored refTypesToList path = do 247 checkIndexExists verbosity path 248 buildTreeRefs <- 249 case listIgnored of 250 DontListIgnored -> do 251 paths <- listWithoutIgnored 252 case refTypesToList of 253 LinksAndSnapshots -> return paths 254 _ -> do 255 allPathsFiltered <- fmap (map buildTreePath . filter predicate) 256 listWithIgnored 257 _ <- evaluate (length allPathsFiltered) 258 return (paths `intersect` allPathsFiltered) 259 260 ListIgnored -> fmap (map buildTreePath . filter predicate) listWithIgnored 261 262 _ <- evaluate (length buildTreeRefs) 263 return buildTreeRefs 264 265 where 266 predicate :: BuildTreeRef -> Bool 267 predicate = case refTypesToList of 268 OnlySnapshots -> (==) SnapshotRef . buildTreeRefType 269 OnlyLinks -> (==) LinkRef . buildTreeRefType 270 LinksAndSnapshots -> const True 271 272 listWithIgnored :: IO [BuildTreeRef] 273 listWithIgnored = readBuildTreeRefsFromFile path 274 275 listWithoutIgnored :: IO [FilePath] 276 listWithoutIgnored = fmap (map buildTreePath) 277 $ readBuildTreeRefsFromCache verbosity path 278 279 280-- | Check that the package index file exists and exit with error if it does not. 281checkIndexExists :: Verbosity -> FilePath -> IO () 282checkIndexExists verbosity path = do 283 indexExists <- doesFileExist path 284 unless indexExists $ 285 die' verbosity $ "index does not exist: '" ++ path ++ "'" 286