-- 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 -> FilePath
ap2fp = FilePath -> AnchoredPath -> FilePath
anchorPath FilePath
""


-- | @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 (FilePath, ByteString)
readHashFile Cache
c HashedDir
subdir PristineHash
hash =
    do FilePath -> IO ()
debugMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Reading hash file "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++PristineHash -> FilePath
forall a. ValidHash a => a -> FilePath
getValidHash PristineHash
hashFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" from "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++HashedDir -> FilePath
hashedDir HashedDir
subdirFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"/"
       (FilePath, ByteString)
r <- Cache -> HashedDir -> FilePath -> IO (FilePath, ByteString)
fetchFileUsingCache Cache
c HashedDir
subdir (PristineHash -> FilePath
forall a. ValidHash a => a -> FilePath
getValidHash PristineHash
hash)
       FilePath -> IO ()
debugMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Result of reading hash file: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath, ByteString) -> FilePath
forall a. Show a => a -> FilePath
show (FilePath, ByteString)
r
       (FilePath, ByteString) -> IO (FilePath, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath, 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 :: 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 -> FilePath -> HashedIO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"dir doesn't exist in mWithSubDirectory..."
    Just PristineHash
h -> do
      (PristineHash
h', a
x) <- PristineHash -> HashedIO a -> HashedIO (PristineHash, a)
forall a. PristineHash -> HashedIO a -> HashedIO (PristineHash, a)
withh PristineHash
h HashedIO a
j
      -- update the parent object with new entry
      [DirEntry] -> HashedIO ()
writecwd ([DirEntry] -> HashedIO ()) -> [DirEntry] -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ ObjType -> Name -> PristineHash -> [DirEntry] -> [DirEntry]
seta ObjType
D Name
dir PristineHash
h' [DirEntry]
cwd
      a -> HashedIO a
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 :: 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 -> FilePath -> HashedIO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"dir doesn't exist..."
    Just PristineHash
h -> PristineHash -> HashedIO a -> HashedIO a
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
_) -> Bool -> HashedIO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Maybe (ObjType, PristineHash)
_ -> Bool -> HashedIO Bool
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 <- Maybe (ObjType, PristineHash) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ObjType, PristineHash) -> Bool)
-> HashedIO (Maybe (ObjType, PristineHash)) -> HashedIO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
path
      Bool -> HashedIO () -> HashedIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (HashedIO () -> HashedIO ()) -> HashedIO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> HashedIO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"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 <- Maybe (ObjType, PristineHash) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ObjType, PristineHash) -> Bool)
-> HashedIO (Maybe (ObjType, PristineHash)) -> HashedIO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` AnchoredPath -> HashedIO (Maybe (ObjType, PristineHash))
identifyThing AnchoredPath
n
      Bool -> HashedIO () -> HashedIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nexists (HashedIO () -> HashedIO ()) -> HashedIO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> HashedIO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"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 -> () -> HashedIO ()
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 <- AnchoredPath -> HashedIO ByteString
forall (m :: * -> *).
ApplyMonadTree m =>
AnchoredPath -> m ByteString
mReadFilePS AnchoredPath
f
      Bool -> HashedIO () -> HashedIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (HashedIO () -> HashedIO ()) -> HashedIO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> HashedIO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> HashedIO ()) -> FilePath -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot remove non-empty file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
ap2fp AnchoredPath
f
      AnchoredPath -> HashedIO ()
rmThing AnchoredPath
f

readFileObject :: AnchoredPath -> HashedIO B.ByteString
readFileObject :: AnchoredPath -> HashedIO ByteString
readFileObject AnchoredPath
path
  | AnchoredPath
path AnchoredPath -> AnchoredPath -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredPath
anchoredRoot = FilePath -> HashedIO ByteString
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"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 -> FilePath -> HashedIO ByteString
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> HashedIO ByteString)
-> FilePath -> HashedIO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"file doesn't exist..." FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> FilePath
ap2fp AnchoredPath
path
                Just PristineHash
h -> PristineHash -> HashedIO ByteString
readhash PristineHash
h
        Right (Name
name, AnchoredPath
path') -> do
          Name -> HashedIO ByteString -> HashedIO ByteString
forall a. Name -> HashedIO a -> HashedIO a
mInSubDirectory Name
name (HashedIO ByteString -> HashedIO ByteString)
-> HashedIO ByteString -> HashedIO ByteString
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 AnchoredPath -> AnchoredPath -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredPath
anchoredRoot = do
      PristineHash
h <- (HashDir -> PristineHash) -> HashedIO PristineHash
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> PristineHash
cwdHash
      Maybe (ObjType, PristineHash)
-> HashedIO (Maybe (ObjType, PristineHash))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ObjType, PristineHash)
 -> HashedIO (Maybe (ObjType, PristineHash)))
-> Maybe (ObjType, PristineHash)
-> HashedIO (Maybe (ObjType, PristineHash))
forall a b. (a -> b) -> a -> b
$ (ObjType, PristineHash) -> Maybe (ObjType, PristineHash)
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 ([DirEntry] -> Maybe (ObjType, PristineHash))
-> HashedIO [DirEntry] -> HashedIO (Maybe (ObjType, PristineHash))
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 -> Maybe (ObjType, PristineHash)
-> HashedIO (Maybe (ObjType, PristineHash))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ObjType, PristineHash)
forall a. Maybe a
Nothing
            Just PristineHash
h -> PristineHash
-> HashedIO (Maybe (ObjType, PristineHash))
-> HashedIO (Maybe (ObjType, PristineHash))
forall a. PristineHash -> HashedIO a -> HashedIO a
inh PristineHash
h (HashedIO (Maybe (ObjType, PristineHash))
 -> HashedIO (Maybe (ObjType, PristineHash)))
-> HashedIO (Maybe (ObjType, PristineHash))
-> HashedIO (Maybe (ObjType, PristineHash))
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 ([DirEntry] -> [DirEntry])
-> HashedIO [DirEntry] -> HashedIO [DirEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HashedIO [DirEntry]
readcwd HashedIO [DirEntry] -> ([DirEntry] -> HashedIO ()) -> HashedIO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [DirEntry] -> HashedIO ()
writecwd
    Right (Name
name,AnchoredPath
path') -> Name -> HashedIO () -> HashedIO ()
forall a. Name -> HashedIO a -> HashedIO a
mWithSubDirectory Name
name (HashedIO () -> HashedIO ()) -> HashedIO () -> HashedIO ()
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' = (DirEntry -> Bool) -> [DirEntry] -> [DirEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ObjType
_,Name
x,PristineHash
_)->Name
xName -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
name) [DirEntry]
cwd
      if [DirEntry] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DirEntry]
cwd' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [DirEntry] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DirEntry]
cwd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        then [DirEntry] -> HashedIO ()
writecwd [DirEntry]
cwd'
        else FilePath -> HashedIO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"obj doesn't exist in rmThing"
    Right (Name
name,AnchoredPath
path') -> Name -> HashedIO () -> HashedIO ()
forall a. Name -> HashedIO a -> HashedIO a
mWithSubDirectory Name
name (HashedIO () -> HashedIO ()) -> HashedIO () -> HashedIO ()
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 <- (HashDir -> Cache) -> StateT HashDir IO Cache
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> Cache
cache
                (FilePath, ByteString)
z <- IO (FilePath, ByteString)
-> StateT HashDir IO (FilePath, ByteString)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (FilePath, ByteString)
 -> StateT HashDir IO (FilePath, ByteString))
-> IO (FilePath, ByteString)
-> StateT HashDir IO (FilePath, ByteString)
forall a b. (a -> b) -> a -> b
$ IO (FilePath, ByteString) -> IO (FilePath, ByteString)
forall a. IO a -> IO a
unsafeInterleaveIO (IO (FilePath, ByteString) -> IO (FilePath, ByteString))
-> IO (FilePath, ByteString) -> IO (FilePath, ByteString)
forall a b. (a -> b) -> a -> b
$ Cache -> HashedDir -> PristineHash -> IO (FilePath, ByteString)
readHashFile Cache
c HashedDir
HashedPristineDir PristineHash
h
                let (FilePath
_,ByteString
out) = (FilePath, ByteString)
z
                ByteString -> HashedIO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out

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

inh :: PristineHash -> HashedIO a -> HashedIO a
inh :: PristineHash -> HashedIO a -> HashedIO a
inh PristineHash
h HashedIO a
j = (PristineHash, a) -> a
forall a b. (a, b) -> b
snd ((PristineHash, a) -> a)
-> StateT HashDir IO (PristineHash, a) -> HashedIO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` PristineHash -> HashedIO a -> StateT HashDir IO (PristineHash, a)
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 <- (HashDir -> PristineHash) -> HashedIO PristineHash
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> PristineHash
cwdHash HashedIO PristineHash
-> (PristineHash -> HashedIO [DirEntry]) -> HashedIO [DirEntry]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PristineHash -> HashedIO [DirEntry]
readdir
             Bool -> HashedIO () -> HashedIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
haveitalready (HashedIO () -> HashedIO ()) -> HashedIO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ [DirEntry] -> HashedIO ()
forall a b. [(a, b, PristineHash)] -> HashedIO ()
speculate [DirEntry]
cwd
             [DirEntry] -> HashedIO [DirEntry]
forall (m :: * -> *) a. Monad m => a -> m a
return [DirEntry]
cwd
    where speculate :: [(a,b,PristineHash)] -> HashedIO ()
          speculate :: [(a, b, PristineHash)] -> HashedIO ()
speculate [(a, b, PristineHash)]
c = do Cache
cac <- (HashDir -> Cache) -> StateT HashDir IO Cache
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> Cache
cache
                           ((a, b, PristineHash) -> HashedIO ())
-> [(a, b, PristineHash)] -> HashedIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(a
_,b
_,PristineHash
z) -> IO () -> HashedIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> HashedIO ()) -> IO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ Cache -> HashedDir -> FilePath -> IO ()
speculateFileUsingCache Cache
cac HashedDir
HashedPristineDir (PristineHash -> FilePath
forall a. ValidHash a => a -> FilePath
getValidHash PristineHash
z)) [(a, b, PristineHash)]
c
          peekroot :: HashedIO Bool
          peekroot :: HashedIO Bool
peekroot = do HashDir Cache
c PristineHash
h <- StateT HashDir IO HashDir
forall s (m :: * -> *). MonadState s m => m s
get
                        IO Bool -> HashedIO Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Bool -> HashedIO Bool) -> IO Bool -> HashedIO Bool
forall a b. (a -> b) -> a -> b
$ Cache -> HashedDir -> FilePath -> IO Bool
peekInCache Cache
c HashedDir
HashedPristineDir (PristineHash -> FilePath
forall a. ValidHash a => a -> FilePath
getValidHash PristineHash
h)

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

data ObjType = F | D deriving ObjType -> ObjType -> Bool
(ObjType -> ObjType -> Bool)
-> (ObjType -> ObjType -> Bool) -> Eq ObjType
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
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ObjType
o ObjType -> ObjType -> Bool
forall a. Eq a => a -> a -> Bool
== ObjType
o')
  PristineHash -> Maybe PristineHash
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
_ [] = Maybe (ObjType, PristineHash)
forall a. Maybe a
Nothing
getany Name
f ((ObjType
o,Name
f',PristineHash
h):[DirEntry]
_) | Name
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
f' = (ObjType, PristineHash) -> Maybe (ObjType, PristineHash)
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
f' = (ObjType
o,Name
f,PristineHash
h)DirEntry -> [DirEntry] -> [DirEntry]
forall a. a -> [a] -> [a]
:[DirEntry]
r
seta ObjType
o Name
f PristineHash
h (DirEntry
x:[DirEntry]
xs) = DirEntry
x DirEntry -> [DirEntry] -> [DirEntry]
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 = ([ByteString] -> [DirEntry]
forall c. ValidHash c => [ByteString] -> [(ObjType, Name, c)]
parseLines ([ByteString] -> [DirEntry])
-> (ByteString -> [ByteString]) -> ByteString -> [DirEntry]
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
    [DirEntry] -> HashedIO [DirEntry]
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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
dirType = (ObjType
D, ByteString -> Name
decodeWhiteName ByteString
n, FilePath -> c
forall a. ValidHash a => FilePath -> a
mkValidHash (FilePath -> c) -> FilePath -> c
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
BC.unpack ByteString
h) (ObjType, Name, c) -> [(ObjType, Name, c)] -> [(ObjType, Name, c)]
forall a. a -> [a] -> [a]
: [ByteString] -> [(ObjType, Name, c)]
parseLines [ByteString]
rest
      | ByteString
t ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
fileType = (ObjType
F, ByteString -> Name
decodeWhiteName ByteString
n, FilePath -> c
forall a. ValidHash a => FilePath -> a
mkValidHash (FilePath -> c) -> FilePath -> c
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
BC.unpack ByteString
h) (ObjType, Name, c) -> [(ObjType, Name, c)] -> [(ObjType, Name, c)]
forall a. a -> [a] -> [a]
: [ByteString] -> [(ObjType, Name, c)]
parseLines [ByteString]
rest
    parseLines [ByteString]
_ = []

dirType :: B.ByteString
dirType :: ByteString
dirType = FilePath -> ByteString
BC.pack FilePath
"directory:"

fileType :: B.ByteString
fileType :: ByteString
fileType = FilePath -> ByteString
BC.pack FilePath
"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 ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (DirEntry -> [ByteString]) -> [DirEntry] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DirEntry -> [ByteString]
forall a. ValidHash a => (ObjType, Name, a) -> [ByteString]
wr [DirEntry]
c [ByteString] -> [ByteString] -> [ByteString]
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, FilePath -> ByteString
BC.pack (a -> FilePath
forall a. ValidHash a => a -> FilePath
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 <- (HashDir -> Cache) -> StateT HashDir IO Cache
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> Cache
cache
  -- pristine files are always compressed
  IO PristineHash -> HashedIO PristineHash
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO PristineHash -> HashedIO PristineHash)
-> IO PristineHash -> HashedIO PristineHash
forall a b. (a -> b) -> a -> b
$ FilePath -> PristineHash
forall a. ValidHash a => FilePath -> a
mkValidHash (FilePath -> PristineHash) -> IO FilePath -> IO PristineHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cache -> Compression -> HashedDir -> ByteString -> IO FilePath
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 :: FilePath -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed FilePath
k Cache
c WithWorkingDir
wwd PristineHash
z = IO ((), HashDir) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ((), HashDir) -> IO ())
-> (HashDir -> IO ((), HashDir)) -> HashDir -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashedIO () -> HashDir -> IO ((), HashDir)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT HashedIO ()
cph (HashDir -> IO ()) -> HashDir -> IO ()
forall a b. (a -> b) -> a -> b
$ HashDir :: Cache -> PristineHash -> HashDir
HashDir { cache :: Cache
cache = Cache
c, cwdHash :: PristineHash
cwdHash = PristineHash
z }
    where cph :: HashedIO ()
cph = do [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
                   IO () -> HashedIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> HashedIO ()) -> IO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> IO ()
tediousSize FilePath
k ([DirEntry] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DirEntry]
cwd)
                   (DirEntry -> HashedIO ()) -> [DirEntry] -> HashedIO ()
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
              IO () -> HashedIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> HashedIO ()) -> IO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
finishedOneIO FilePath
k (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
name2fp Name
n
              --lift $ debugMessage $ "DEBUG copyHashed " ++ show n
              case WithWorkingDir
wwd of
                WithWorkingDir
WithWorkingDir -> IO () -> HashedIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> HashedIO ()) -> IO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (Name -> FilePath
name2fp Name
n) ByteString
ps
                WithWorkingDir
NoWorkingDir   -> ByteString
ps ByteString -> HashedIO () -> HashedIO ()
`seq` () -> HashedIO ()
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 FilePath -> Bool
isMaliciousSubPath (Name -> FilePath
name2fp Name
n)
                 then FilePath -> HashedIO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath
"Caught malicious path: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
name2fp Name
n)
                 else do
                 IO () -> HashedIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> HashedIO ()) -> IO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
finishedOneIO FilePath
k (Name -> FilePath
name2fp Name
n)
                 case WithWorkingDir
wwd of
                   WithWorkingDir
WithWorkingDir -> do
                     IO () -> HashedIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> HashedIO ()) -> IO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
False (Name -> FilePath
name2fp Name
n)
                     IO () -> HashedIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> HashedIO ()) -> IO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (Name -> FilePath
name2fp Name
n) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed FilePath
k Cache
c WithWorkingDir
WithWorkingDir PristineHash
h
                   WithWorkingDir
NoWorkingDir ->
                     IO () -> HashedIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> HashedIO ()) -> IO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed FilePath
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 :: FilePath -> Cache -> PristineHash -> IO [(FilePath, ByteString)]
pathsAndContents FilePath
path Cache
c PristineHash
root = StateT HashDir IO [(FilePath, ByteString)]
-> HashDir -> IO [(FilePath, ByteString)]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT HashDir IO [(FilePath, ByteString)]
cph HashDir :: Cache -> PristineHash -> HashDir
HashDir { cache :: Cache
cache = Cache
c, cwdHash :: PristineHash
cwdHash = PristineHash
root }
    where cph :: StateT HashDir IO [(FilePath, ByteString)]
cph = do [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
                   [(FilePath, ByteString)]
pacs <- [[(FilePath, ByteString)]] -> [(FilePath, ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(FilePath, ByteString)]] -> [(FilePath, ByteString)])
-> StateT HashDir IO [[(FilePath, ByteString)]]
-> StateT HashDir IO [(FilePath, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DirEntry -> StateT HashDir IO [(FilePath, ByteString)])
-> [DirEntry] -> StateT HashDir IO [[(FilePath, ByteString)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DirEntry -> StateT HashDir IO [(FilePath, ByteString)]
cp [DirEntry]
cwd
                   let current :: [(FilePath, ByteString)]
current = if FilePath
path FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"." then [] else [(FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" , ByteString
B.empty)]
                   [(FilePath, ByteString)]
-> StateT HashDir IO [(FilePath, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FilePath, ByteString)]
 -> StateT HashDir IO [(FilePath, ByteString)])
-> [(FilePath, ByteString)]
-> StateT HashDir IO [(FilePath, ByteString)]
forall a b. (a -> b) -> a -> b
$ [(FilePath, ByteString)]
current [(FilePath, ByteString)]
-> [(FilePath, ByteString)] -> [(FilePath, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, ByteString)]
pacs
          cp :: DirEntry -> StateT HashDir IO [(FilePath, ByteString)]
cp (ObjType
F,Name
n,PristineHash
h) = do
              ByteString
ps <- PristineHash -> HashedIO ByteString
readhash PristineHash
h
              let p :: FilePath
p = (if FilePath
path FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"." then FilePath
"" else FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
name2fp Name
n
              [(FilePath, ByteString)]
-> StateT HashDir IO [(FilePath, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath
p,ByteString
ps)]
          cp (ObjType
D,Name
n,PristineHash
h) = do
              let p :: FilePath
p = (if FilePath
path FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"." then FilePath
"" else FilePath
path) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
name2fp Name
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/"
              IO [(FilePath, ByteString)]
-> StateT HashDir IO [(FilePath, ByteString)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [(FilePath, ByteString)]
 -> StateT HashDir IO [(FilePath, ByteString)])
-> IO [(FilePath, ByteString)]
-> StateT HashDir IO [(FilePath, ByteString)]
forall a b. (a -> b) -> a -> b
$ FilePath -> Cache -> PristineHash -> IO [(FilePath, ByteString)]
pathsAndContents FilePath
p Cache
c PristineHash
h

copyPartialsHashed :: Cache -> PristineHash -> [AnchoredPath] -> IO ()
copyPartialsHashed :: Cache -> PristineHash -> [AnchoredPath] -> IO ()
copyPartialsHashed Cache
c PristineHash
root = (AnchoredPath -> IO ()) -> [AnchoredPath] -> IO ()
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 -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just AnchoredPath
super ->
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (AnchoredPath -> FilePath
ap2fp AnchoredPath
super)
    IO ((), HashDir) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ((), HashDir) -> IO ()) -> IO ((), HashDir) -> IO ()
forall a b. (a -> b) -> a -> b
$ HashedIO () -> HashDir -> IO ((), HashDir)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT HashedIO ()
copy HashDir :: Cache -> PristineHash -> HashDir
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
          IO () -> HashedIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> HashedIO ()) -> IO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (AnchoredPath -> FilePath
ap2fp AnchoredPath
path)
          IO () -> HashedIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> HashedIO ()) -> IO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$
            FilePath -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (AnchoredPath -> FilePath
ap2fp AnchoredPath
path) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed FilePath
"" Cache
c WithWorkingDir
WithWorkingDir PristineHash
h
        Just (ObjType
F, PristineHash
h) -> do
          ByteString
ps <- PristineHash -> HashedIO ByteString
readhash PristineHash
h
          IO () -> HashedIO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> HashedIO ()) -> IO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (AnchoredPath -> FilePath
ap2fp AnchoredPath
path) ByteString
ps
        Maybe (ObjType, PristineHash)
Nothing -> () -> HashedIO ()
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"
      FilePath -> IO ()
debugMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Cleaning out " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ HashedDir -> FilePath
hashedDir HashedDir
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"..."
      let hashdir :: FilePath
hashdir = FilePath
darcsdir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ HashedDir -> FilePath
hashedDir HashedDir
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/"
      Set ByteString
hs <- [FilePath] -> Set ByteString
set ([FilePath] -> Set ByteString)
-> IO [FilePath] -> IO (Set ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO [FilePath]
getHashedFiles FilePath
hashdir ((PristineHash -> FilePath) -> [PristineHash] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PristineHash -> FilePath
forall a. ValidHash a => a -> FilePath
getValidHash [PristineHash]
hashroots)
      Set ByteString
fs <- [FilePath] -> Set ByteString
set ([FilePath] -> Set ByteString)
-> ([FilePath] -> [FilePath]) -> [FilePath] -> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
okayHash ([FilePath] -> Set ByteString)
-> IO [FilePath] -> IO (Set ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
hashdir
      (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
hashdirFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)) (Set ByteString -> [FilePath]
unset (Set ByteString -> [FilePath]) -> Set ByteString -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set ByteString
fs Set ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ByteString
hs)
      -- and also clean out any global caches.
      FilePath -> IO ()
debugMessage FilePath
"Cleaning out any global caches..."
      Cache -> HashedDir -> [FilePath] -> IO ()
cleanCachesWithHint Cache
c HashedDir
dir (Set ByteString -> [FilePath]
unset (Set ByteString -> [FilePath]) -> Set ByteString -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set ByteString
fs Set ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ByteString
hs)
   where set :: [FilePath] -> Set ByteString
set = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList ([ByteString] -> Set ByteString)
-> ([FilePath] -> [ByteString]) -> [FilePath] -> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> ByteString) -> [FilePath] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> ByteString
BC.pack
         unset :: Set ByteString -> [FilePath]
unset = (ByteString -> FilePath) -> [ByteString] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> FilePath
BC.unpack ([ByteString] -> [FilePath])
-> (Set ByteString -> [ByteString]) -> Set ByteString -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ByteString -> [ByteString]
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 :: FilePath -> [FilePath] -> IO [FilePath]
getHashedFiles FilePath
hashdir [FilePath]
hashroots = do
  let listone :: FilePath -> IO [FilePath]
listone FilePath
h = do
        let size :: Maybe Int
size = ByteString -> Maybe Int
decodeDarcsSize (ByteString -> Maybe Int) -> ByteString -> Maybe Int
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
BC.pack FilePath
h
            hash :: Hash
hash = ByteString -> Hash
decodeDarcsHash (ByteString -> Hash) -> ByteString -> Hash
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
BC.pack FilePath
h
        [(ItemType, Name, Maybe Int, Hash)]
x <- FilePath
-> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]
readDarcsHashedDir FilePath
hashdir (Maybe Int
size, Hash
hash)
        let subs :: [FilePath]
subs = [(FilePath, Maybe (Int64, Int)) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, Maybe (Int64, Int)) -> FilePath)
-> (FilePath, Maybe (Int64, Int)) -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> (Maybe Int, Hash) -> (FilePath, Maybe (Int64, Int))
darcsLocation FilePath
"" (Maybe Int
s, Hash
h') | (ItemType
TreeType, Name
_, Maybe Int
s, Hash
h') <- [(ItemType, Name, Maybe Int, Hash)]
x]
            hashes :: [FilePath]
hashes = FilePath
h FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [(FilePath, Maybe (Int64, Int)) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, Maybe (Int64, Int)) -> FilePath)
-> (FilePath, Maybe (Int64, Int)) -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> (Maybe Int, Hash) -> (FilePath, Maybe (Int64, Int))
darcsLocation FilePath
"" (Maybe Int
s, Hash
h') | (ItemType
_, Name
_, Maybe Int
s, Hash
h') <- [(ItemType, Name, Maybe Int, Hash)]
x]
        ([FilePath]
hashes [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++) ([FilePath] -> [FilePath])
-> ([[FilePath]] -> [FilePath]) -> [[FilePath]] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO [FilePath]
listone [FilePath]
subs
  [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO [FilePath]
listone [FilePath]
hashroots