-- Copyright (C) 2007 David Roundy
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software Foundation,
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# LANGUAGE MultiParamTypeClasses #-}


module Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed,
                                   cleanHashdir, getHashedFiles,
                                   pathsAndContents
                                 ) where

import Darcs.Prelude

import Darcs.Util.Global ( darcsdir )
import qualified Data.Set as Set
import System.Directory ( getDirectoryContents, createDirectoryIfMissing )
import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift, evalStateT )
import Control.Monad ( when, void, unless, guard )
import Data.Maybe ( isJust )
import System.IO.Unsafe ( unsafeInterleaveIO )

import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, writeFileUsingCache,
                                peekInCache, speculateFileUsingCache,
                                okayHash, cleanCachesWithHint, HashedDir(..), hashedDir )
import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) )
import Darcs.Repository.Flags ( Compression( .. ), WithWorkingDir (..) )
import Darcs.Repository.Inventory ( PristineHash, getValidHash, mkValidHash )
import Darcs.Util.Lock ( writeAtomicFilePS, removeFileMayNotExist )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Progress ( debugMessage, tediousSize, finishedOneIO )
import Darcs.Util.Path
    ( AnchoredPath
    , anchorPath
    , anchoredRoot
    , parent
    , breakOnDir
    , Name
    , name2fp
    , decodeWhiteName
    , encodeWhiteName
    , isMaliciousSubPath
    )

import Darcs.Util.ByteString ( linesPS, unlinesPS )
import qualified Data.ByteString       as B  (ByteString, length, empty)
import qualified Data.ByteString.Char8 as BC (unpack, pack)

import Darcs.Util.Tree.Hashed( readDarcsHashedDir, darcsLocation,
                             decodeDarcsHash, decodeDarcsSize )
import Darcs.Util.Tree( ItemType(..), Tree )

ap2fp :: AnchoredPath -> FilePath
ap2fp :: AnchoredPath -> [Char]
ap2fp = [Char] -> AnchoredPath -> [Char]
anchorPath [Char]
""


-- | @readHashFile c subdir hash@ reads the file with hash @hash@ in dir subdir,
-- fetching it from 'Cache' @c@ if needed. The return value is a pair of the
-- absolute file path and the content.
readHashFile :: Cache -> HashedDir -> PristineHash -> IO (FilePath,B.ByteString)
readHashFile :: Cache -> HashedDir -> PristineHash -> IO ([Char], ByteString)
readHashFile Cache
c HashedDir
subdir PristineHash
hash =
    do [Char] -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ [Char]
"Reading hash file "forall a. [a] -> [a] -> [a]
++forall a. ValidHash a => a -> [Char]
getValidHash PristineHash
hashforall a. [a] -> [a] -> [a]
++[Char]
" from "forall a. [a] -> [a] -> [a]
++HashedDir -> [Char]
hashedDir HashedDir
subdirforall a. [a] -> [a] -> [a]
++[Char]
"/"
       ([Char], ByteString)
r <- Cache -> HashedDir -> [Char] -> IO ([Char], ByteString)
fetchFileUsingCache Cache
c HashedDir
subdir (forall a. ValidHash a => a -> [Char]
getValidHash PristineHash
hash)
       [Char] -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ [Char]
"Result of reading hash file: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ([Char], ByteString)
r
       forall (m :: * -> *) a. Monad m => a -> m a
return ([Char], ByteString)
r

-- TODO an obvious optimization would be to remember
-- the current path and a stack of directories we opened.
-- Then we could batch operations in the same directory and write the
-- result back only when we pop a dir off teh stack.
data HashDir = HashDir { HashDir -> Cache
cache :: !Cache,
                         HashDir -> PristineHash
cwdHash :: !PristineHash }
type HashedIO = StateT HashDir IO

mWithSubDirectory :: Name -> HashedIO a -> HashedIO a
mWithSubDirectory :: forall a. Name -> HashedIO a -> HashedIO a
mWithSubDirectory Name
dir HashedIO a
j = do
  [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
  case ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta ObjType
D Name
dir [DirEntry]
cwd of
    Maybe PristineHash
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"dir doesn't exist in mWithSubDirectory..."
    Just PristineHash
h -> do
      (PristineHash
h', a
x) <- forall a. PristineHash -> HashedIO a -> HashedIO (PristineHash, a)
withh PristineHash
h HashedIO a
j
      -- update the parent object with new entry
      [DirEntry] -> HashedIO ()
writecwd forall a b. (a -> b) -> a -> b
$ ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]
seta ObjType
D Name
dir PristineHash
h' [DirEntry]
cwd
      forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | This is withCurrentDirectory for read-only actions.
mInSubDirectory :: Name -> HashedIO a -> HashedIO a
mInSubDirectory :: forall a. Name -> HashedIO a -> HashedIO a
mInSubDirectory Name
dir HashedIO a
j = do
  [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
  case ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta ObjType
D Name
dir [DirEntry]
cwd of
    Maybe PristineHash
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"dir doesn't exist..."
    Just PristineHash
h -> forall a. PristineHash -> HashedIO a -> HashedIO a
inh PristineHash
h HashedIO a
j

instance ApplyMonad Tree HashedIO where
    type ApplyMonadBase HashedIO = IO

instance ApplyMonadTree HashedIO where
    mDoesDirectoryExist :: AnchoredPath -> HashedIO Bool
mDoesDirectoryExist AnchoredPath
path = do
      Maybe (ObjType, PristineHash)
thing <- AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
path
      case Maybe (ObjType, PristineHash)
thing of
        Just (ObjType
D, PristineHash
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Maybe (ObjType, PristineHash)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

    mReadFilePS :: AnchoredPath -> HashedIO ByteString
mReadFilePS = AnchoredPath -> HashedIO ByteString
readFileObject

    mCreateDirectory :: AnchoredPath -> HashedIO ()
mCreateDirectory AnchoredPath
path = do
      PristineHash
h <- ByteString -> HashedIO PristineHash
writeHashFile ByteString
B.empty
      Bool
exists <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
path
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"can't mCreateDirectory over an existing object."
      AnchoredPath -> (ObjType, PristineHash) -> HashedIO ()
addThing AnchoredPath
path (ObjType
D, PristineHash
h)

    mRename :: AnchoredPath -> AnchoredPath -> HashedIO ()
mRename AnchoredPath
o AnchoredPath
n = do
      Bool
nexists <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
n
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nexists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"mRename failed..."
      Maybe (ObjType, PristineHash)
mx <- AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
o
                     -- for backwards compatibility accept rename of nonexistent files.
      case Maybe (ObjType, PristineHash)
mx of
        Maybe (ObjType, PristineHash)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (ObjType, PristineHash)
x -> do
          AnchoredPath -> HashedIO ()
rmThing AnchoredPath
o
          AnchoredPath -> (ObjType, PristineHash) -> HashedIO ()
addThing AnchoredPath
n (ObjType, PristineHash)
x

    mRemoveDirectory :: AnchoredPath -> HashedIO ()
mRemoveDirectory = AnchoredPath -> HashedIO ()
rmThing

    mRemoveFile :: AnchoredPath -> HashedIO ()
mRemoveFile AnchoredPath
f = do
      ByteString
x <- forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> m ByteString
mReadFilePS AnchoredPath
f
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
x forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot remove non-empty file " forall a. [a] -> [a] -> [a]
++ AnchoredPath -> [Char]
ap2fp AnchoredPath
f
      AnchoredPath -> HashedIO ()
rmThing AnchoredPath
f

readFileObject :: AnchoredPath -> HashedIO B.ByteString
readFileObject :: AnchoredPath -> HashedIO ByteString
readFileObject AnchoredPath
path
  | AnchoredPath
path forall a. Eq a => a -> a -> Bool
== AnchoredPath
anchoredRoot = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"root dir is not a file..."
  | Bool
otherwise =
      case AnchoredPath -> Either Name (Name, AnchoredPath)
breakOnDir AnchoredPath
path of
        Left Name
file -> do
          [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
          case ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta ObjType
F Name
file [DirEntry]
cwd of
                Maybe PristineHash
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"file doesn't exist..." forall a. [a] -> [a] -> [a]
++ AnchoredPath -> [Char]
ap2fp AnchoredPath
path
                Just PristineHash
h -> PristineHash -> HashedIO ByteString
readhash PristineHash
h
        Right (Name
name, AnchoredPath
path') -> do
          forall a. Name -> HashedIO a -> HashedIO a
mInSubDirectory Name
name forall a b. (a -> b) -> a -> b
$ AnchoredPath -> HashedIO ByteString
readFileObject AnchoredPath
path'

identifyThing :: AnchoredPath -> HashedIO (Maybe (ObjType,PristineHash))
identifyThing :: AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
path
  | AnchoredPath
path forall a. Eq a => a -> a -> Bool
== AnchoredPath
anchoredRoot = do
      PristineHash
h <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> PristineHash
cwdHash
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (ObjType
D, PristineHash
h)
  | Bool
otherwise =
      case AnchoredPath -> Either Name (Name, AnchoredPath)
breakOnDir AnchoredPath
path of
        Left Name
name -> Name -> [DirEntry] -> Maybe (ObjType, PristineHash)
getany Name
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HashedIO [DirEntry]
readcwd
        Right (Name
dir, AnchoredPath
path') -> do
          [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
          case ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta ObjType
D Name
dir [DirEntry]
cwd of
            Maybe PristineHash
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just PristineHash
h -> forall a. PristineHash -> HashedIO a -> HashedIO a
inh PristineHash
h forall a b. (a -> b) -> a -> b
$ AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
path'

addThing :: AnchoredPath -> (ObjType,PristineHash) -> HashedIO ()
addThing :: AnchoredPath -> (ObjType, PristineHash) -> HashedIO ()
addThing AnchoredPath
path (ObjType
o, PristineHash
h) =
  case AnchoredPath -> Either Name (Name, AnchoredPath)
breakOnDir AnchoredPath
path of
    Left Name
name -> ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]
seta ObjType
o Name
name PristineHash
h forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HashedIO [DirEntry]
readcwd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [DirEntry] -> HashedIO ()
writecwd
    Right (Name
name,AnchoredPath
path') -> forall a. Name -> HashedIO a -> HashedIO a
mWithSubDirectory Name
name forall a b. (a -> b) -> a -> b
$ AnchoredPath -> (ObjType, PristineHash) -> HashedIO ()
addThing AnchoredPath
path' (ObjType
o,PristineHash
h)

rmThing :: AnchoredPath -> HashedIO ()
rmThing :: AnchoredPath -> HashedIO ()
rmThing AnchoredPath
path = 
  case AnchoredPath -> Either Name (Name, AnchoredPath)
breakOnDir AnchoredPath
path of
    Left Name
name -> do
      [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
      let cwd' :: [DirEntry]
cwd' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(ObjType
_,Name
x,PristineHash
_)->Name
xforall a. Eq a => a -> a -> Bool
/= Name
name) [DirEntry]
cwd
      if forall (t :: * -> *) a. Foldable t => t a -> Int
length [DirEntry]
cwd' forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [DirEntry]
cwd forall a. Num a => a -> a -> a
- Int
1
        then [DirEntry] -> HashedIO ()
writecwd [DirEntry]
cwd'
        else forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"obj doesn't exist in rmThing"
    Right (Name
name,AnchoredPath
path') -> forall a. Name -> HashedIO a -> HashedIO a
mWithSubDirectory Name
name forall a b. (a -> b) -> a -> b
$ AnchoredPath -> HashedIO ()
rmThing AnchoredPath
path'

readhash :: PristineHash -> HashedIO B.ByteString
readhash :: PristineHash -> HashedIO ByteString
readhash PristineHash
h = do Cache
c <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> Cache
cache
                ([Char], ByteString)
z <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ Cache -> HashedDir -> PristineHash -> IO ([Char], ByteString)
readHashFile Cache
c HashedDir
HashedPristineDir PristineHash
h
                let ([Char]
_,ByteString
out) = ([Char], ByteString)
z
                forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out

withh :: PristineHash -> HashedIO a -> HashedIO (PristineHash,a)
withh :: forall a. PristineHash -> HashedIO a -> HashedIO (PristineHash, a)
withh PristineHash
h HashedIO a
j = do HashDir
hd <- forall s (m :: * -> *). MonadState s m => m s
get
               forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ HashDir
hd { cwdHash :: PristineHash
cwdHash = PristineHash
h }
               a
x <- HashedIO a
j
               PristineHash
h' <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> PristineHash
cwdHash
               forall s (m :: * -> *). MonadState s m => s -> m ()
put HashDir
hd
               forall (m :: * -> *) a. Monad m => a -> m a
return (PristineHash
h',a
x)

inh :: PristineHash -> HashedIO a -> HashedIO a
inh :: forall a. PristineHash -> HashedIO a -> HashedIO a
inh PristineHash
h HashedIO a
j = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. PristineHash -> HashedIO a -> HashedIO (PristineHash, a)
withh PristineHash
h HashedIO a
j

type DirEntry = (ObjType, Name, PristineHash)

readcwd :: HashedIO [DirEntry]
readcwd :: HashedIO [DirEntry]
readcwd = do Bool
haveitalready <- HashedIO Bool
peekroot
             [DirEntry]
cwd <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> PristineHash
cwdHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PristineHash -> HashedIO [DirEntry]
readdir
             forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
haveitalready forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b, PristineHash)] -> HashedIO ()
speculate [DirEntry]
cwd
             forall (m :: * -> *) a. Monad m => a -> m a
return [DirEntry]
cwd
    where speculate :: [(a,b,PristineHash)] -> HashedIO ()
          speculate :: forall a b. [(a, b, PristineHash)] -> HashedIO ()
speculate [(a, b, PristineHash)]
c = do Cache
cac <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> Cache
cache
                           forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(a
_,b
_,PristineHash
z) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Cache -> HashedDir -> [Char] -> IO ()
speculateFileUsingCache Cache
cac HashedDir
HashedPristineDir (forall a. ValidHash a => a -> [Char]
getValidHash PristineHash
z)) [(a, b, PristineHash)]
c
          peekroot :: HashedIO Bool
          peekroot :: HashedIO Bool
peekroot = do HashDir Cache
c PristineHash
h <- forall s (m :: * -> *). MonadState s m => m s
get
                        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Cache -> HashedDir -> [Char] -> IO Bool
peekInCache Cache
c HashedDir
HashedPristineDir (forall a. ValidHash a => a -> [Char]
getValidHash PristineHash
h)

writecwd :: [DirEntry] -> HashedIO ()
writecwd :: [DirEntry] -> HashedIO ()
writecwd [DirEntry]
c = do
  PristineHash
h <- [DirEntry] -> HashedIO PristineHash
writedir [DirEntry]
c
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \HashDir
hd -> HashDir
hd { cwdHash :: PristineHash
cwdHash = PristineHash
h }

data ObjType = F | D deriving ObjType -> ObjType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ObjType -> ObjType -> Bool
$c/= :: ObjType -> ObjType -> Bool
== :: ObjType -> ObjType -> Bool
$c== :: ObjType -> ObjType -> Bool
Eq

-- | @geta objtype name direntries@ tries to find an object of type @objtype@ named @name@
-- in @direntries@.
geta :: ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta :: ObjType -> Name -> [DirEntry] -> Maybe PristineHash
geta ObjType
o Name
f [DirEntry]
c = do
  (ObjType
o', PristineHash
h) <- Name -> [DirEntry] -> Maybe (ObjType, PristineHash)
getany Name
f [DirEntry]
c
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ObjType
o forall a. Eq a => a -> a -> Bool
== ObjType
o')
  forall (m :: * -> *) a. Monad m => a -> m a
return PristineHash
h

getany :: Name -> [DirEntry] -> Maybe (ObjType,PristineHash)
getany :: Name -> [DirEntry] -> Maybe (ObjType, PristineHash)
getany Name
_ [] = forall a. Maybe a
Nothing
getany Name
f ((ObjType
o,Name
f',PristineHash
h):[DirEntry]
_) | Name
f forall a. Eq a => a -> a -> Bool
== Name
f' = forall a. a -> Maybe a
Just (ObjType
o,PristineHash
h)
getany Name
f (DirEntry
_:[DirEntry]
r) = Name -> [DirEntry] -> Maybe (ObjType, PristineHash)
getany Name
f [DirEntry]
r

seta :: ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]
seta :: ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]
seta ObjType
o Name
f PristineHash
h [] = [(ObjType
o,Name
f,PristineHash
h)]
seta ObjType
o Name
f PristineHash
h ((ObjType
_,Name
f',PristineHash
_):[DirEntry]
r) | Name
f forall a. Eq a => a -> a -> Bool
== Name
f' = (ObjType
o,Name
f,PristineHash
h)forall a. a -> [a] -> [a]
:[DirEntry]
r
seta ObjType
o Name
f PristineHash
h (DirEntry
x:[DirEntry]
xs) = DirEntry
x forall a. a -> [a] -> [a]
: ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]
seta ObjType
o Name
f PristineHash
h [DirEntry]
xs

readdir :: PristineHash -> HashedIO [DirEntry]
readdir :: PristineHash -> HashedIO [DirEntry]
readdir PristineHash
hash = do
    ByteString
content <- PristineHash -> HashedIO ByteString
readhash PristineHash
hash
    -- lift $ debugMessage  $ show x
    let r :: [DirEntry]
r = (forall {c}. ValidHash c => [ByteString] -> [(ObjType, Name, c)]
parseLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
linesPS) ByteString
content
    --lift $ debugMessage  $ unlines $ map (\(_,path,_) -> "DEBUG readdir " ++
    --  hash ++ " entry: " ++ show path) r
    forall (m :: * -> *) a. Monad m => a -> m a
return [DirEntry]
r
  where
    parseLines :: [ByteString] -> [(ObjType, Name, c)]
parseLines (ByteString
t:ByteString
n:ByteString
h:[ByteString]
rest)
      | ByteString
t forall a. Eq a => a -> a -> Bool
== ByteString
dirType = (ObjType
D, ByteString -> Name
decodeWhiteName ByteString
n, forall a. ValidHash a => [Char] -> a
mkValidHash forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
BC.unpack ByteString
h) forall a. a -> [a] -> [a]
: [ByteString] -> [(ObjType, Name, c)]
parseLines [ByteString]
rest
      | ByteString
t forall a. Eq a => a -> a -> Bool
== ByteString
fileType = (ObjType
F, ByteString -> Name
decodeWhiteName ByteString
n, forall a. ValidHash a => [Char] -> a
mkValidHash forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
BC.unpack ByteString
h) forall a. a -> [a] -> [a]
: [ByteString] -> [(ObjType, Name, c)]
parseLines [ByteString]
rest
    parseLines [ByteString]
_ = []

dirType :: B.ByteString
dirType :: ByteString
dirType = [Char] -> ByteString
BC.pack [Char]
"directory:"

fileType :: B.ByteString
fileType :: ByteString
fileType = [Char] -> ByteString
BC.pack [Char]
"file:"

writedir :: [DirEntry] -> HashedIO PristineHash
writedir :: [DirEntry] -> HashedIO PristineHash
writedir [DirEntry]
c = do
  --lift $ debugMessage  $ unlines $ map (\(_,path,_) -> "DEBUG writedir entry: " ++ show path) c
  ByteString -> HashedIO PristineHash
writeHashFile ByteString
cps
  where
    cps :: ByteString
cps = [ByteString] -> ByteString
unlinesPS forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. ValidHash a => (ObjType, Name, a) -> [ByteString]
wr [DirEntry]
c forall a. [a] -> [a] -> [a]
++ [ByteString
B.empty]
    wr :: (ObjType, Name, a) -> [ByteString]
wr (ObjType
o,Name
d,a
h) = [ObjType -> ByteString
showO ObjType
o, Name -> ByteString
encodeWhiteName Name
d, [Char] -> ByteString
BC.pack (forall a. ValidHash a => a -> [Char]
getValidHash a
h)]
    showO :: ObjType -> ByteString
showO ObjType
D = ByteString
dirType
    showO ObjType
F = ByteString
fileType

writeHashFile :: B.ByteString -> HashedIO PristineHash
writeHashFile :: ByteString -> HashedIO PristineHash
writeHashFile ByteString
ps = do
  Cache
c <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> Cache
cache
  -- pristine files are always compressed
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. ValidHash a => [Char] -> a
mkValidHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cache -> Compression -> HashedDir -> ByteString -> IO [Char]
writeFileUsingCache Cache
c Compression
GzipCompression HashedDir
HashedPristineDir ByteString
ps

type ProgressKey = String

-- | Grab a whole pristine tree from a hash, and, if asked,
--   write files in the working tree.
copyHashed :: ProgressKey -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed :: [Char] -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed [Char]
k Cache
c WithWorkingDir
wwd PristineHash
z = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT HashedIO ()
cph forall a b. (a -> b) -> a -> b
$ HashDir { cache :: Cache
cache = Cache
c, cwdHash :: PristineHash
cwdHash = PristineHash
z }
    where cph :: HashedIO ()
cph = do [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
                   forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> IO ()
tediousSize [Char]
k (forall (t :: * -> *) a. Foldable t => t a -> Int
length [DirEntry]
cwd)
                   forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DirEntry -> HashedIO ()
cp [DirEntry]
cwd
          cp :: DirEntry -> HashedIO ()
cp (ObjType
F,Name
n,PristineHash
h) = do
              ByteString
ps <- PristineHash -> HashedIO ByteString
readhash PristineHash
h
              forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k forall a b. (a -> b) -> a -> b
$ Name -> [Char]
name2fp Name
n
              --lift $ debugMessage $ "DEBUG copyHashed " ++ show n
              case WithWorkingDir
wwd of
                WithWorkingDir
WithWorkingDir -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (Name -> [Char]
name2fp Name
n) ByteString
ps
                WithWorkingDir
NoWorkingDir   -> ByteString
ps seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                  -- force evaluation of ps to actually copy hashed file
          cp (ObjType
D,Name
n,PristineHash
h) =
              if [Char] -> Bool
isMaliciousSubPath (Name -> [Char]
name2fp Name
n)
                 then forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Caught malicious path: " forall a. [a] -> [a] -> [a]
++ Name -> [Char]
name2fp Name
n)
                 else do
                 forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k (Name -> [Char]
name2fp Name
n)
                 case WithWorkingDir
wwd of
                   WithWorkingDir
WithWorkingDir -> do
                     forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
False (Name -> [Char]
name2fp Name
n)
                     forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (Name -> [Char]
name2fp Name
n) forall a b. (a -> b) -> a -> b
$ [Char] -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed [Char]
k Cache
c WithWorkingDir
WithWorkingDir PristineHash
h
                   WithWorkingDir
NoWorkingDir ->
                     forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed [Char]
k Cache
c WithWorkingDir
NoWorkingDir PristineHash
h

-- | Returns a list of pairs (FilePath, (strict) ByteString) of
--   the pristine tree starting with the hash @root@.
--   @path@ should be either "." or end with "/"
--   Separator "/" is used since this function is used to generate
--   zip archives from pristine trees.
pathsAndContents :: FilePath -> Cache ->  PristineHash -> IO [(FilePath,B.ByteString)]
pathsAndContents :: [Char] -> Cache -> PristineHash -> IO [([Char], ByteString)]
pathsAndContents [Char]
path Cache
c PristineHash
root = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT HashDir IO [([Char], ByteString)]
cph HashDir { cache :: Cache
cache = Cache
c, cwdHash :: PristineHash
cwdHash = PristineHash
root }
    where cph :: StateT HashDir IO [([Char], ByteString)]
cph = do [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
                   [([Char], ByteString)]
pacs <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DirEntry -> StateT HashDir IO [([Char], ByteString)]
cp [DirEntry]
cwd
                   let current :: [([Char], ByteString)]
current = if [Char]
path forall a. Eq a => a -> a -> Bool
== [Char]
"." then [] else [([Char]
path forall a. [a] -> [a] -> [a]
++ [Char]
"/" , ByteString
B.empty)]
                   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [([Char], ByteString)]
current forall a. [a] -> [a] -> [a]
++ [([Char], ByteString)]
pacs
          cp :: DirEntry -> StateT HashDir IO [([Char], ByteString)]
cp (ObjType
F,Name
n,PristineHash
h) = do
              ByteString
ps <- PristineHash -> HashedIO ByteString
readhash PristineHash
h
              let p :: [Char]
p = (if [Char]
path forall a. Eq a => a -> a -> Bool
== [Char]
"." then [Char]
"" else [Char]
path forall a. [a] -> [a] -> [a]
++ [Char]
"/") forall a. [a] -> [a] -> [a]
++ Name -> [Char]
name2fp Name
n
              forall (m :: * -> *) a. Monad m => a -> m a
return [([Char]
p,ByteString
ps)]
          cp (ObjType
D,Name
n,PristineHash
h) = do
              let p :: [Char]
p = (if [Char]
path forall a. Eq a => a -> a -> Bool
== [Char]
"." then [Char]
"" else [Char]
path) forall a. [a] -> [a] -> [a]
++ Name -> [Char]
name2fp Name
n forall a. [a] -> [a] -> [a]
++ [Char]
"/"
              forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Char] -> Cache -> PristineHash -> IO [([Char], ByteString)]
pathsAndContents [Char]
p Cache
c PristineHash
h

copyPartialsHashed :: Cache -> PristineHash -> [AnchoredPath] -> IO ()
copyPartialsHashed :: Cache -> PristineHash -> [AnchoredPath] -> IO ()
copyPartialsHashed Cache
c PristineHash
root = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Cache -> PristineHash -> AnchoredPath -> IO ()
copyPartialHashed Cache
c PristineHash
root)

copyPartialHashed :: Cache -> PristineHash -> AnchoredPath -> IO ()
copyPartialHashed :: Cache -> PristineHash -> AnchoredPath -> IO ()
copyPartialHashed Cache
c PristineHash
root AnchoredPath
path = do
    case AnchoredPath -> Maybe AnchoredPath
parent AnchoredPath
path of
      Maybe AnchoredPath
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just AnchoredPath
super ->
        Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (AnchoredPath -> [Char]
ap2fp AnchoredPath
super)
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT HashedIO ()
copy HashDir {cache :: Cache
cache = Cache
c, cwdHash :: PristineHash
cwdHash = PristineHash
root}
  where
    copy :: HashedIO ()
copy = do
      Maybe (ObjType, PristineHash)
mt <- AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
path
      case Maybe (ObjType, PristineHash)
mt of
        Just (ObjType
D, PristineHash
h) -> do
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (AnchoredPath -> [Char]
ap2fp AnchoredPath
path)
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
            forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (AnchoredPath -> [Char]
ap2fp AnchoredPath
path) forall a b. (a -> b) -> a -> b
$ [Char] -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed [Char]
"" Cache
c WithWorkingDir
WithWorkingDir PristineHash
h
        Just (ObjType
F, PristineHash
h) -> do
          ByteString
ps <- PristineHash -> HashedIO ByteString
readhash PristineHash
h
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (AnchoredPath -> [Char]
ap2fp AnchoredPath
path) ByteString
ps
        Maybe (ObjType, PristineHash)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- hmm, ignore unknown paths, maybe better fail?

cleanHashdir :: Cache -> HashedDir -> [PristineHash] -> IO ()
cleanHashdir :: Cache -> HashedDir -> [PristineHash] -> IO ()
cleanHashdir Cache
c HashedDir
dir [PristineHash]
hashroots =
   do -- we'll remove obsolete bits of "dir"
      [Char] -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ [Char]
"Cleaning out " forall a. [a] -> [a] -> [a]
++ HashedDir -> [Char]
hashedDir HashedDir
dir forall a. [a] -> [a] -> [a]
++ [Char]
"..."
      let hashdir :: [Char]
hashdir = [Char]
darcsdir forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ HashedDir -> [Char]
hashedDir HashedDir
dir forall a. [a] -> [a] -> [a]
++ [Char]
"/"
      Set ByteString
hs <- [[Char]] -> Set ByteString
set forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [[Char]] -> IO [[Char]]
getHashedFiles [Char]
hashdir (forall a b. (a -> b) -> [a] -> [b]
map forall a. ValidHash a => a -> [Char]
getValidHash [PristineHash]
hashroots)
      Set ByteString
fs <- [[Char]] -> Set ByteString
set forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
okayHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
getDirectoryContents [Char]
hashdir
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
hashdirforall a. [a] -> [a] -> [a]
++)) (Set ByteString -> [[Char]]
unset forall a b. (a -> b) -> a -> b
$ Set ByteString
fs forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ByteString
hs)
      -- and also clean out any global caches.
      [Char] -> IO ()
debugMessage [Char]
"Cleaning out any global caches..."
      Cache -> HashedDir -> [[Char]] -> IO ()
cleanCachesWithHint Cache
c HashedDir
dir (Set ByteString -> [[Char]]
unset forall a b. (a -> b) -> a -> b
$ Set ByteString
fs forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ByteString
hs)
   where set :: [[Char]] -> Set ByteString
set = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [Char] -> ByteString
BC.pack
         unset :: Set ByteString -> [[Char]]
unset = forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [Char]
BC.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList

-- | getHashedFiles returns all hash files targeted by files in hashroots in
-- the hashdir directory.
getHashedFiles :: FilePath -> [String] -> IO [String]
getHashedFiles :: [Char] -> [[Char]] -> IO [[Char]]
getHashedFiles [Char]
hashdir [[Char]]
hashroots = do
  let listone :: [Char] -> IO [[Char]]
listone [Char]
h = do
        let size :: Maybe Int
size = ByteString -> Maybe Int
decodeDarcsSize forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BC.pack [Char]
h
            hash :: Hash
hash = ByteString -> Hash
decodeDarcsHash forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BC.pack [Char]
h
        [(ItemType, Name, Maybe Int, Hash)]
x <- [Char]
-> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]
readDarcsHashedDir [Char]
hashdir (Maybe Int
size, Hash
hash)
        let subs :: [[Char]]
subs = [forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ [Char] -> (Maybe Int, Hash) -> FileSegment
darcsLocation [Char]
"" (Maybe Int
s, Hash
h') | (ItemType
TreeType, Name
_, Maybe Int
s, Hash
h') <- [(ItemType, Name, Maybe Int, Hash)]
x]
            hashes :: [[Char]]
hashes = [Char]
h forall a. a -> [a] -> [a]
: [forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ [Char] -> (Maybe Int, Hash) -> FileSegment
darcsLocation [Char]
"" (Maybe Int
s, Hash
h') | (ItemType
_, Name
_, Maybe Int
s, Hash
h') <- [(ItemType, Name, Maybe Int, Hash)]
x]
        ([[Char]]
hashes forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Char] -> IO [[Char]]
listone [[Char]]
subs
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Char] -> IO [[Char]]
listone [[Char]]
hashroots