--  Copyright (C) 2009-2011 Petr Rockai
--
--  BSD3
-- | The plain format implementation resides in this module. The plain format
-- does not use any hashing and basically just wraps a normal filesystem tree
-- in the hashed-storage API.
--
-- NB. The 'read' function on Blobs coming from a plain tree is susceptible to
-- file content changes. Since we use mmap in 'read', this will break
-- referential transparency and produce unexpected results. Please always make
-- sure that all parallel access to the underlying filesystem tree never
-- mutates files. Unlink + recreate is fine though (in other words, the
-- 'writePlainTree' implemented in this module is safe in this respect).
module Darcs.Util.Tree.Plain
    ( -- * Obtaining Trees.
    --
    -- | Please note that Trees obtained this way will contain Stub
    -- items. These need to be executed (they are IO actions) in order to be
    -- accessed. Use 'expand' to do this. However, many operations are
    -- perfectly fine to be used on a stubbed Tree (and it is often more
    -- efficient to do everything that can be done before expanding a Tree).
      readPlainTree

    -- * Writing trees.
    , writePlainTree
    ) where

import Control.Monad ( forM )
import Data.Maybe( catMaybes )
import qualified Data.ByteString.Lazy as BL
import System.FilePath( (</>) )
import System.Directory ( listDirectory, createDirectoryIfMissing )
import System.Posix.Files
    ( getSymbolicLinkStatus, isDirectory, isRegularFile, FileStatus )

import Darcs.Prelude

import Darcs.Util.Path
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.ByteString ( readSegment )
import Darcs.Util.Hash( Hash( NoHash) )
import Darcs.Util.Tree( Tree(), TreeItem(..)
                          , Blob(..), makeTree
                          , list, readBlob, expand )

readPlainDir :: FilePath -> IO [(FilePath, FileStatus)]
readPlainDir :: FilePath -> IO [(FilePath, FileStatus)]
readPlainDir FilePath
dir =
  FilePath
-> IO [(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)]
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory FilePath
dir (IO [(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)])
-> IO [(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)]
forall a b. (a -> b) -> a -> b
$ do
    [FilePath]
items <- FilePath -> IO [FilePath]
listDirectory FilePath
"."
    [FilePath]
-> (FilePath -> IO (FilePath, FileStatus))
-> IO [(FilePath, FileStatus)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
items ((FilePath -> IO (FilePath, FileStatus))
 -> IO [(FilePath, FileStatus)])
-> (FilePath -> IO (FilePath, FileStatus))
-> IO [(FilePath, FileStatus)]
forall a b. (a -> b) -> a -> b
$ \FilePath
s -> do
      FileStatus
st <- FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
s
      (FilePath, FileStatus) -> IO (FilePath, FileStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
s, FileStatus
st)

readPlainTree :: FilePath -> IO (Tree IO)
readPlainTree :: FilePath -> IO (Tree IO)
readPlainTree FilePath
dir = do
  [(FilePath, FileStatus)]
items <- FilePath -> IO [(FilePath, FileStatus)]
readPlainDir FilePath
dir
  let subs :: [(Name, TreeItem IO)]
subs = [Maybe (Name, TreeItem IO)] -> [(Name, TreeItem IO)]
forall a. [Maybe a] -> [a]
catMaybes [
       let name :: Name
name = (FilePath -> Name)
-> (Name -> Name) -> Either FilePath Name -> Name
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> Name
forall a. HasCallStack => FilePath -> a
error Name -> Name
forall a. a -> a
id (Either FilePath Name -> Name) -> Either FilePath Name -> Name
forall a b. (a -> b) -> a -> b
$ FilePath -> Either FilePath Name
makeName FilePath
name'
        in case FileStatus
status of
             FileStatus
_ | FileStatus -> Bool
isDirectory FileStatus
status -> (Name, TreeItem IO) -> Maybe (Name, TreeItem IO)
forall a. a -> Maybe a
Just (Name
name, IO (Tree IO) -> Hash -> TreeItem IO
forall (m :: * -> *). m (Tree m) -> Hash -> TreeItem m
Stub (FilePath -> IO (Tree IO)
readPlainTree (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
name')) Hash
NoHash)
             FileStatus
_ | FileStatus -> Bool
isRegularFile FileStatus
status -> (Name, TreeItem IO) -> Maybe (Name, TreeItem IO)
forall a. a -> Maybe a
Just (Name
name, Blob IO -> TreeItem IO
forall (m :: * -> *). Blob m -> TreeItem m
File (Blob IO -> TreeItem IO) -> Blob IO -> TreeItem IO
forall a b. (a -> b) -> a -> b
$ IO ByteString -> Hash -> Blob IO
forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob (FilePath -> IO ByteString
readBlob' FilePath
name') Hash
NoHash)
             FileStatus
_ -> Maybe (Name, TreeItem IO)
forall a. Maybe a
Nothing
            | (FilePath
name', FileStatus
status) <- [(FilePath, FileStatus)]
items ]
  Tree IO -> IO (Tree IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO -> IO (Tree IO)) -> Tree IO -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ [(Name, TreeItem IO)] -> Tree IO
forall (m :: * -> *). [(Name, TreeItem m)] -> Tree m
makeTree [(Name, TreeItem IO)]
subs
    where readBlob' :: FilePath -> IO ByteString
readBlob' FilePath
name = FileSegment -> IO ByteString
readSegment (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
name, Maybe (Int64, Int)
forall a. Maybe a
Nothing)

-- | Write out /full/ tree to a plain directory structure. If you instead want
-- to make incremental updates, refer to "Darcs.Util.Tree.Monad".
writePlainTree :: Tree IO -> FilePath -> IO ()
writePlainTree :: Tree IO -> FilePath -> IO ()
writePlainTree Tree IO
t FilePath
dir = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
  Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree IO
t IO (Tree IO) -> (Tree IO -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((AnchoredPath, TreeItem IO) -> IO ())
-> [(AnchoredPath, TreeItem IO)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AnchoredPath, TreeItem IO) -> IO ()
write ([(AnchoredPath, TreeItem IO)] -> IO ())
-> (Tree IO -> [(AnchoredPath, TreeItem IO)]) -> Tree IO -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list
    where write :: (AnchoredPath, TreeItem IO) -> IO ()
write (AnchoredPath
p, File Blob IO
b) = AnchoredPath -> Blob IO -> IO ()
write' AnchoredPath
p Blob IO
b
          write (AnchoredPath
p, SubTree Tree IO
_) =
              Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> AnchoredPath -> FilePath
anchorPath FilePath
dir AnchoredPath
p)
          write (AnchoredPath, TreeItem IO)
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          write' :: AnchoredPath -> Blob IO -> IO ()
write' AnchoredPath
p Blob IO
b = Blob IO -> IO ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob IO
b IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
BL.writeFile (FilePath -> AnchoredPath -> FilePath
anchorPath FilePath
dir AnchoredPath
p)