-- 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 ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Reading hash file "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++PristineHash -> [Char]
forall a. ValidHash a => a -> [Char]
getValidHash PristineHash
hash[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" from "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++HashedDir -> [Char]
hashedDir HashedDir
subdir[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"/"
       ([Char], ByteString)
r <- Cache -> HashedDir -> [Char] -> IO ([Char], ByteString)
fetchFileUsingCache Cache
c HashedDir
subdir (PristineHash -> [Char]
forall a. ValidHash a => a -> [Char]
getValidHash PristineHash
hash)
       [Char] -> IO ()
debugMessage ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Result of reading hash file: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char], ByteString) -> [Char]
forall a. Show a => a -> [Char]
show ([Char], ByteString)
r
       ([Char], ByteString) -> IO ([Char], ByteString)
forall a. a -> IO a
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 -> [Char] -> HashedIO a
forall a. [Char] -> StateT HashDir IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"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 a. a -> StateT HashDir IO 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 :: 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 -> [Char] -> HashedIO a
forall a. [Char] -> StateT HashDir IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"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 a. a -> StateT HashDir IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Maybe (ObjType, PristineHash)
_ -> Bool -> HashedIO Bool
forall a. a -> StateT HashDir IO a
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 a b. (a -> b) -> StateT HashDir IO a -> StateT HashDir IO b
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
$ [Char] -> HashedIO ()
forall a. [Char] -> StateT HashDir IO a
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 <- Maybe (ObjType, PristineHash) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ObjType, PristineHash) -> Bool)
-> HashedIO (Maybe (ObjType, PristineHash)) -> HashedIO Bool
forall a b. (a -> b) -> StateT HashDir IO a -> StateT HashDir IO b
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
$ [Char] -> HashedIO ()
forall a. [Char] -> StateT HashDir IO a
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 -> () -> HashedIO ()
forall a. a -> StateT HashDir IO a
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
$ [Char] -> HashedIO ()
forall a. [Char] -> StateT HashDir IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> HashedIO ()) -> [Char] -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot remove non-empty file " [Char] -> [Char] -> [Char]
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 AnchoredPath -> AnchoredPath -> Bool
forall a. Eq a => a -> a -> Bool
== AnchoredPath
anchoredRoot = [Char] -> HashedIO ByteString
forall a. [Char] -> StateT HashDir IO a
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 -> [Char] -> HashedIO ByteString
forall a. [Char] -> StateT HashDir IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> HashedIO ByteString) -> [Char] -> HashedIO ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"file doesn't exist..." [Char] -> [Char] -> [Char]
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
          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 a. a -> StateT HashDir IO a
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 a b. (a -> b) -> StateT HashDir IO a -> StateT HashDir IO b
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 a. a -> StateT HashDir IO a
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 a b. (a -> b) -> StateT HashDir IO a -> StateT HashDir IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HashedIO [DirEntry]
readcwd HashedIO [DirEntry] -> ([DirEntry] -> HashedIO ()) -> HashedIO ()
forall a b.
StateT HashDir IO a
-> (a -> StateT HashDir IO b) -> StateT HashDir IO b
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 a. [a] -> 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 a. [a] -> 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 [Char] -> HashedIO ()
forall a. [Char] -> StateT HashDir IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"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
                ([Char], ByteString)
z <- IO ([Char], ByteString) -> StateT HashDir IO ([Char], ByteString)
forall (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO ([Char], ByteString) -> StateT HashDir IO ([Char], ByteString))
-> IO ([Char], ByteString)
-> StateT HashDir IO ([Char], ByteString)
forall a b. (a -> b) -> a -> b
$ IO ([Char], ByteString) -> IO ([Char], ByteString)
forall a. IO a -> IO a
unsafeInterleaveIO (IO ([Char], ByteString) -> IO ([Char], ByteString))
-> IO ([Char], ByteString) -> IO ([Char], ByteString)
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
                ByteString -> HashedIO ByteString
forall a. a -> StateT HashDir IO a
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 <- 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 a. a -> StateT HashDir IO a
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 = (PristineHash, a) -> a
forall a b. (a, b) -> b
snd ((PristineHash, a) -> a)
-> StateT HashDir IO (PristineHash, a) -> HashedIO a
forall a b. (a -> b) -> StateT HashDir IO a -> StateT HashDir IO b
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 a b.
StateT HashDir IO a
-> (a -> StateT HashDir IO b) -> StateT HashDir IO b
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 a. a -> StateT HashDir IO a
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 <- (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 (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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 -> [Char] -> IO ()
speculateFileUsingCache Cache
cac HashedDir
HashedPristineDir (PristineHash -> [Char]
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 <- StateT HashDir IO HashDir
forall s (m :: * -> *). MonadState s m => m s
get
                        IO Bool -> HashedIO Bool
forall (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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 -> [Char] -> IO Bool
peekInCache Cache
c HashedDir
HashedPristineDir (PristineHash -> [Char]
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
  (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
$c== :: ObjType -> ObjType -> Bool
== :: ObjType -> ObjType -> Bool
$c/= :: ObjType -> ObjType -> Bool
/= :: 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 a. a -> Maybe a
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 a. a -> StateT HashDir IO a
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, [Char] -> c
forall a. ValidHash a => [Char] -> a
mkValidHash ([Char] -> c) -> [Char] -> c
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
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, [Char] -> c
forall a. ValidHash a => [Char] -> a
mkValidHash ([Char] -> c) -> [Char] -> c
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
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 = [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 ([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, [Char] -> ByteString
BC.pack (a -> [Char]
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 <- (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 (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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
$ [Char] -> PristineHash
forall a. ValidHash a => [Char] -> a
mkValidHash ([Char] -> PristineHash) -> IO [Char] -> IO PristineHash
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 = 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 :: Cache
cache = Cache
c, cwdHash :: PristineHash
cwdHash = PristineHash
z }
    where cph :: HashedIO ()
cph = do [DirEntry]
cwd <- HashedIO [DirEntry]
readcwd
                   IO () -> HashedIO ()
forall (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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
$ [Char] -> Int -> IO ()
tediousSize [Char]
k ([DirEntry] -> Int
forall a. [a] -> 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 (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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
$ [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
name2fp Name
n
              --lift $ debugMessage $ "DEBUG copyHashed " ++ show n
              case WithWorkingDir
wwd of
                WithWorkingDir
WithWorkingDir -> IO () -> HashedIO ()
forall (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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
$ [Char] -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (Name -> [Char]
name2fp Name
n) ByteString
ps
                WithWorkingDir
NoWorkingDir   -> ByteString
ps ByteString -> HashedIO () -> HashedIO ()
forall a b. a -> b -> b
`seq` () -> HashedIO ()
forall a. a -> StateT HashDir IO a
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 [Char] -> HashedIO ()
forall a. [Char] -> StateT HashDir IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Caught malicious path: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
name2fp Name
n)
                 else do
                 IO () -> HashedIO ()
forall (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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
$ [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k (Name -> [Char]
name2fp Name
n)
                 case WithWorkingDir
wwd of
                   WithWorkingDir
WithWorkingDir -> do
                     IO () -> HashedIO ()
forall (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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 -> [Char] -> IO ()
createDirectoryIfMissing Bool
False (Name -> [Char]
name2fp Name
n)
                     IO () -> HashedIO ()
forall (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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
$ [Char] -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (Name -> [Char]
name2fp Name
n) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Cache -> WithWorkingDir -> PristineHash -> IO ()
copyHashed [Char]
k Cache
c WithWorkingDir
WithWorkingDir PristineHash
h
                   WithWorkingDir
NoWorkingDir ->
                     IO () -> HashedIO ()
forall (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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
$ [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 = StateT HashDir IO [([Char], ByteString)]
-> HashDir -> IO [([Char], ByteString)]
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 <- [[([Char], ByteString)]] -> [([Char], ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[([Char], ByteString)]] -> [([Char], ByteString)])
-> StateT HashDir IO [[([Char], ByteString)]]
-> StateT HashDir IO [([Char], ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DirEntry -> StateT HashDir IO [([Char], ByteString)])
-> [DirEntry] -> StateT HashDir IO [[([Char], ByteString)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DirEntry -> StateT HashDir IO [([Char], ByteString)]
cp [DirEntry]
cwd
                   let current :: [([Char], ByteString)]
current = if [Char]
path [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"." then [] else [([Char]
path [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" , ByteString
B.empty)]
                   [([Char], ByteString)] -> StateT HashDir IO [([Char], ByteString)]
forall a. a -> StateT HashDir IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([([Char], ByteString)]
 -> StateT HashDir IO [([Char], ByteString)])
-> [([Char], ByteString)]
-> StateT HashDir IO [([Char], ByteString)]
forall a b. (a -> b) -> a -> b
$ [([Char], ByteString)]
current [([Char], ByteString)]
-> [([Char], ByteString)] -> [([Char], ByteString)]
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 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"." then [Char]
"" else [Char]
path [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
name2fp Name
n
              [([Char], ByteString)] -> StateT HashDir IO [([Char], ByteString)]
forall a. a -> StateT HashDir IO a
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 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"." then [Char]
"" else [Char]
path) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
name2fp Name
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/"
              IO [([Char], ByteString)]
-> StateT HashDir IO [([Char], ByteString)]
forall (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [([Char], ByteString)]
 -> StateT HashDir IO [([Char], ByteString)])
-> IO [([Char], ByteString)]
-> StateT HashDir IO [([Char], ByteString)]
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 = (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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just AnchoredPath
super ->
        Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (AnchoredPath -> [Char]
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 :: 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 (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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 -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (AnchoredPath -> [Char]
ap2fp AnchoredPath
path)
          IO () -> HashedIO ()
forall (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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
$
            [Char] -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (AnchoredPath -> [Char]
ap2fp AnchoredPath
path) (IO () -> IO ()) -> IO () -> IO ()
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
          IO () -> HashedIO ()
forall (m :: * -> *) a. Monad m => m a -> StateT HashDir m a
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
$ [Char] -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (AnchoredPath -> [Char]
ap2fp AnchoredPath
path) ByteString
ps
        Maybe (ObjType, PristineHash)
Nothing -> () -> HashedIO ()
forall a. a -> StateT HashDir IO a
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 ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Cleaning out " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ HashedDir -> [Char]
hashedDir HashedDir
dir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"..."
      let hashdir :: [Char]
hashdir = [Char]
darcsdir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ HashedDir -> [Char]
hashedDir HashedDir
dir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/"
      Set ByteString
hs <- [[Char]] -> Set ByteString
set ([[Char]] -> Set ByteString) -> IO [[Char]] -> IO (Set ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [[Char]] -> IO [[Char]]
getHashedFiles [Char]
hashdir ((PristineHash -> [Char]) -> [PristineHash] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map PristineHash -> [Char]
forall a. ValidHash a => a -> [Char]
getValidHash [PristineHash]
hashroots)
      Set ByteString
fs <- [[Char]] -> Set ByteString
set ([[Char]] -> Set ByteString)
-> ([[Char]] -> [[Char]]) -> [[Char]] -> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
okayHash ([[Char]] -> Set ByteString) -> IO [[Char]] -> IO (Set ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO [[Char]]
getDirectoryContents [Char]
hashdir
      ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
hashdir[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)) (Set ByteString -> [[Char]]
unset (Set ByteString -> [[Char]]) -> Set ByteString -> [[Char]]
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.
      [Char] -> IO ()
debugMessage [Char]
"Cleaning out any global caches..."
      Cache -> HashedDir -> [[Char]] -> IO ()
cleanCachesWithHint Cache
c HashedDir
dir (Set ByteString -> [[Char]]
unset (Set ByteString -> [[Char]]) -> Set ByteString -> [[Char]]
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 :: [[Char]] -> Set ByteString
set = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList ([ByteString] -> Set ByteString)
-> ([[Char]] -> [ByteString]) -> [[Char]] -> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> ByteString) -> [[Char]] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> ByteString
BC.pack
         unset :: Set ByteString -> [[Char]]
unset = (ByteString -> [Char]) -> [ByteString] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [Char]
BC.unpack ([ByteString] -> [[Char]])
-> (Set ByteString -> [ByteString]) -> Set ByteString -> [[Char]]
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 :: [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 (ByteString -> Maybe Int) -> ByteString -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BC.pack [Char]
h
            hash :: Hash
hash = ByteString -> Hash
decodeDarcsHash (ByteString -> Hash) -> ByteString -> Hash
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 = [([Char], Maybe (Int64, Int)) -> [Char]
forall a b. (a, b) -> a
fst (([Char], Maybe (Int64, Int)) -> [Char])
-> ([Char], Maybe (Int64, Int)) -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> (Maybe Int, Hash) -> ([Char], Maybe (Int64, Int))
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 [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [([Char], Maybe (Int64, Int)) -> [Char]
forall a b. (a, b) -> a
fst (([Char], Maybe (Int64, Int)) -> [Char])
-> ([Char], Maybe (Int64, Int)) -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> (Maybe Int, Hash) -> ([Char], Maybe (Int64, Int))
darcsLocation [Char]
"" (Maybe Int
s, Hash
h') | (ItemType
_, Name
_, Maybe Int
s, Hash
h') <- [(ItemType, Name, Maybe Int, Hash)]
x]
        ([[Char]]
hashes [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]])
-> ([[[Char]]] -> [[Char]]) -> [[[Char]]] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]]) -> IO [[[Char]]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> IO [[Char]]) -> [[Char]] -> IO [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> IO [[Char]]
listone [[Char]]
subs
  [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]]) -> IO [[[Char]]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> IO [[Char]]) -> [[Char]] -> IO [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> IO [[Char]]
listone [[Char]]
hashroots