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