-- 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 Prelude ()
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 )
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.Util.Lock ( writeAtomicFilePS, removeFileMayNotExist )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Progress ( debugMessage, tediousSize, finishedOneIO )
import Darcs.Util.Path
    ( FileName
    , normPath
    , fp2fn
    , fn2fp
    , fn2ps
    , ps2fn
    , breakOnDir
    , ownName
    , superName
    , FilePathLike
    , toFilePath
    , 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 )

-- | @readHashFile c subdir hash@ reads the file with hash @hash@ in dir subdir,
-- fetching it from 'Cache' @c@ if needed.
readHashFile :: Cache -> HashedDir -> String -> IO (String,B.ByteString)
readHashFile :: Cache -> HashedDir -> String -> IO (String, ByteString)
readHashFile c :: Cache
c subdir :: HashedDir
subdir hash :: String
hash =
    do String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Reading hash file "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
hashString -> String -> String
forall a. [a] -> [a] -> [a]
++" from "String -> String -> String
forall a. [a] -> [a] -> [a]
++HashedDir -> String
hashedDir HashedDir
subdirString -> String -> String
forall a. [a] -> [a] -> [a]
++"/"
       (String, ByteString)
r <- Cache -> HashedDir -> String -> IO (String, ByteString)
fetchFileUsingCache Cache
c HashedDir
subdir String
hash
       String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Result of reading hash file: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, ByteString) -> String
forall a. Show a => a -> String
show (String, ByteString)
r
       (String, ByteString) -> IO (String, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (String, ByteString)
r

data HashDir = HashDir { HashDir -> Cache
cache :: !Cache,
                         HashDir -> String
rootHash :: !String }
type HashedIO = StateT HashDir IO

mWithCurrentDirectory :: FileName -> HashedIO a -> HashedIO a
mWithCurrentDirectory :: FileName -> HashedIO a -> HashedIO a
mWithCurrentDirectory fn :: FileName
fn j :: HashedIO a
j
    | FileName
fn' FileName -> FileName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> FileName
fp2fn "" = HashedIO a
j
    | Bool
otherwise =
        case FileName -> Maybe (FileName, FileName)
breakOnDir FileName
fn' of
        Nothing -> do [(ObjType, FileName, String)]
c <- HashedIO [(ObjType, FileName, String)]
readroot
                      case ObjType
-> FileName -> [(ObjType, FileName, String)] -> Maybe String
geta ObjType
D FileName
fn' [(ObjType, FileName, String)]
c of
                        Nothing -> String -> HashedIO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "dir doesn't exist in mWithCurrentDirectory..."
                        Just h :: String
h -> do (h' :: String
h',x :: a
x) <- String -> HashedIO a -> HashedIO (String, a)
forall a. String -> HashedIO a -> HashedIO (String, a)
withh String
h HashedIO a
j
                                     [(ObjType, FileName, String)] -> HashedIO ()
writeroot ([(ObjType, FileName, String)] -> HashedIO ())
-> [(ObjType, FileName, String)] -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ ObjType
-> FileName
-> String
-> [(ObjType, FileName, String)]
-> [(ObjType, FileName, String)]
seta ObjType
D FileName
fn' String
h' [(ObjType, FileName, String)]
c
                                     a -> HashedIO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        Just (d :: FileName
d,fn'' :: FileName
fn'') -> do [(ObjType, FileName, String)]
c <- HashedIO [(ObjType, FileName, String)]
readroot
                            case ObjType
-> FileName -> [(ObjType, FileName, String)] -> Maybe String
geta ObjType
D FileName
d [(ObjType, FileName, String)]
c of
                              Nothing -> String -> HashedIO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "dir doesn't exist..."
                              Just h :: String
h -> do (h' :: String
h',x :: a
x) <- String -> HashedIO a -> HashedIO (String, a)
forall a. String -> HashedIO a -> HashedIO (String, a)
withh String
h (HashedIO a -> HashedIO (String, a))
-> HashedIO a -> HashedIO (String, a)
forall a b. (a -> b) -> a -> b
$ FileName -> HashedIO a -> HashedIO a
forall a. FileName -> HashedIO a -> HashedIO a
mWithCurrentDirectory FileName
fn'' HashedIO a
j
                                           [(ObjType, FileName, String)] -> HashedIO ()
writeroot ([(ObjType, FileName, String)] -> HashedIO ())
-> [(ObjType, FileName, String)] -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ ObjType
-> FileName
-> String
-> [(ObjType, FileName, String)]
-> [(ObjType, FileName, String)]
seta ObjType
D FileName
d String
h' [(ObjType, FileName, String)]
c
                                           a -> HashedIO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    where fn' :: FileName
fn' = FileName -> FileName
normPath FileName
fn

mInCurrentDirectory :: FileName -> HashedIO a -> HashedIO a
mInCurrentDirectory :: FileName -> HashedIO a -> HashedIO a
mInCurrentDirectory fn :: FileName
fn j :: HashedIO a
j | FileName
fn' FileName -> FileName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> FileName
fp2fn "" = HashedIO a
j
                         | Bool
otherwise =
                             case FileName -> Maybe (FileName, FileName)
breakOnDir FileName
fn' of
                             Nothing -> do [(ObjType, FileName, String)]
c <- HashedIO [(ObjType, FileName, String)]
readroot
                                           case ObjType
-> FileName -> [(ObjType, FileName, String)] -> Maybe String
geta ObjType
D FileName
fn' [(ObjType, FileName, String)]
c of
                                             Nothing -> String -> HashedIO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "dir doesn't exist mInCurrentDirectory..."
                                             Just h :: String
h -> String -> HashedIO a -> HashedIO a
forall a. String -> HashedIO a -> HashedIO a
inh String
h HashedIO a
j
                             Just (d :: FileName
d,fn'' :: FileName
fn'') -> do [(ObjType, FileName, String)]
c <- HashedIO [(ObjType, FileName, String)]
readroot
                                                 case ObjType
-> FileName -> [(ObjType, FileName, String)] -> Maybe String
geta ObjType
D FileName
d [(ObjType, FileName, String)]
c of
                                                   Nothing -> String -> HashedIO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "dir doesn't exist..."
                                                   Just h :: String
h -> String -> HashedIO a -> HashedIO a
forall a. String -> HashedIO a -> HashedIO a
inh String
h (HashedIO a -> HashedIO a) -> HashedIO a -> HashedIO a
forall a b. (a -> b) -> a -> b
$ FileName -> HashedIO a -> HashedIO a
forall a. FileName -> HashedIO a -> HashedIO a
mInCurrentDirectory FileName
fn'' HashedIO a
j
    where fn' :: FileName
fn' = FileName -> FileName
normPath FileName
fn

instance ApplyMonad Tree HashedIO where
    type ApplyMonadBase HashedIO = IO

instance ApplyMonadTree HashedIO where
    mDoesDirectoryExist :: FileName -> HashedIO Bool
mDoesDirectoryExist fn :: FileName
fn = do Maybe (ObjType, String)
thing <- FileName -> HashedIO (Maybe (ObjType, String))
identifyThing FileName
fn
                                case Maybe (ObjType, String)
thing of Just (D,_) -> Bool -> HashedIO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                                              _ -> Bool -> HashedIO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    mReadFilePS :: FileName -> HashedIO ByteString
mReadFilePS fn :: FileName
fn = FileName -> HashedIO ByteString -> HashedIO ByteString
forall a. FileName -> HashedIO a -> HashedIO a
mInCurrentDirectory (FileName -> FileName
superName FileName
fn) (HashedIO ByteString -> HashedIO ByteString)
-> HashedIO ByteString -> HashedIO ByteString
forall a b. (a -> b) -> a -> b
$ do
                                          [(ObjType, FileName, String)]
c <- HashedIO [(ObjType, FileName, String)]
readroot
                                          case ObjType
-> FileName -> [(ObjType, FileName, String)] -> Maybe String
geta ObjType
F (FileName -> FileName
ownName FileName
fn) [(ObjType, FileName, String)]
c of
                                            Nothing -> String -> HashedIO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> HashedIO ByteString) -> String -> HashedIO ByteString
forall a b. (a -> b) -> a -> b
$ " file don't exist... "String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileName -> String
fn2fp FileName
fn
                                            Just h :: String
h -> String -> HashedIO ByteString
readhash String
h
    mCreateDirectory :: FileName -> HashedIO ()
mCreateDirectory fn :: FileName
fn = do String
h <- ByteString -> HashedIO String
writeHashFile ByteString
B.empty
                             Bool
exists <- Maybe (ObjType, String) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ObjType, String) -> Bool)
-> HashedIO (Maybe (ObjType, String)) -> HashedIO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FileName -> HashedIO (Maybe (ObjType, String))
identifyThing FileName
fn
                             Bool -> HashedIO () -> HashedIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (HashedIO () -> HashedIO ()) -> HashedIO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ String -> HashedIO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "can't mCreateDirectory over an existing object."
                             FileName -> (ObjType, String) -> HashedIO ()
makeThing FileName
fn (ObjType
D,String
h)
    mRename :: FileName -> FileName -> HashedIO ()
mRename o :: FileName
o n :: FileName
n = do Bool
nexists <- Maybe (ObjType, String) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ObjType, String) -> Bool)
-> HashedIO (Maybe (ObjType, String)) -> HashedIO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FileName -> HashedIO (Maybe (ObjType, String))
identifyThing FileName
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
$ String -> HashedIO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "mRename failed..."
                     Maybe (ObjType, String)
mx <- FileName -> HashedIO (Maybe (ObjType, String))
identifyThing FileName
o
                     -- for backwards compatibility accept rename of nonexistent files.
                     case Maybe (ObjType, String)
mx of Nothing -> () -> HashedIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                Just x :: (ObjType, String)
x -> do FileName -> HashedIO ()
rmThing FileName
o
                                             FileName -> (ObjType, String) -> HashedIO ()
makeThing FileName
n (ObjType, String)
x
    mRemoveDirectory :: FileName -> HashedIO ()
mRemoveDirectory = FileName -> HashedIO ()
rmThing
    mRemoveFile :: FileName -> HashedIO ()
mRemoveFile f :: FileName
f = do ByteString
x <- FileName -> HashedIO ByteString
forall (m :: * -> *). ApplyMonadTree m => FileName -> m ByteString
mReadFilePS FileName
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
/= 0) (HashedIO () -> HashedIO ()) -> HashedIO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$
                            String -> HashedIO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> HashedIO ()) -> String -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ "Cannot remove non-empty file "String -> String -> String
forall a. [a] -> [a] -> [a]
++FileName -> String
fn2fp FileName
f
                       FileName -> HashedIO ()
rmThing FileName
f

identifyThing :: FileName -> HashedIO (Maybe (ObjType,String))
identifyThing :: FileName -> HashedIO (Maybe (ObjType, String))
identifyThing fn :: FileName
fn | FileName
fn' FileName -> FileName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> FileName
fp2fn "" = do String
h <- (HashDir -> String) -> HashedIO String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> String
rootHash
                                        Maybe (ObjType, String) -> HashedIO (Maybe (ObjType, String))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ObjType, String) -> HashedIO (Maybe (ObjType, String)))
-> Maybe (ObjType, String) -> HashedIO (Maybe (ObjType, String))
forall a b. (a -> b) -> a -> b
$ (ObjType, String) -> Maybe (ObjType, String)
forall a. a -> Maybe a
Just (ObjType
D, String
h)
                 | Bool
otherwise = case FileName -> Maybe (FileName, FileName)
breakOnDir FileName
fn' of
                               Nothing -> FileName
-> [(ObjType, FileName, String)] -> Maybe (ObjType, String)
getany FileName
fn' ([(ObjType, FileName, String)] -> Maybe (ObjType, String))
-> HashedIO [(ObjType, FileName, String)]
-> HashedIO (Maybe (ObjType, String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HashedIO [(ObjType, FileName, String)]
readroot
                               Just (d :: FileName
d,fn'' :: FileName
fn'') -> do [(ObjType, FileName, String)]
c <- HashedIO [(ObjType, FileName, String)]
readroot
                                                   case ObjType
-> FileName -> [(ObjType, FileName, String)] -> Maybe String
geta ObjType
D FileName
d [(ObjType, FileName, String)]
c of
                                                     Nothing -> Maybe (ObjType, String) -> HashedIO (Maybe (ObjType, String))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ObjType, String)
forall a. Maybe a
Nothing
                                                     Just h :: String
h -> String
-> HashedIO (Maybe (ObjType, String))
-> HashedIO (Maybe (ObjType, String))
forall a. String -> HashedIO a -> HashedIO a
inh String
h (HashedIO (Maybe (ObjType, String))
 -> HashedIO (Maybe (ObjType, String)))
-> HashedIO (Maybe (ObjType, String))
-> HashedIO (Maybe (ObjType, String))
forall a b. (a -> b) -> a -> b
$ FileName -> HashedIO (Maybe (ObjType, String))
identifyThing FileName
fn''
        where fn' :: FileName
fn' = FileName -> FileName
normPath FileName
fn

makeThing :: FileName -> (ObjType,String) -> HashedIO ()
makeThing :: FileName -> (ObjType, String) -> HashedIO ()
makeThing fn :: FileName
fn (o :: ObjType
o,h :: String
h) = FileName -> HashedIO () -> HashedIO ()
forall a. FileName -> HashedIO a -> HashedIO a
mWithCurrentDirectory (FileName -> FileName
superName (FileName -> FileName) -> FileName -> FileName
forall a b. (a -> b) -> a -> b
$ FileName -> FileName
normPath FileName
fn) (HashedIO () -> HashedIO ()) -> HashedIO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$
                     ObjType
-> FileName
-> String
-> [(ObjType, FileName, String)]
-> [(ObjType, FileName, String)]
seta ObjType
o (FileName -> FileName
ownName (FileName -> FileName) -> FileName -> FileName
forall a b. (a -> b) -> a -> b
$ FileName -> FileName
normPath FileName
fn) String
h ([(ObjType, FileName, String)] -> [(ObjType, FileName, String)])
-> HashedIO [(ObjType, FileName, String)]
-> HashedIO [(ObjType, FileName, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HashedIO [(ObjType, FileName, String)]
readroot HashedIO [(ObjType, FileName, String)]
-> ([(ObjType, FileName, String)] -> HashedIO ()) -> HashedIO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(ObjType, FileName, String)] -> HashedIO ()
writeroot

rmThing :: FileName -> HashedIO ()
rmThing :: FileName -> HashedIO ()
rmThing fn :: FileName
fn = FileName -> HashedIO () -> HashedIO ()
forall a. FileName -> HashedIO a -> HashedIO a
mWithCurrentDirectory (FileName -> FileName
superName (FileName -> FileName) -> FileName -> FileName
forall a b. (a -> b) -> a -> b
$ FileName -> FileName
normPath FileName
fn) (HashedIO () -> HashedIO ()) -> HashedIO () -> HashedIO ()
forall a b. (a -> b) -> a -> b
$
             do [(ObjType, FileName, String)]
c <- HashedIO [(ObjType, FileName, String)]
readroot
                let c' :: [(ObjType, FileName, String)]
c' = ((ObjType, FileName, String) -> Bool)
-> [(ObjType, FileName, String)] -> [(ObjType, FileName, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(_,x :: FileName
x,_)->FileName
xFileName -> FileName -> Bool
forall a. Eq a => a -> a -> Bool
/= FileName -> FileName
ownName (FileName -> FileName
normPath FileName
fn)) [(ObjType, FileName, String)]
c
                if [(ObjType, FileName, String)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ObjType, FileName, String)]
c' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(ObjType, FileName, String)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ObjType, FileName, String)]
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                  then [(ObjType, FileName, String)] -> HashedIO ()
writeroot [(ObjType, FileName, String)]
c'
                  else String -> HashedIO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "obj doesn't exist in rmThing"

readhash :: String -> HashedIO B.ByteString
readhash :: String -> HashedIO ByteString
readhash h :: String
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
                (String, ByteString)
z <- IO (String, ByteString) -> StateT HashDir IO (String, ByteString)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (String, ByteString) -> StateT HashDir IO (String, ByteString))
-> IO (String, ByteString)
-> StateT HashDir IO (String, ByteString)
forall a b. (a -> b) -> a -> b
$ IO (String, ByteString) -> IO (String, ByteString)
forall a. IO a -> IO a
unsafeInterleaveIO (IO (String, ByteString) -> IO (String, ByteString))
-> IO (String, ByteString) -> IO (String, ByteString)
forall a b. (a -> b) -> a -> b
$ Cache -> HashedDir -> String -> IO (String, ByteString)
readHashFile Cache
c HashedDir
HashedPristineDir String
h
                let (_,out :: ByteString
out) = (String, ByteString)
z
                ByteString -> HashedIO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out

withh :: String -> HashedIO a -> HashedIO (String,a)
withh :: String -> HashedIO a -> HashedIO (String, a)
withh h :: String
h j :: 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 { rootHash :: String
rootHash = String
h }
               a
x <- HashedIO a
j
               String
h' <- (HashDir -> String) -> HashedIO String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> String
rootHash
               HashDir -> HashedIO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put HashDir
hd
               (String, a) -> HashedIO (String, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
h',a
x)

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

readroot :: HashedIO [(ObjType, FileName, String)]
readroot :: HashedIO [(ObjType, FileName, String)]
readroot = do Bool
haveitalready <- HashedIO Bool
peekroot
              [(ObjType, FileName, String)]
cc <- (HashDir -> String) -> HashedIO String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HashDir -> String
rootHash HashedIO String
-> (String -> HashedIO [(ObjType, FileName, String)])
-> HashedIO [(ObjType, FileName, String)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> HashedIO [(ObjType, FileName, String)]
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
$ [(ObjType, FileName, String)] -> HashedIO ()
forall a b. [(a, b, String)] -> HashedIO ()
speculate [(ObjType, FileName, String)]
cc
              [(ObjType, FileName, String)]
-> HashedIO [(ObjType, FileName, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(ObjType, FileName, String)]
cc
    where speculate :: [(a,b,String)] -> HashedIO ()
          speculate :: [(a, b, String)] -> HashedIO ()
speculate c :: [(a, b, String)]
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, String) -> HashedIO ()) -> [(a, b, String)] -> HashedIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(_,_,z :: String
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 -> String -> IO ()
speculateFileUsingCache Cache
cac HashedDir
HashedPristineDir String
z) [(a, b, String)]
c
          peekroot :: HashedIO Bool
          peekroot :: HashedIO Bool
peekroot = do HashDir c :: Cache
c h :: String
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 -> String -> IO Bool
peekInCache Cache
c HashedDir
HashedPristineDir String
h

writeroot :: [(ObjType, FileName, String)] -> HashedIO ()
writeroot :: [(ObjType, FileName, String)] -> HashedIO ()
writeroot c :: [(ObjType, FileName, String)]
c = do
  String
h <- [(ObjType, FileName, String)] -> HashedIO String
writedir [(ObjType, FileName, String)]
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
$ \hd :: HashDir
hd -> HashDir
hd { rootHash :: String
rootHash = String
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 stuff@ tries to get an object of type @objtype@ named @name@
-- in @stuff@.
geta :: ObjType -> FileName -> [(ObjType, FileName, String)] -> Maybe String
geta :: ObjType
-> FileName -> [(ObjType, FileName, String)] -> Maybe String
geta o :: ObjType
o f :: FileName
f c :: [(ObjType, FileName, String)]
c = do (o' :: ObjType
o',h :: String
h) <- FileName
-> [(ObjType, FileName, String)] -> Maybe (ObjType, String)
getany FileName
f [(ObjType, FileName, String)]
c
                if ObjType
o ObjType -> ObjType -> Bool
forall a. Eq a => a -> a -> Bool
== ObjType
o' then String -> Maybe String
forall a. a -> Maybe a
Just String
h else Maybe String
forall a. Maybe a
Nothing

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

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

readdir :: String -> HashedIO [(ObjType, FileName, String)]
readdir :: String -> HashedIO [(ObjType, FileName, String)]
readdir hash :: String
hash = do
  ByteString
x <- String -> HashedIO ByteString
readhash String
hash
  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
$ String -> IO ()
debugMessage  (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
x
  let r :: [(ObjType, FileName, String)]
r = ([ByteString] -> [(ObjType, FileName, String)]
parsed ([ByteString] -> [(ObjType, FileName, String)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(ObjType, FileName, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
linesPS) ByteString
x
  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
$ String -> IO ()
debugMessage  (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((ObjType, FileName, String) -> String)
-> [(ObjType, FileName, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(_,fn :: FileName
fn,_) -> "DEBUG readdir " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hash String -> String -> String
forall a. [a] -> [a] -> [a]
++ " entry: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileName -> String
forall a. Show a => a -> String
show FileName
fn) [(ObjType, FileName, String)]
r
  [(ObjType, FileName, String)]
-> HashedIO [(ObjType, FileName, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(ObjType, FileName, String)]
r
  where
    parsed :: [ByteString] -> [(ObjType, FileName, String)]
parsed (t :: ByteString
t:n :: ByteString
n:h :: ByteString
h:rest :: [ByteString]
rest) | ByteString
t ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
dir = (ObjType
D, ByteString -> FileName
ps2fn ByteString
n, ByteString -> String
BC.unpack ByteString
h) (ObjType, FileName, String)
-> [(ObjType, FileName, String)] -> [(ObjType, FileName, String)]
forall a. a -> [a] -> [a]
: [ByteString] -> [(ObjType, FileName, String)]
parsed [ByteString]
rest
                        | ByteString
t ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
file = (ObjType
F, ByteString -> FileName
ps2fn ByteString
n, ByteString -> String
BC.unpack ByteString
h) (ObjType, FileName, String)
-> [(ObjType, FileName, String)] -> [(ObjType, FileName, String)]
forall a. a -> [a] -> [a]
: [ByteString] -> [(ObjType, FileName, String)]
parsed [ByteString]
rest
    parsed _ = []

dir :: B.ByteString
dir :: ByteString
dir = String -> ByteString
BC.pack "directory:"
file :: B.ByteString
file :: ByteString
file = String -> ByteString
BC.pack "file:"


writedir :: [(ObjType, FileName, String)] -> HashedIO String
writedir :: [(ObjType, FileName, String)] -> HashedIO String
writedir c :: [(ObjType, FileName, String)]
c = 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
$ String -> IO ()
debugMessage  (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((ObjType, FileName, String) -> String)
-> [(ObjType, FileName, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(_,fn :: FileName
fn,_) -> "DEBUG writedir entry: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileName -> String
forall a. Show a => a -> String
show FileName
fn) [(ObjType, FileName, String)]
c
  ByteString -> HashedIO String
writeHashFile ByteString
cps
  where
    cps :: ByteString
cps = [ByteString] -> ByteString
unlinesPS ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ((ObjType, FileName, String) -> [ByteString])
-> [(ObjType, FileName, String)] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ObjType, FileName, String) -> [ByteString]
wr [(ObjType, FileName, String)]
c [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
B.empty]
    wr :: (ObjType, FileName, String) -> [ByteString]
wr (o :: ObjType
o,d :: FileName
d,h :: String
h) = [ObjType -> ByteString
showO ObjType
o,FileName -> ByteString
fn2ps FileName
d,String -> ByteString
BC.pack String
h]
    showO :: ObjType -> ByteString
showO D = ByteString
dir
    showO F = ByteString
file

writeHashFile :: B.ByteString -> HashedIO String
writeHashFile :: ByteString -> HashedIO String
writeHashFile ps :: 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 String -> HashedIO String
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO String -> HashedIO String) -> IO String -> HashedIO String
forall a b. (a -> b) -> a -> b
$ Cache -> Compression -> HashedDir -> ByteString -> IO String
writeFileUsingCache Cache
c Compression
GzipCompression HashedDir
HashedPristineDir ByteString
ps


-- | Grab a whole pristine tree from a hash, and, if asked,
--   write files in the working copy.
copyHashed :: String -> Cache -> WithWorkingDir -> String -> IO ()
copyHashed :: String -> Cache -> WithWorkingDir -> String -> IO ()
copyHashed k :: String
k c :: Cache
c wwd :: WithWorkingDir
wwd z :: String
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
$ $WHashDir :: Cache -> String -> HashDir
HashDir { cache :: Cache
cache = Cache
c, rootHash :: String
rootHash = String
z }
    where cph :: HashedIO ()
cph = do [(ObjType, FileName, String)]
cc <- HashedIO [(ObjType, FileName, String)]
readroot
                   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
$ String -> Int -> IO ()
tediousSize String
k ([(ObjType, FileName, String)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ObjType, FileName, String)]
cc)
                   ((ObjType, FileName, String) -> HashedIO ())
-> [(ObjType, FileName, String)] -> HashedIO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ObjType, FileName, String) -> HashedIO ()
cp [(ObjType, FileName, String)]
cc
          cp :: (ObjType, FileName, String) -> HashedIO ()
cp (F,n :: FileName
n,h :: String
h) = do
              ByteString
ps <- String -> HashedIO ByteString
readhash String
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
$ String -> String -> IO ()
finishedOneIO String
k (FileName -> String
fn2fp FileName
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
$ String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "DEBUG copyHashed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileName -> String
forall a. Show a => a -> String
show FileName
n
              case WithWorkingDir
wwd of
                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
$ String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (FileName -> String
fn2fp FileName
n) ByteString
ps
                NoWorkingDir   -> ByteString
ps ByteString -> HashedIO () -> HashedIO ()
forall a b. a -> b -> b
`seq` () -> HashedIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                  -- force evaluation of ps to actually copy hashed file
          cp (D,n :: FileName
n,h :: String
h) =
              if String -> Bool
isMaliciousSubPath (FileName -> String
fn2fp FileName
n)
                 then String -> HashedIO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Caught malicious path: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileName -> String
fn2fp FileName
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
$ String -> String -> IO ()
finishedOneIO String
k (FileName -> String
fn2fp FileName
n)
                 case WithWorkingDir
wwd of
                   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 -> String -> IO ()
createDirectoryIfMissing Bool
False (FileName -> String
fn2fp FileName
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
$ String -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (FileName -> String
fn2fp FileName
n) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Cache -> WithWorkingDir -> String -> IO ()
copyHashed String
k Cache
c WithWorkingDir
WithWorkingDir String
h
                   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
$ String -> Cache -> WithWorkingDir -> String -> IO ()
copyHashed String
k Cache
c WithWorkingDir
NoWorkingDir String
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 ->  String -> IO [(FilePath,B.ByteString)]
pathsAndContents :: String -> Cache -> String -> IO [(String, ByteString)]
pathsAndContents path :: String
path c :: Cache
c root :: String
root = StateT HashDir IO [(String, ByteString)]
-> HashDir -> IO [(String, ByteString)]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT HashDir IO [(String, ByteString)]
cph $WHashDir :: Cache -> String -> HashDir
HashDir { cache :: Cache
cache = Cache
c, rootHash :: String
rootHash = String
root }
    where cph :: StateT HashDir IO [(String, ByteString)]
cph = do [(ObjType, FileName, String)]
cc <- HashedIO [(ObjType, FileName, String)]
readroot
                   [(String, ByteString)]
pacs <- [[(String, ByteString)]] -> [(String, ByteString)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(String, ByteString)]] -> [(String, ByteString)])
-> StateT HashDir IO [[(String, ByteString)]]
-> StateT HashDir IO [(String, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ObjType, FileName, String)
 -> StateT HashDir IO [(String, ByteString)])
-> [(ObjType, FileName, String)]
-> StateT HashDir IO [[(String, ByteString)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ObjType, FileName, String)
-> StateT HashDir IO [(String, ByteString)]
cp [(ObjType, FileName, String)]
cc
                   let current :: [(String, ByteString)]
current = if String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "." then [] else [(String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/" , ByteString
B.empty)]
                   [(String, ByteString)] -> StateT HashDir IO [(String, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, ByteString)]
 -> StateT HashDir IO [(String, ByteString)])
-> [(String, ByteString)]
-> StateT HashDir IO [(String, ByteString)]
forall a b. (a -> b) -> a -> b
$ [(String, ByteString)]
current [(String, ByteString)]
-> [(String, ByteString)] -> [(String, ByteString)]
forall a. [a] -> [a] -> [a]
++ [(String, ByteString)]
pacs
          cp :: (ObjType, FileName, String)
-> StateT HashDir IO [(String, ByteString)]
cp (F,n :: FileName
n,h :: String
h) = do
              ByteString
ps <- String -> HashedIO ByteString
readhash String
h
              let p :: String
p = (if String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "." then "" else String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/") String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileName -> String
fn2fp FileName
n
              [(String, ByteString)] -> StateT HashDir IO [(String, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(String
p,ByteString
ps)]
          cp (D,n :: FileName
n,h :: String
h) = do
              let p :: String
p = (if String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "." then "" else String
path) String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileName -> String
fn2fp FileName
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/"
              IO [(String, ByteString)]
-> StateT HashDir IO [(String, ByteString)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [(String, ByteString)]
 -> StateT HashDir IO [(String, ByteString)])
-> IO [(String, ByteString)]
-> StateT HashDir IO [(String, ByteString)]
forall a b. (a -> b) -> a -> b
$ String -> Cache -> String -> IO [(String, ByteString)]
pathsAndContents String
p Cache
c String
h

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

copyPartialHashed :: FilePathLike fp => Cache -> String -> fp -> IO ()
copyPartialHashed :: Cache -> String -> fp -> IO ()
copyPartialHashed c :: Cache
c root :: String
root ff :: fp
ff =
    do Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
basename (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ fp -> String
forall a. FilePathLike a => a -> String
toFilePath fp
ff)
       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 (FileName -> HashedIO ()
cp (FileName -> HashedIO ()) -> FileName -> HashedIO ()
forall a b. (a -> b) -> a -> b
$ String -> FileName
fp2fn (String -> FileName) -> String -> FileName
forall a b. (a -> b) -> a -> b
$ fp -> String
forall a. FilePathLike a => a -> String
toFilePath fp
ff)
                 $WHashDir :: Cache -> String -> HashDir
HashDir { cache :: Cache
cache = Cache
c,
                           rootHash :: String
rootHash = String
root }
 where basename :: String -> String
basename = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ('/' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ('/' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse
       cp :: FileName -> HashedIO ()
cp f :: FileName
f = do Maybe (ObjType, String)
mt <- FileName -> HashedIO (Maybe (ObjType, String))
identifyThing FileName
f
                 case Maybe (ObjType, String)
mt of
                   Just (D,h :: String
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 -> String -> IO ()
createDirectoryIfMissing Bool
True (FileName -> String
fn2fp FileName
f)
                                    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
$ String -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (FileName -> String
fn2fp FileName
f) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Cache -> WithWorkingDir -> String -> IO ()
copyHashed "" Cache
c WithWorkingDir
WithWorkingDir String
h
                   Just (F,h :: String
h) -> do ByteString
ps <- String -> HashedIO ByteString
readhash String
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
$ String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS (FileName -> String
fn2fp FileName
f) ByteString
ps
                   Nothing -> () -> HashedIO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

cleanHashdir :: Cache -> HashedDir -> [String] -> IO ()
cleanHashdir :: Cache -> HashedDir -> [String] -> IO ()
cleanHashdir c :: Cache
c dir_ :: HashedDir
dir_ hashroots :: [String]
hashroots =
   do -- we'll remove obsolete bits of "dir"
      String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Cleaning out " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HashedDir -> String
hashedDir HashedDir
dir_ String -> String -> String
forall a. [a] -> [a] -> [a]
++ "..."
      let hashdir :: String
hashdir = String
darcsdir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HashedDir -> String
hashedDir HashedDir
dir_ String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/"
      Set ByteString
hs <- [String] -> Set ByteString
set ([String] -> Set ByteString) -> IO [String] -> IO (Set ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> IO [String]
getHashedFiles String
hashdir [String]
hashroots
      Set ByteString
fs <- [String] -> Set ByteString
set ([String] -> Set ByteString)
-> ([String] -> [String]) -> [String] -> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
okayHash ([String] -> Set ByteString) -> IO [String] -> IO (Set ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
hashdir
      (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
hashdirString -> String -> String
forall a. [a] -> [a] -> [a]
++)) (Set ByteString -> [String]
unset (Set ByteString -> [String]) -> Set ByteString -> [String]
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.
      String -> IO ()
debugMessage "Cleaning out any global caches..."
      Cache -> HashedDir -> [String] -> IO ()
cleanCachesWithHint Cache
c HashedDir
dir_ (Set ByteString -> [String]
unset (Set ByteString -> [String]) -> Set ByteString -> [String]
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 :: [String] -> Set ByteString
set = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList ([ByteString] -> Set ByteString)
-> ([String] -> [ByteString]) -> [String] -> Set ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ByteString) -> [String] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map String -> ByteString
BC.pack
         unset :: Set ByteString -> [String]
unset = (ByteString -> String) -> [ByteString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> String
BC.unpack ([ByteString] -> [String])
-> (Set ByteString -> [ByteString]) -> Set ByteString -> [String]
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 :: String -> [String] -> IO [String]
getHashedFiles :: String -> [String] -> IO [String]
getHashedFiles hashdir :: String
hashdir hashroots :: [String]
hashroots = do
      let listone :: String -> IO [String]
listone h :: String
h = do let size :: Maybe Int
size = ByteString -> Maybe Int
decodeDarcsSize (ByteString -> Maybe Int) -> ByteString -> Maybe Int
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack String
h
                             hash :: Hash
hash = ByteString -> Hash
decodeDarcsHash (ByteString -> Hash) -> ByteString -> Hash
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack String
h
                         [(ItemType, Name, Maybe Int, Hash)]
x <- String
-> (Maybe Int, Hash) -> IO [(ItemType, Name, Maybe Int, Hash)]
readDarcsHashedDir String
hashdir (Maybe Int
size, Hash
hash)
                         let subs :: [String]
subs = [ (String, Maybe (Int64, Int)) -> String
forall a b. (a, b) -> a
fst ((String, Maybe (Int64, Int)) -> String)
-> (String, Maybe (Int64, Int)) -> String
forall a b. (a -> b) -> a -> b
$ String -> (Maybe Int, Hash) -> (String, Maybe (Int64, Int))
darcsLocation "" (Maybe Int
s, Hash
h') | (TreeType, _, s :: Maybe Int
s, h' :: Hash
h') <- [(ItemType, Name, Maybe Int, Hash)]
x ]
                             hashes :: [String]
hashes = String
h String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [ (String, Maybe (Int64, Int)) -> String
forall a b. (a, b) -> a
fst ((String, Maybe (Int64, Int)) -> String)
-> (String, Maybe (Int64, Int)) -> String
forall a b. (a -> b) -> a -> b
$ String -> (Maybe Int, Hash) -> (String, Maybe (Int64, Int))
darcsLocation "" (Maybe Int
s, Hash
h') | (_, _, s :: Maybe Int
s, h' :: Hash
h') <- [(ItemType, Name, Maybe Int, Hash)]
x ]
                         ([String]
hashes[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> ([[String]] -> [String]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
listone [String]
subs
      [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
listone [String]
hashroots