{-# LANGUAGE CPP, MultiParamTypeClasses #-}
module Darcs.Util.Index
( openIndex
, updateIndexFrom
, indexFormatValid
, treeFromIndex
, listFileIDs
, Index
, filter
, getFileID
, align
) where
import Darcs.Prelude hiding ( readFile, writeFile, filter )
import Darcs.Util.ByteString ( readSegment, decodeLocale )
import qualified Darcs.Util.File ( getFileStatus )
import Darcs.Util.Hash( sha256, rawHash )
import Darcs.Util.Tree
import Darcs.Util.Path
( AnchoredPath
, anchorPath
, anchoredRoot
, Name
, rawMakeName
, appendPath
, flatten
)
import Control.Monad( when )
import Control.Exception( catch, throw, SomeException, Exception )
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Data.ByteString.Unsafe( unsafeHead, unsafeDrop )
import Data.ByteString.Internal
( c2w
, fromForeignPtr
, memcpy
, nullForeignPtr
, toForeignPtr
)
import Data.Int( Int64, Int32 )
import Data.IORef( )
import Data.Maybe( fromJust, isJust, fromMaybe )
import Data.Typeable( Typeable )
import Foreign.Storable
import Foreign.ForeignPtr( ForeignPtr, withForeignPtr, castForeignPtr )
import Foreign.Ptr( Ptr, plusPtr )
import System.IO ( hPutStrLn, stderr )
import System.IO.MMap( mmapFileForeignPtr, Mode(..) )
import System.Directory( doesFileExist, getCurrentDirectory, doesDirectoryExist )
import System.Directory( renameFile )
import System.FilePath( (<.>) )
#ifdef WIN32
import System.Win32.File
( BY_HANDLE_FILE_INFORMATION(..)
, closeHandle
, createFile
, fILE_FLAG_BACKUP_SEMANTICS
, fILE_SHARE_NONE
, gENERIC_NONE
, getFileInformationByHandle
, oPEN_EXISTING
)
#else
import qualified System.Posix.Files as F ( getSymbolicLinkStatus, fileID )
#endif
import System.FilePath ( (</>) )
import qualified System.Posix.Files as F
( modificationTime, fileSize, isDirectory, isSymbolicLink
, FileStatus
)
import System.Posix.Types ( FileID, EpochTime, FileOffset )
data Item = Item { Item -> Ptr ()
iBase :: !(Ptr ())
, Item -> ByteString
iHashAndDescriptor :: !B.ByteString
} deriving Int -> Item -> ShowS
[Item] -> ShowS
Item -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Item] -> ShowS
$cshowList :: [Item] -> ShowS
show :: Item -> String
$cshow :: Item -> String
showsPrec :: Int -> Item -> ShowS
$cshowsPrec :: Int -> Item -> ShowS
Show
index_version :: B.ByteString
index_version :: ByteString
index_version = String -> ByteString
BC.pack String
"HSI6"
index_endianness_indicator :: Int32
index_endianness_indicator :: Int32
index_endianness_indicator = Int32
1
size_header, size_magic, size_endianness_indicator :: Int
size_magic :: Int
size_magic = Int
4
size_endianness_indicator :: Int
size_endianness_indicator = Int
4
= Int
size_magic forall a. Num a => a -> a -> a
+ Int
size_endianness_indicator
size_dsclen, size_hash, size_size, size_aux, size_fileid :: Int
size_size :: Int
size_size = Int
8
size_aux :: Int
size_aux = Int
8
size_fileid :: Int
size_fileid = Int
8
size_dsclen :: Int
size_dsclen = Int
4
size_hash :: Int
size_hash = Int
32
size_type, size_null :: Int
size_type :: Int
size_type = Int
1
size_null :: Int
size_null = Int
1
off_size, off_aux, off_hash, off_dsc, off_dsclen, off_fileid :: Int
off_size :: Int
off_size = Int
0
off_aux :: Int
off_aux = Int
off_size forall a. Num a => a -> a -> a
+ Int
size_size
off_fileid :: Int
off_fileid = Int
off_aux forall a. Num a => a -> a -> a
+ Int
size_aux
off_dsclen :: Int
off_dsclen = Int
off_fileid forall a. Num a => a -> a -> a
+ Int
size_fileid
off_hash :: Int
off_hash = Int
off_dsclen forall a. Num a => a -> a -> a
+ Int
size_dsclen
off_dsc :: Int
off_dsc = Int
off_hash forall a. Num a => a -> a -> a
+ Int
size_hash
itemAllocSize :: AnchoredPath -> Int
itemAllocSize :: AnchoredPath -> Int
itemAllocSize AnchoredPath
apath = forall a. Integral a => a -> a -> a
align Int
4 forall a b. (a -> b) -> a -> b
$
Int
size_size forall a. Num a => a -> a -> a
+ Int
size_aux forall a. Num a => a -> a -> a
+ Int
size_fileid forall a. Num a => a -> a -> a
+ Int
size_dsclen forall a. Num a => a -> a -> a
+ Int
size_hash forall a. Num a => a -> a -> a
+
Int
size_type forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length (AnchoredPath -> ByteString
flatten AnchoredPath
apath) forall a. Num a => a -> a -> a
+ Int
size_null
itemSize, itemNext :: Item -> Int
itemSize :: Item -> Int
itemSize Item
i =
Int
size_size forall a. Num a => a -> a -> a
+ Int
size_aux forall a. Num a => a -> a -> a
+ Int
size_fileid forall a. Num a => a -> a -> a
+ Int
size_dsclen forall a. Num a => a -> a -> a
+
(ByteString -> Int
B.length forall a b. (a -> b) -> a -> b
$ Item -> ByteString
iHashAndDescriptor Item
i)
itemNext :: Item -> Int
itemNext Item
i = forall a. Integral a => a -> a -> a
align Int
4 (Item -> Int
itemSize Item
i forall a. Num a => a -> a -> a
+ Int
1)
iHash, iDescriptor :: Item -> B.ByteString
iDescriptor :: Item -> ByteString
iDescriptor = Int -> ByteString -> ByteString
unsafeDrop Int
size_hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> ByteString
iHashAndDescriptor
iHash :: Item -> ByteString
iHash = Int -> ByteString -> ByteString
B.take Int
size_hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> ByteString
iHashAndDescriptor
iPath :: Item -> FilePath
iPath :: Item -> String
iPath = ByteString -> String
decodeLocale forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
unsafeDrop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> ByteString
iDescriptor
iSize, iAux :: Item -> Ptr Int64
iSize :: Item -> Ptr Int64
iSize Item
i = forall a b. Ptr a -> Int -> Ptr b
plusPtr (Item -> Ptr ()
iBase Item
i) Int
off_size
iAux :: Item -> Ptr Int64
iAux Item
i = forall a b. Ptr a -> Int -> Ptr b
plusPtr (Item -> Ptr ()
iBase Item
i) Int
off_aux
iFileID :: Item -> Ptr FileID
iFileID :: Item -> Ptr FileID
iFileID Item
i = forall a b. Ptr a -> Int -> Ptr b
plusPtr (Item -> Ptr ()
iBase Item
i) Int
off_fileid
itemIsDir :: Item -> Bool
itemIsDir :: Item -> Bool
itemIsDir Item
i = ByteString -> Word8
unsafeHead (Item -> ByteString
iDescriptor Item
i) forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'D'
type FileStatus = Maybe F.FileStatus
modificationTime :: FileStatus -> EpochTime
modificationTime :: FileStatus -> EpochTime
modificationTime = forall b a. b -> (a -> b) -> Maybe a -> b
maybe EpochTime
0 FileStatus -> EpochTime
F.modificationTime
fileSize :: FileStatus -> FileOffset
fileSize :: FileStatus -> FileOffset
fileSize = forall b a. b -> (a -> b) -> Maybe a -> b
maybe FileOffset
0 FileStatus -> FileOffset
F.fileSize
fileExists :: FileStatus -> Bool
fileExists :: FileStatus -> Bool
fileExists = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a b. a -> b -> a
const Bool
True)
isDirectory :: FileStatus -> Bool
isDirectory :: FileStatus -> Bool
isDirectory = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False FileStatus -> Bool
F.isDirectory
createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item
createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item
createItem ItemType
typ AnchoredPath
apath ForeignPtr ()
fp Int
off = do
let dsc :: ByteString
dsc =
[ByteString] -> ByteString
B.concat
[ Char -> ByteString
BC.singleton forall a b. (a -> b) -> a -> b
$ if ItemType
typ forall a. Eq a => a -> a -> Bool
== ItemType
TreeType then Char
'D' else Char
'F'
, AnchoredPath -> ByteString
flatten AnchoredPath
apath
, Word8 -> ByteString
B.singleton Word8
0
]
(ForeignPtr Word8
dsc_fp, Int
dsc_start, Int
dsc_len) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
dsc
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
fp forall a b. (a -> b) -> a -> b
$ \Ptr ()
p ->
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
dsc_fp forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dsc_p -> do
FileID
fileid <- forall a. a -> Maybe a -> a
fromMaybe FileID
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredPath -> IO (Maybe FileID)
getFileID AnchoredPath
apath
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr ()
p (Int
off forall a. Num a => a -> a -> a
+ Int
off_fileid) (forall a b. (Integral a, Num b) => a -> b
fromIntegral FileID
fileid :: Int64)
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr ()
p (Int
off forall a. Num a => a -> a -> a
+ Int
off_dsclen) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dsc_len :: Int32)
Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memcpy
(forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr ()
p forall a b. (a -> b) -> a -> b
$ Int
off forall a. Num a => a -> a -> a
+ Int
off_dsc)
(forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dsc_p Int
dsc_start)
(forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dsc_len)
ForeignPtr () -> Int -> IO Item
peekItem ForeignPtr ()
fp Int
off
peekItem :: ForeignPtr () -> Int -> IO Item
peekItem :: ForeignPtr () -> Int -> IO Item
peekItem ForeignPtr ()
fp Int
off =
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
fp forall a b. (a -> b) -> a -> b
$ \Ptr ()
p -> do
Int32
nl' :: Int32 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr ()
p (Int
off forall a. Num a => a -> a -> a
+ Int
off_dsclen)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
nl' forall a. Ord a => a -> a -> Bool
<= Int32
2) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Descriptor too short in peekItem!"
let nl :: Int
nl = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
nl'
dsc :: ByteString
dsc =
ForeignPtr Word8 -> Int -> Int -> ByteString
fromForeignPtr
(forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr ()
fp)
(Int
off forall a. Num a => a -> a -> a
+ Int
off_hash)
(Int
size_hash forall a. Num a => a -> a -> a
+ Int
nl forall a. Num a => a -> a -> a
- Int
1)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Item {iBase :: Ptr ()
iBase = forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr ()
p Int
off, iHashAndDescriptor :: ByteString
iHashAndDescriptor = ByteString
dsc}
updateItem :: Item -> Int64 -> Hash -> IO ()
updateItem :: Item -> Int64 -> Hash -> IO ()
updateItem Item
item Int64
_ Hash
NoHash =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Index.update NoHash: " forall a. [a] -> [a] -> [a]
++ Item -> String
iPath Item
item
updateItem Item
item Int64
size Hash
hash =
do forall a. Storable a => Ptr a -> a -> IO ()
poke (Item -> Ptr Int64
iSize Item
item) Int64
size
ByteString -> ByteString -> IO ()
unsafePokeBS (Item -> ByteString
iHash Item
item) (Hash -> ByteString
rawHash Hash
hash)
updateFileID :: Item -> FileID -> IO ()
updateFileID :: Item -> FileID -> IO ()
updateFileID Item
item FileID
fileid = forall a. Storable a => Ptr a -> a -> IO ()
poke (Item -> Ptr FileID
iFileID Item
item) forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral FileID
fileid
updateAux :: Item -> Int64 -> IO ()
updateAux :: Item -> Int64 -> IO ()
updateAux Item
item Int64
aux = forall a. Storable a => Ptr a -> a -> IO ()
poke (Item -> Ptr Int64
iAux Item
item) forall a b. (a -> b) -> a -> b
$ Int64
aux
updateTime :: forall a.(Enum a) => Item -> a -> IO ()
updateTime :: forall a. Enum a => Item -> a -> IO ()
updateTime Item
item a
mtime = Item -> Int64 -> IO ()
updateAux Item
item (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum a
mtime)
iHash' :: Item -> Hash
iHash' :: Item -> Hash
iHash' Item
i = ByteString -> Hash
SHA256 (Item -> ByteString
iHash Item
i)
mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int)
mmapIndex :: forall a. String -> Int -> IO (ForeignPtr a, Int)
mmapIndex String
indexpath Int
req_size = do
Int
act_size <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> FileOffset
fileSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
Darcs.Util.File.getFileStatus String
indexpath
let size :: Int
size = case Int
req_size forall a. Ord a => a -> a -> Bool
> Int
0 of
Bool
True -> Int
req_size
Bool
False | Int
act_size forall a. Ord a => a -> a -> Bool
>= Int
size_header -> Int
act_size forall a. Num a => a -> a -> a
- Int
size_header
| Bool
otherwise -> Int
0
case Int
size of
Int
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr Word8
nullForeignPtr, Int
size)
Int
_ -> do (ForeignPtr a
x, Int
_, Int
_) <- forall a.
String -> Mode -> Maybe (Int64, Int) -> IO (ForeignPtr a, Int, Int)
mmapFileForeignPtr String
indexpath
Mode
ReadWriteEx (forall a. a -> Maybe a
Just (Int64
0, Int
size forall a. Num a => a -> a -> a
+ Int
size_header))
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr a
x, Int
size)
data IndexM m = Index { forall (m :: * -> *). IndexM m -> ForeignPtr ()
mmap :: (ForeignPtr ())
, forall (m :: * -> *). IndexM m -> String
basedir :: FilePath
, forall (m :: * -> *). IndexM m -> Tree m -> Hash
hashtree :: Tree m -> Hash
, forall (m :: * -> *).
IndexM m -> AnchoredPath -> TreeItem m -> Bool
predicate :: AnchoredPath -> TreeItem m -> Bool }
| EmptyIndex
type Index = IndexM IO
data State = State
{ State -> Int
dirlength :: !Int
, State -> AnchoredPath
path :: !AnchoredPath
, State -> Int
start :: !Int
}
data Result = Result
{ Result -> Bool
changed :: !Bool
, Result -> Int
next :: !Int
, Result -> Maybe (TreeItem IO)
treeitem :: !(Maybe (TreeItem IO))
, Result -> Item
resitem :: !Item
}
readItem :: Index -> State -> IO Result
readItem :: Index -> State -> IO Result
readItem Index
index State
state = do
Item
item <- ForeignPtr () -> Int -> IO Item
peekItem (forall (m :: * -> *). IndexM m -> ForeignPtr ()
mmap Index
index) (State -> Int
start State
state)
Result
res' <- if Item -> Bool
itemIsDir Item
item
then Index -> State -> Item -> IO Result
readDir Index
index State
state Item
item
else Index -> State -> Item -> IO Result
readFile Index
index State
state Item
item
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res'
data CorruptIndex = CorruptIndex String deriving (CorruptIndex -> CorruptIndex -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CorruptIndex -> CorruptIndex -> Bool
$c/= :: CorruptIndex -> CorruptIndex -> Bool
== :: CorruptIndex -> CorruptIndex -> Bool
$c== :: CorruptIndex -> CorruptIndex -> Bool
Eq, Typeable)
instance Exception CorruptIndex
instance Show CorruptIndex where show :: CorruptIndex -> String
show (CorruptIndex String
s) = String
s
nameof :: Item -> State -> Maybe Name
nameof :: Item -> State -> Maybe Name
nameof Item
item State
state
| Item -> ByteString
iDescriptor Item
item forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"D." = forall a. Maybe a
Nothing
| Bool
otherwise =
case ByteString -> Either String Name
rawMakeName forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop (State -> Int
dirlength State
state forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ Item -> ByteString
iDescriptor Item
item of
Left String
msg -> forall a e. Exception e => e -> a
throw (String -> CorruptIndex
CorruptIndex String
msg)
Right Name
name -> forall a. a -> Maybe a
Just Name
name
maybeAppendName :: AnchoredPath -> Maybe Name -> AnchoredPath
maybeAppendName :: AnchoredPath -> Maybe Name -> AnchoredPath
maybeAppendName AnchoredPath
parent = forall b a. b -> (a -> b) -> Maybe a -> b
maybe AnchoredPath
parent (AnchoredPath
parent AnchoredPath -> Name -> AnchoredPath
`appendPath`)
substateof :: Item -> State -> State
substateof :: Item -> State -> State
substateof Item
item State
state =
State
state
{ start :: Int
start = State -> Int
start State
state forall a. Num a => a -> a -> a
+ Item -> Int
itemNext Item
item
, path :: AnchoredPath
path = State -> AnchoredPath
path State
state AnchoredPath -> Maybe Name -> AnchoredPath
`maybeAppendName` Maybe Name
myname
, dirlength :: Int
dirlength =
case Maybe Name
myname of
Maybe Name
Nothing ->
State -> Int
dirlength State
state
Just Name
_ ->
ByteString -> Int
B.length (Item -> ByteString
iDescriptor Item
item)
}
where
myname :: Maybe Name
myname = Item -> State -> Maybe Name
nameof Item
item State
state
readDir :: Index -> State -> Item -> IO Result
readDir :: Index -> State -> Item -> IO Result
readDir Index
index State
state Item
item = do
Int
following <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek (Item -> Ptr Int64
iAux Item
item)
FileStatus
st <- String -> IO FileStatus
getFileStatus (Item -> String
iPath Item
item)
let exists :: Bool
exists = FileStatus -> Bool
fileExists FileStatus
st Bool -> Bool -> Bool
&& FileStatus -> Bool
isDirectory FileStatus
st
FileID
fileid <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ Item -> Ptr FileID
iFileID Item
item)
FileID
fileid' <- forall a. a -> Maybe a -> a
fromMaybe FileID
fileid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe FileID)
getFileID' forall a b. (a -> b) -> a -> b
$ Item -> String
iPath Item
item)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileID
fileid forall a. Eq a => a -> a -> Bool
== FileID
0) forall a b. (a -> b) -> a -> b
$ Item -> FileID -> IO ()
updateFileID Item
item FileID
fileid'
let substate :: State
substate = Item -> State -> State
substateof Item
item State
state
want :: Bool
want = Bool
exists Bool -> Bool -> Bool
&& (forall (m :: * -> *).
IndexM m -> AnchoredPath -> TreeItem m -> Bool
predicate Index
index) (State -> AnchoredPath
path State
substate) (forall (m :: * -> *). m (Tree m) -> Hash -> TreeItem m
Stub forall a. HasCallStack => a
undefined Hash
NoHash)
oldhash :: Hash
oldhash = Item -> Hash
iHash' Item
item
subs :: Int -> IO [(Maybe Name, Result)]
subs Int
off =
case forall a. Ord a => a -> a -> Ordering
compare Int
off Int
following of
Ordering
LT -> do
Result
result <- Index -> State -> IO Result
readItem Index
index forall a b. (a -> b) -> a -> b
$ State
substate { start :: Int
start = Int
off }
[(Maybe Name, Result)]
rest <- Int -> IO [(Maybe Name, Result)]
subs forall a b. (a -> b) -> a -> b
$ Result -> Int
next Result
result
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (Item -> State -> Maybe Name
nameof (Result -> Item
resitem Result
result) State
substate, Result
result) forall a. a -> [a] -> [a]
: [(Maybe Name, Result)]
rest
Ordering
EQ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Ordering
GT ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"Offset mismatch at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
off forall a. [a] -> [a] -> [a]
++
String
" (ends at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
following forall a. [a] -> [a] -> [a]
++ String
")"
[(Maybe Name, Result)]
inferiors <- if Bool
want then Int -> IO [(Maybe Name, Result)]
subs forall a b. (a -> b) -> a -> b
$ State -> Int
start State
substate
else forall (m :: * -> *) a. Monad m => a -> m a
return []
let we_changed :: Bool
we_changed = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Result -> Bool
changed Result
x | (Maybe Name
_, Result
x) <- [(Maybe Name, Result)]
inferiors ] Bool -> Bool -> Bool
|| Bool
nullleaf
nullleaf :: Bool
nullleaf = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe Name, Result)]
inferiors Bool -> Bool -> Bool
&& Hash
oldhash forall a. Eq a => a -> a -> Bool
== Hash
nullsha
nullsha :: Hash
nullsha = ByteString -> Hash
SHA256 (Int -> Word8 -> ByteString
B.replicate Int
32 Word8
0)
tree' :: Tree IO
tree' =
forall (m :: * -> *). [(Name, TreeItem m)] -> Tree m
makeTree
[ (Name
n, forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Result -> Maybe (TreeItem IO)
treeitem Result
s)
| (Just Name
n, Result
s) <- [(Maybe Name, Result)]
inferiors, forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Result -> Maybe (TreeItem IO)
treeitem Result
s ]
treehash :: Hash
treehash = if Bool
we_changed then forall (m :: * -> *). IndexM m -> Tree m -> Hash
hashtree Index
index Tree IO
tree' else Hash
oldhash
tree :: Tree IO
tree = Tree IO
tree' { treeHash :: Hash
treeHash = Hash
treehash }
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exists Bool -> Bool -> Bool
&& Bool
we_changed) forall a b. (a -> b) -> a -> b
$ Item -> Int64 -> Hash -> IO ()
updateItem Item
item Int64
0 Hash
treehash
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Result { changed :: Bool
changed = Bool -> Bool
not Bool
exists Bool -> Bool -> Bool
|| Bool
we_changed
, next :: Int
next = Int
following
, treeitem :: Maybe (TreeItem IO)
treeitem = if Bool
want then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree IO
tree
else forall a. Maybe a
Nothing
, resitem :: Item
resitem = Item
item }
readFile :: Index -> State -> Item -> IO Result
readFile :: Index -> State -> Item -> IO Result
readFile Index
index State
state Item
item = do
FileStatus
st <- String -> IO FileStatus
getFileStatus (Item -> String
iPath Item
item)
EpochTime
mtime <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ Item -> Ptr Int64
iAux Item
item)
Int64
size <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ Item -> Ptr Int64
iSize Item
item
FileID
fileid <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ Item -> Ptr FileID
iFileID Item
item)
FileID
fileid' <- forall a. a -> Maybe a -> a
fromMaybe FileID
fileid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe FileID)
getFileID' forall a b. (a -> b) -> a -> b
$ Item -> String
iPath Item
item)
let mtime' :: EpochTime
mtime' = FileStatus -> EpochTime
modificationTime FileStatus
st
size' :: Int64
size' = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ FileStatus -> FileOffset
fileSize FileStatus
st
readblob :: IO ByteString
readblob = FileSegment -> IO ByteString
readSegment (forall (m :: * -> *). IndexM m -> String
basedir Index
index String -> ShowS
</> (Item -> String
iPath Item
item), forall a. Maybe a
Nothing)
exists :: Bool
exists = FileStatus -> Bool
fileExists FileStatus
st Bool -> Bool -> Bool
&& Bool -> Bool
not (FileStatus -> Bool
isDirectory FileStatus
st)
we_changed :: Bool
we_changed = EpochTime
mtime forall a. Eq a => a -> a -> Bool
/= EpochTime
mtime' Bool -> Bool -> Bool
|| Int64
size forall a. Eq a => a -> a -> Bool
/= Int64
size'
hash :: Hash
hash = Item -> Hash
iHash' Item
item
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exists Bool -> Bool -> Bool
&& Bool
we_changed) forall a b. (a -> b) -> a -> b
$
do Hash
hash' <- ByteString -> Hash
sha256 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO ByteString
readblob
Item -> Int64 -> Hash -> IO ()
updateItem Item
item Int64
size' Hash
hash'
forall a. Enum a => Item -> a -> IO ()
updateTime Item
item EpochTime
mtime'
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileID
fileid forall a. Eq a => a -> a -> Bool
== FileID
0) forall a b. (a -> b) -> a -> b
$ Item -> FileID -> IO ()
updateFileID Item
item FileID
fileid'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Result { changed :: Bool
changed = Bool -> Bool
not Bool
exists Bool -> Bool -> Bool
|| Bool
we_changed
, next :: Int
next = State -> Int
start State
state forall a. Num a => a -> a -> a
+ Item -> Int
itemNext Item
item
, treeitem :: Maybe (TreeItem IO)
treeitem = if Bool
exists then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Blob m -> TreeItem m
File forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob IO ByteString
readblob Hash
hash else forall a. Maybe a
Nothing
, resitem :: Item
resitem = Item
item }
data ResultF = ResultF
{ ResultF -> Int
nextF :: !Int
, ResultF -> Item
resitemF :: !Item
, ResultF -> [((AnchoredPath, ItemType), FileID)]
_fileIDs :: [((AnchoredPath, ItemType), FileID)]
}
listFileIDs :: Index -> IO ([((AnchoredPath, ItemType), FileID)])
listFileIDs :: Index -> IO [((AnchoredPath, ItemType), FileID)]
listFileIDs Index
EmptyIndex = forall (m :: * -> *) a. Monad m => a -> m a
return []
listFileIDs Index
index =
do let initial :: State
initial = State { start :: Int
start = Int
size_header
, dirlength :: Int
dirlength = Int
0
, path :: AnchoredPath
path = AnchoredPath
anchoredRoot }
ResultF
res <- Index -> State -> IO ResultF
readItemFileIDs Index
index State
initial
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ResultF -> [((AnchoredPath, ItemType), FileID)]
_fileIDs ResultF
res
readItemFileIDs :: Index -> State -> IO ResultF
readItemFileIDs :: Index -> State -> IO ResultF
readItemFileIDs Index
index State
state = do
Item
item <- ForeignPtr () -> Int -> IO Item
peekItem (forall (m :: * -> *). IndexM m -> ForeignPtr ()
mmap Index
index) (State -> Int
start State
state)
ResultF
res' <- if Item -> Bool
itemIsDir Item
item
then Index -> State -> Item -> IO ResultF
readDirFileIDs Index
index State
state Item
item
else Index -> State -> Item -> IO ResultF
readFileFileID Index
index State
state Item
item
forall (m :: * -> *) a. Monad m => a -> m a
return ResultF
res'
readDirFileIDs :: Index -> State -> Item -> IO ResultF
readDirFileIDs :: Index -> State -> Item -> IO ResultF
readDirFileIDs Index
index State
state Item
item =
do FileID
fileid <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ Item -> Ptr FileID
iFileID Item
item)
Int
following <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek (Item -> Ptr Int64
iAux Item
item)
let substate :: State
substate = Item -> State -> State
substateof Item
item State
state
subs :: Int -> IO [(Maybe Name, ResultF)]
subs Int
off =
case forall a. Ord a => a -> a -> Ordering
compare Int
off Int
following of
Ordering
LT -> do
ResultF
result <- Index -> State -> IO ResultF
readItemFileIDs Index
index forall a b. (a -> b) -> a -> b
$ State
substate {start :: Int
start = Int
off}
[(Maybe Name, ResultF)]
rest <- Int -> IO [(Maybe Name, ResultF)]
subs forall a b. (a -> b) -> a -> b
$ ResultF -> Int
nextF ResultF
result
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (Item -> State -> Maybe Name
nameof (ResultF -> Item
resitemF ResultF
result) State
substate, ResultF
result) forall a. a -> [a] -> [a]
: [(Maybe Name, ResultF)]
rest
Ordering
EQ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Ordering
GT ->
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"Offset mismatch at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
off forall a. [a] -> [a] -> [a]
++
String
" (ends at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
following forall a. [a] -> [a] -> [a]
++ String
")"
[(Maybe Name, ResultF)]
inferiors <- Int -> IO [(Maybe Name, ResultF)]
subs forall a b. (a -> b) -> a -> b
$ State -> Int
start State
substate
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ResultF { nextF :: Int
nextF = Int
following
, resitemF :: Item
resitemF = Item
item
, _fileIDs :: [((AnchoredPath, ItemType), FileID)]
_fileIDs = (((State -> AnchoredPath
path State
substate, ItemType
TreeType), FileID
fileid)forall a. a -> [a] -> [a]
:forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ResultF -> [((AnchoredPath, ItemType), FileID)]
_fileIDs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Maybe Name, ResultF)]
inferiors) }
readFileFileID :: Index -> State -> Item -> IO ResultF
readFileFileID :: Index -> State -> Item -> IO ResultF
readFileFileID Index
_ State
state Item
item =
do FileID
fileid' <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ Item -> Ptr FileID
iFileID Item
item)
let myname :: Maybe Name
myname = Item -> State -> Maybe Name
nameof Item
item State
state
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ResultF { nextF :: Int
nextF = State -> Int
start State
state forall a. Num a => a -> a -> a
+ Item -> Int
itemNext Item
item
, resitemF :: Item
resitemF = Item
item
, _fileIDs :: [((AnchoredPath, ItemType), FileID)]
_fileIDs = [((State -> AnchoredPath
path State
state AnchoredPath -> Maybe Name -> AnchoredPath
`maybeAppendName` Maybe Name
myname, ItemType
BlobType), FileID
fileid')] }
openIndex :: FilePath -> (Tree IO -> Hash) -> IO Index
openIndex :: String -> (Tree IO -> Hash) -> IO Index
openIndex String
indexpath Tree IO -> Hash
ht = do
(ForeignPtr ()
mmap_ptr, Int
mmap_size) <- forall a. String -> Int -> IO (ForeignPtr a, Int)
mmapIndex String
indexpath Int
0
String
base <- IO String
getCurrentDirectory
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Int
mmap_size forall a. Eq a => a -> a -> Bool
== Int
0 then forall (m :: * -> *). IndexM m
EmptyIndex
else Index { mmap :: ForeignPtr ()
mmap = ForeignPtr ()
mmap_ptr
, basedir :: String
basedir = String
base
, hashtree :: Tree IO -> Hash
hashtree = Tree IO -> Hash
ht
, predicate :: AnchoredPath -> TreeItem IO -> Bool
predicate = \AnchoredPath
_ TreeItem IO
_ -> Bool
True }
formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO ()
formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO ()
formatIndex ForeignPtr ()
mmap_ptr Tree IO
old Tree IO
reference =
do Int
_ <- forall {m :: * -> *}. TreeItem m -> AnchoredPath -> Int -> IO Int
create (forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree IO
reference) (AnchoredPath
anchoredRoot) Int
size_header
ByteString -> ByteString -> IO ()
unsafePokeBS ByteString
magic ByteString
index_version
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
mmap_ptr forall a b. (a -> b) -> a -> b
$ \Ptr ()
ptr ->
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr ()
ptr Int
size_magic Int32
index_endianness_indicator
where magic :: ByteString
magic = ForeignPtr Word8 -> Int -> Int -> ByteString
fromForeignPtr (forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr ()
mmap_ptr) Int
0 Int
4
create :: TreeItem m -> AnchoredPath -> Int -> IO Int
create (File Blob m
_) AnchoredPath
path' Int
off =
do Item
i <- ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item
createItem ItemType
BlobType AnchoredPath
path' ForeignPtr ()
mmap_ptr Int
off
let flatpath :: String
flatpath = String -> AnchoredPath -> String
anchorPath String
"" AnchoredPath
path'
case forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree IO
old AnchoredPath
path' of
Maybe (TreeItem IO)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TreeItem IO
ti -> do FileStatus
st <- String -> IO FileStatus
getFileStatus String
flatpath
let hash :: Hash
hash = forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem IO
ti
mtime :: EpochTime
mtime = FileStatus -> EpochTime
modificationTime FileStatus
st
size :: FileOffset
size = FileStatus -> FileOffset
fileSize FileStatus
st
Item -> Int64 -> Hash -> IO ()
updateItem Item
i (forall a b. (Integral a, Num b) => a -> b
fromIntegral FileOffset
size) Hash
hash
forall a. Enum a => Item -> a -> IO ()
updateTime Item
i EpochTime
mtime
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
off forall a. Num a => a -> a -> a
+ Item -> Int
itemNext Item
i
create (SubTree Tree m
s) AnchoredPath
path' Int
off =
do Item
i <- ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item
createItem ItemType
TreeType AnchoredPath
path' ForeignPtr ()
mmap_ptr Int
off
case forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree IO
old AnchoredPath
path' of
Maybe (TreeItem IO)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TreeItem IO
ti | forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem IO
ti forall a. Eq a => a -> a -> Bool
== Hash
NoHash -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> Item -> Int64 -> Hash -> IO ()
updateItem Item
i Int64
0 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem IO
ti
let subs :: [(Name, TreeItem m)] -> IO Int
subs [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
off forall a. Num a => a -> a -> a
+ Item -> Int
itemNext Item
i
subs ((Name
name,TreeItem m
x):[(Name, TreeItem m)]
xs) = do
let path'' :: AnchoredPath
path'' = AnchoredPath
path' AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
name
Int
noff <- [(Name, TreeItem m)] -> IO Int
subs [(Name, TreeItem m)]
xs
TreeItem m -> AnchoredPath -> Int -> IO Int
create TreeItem m
x AnchoredPath
path'' Int
noff
Int
lastOff <- [(Name, TreeItem m)] -> IO Int
subs (forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
s)
forall a. Storable a => Ptr a -> a -> IO ()
poke (Item -> Ptr Int64
iAux Item
i) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lastOff)
forall (m :: * -> *) a. Monad m => a -> m a
return Int
lastOff
create (Stub m (Tree m)
_ Hash
_) AnchoredPath
path' Int
_ =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Cannot create index from stubbed Tree at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show AnchoredPath
path'
updateIndexFrom :: FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index
updateIndexFrom :: String -> (Tree IO -> Hash) -> Tree IO -> IO Index
updateIndexFrom String
indexpath Tree IO -> Hash
hashtree' Tree IO
ref =
do Tree IO
old_tree <- Index -> IO (Tree IO)
treeFromIndex forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> (Tree IO -> Hash) -> IO Index
openIndex String
indexpath Tree IO -> Hash
hashtree'
Tree IO
reference <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree IO
ref
let len_root :: Int
len_root = AnchoredPath -> Int
itemAllocSize AnchoredPath
anchoredRoot
len :: Int
len = Int
len_root forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ AnchoredPath -> Int
itemAllocSize AnchoredPath
p | (AnchoredPath
p, TreeItem IO
_) <- forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
reference ]
Bool
exist <- String -> IO Bool
doesFileExist String
indexpath
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exist forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
renameFile String
indexpath (String
indexpath String -> ShowS
<.> String
"old")
(ForeignPtr ()
mmap_ptr, Int
_) <- forall a. String -> Int -> IO (ForeignPtr a, Int)
mmapIndex String
indexpath Int
len
ForeignPtr () -> Tree IO -> Tree IO -> IO ()
formatIndex ForeignPtr ()
mmap_ptr Tree IO
old_tree Tree IO
reference
String -> (Tree IO -> Hash) -> IO Index
openIndex String
indexpath Tree IO -> Hash
hashtree'
treeFromIndex :: Index -> IO (Tree IO)
treeFromIndex :: Index -> IO (Tree IO)
treeFromIndex Index
EmptyIndex = forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *). Tree m
emptyTree
treeFromIndex Index
index =
do let initial :: State
initial = State { start :: Int
start = Int
size_header
, dirlength :: Int
dirlength = Int
0
, path :: AnchoredPath
path = AnchoredPath
anchoredRoot }
Result
res <- Index -> State -> IO Result
readItem Index
index State
initial
case Result -> Maybe (TreeItem IO)
treeitem Result
res of
Just (SubTree Tree IO
tree) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
filter (forall (m :: * -> *).
IndexM m -> AnchoredPath -> TreeItem m -> Bool
predicate Index
index) Tree IO
tree
Maybe (TreeItem IO)
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected failure in treeFromIndex!"
indexFormatValid :: FilePath -> IO Bool
indexFormatValid :: String -> IO Bool
indexFormatValid String
path' =
do
(ForeignPtr Any
start, Int
_, Int
_) <- forall a.
String -> Mode -> Maybe (Int64, Int) -> IO (ForeignPtr a, Int, Int)
mmapFileForeignPtr String
path' Mode
ReadOnly (forall a. a -> Maybe a
Just (Int64
0, Int
size_header))
let magic :: ByteString
magic = ForeignPtr Word8 -> Int -> Int -> ByteString
fromForeignPtr (forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr Any
start) Int
0 Int
4
Int32
endianness_indicator <- forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Any
start forall a b. (a -> b) -> a -> b
$ \Ptr Any
ptr -> forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
ptr Int
4
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
ByteString
index_version forall a. Eq a => a -> a -> Bool
== ByteString
magic Bool -> Bool -> Bool
&& Int32
index_endianness_indicator forall a. Eq a => a -> a -> Bool
== Int32
endianness_indicator
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_::SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
instance FilterTree IndexM IO where
filter :: (AnchoredPath -> TreeItem IO -> Bool) -> Index -> Index
filter AnchoredPath -> TreeItem IO -> Bool
_ Index
EmptyIndex = forall (m :: * -> *). IndexM m
EmptyIndex
filter AnchoredPath -> TreeItem IO -> Bool
p Index
index = Index
index { predicate :: AnchoredPath -> TreeItem IO -> Bool
predicate = \AnchoredPath
a TreeItem IO
b -> forall (m :: * -> *).
IndexM m -> AnchoredPath -> TreeItem m -> Bool
predicate Index
index AnchoredPath
a TreeItem IO
b Bool -> Bool -> Bool
&& AnchoredPath -> TreeItem IO -> Bool
p AnchoredPath
a TreeItem IO
b }
getFileID :: AnchoredPath -> IO (Maybe FileID)
getFileID :: AnchoredPath -> IO (Maybe FileID)
getFileID = String -> IO (Maybe FileID)
getFileID' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AnchoredPath -> String
anchorPath String
""
getFileID' :: FilePath -> IO (Maybe FileID)
getFileID' :: String -> IO (Maybe FileID)
getFileID' String
fp = do
Bool
file_exists <- String -> IO Bool
doesFileExist String
fp
Bool
dir_exists <- String -> IO Bool
doesDirectoryExist String
fp
if Bool
file_exists Bool -> Bool -> Bool
|| Bool
dir_exists
#ifdef WIN32
then do
h <-
createFile fp gENERIC_NONE fILE_SHARE_NONE Nothing
oPEN_EXISTING fILE_FLAG_BACKUP_SEMANTICS Nothing
fhnumber <-
(Just . fromIntegral . bhfiFileIndex) <$> getFileInformationByHandle h
closeHandle h
return fhnumber
#else
then (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> FileID
F.fileID) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
F.getSymbolicLinkStatus String
fp
#endif
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
unsafePokeBS :: BC.ByteString -> BC.ByteString -> IO ()
unsafePokeBS :: ByteString -> ByteString -> IO ()
unsafePokeBS ByteString
to ByteString
from =
do let (ForeignPtr Word8
fp_to, Int
off_to, Int
len_to) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
to
(ForeignPtr Word8
fp_from, Int
off_from, Int
len_from) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
from
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len_to forall a. Eq a => a -> a -> Bool
/= Int
len_from) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Length mismatch in unsafePokeBS: from = "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
len_from forall a. [a] -> [a] -> [a]
++ String
" /= to = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
len_to
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp_from forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p_from ->
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp_to forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p_to ->
Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memcpy (forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
p_to Int
off_to)
(forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
p_from Int
off_from)
(forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len_to)
align :: Integral a => a -> a -> a
align :: forall a. Integral a => a -> a -> a
align a
boundary a
i = case a
i forall a. Integral a => a -> a -> a
`rem` a
boundary of
a
0 -> a
i
a
x -> a
i forall a. Num a => a -> a -> a
+ a
boundary forall a. Num a => a -> a -> a
- a
x
{-# INLINE align #-}
getFileStatus :: FilePath -> IO FileStatus
getFileStatus :: String -> IO FileStatus
getFileStatus String
path = do
FileStatus
mst <- String -> IO FileStatus
Darcs.Util.File.getFileStatus String
path
case FileStatus
mst of
Just FileStatus
st
| FileStatus -> Bool
F.isSymbolicLink FileStatus
st -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Warning: ignoring symbolic link " forall a. [a] -> [a] -> [a]
++ String
path
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
FileStatus
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return FileStatus
mst