{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses #-}
module Darcs.Util.Index( readIndex, updateIndexFrom, indexFormatValid
, updateIndex, listFileIDs, Index, filter
, getFileID
, align
, xlate32
, xlate64 )
where
import Prelude hiding ( lookup, readFile, writeFile, filter, (<$>) )
import Darcs.Util.ByteString ( readSegment, decodeLocale )
import Darcs.Util.File ( getFileStatus )
import Darcs.Util.Hash( sha256, rawHash )
import Darcs.Util.Tree
import Darcs.Util.Path
( AnchoredPath(..)
, anchorPath
, anchoredRoot
, unsafeMakeName
, appendPath
, flatten
)
import Control.Monad( when )
import Control.Exception( catch, SomeException )
import Control.Applicative( (<$>) )
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Data.ByteString.Unsafe( unsafeHead, unsafeDrop )
import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy
, nullForeignPtr, c2w )
import Data.Bits( Bits )
#ifdef BIGENDIAN
import Data.Bits( (.&.), (.|.), shift, shiftL, rotateR )
#endif
import Data.Int( Int64, Int32 )
import Data.IORef( )
import Data.Maybe( fromJust, isJust, fromMaybe )
import Foreign.Storable
import Foreign.ForeignPtr( ForeignPtr, withForeignPtr, castForeignPtr )
import Foreign.Ptr( Ptr, plusPtr )
import System.IO.MMap( mmapFileForeignPtr, mmapFileByteString, Mode(..) )
import System.Directory( doesFileExist, getCurrentDirectory, doesDirectoryExist )
#if mingw32_HOST_OS
import System.Directory( renameFile )
import System.FilePath( (<.>) )
#else
import System.Directory( removeFile )
#endif
#ifdef WIN32
import System.Win32.File ( createFile, getFileInformationByHandle, BY_HANDLE_FILE_INFORMATION(..),
fILE_SHARE_NONE, fILE_FLAG_BACKUP_SEMANTICS,
gENERIC_NONE, oPEN_EXISTING, closeHandle )
#else
import qualified System.Posix.Files as F ( getSymbolicLinkStatus, fileID )
#endif
import System.FilePath ( (</>) )
import qualified System.Posix.Files as F
( modificationTime, fileSize, isDirectory
, 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
(Int -> Item -> ShowS)
-> (Item -> String) -> ([Item] -> ShowS) -> Show Item
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
size_magic :: Int
size_magic :: Int
size_magic = 4
size_dsclen, size_hash, size_size, size_aux, size_fileid :: Int
size_size :: Int
size_size = 8
size_aux :: Int
size_aux = 8
size_fileid :: Int
size_fileid = 8
size_dsclen :: Int
size_dsclen = 4
size_hash :: Int
size_hash = 32
off_size, off_aux, off_hash, off_dsc, off_dsclen, off_fileid :: Int
off_size :: Int
off_size = 0
off_aux :: Int
off_aux = Int
off_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_size
off_fileid :: Int
off_fileid = Int
off_aux Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_aux
off_dsclen :: Int
off_dsclen = Int
off_fileid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_fileid
off_hash :: Int
off_hash = Int
off_dsclen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_dsclen
off_dsc :: Int
off_dsc = Int
off_hash Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_hash
itemAllocSize :: AnchoredPath -> Int
itemAllocSize :: AnchoredPath -> Int
itemAllocSize apath :: AnchoredPath
apath =
Int -> Int -> Int
forall a. Integral a => a -> a -> a
align 4 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
size_hash Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_aux Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_fileid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_dsclen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length (AnchoredPath -> ByteString
flatten AnchoredPath
apath)
itemSize, itemNext :: Item -> Int
itemSize :: Item -> Int
itemSize i :: Item
i = Int
size_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_aux Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_fileid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_dsclen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (ByteString -> Int
B.length (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ Item -> ByteString
iHashAndDescriptor Item
i)
itemNext :: Item -> Int
itemNext i :: Item
i = Int -> Int -> Int
forall a. Integral a => a -> a -> a
align 4 (Item -> Int
itemSize Item
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
iHash, iDescriptor :: Item -> B.ByteString
iDescriptor :: Item -> ByteString
iDescriptor = Int -> ByteString -> ByteString
unsafeDrop Int
size_hash (ByteString -> ByteString)
-> (Item -> ByteString) -> Item -> ByteString
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 (ByteString -> ByteString)
-> (Item -> ByteString) -> Item -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> ByteString
iHashAndDescriptor
iPath :: Item -> FilePath
iPath :: Item -> String
iPath = ByteString -> String
decodeLocale (ByteString -> String) -> (Item -> ByteString) -> Item -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
unsafeDrop 1 (ByteString -> ByteString)
-> (Item -> ByteString) -> Item -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> ByteString
iDescriptor
iSize, iAux :: Item -> Ptr Int64
iSize :: Item -> Ptr Int64
iSize i :: Item
i = Ptr () -> Int -> Ptr Int64
forall a b. Ptr a -> Int -> Ptr b
plusPtr (Item -> Ptr ()
iBase Item
i) Int
off_size
iAux :: Item -> Ptr Int64
iAux i :: Item
i = Ptr () -> Int -> Ptr Int64
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 i :: Item
i = Ptr () -> Int -> Ptr FileID
forall a b. Ptr a -> Int -> Ptr b
plusPtr (Item -> Ptr ()
iBase Item
i) Int
off_fileid
itemIsDir :: Item -> Bool
itemIsDir :: Item -> Bool
itemIsDir i :: Item
i = ByteString -> Word8
unsafeHead (Item -> ByteString
iDescriptor Item
i) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w 'D'
xlatePeek64 :: (Storable a, Num a, Bits a) => Ptr a -> IO a
xlatePeek64 :: Ptr a -> IO a
xlatePeek64 = (a -> a) -> IO a -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
forall a. (Num a, Bits a) => a -> a
xlate64 (IO a -> IO a) -> (Ptr a -> IO a) -> Ptr a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek
xlatePoke64 :: (Storable a, Num a, Bits a) => Ptr a -> a -> IO ()
xlatePoke64 :: Ptr a -> a -> IO ()
xlatePoke64 ptr :: Ptr a
ptr v :: a
v = Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
ptr (a -> a
forall a. (Num a, Bits a) => a -> a
xlate64 a
v)
type FileStatus = Maybe F.FileStatus
modificationTime :: FileStatus -> EpochTime
modificationTime :: FileStatus -> EpochTime
modificationTime = EpochTime -> (FileStatus -> EpochTime) -> FileStatus -> EpochTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 FileStatus -> EpochTime
F.modificationTime
fileSize :: FileStatus -> FileOffset
fileSize :: FileStatus -> FileOffset
fileSize = FileOffset
-> (FileStatus -> FileOffset) -> FileStatus -> FileOffset
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 FileStatus -> FileOffset
F.fileSize
fileExists :: FileStatus -> Bool
fileExists :: FileStatus -> Bool
fileExists = Bool -> (FileStatus -> Bool) -> FileStatus -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> FileStatus -> Bool
forall a b. a -> b -> a
const Bool
True)
isDirectory :: FileStatus -> Bool
isDirectory :: FileStatus -> Bool
isDirectory = Bool -> (FileStatus -> Bool) -> FileStatus -> Bool
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 typ :: ItemType
typ apath :: AnchoredPath
apath fp :: ForeignPtr ()
fp off :: Int
off =
do let dsc :: ByteString
dsc = [ByteString] -> ByteString
B.concat [ Char -> ByteString
BC.singleton (Char -> ByteString) -> Char -> ByteString
forall a b. (a -> b) -> a -> b
$ if ItemType
typ ItemType -> ItemType -> Bool
forall a. Eq a => a -> a -> Bool
== ItemType
TreeType then 'D' else 'F'
, AnchoredPath -> ByteString
flatten AnchoredPath
apath
, Word8 -> ByteString
B.singleton 0 ]
(dsc_fp :: ForeignPtr Word8
dsc_fp, dsc_start :: Int
dsc_start, dsc_len :: Int
dsc_len) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
dsc
ForeignPtr () -> (Ptr () -> IO Item) -> IO Item
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
fp ((Ptr () -> IO Item) -> IO Item) -> (Ptr () -> IO Item) -> IO Item
forall a b. (a -> b) -> a -> b
$ \p :: Ptr ()
p ->
ForeignPtr Word8 -> (Ptr Word8 -> IO Item) -> IO Item
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
dsc_fp ((Ptr Word8 -> IO Item) -> IO Item)
-> (Ptr Word8 -> IO Item) -> IO Item
forall a b. (a -> b) -> a -> b
$ \dsc_p :: Ptr Word8
dsc_p ->
do FileID
fileid <- FileID -> Maybe FileID -> FileID
forall a. a -> Maybe a -> a
fromMaybe 0 (Maybe FileID -> FileID) -> IO (Maybe FileID) -> IO FileID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredPath -> IO (Maybe FileID)
getFileID AnchoredPath
apath
Ptr () -> Int -> Int64 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr ()
p (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off_fileid) (Int64 -> Int64
forall a. (Num a, Bits a) => a -> a
xlate64 (Int64 -> Int64) -> Int64 -> Int64
forall a b. (a -> b) -> a -> b
$ FileID -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral FileID
fileid :: Int64)
Ptr () -> Int -> Int32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr ()
p (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off_dsclen) (Int32 -> Int32
forall a. (Num a, Bits a) => a -> a
xlate32 (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dsc_len :: Int32)
Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memcpy (Ptr () -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr ()
p (Int -> Ptr Word8) -> Int -> Ptr Word8
forall a b. (a -> b) -> a -> b
$ Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off_dsc)
(Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dsc_p Int
dsc_start)
(Int -> Int
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 fp :: ForeignPtr ()
fp off :: Int
off =
ForeignPtr () -> (Ptr () -> IO Item) -> IO Item
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
fp ((Ptr () -> IO Item) -> IO Item) -> (Ptr () -> IO Item) -> IO Item
forall a b. (a -> b) -> a -> b
$ \p :: Ptr ()
p -> do
Int32
nl' :: Int32 <- Int32 -> Int32
forall a. (Num a, Bits a) => a -> a
xlate32 (Int32 -> Int32) -> IO Int32 -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Ptr () -> Int -> IO Int32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr ()
p (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off_dsclen)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
nl' Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
<= 2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Descriptor too short in peekItem!"
let nl :: Int
nl = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
nl'
dsc :: ByteString
dsc = ForeignPtr Word8 -> Int -> Int -> ByteString
fromForeignPtr (ForeignPtr () -> ForeignPtr Word8
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr ()
fp) (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off_hash) (Int
size_hash Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nl Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
Item -> IO Item
forall (m :: * -> *) a. Monad m => a -> m a
return (Item -> IO Item) -> Item -> IO Item
forall a b. (a -> b) -> a -> b
$! $WItem :: Ptr () -> ByteString -> Item
Item { iBase :: Ptr ()
iBase = Ptr () -> Int -> Ptr ()
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
item _ NoHash =
String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Index.update NoHash: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Item -> String
iPath Item
item
updateItem item :: Item
item size :: Int64
size hash :: Hash
hash =
do Ptr Int64 -> Int64 -> IO ()
forall a. (Storable a, Num a, Bits a) => Ptr a -> a -> IO ()
xlatePoke64 (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
item fileid :: FileID
fileid = Ptr FileID -> FileID -> IO ()
forall a. (Storable a, Num a, Bits a) => Ptr a -> a -> IO ()
xlatePoke64 (Item -> Ptr FileID
iFileID Item
item) (FileID -> IO ()) -> FileID -> IO ()
forall a b. (a -> b) -> a -> b
$ FileID -> FileID
forall a b. (Integral a, Num b) => a -> b
fromIntegral FileID
fileid
updateAux :: Item -> Int64 -> IO ()
updateAux :: Item -> Int64 -> IO ()
updateAux item :: Item
item aux :: Int64
aux = Ptr Int64 -> Int64 -> IO ()
forall a. (Storable a, Num a, Bits a) => Ptr a -> a -> IO ()
xlatePoke64 (Item -> Ptr Int64
iAux Item
item) (Int64 -> IO ()) -> Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int64
aux
updateTime :: forall a.(Enum a) => Item -> a -> IO ()
updateTime :: Item -> a -> IO ()
updateTime item :: Item
item mtime :: a
mtime = Item -> Int64 -> IO ()
updateAux Item
item (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Enum a => a -> Int
fromEnum a
mtime)
iHash' :: Item -> Hash
iHash' :: Item -> Hash
iHash' i :: Item
i = ByteString -> Hash
SHA256 (Item -> ByteString
iHash Item
i)
mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int)
mmapIndex :: String -> Int -> IO (ForeignPtr a, Int)
mmapIndex indexpath :: String
indexpath req_size :: Int
req_size = do
Int
act_size <- FileOffset -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileOffset -> Int)
-> (FileStatus -> FileOffset) -> FileStatus -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> FileOffset
fileSize (FileStatus -> Int) -> IO FileStatus -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
getFileStatus String
indexpath
let size :: Int
size = case Int
req_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 of
True -> Int
req_size
False | Int
act_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
size_magic -> Int
act_size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
size_magic
| Bool
otherwise -> 0
case Int
size of
0 -> (ForeignPtr a, Int) -> IO (ForeignPtr a, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> ForeignPtr a
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr Word8
nullForeignPtr, Int
size)
_ -> do (x :: ForeignPtr a
x, _, _) <- String -> Mode -> Maybe (Int64, Int) -> IO (ForeignPtr a, Int, Int)
forall a.
String -> Mode -> Maybe (Int64, Int) -> IO (ForeignPtr a, Int, Int)
mmapFileForeignPtr String
indexpath
Mode
ReadWriteEx ((Int64, Int) -> Maybe (Int64, Int)
forall a. a -> Maybe a
Just (0, Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_magic))
(ForeignPtr a, Int) -> IO (ForeignPtr a, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr a
x, Int
size)
data IndexM m = Index { IndexM m -> ForeignPtr ()
mmap :: (ForeignPtr ())
, IndexM m -> String
basedir :: FilePath
, IndexM m -> Tree m -> Hash
hashtree :: Tree m -> Hash
, 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 }
data ResultF = ResultF {
ResultF -> Int
nextF :: !Int
, ResultF -> Item
resitemF :: !Item
, ResultF -> [((AnchoredPath, ItemType), FileID)]
_fileIDs :: [((AnchoredPath, ItemType), FileID)] }
readItem :: Index -> State -> IO Result
readItem :: Index -> State -> IO Result
readItem index :: Index
index state :: State
state = do
Item
item <- ForeignPtr () -> Int -> IO Item
peekItem (Index -> ForeignPtr ()
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
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res'
readDir :: Index -> State -> Item -> IO Result
readDir :: Index -> State -> Item -> IO Result
readDir index :: Index
index state :: State
state item :: Item
item = do
Int
following <- Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> IO Int64 -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Int64 -> IO Int64
forall a. (Storable a, Num a, Bits a) => Ptr a -> IO a
xlatePeek64 (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 <- FileID -> FileID
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileID -> FileID) -> IO FileID -> IO FileID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr FileID -> IO FileID
forall a. (Storable a, Num a, Bits a) => Ptr a -> IO a
xlatePeek64 (Ptr FileID -> IO FileID) -> Ptr FileID -> IO FileID
forall a b. (a -> b) -> a -> b
$ Item -> Ptr FileID
iFileID Item
item)
FileID
fileid' <- FileID -> Maybe FileID -> FileID
forall a. a -> Maybe a -> a
fromMaybe FileID
fileid (Maybe FileID -> FileID) -> IO (Maybe FileID) -> IO FileID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe FileID)
getFileID' (String -> IO (Maybe FileID)) -> String -> IO (Maybe FileID)
forall a b. (a -> b) -> a -> b
$ Item -> String
iPath Item
item)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileID
fileid FileID -> FileID -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Item -> FileID -> IO ()
updateFileID Item
item FileID
fileid'
let name :: Item -> Int -> Name
name it :: Item
it dirlen :: Int
dirlen = ByteString -> Name
unsafeMakeName (ByteString -> Name) -> ByteString -> Name
forall a b. (a -> b) -> a -> b
$ (Int -> ByteString -> ByteString
B.drop (Int
dirlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Item -> ByteString
iDescriptor Item
it)
namelength :: Int
namelength = (ByteString -> Int
B.length (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ Item -> ByteString
iDescriptor Item
item) Int -> Int -> Int
forall a. Num a => a -> a -> a
- (State -> Int
dirlength State
state)
myname :: Name
myname = Item -> Int -> Name
name Item
item (State -> Int
dirlength State
state)
substate :: State
substate = State
state { start :: Int
start = State -> Int
start State
state Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Item -> Int
itemNext Item
item
, path :: AnchoredPath
path = State -> AnchoredPath
path State
state AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
myname
, dirlength :: Int
dirlength = if Name
myname Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Name
unsafeMakeName (Char -> ByteString
BC.singleton '.')
then State -> Int
dirlength State
state
else State -> Int
dirlength State
state Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
namelength }
want :: Bool
want = Bool
exists Bool -> Bool -> Bool
&& (Index -> AnchoredPath -> TreeItem IO -> Bool
forall (m :: * -> *).
IndexM m -> AnchoredPath -> TreeItem m -> Bool
predicate Index
index) (State -> AnchoredPath
path State
substate) (IO (Tree IO) -> Hash -> TreeItem IO
forall (m :: * -> *). m (Tree m) -> Hash -> TreeItem m
Stub IO (Tree IO)
forall a. HasCallStack => a
undefined Hash
NoHash)
oldhash :: Hash
oldhash = Item -> Hash
iHash' Item
item
subs :: Int -> IO [(Name, Result)]
subs off :: Int
off | Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
following = do
Result
result <- Index -> State -> IO Result
readItem Index
index (State -> IO Result) -> State -> IO Result
forall a b. (a -> b) -> a -> b
$ State
substate { start :: Int
start = Int
off }
[(Name, Result)]
rest <- Int -> IO [(Name, Result)]
subs (Int -> IO [(Name, Result)]) -> Int -> IO [(Name, Result)]
forall a b. (a -> b) -> a -> b
$ Result -> Int
next Result
result
[(Name, Result)] -> IO [(Name, Result)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Result)] -> IO [(Name, Result)])
-> [(Name, Result)] -> IO [(Name, Result)]
forall a b. (a -> b) -> a -> b
$! (Item -> Int -> Name
name (Result -> Item
resitem Result
result) (Int -> Name) -> Int -> Name
forall a b. (a -> b) -> a -> b
$ State -> Int
dirlength State
substate, Result
result) (Name, Result) -> [(Name, Result)] -> [(Name, Result)]
forall a. a -> [a] -> [a]
: [(Name, Result)]
rest
subs coff :: Int
coff | Int
coff Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
following = [(Name, Result)] -> IO [(Name, Result)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = String -> IO [(Name, Result)]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO [(Name, Result)]) -> String -> IO [(Name, Result)]
forall a b. (a -> b) -> a -> b
$ "Offset mismatch at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
coff String -> ShowS
forall a. [a] -> [a] -> [a]
++
" (ends at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
following String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
[(Name, Result)]
inferiors <- if Bool
want then Int -> IO [(Name, Result)]
subs (Int -> IO [(Name, Result)]) -> Int -> IO [(Name, Result)]
forall a b. (a -> b) -> a -> b
$ State -> Int
start State
substate
else [(Name, Result)] -> IO [(Name, Result)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
let we_changed :: Bool
we_changed = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Result -> Bool
changed Result
x | (_, x :: Result
x) <- [(Name, Result)]
inferiors ] Bool -> Bool -> Bool
|| Bool
nullleaf
nullleaf :: Bool
nullleaf = [(Name, Result)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, Result)]
inferiors Bool -> Bool -> Bool
&& Hash
oldhash Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
nullsha
nullsha :: Hash
nullsha = ByteString -> Hash
SHA256 (Int -> Word8 -> ByteString
B.replicate 32 0)
tree' :: Tree IO
tree' = [(Name, TreeItem IO)] -> Tree IO
forall (m :: * -> *). [(Name, TreeItem m)] -> Tree m
makeTree [ (Name
n, Maybe (TreeItem IO) -> TreeItem IO
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (TreeItem IO) -> TreeItem IO)
-> Maybe (TreeItem IO) -> TreeItem IO
forall a b. (a -> b) -> a -> b
$ Result -> Maybe (TreeItem IO)
treeitem Result
s) | (n :: Name
n, s :: Result
s) <- [(Name, Result)]
inferiors, Maybe (TreeItem IO) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (TreeItem IO) -> Bool) -> Maybe (TreeItem IO) -> Bool
forall a b. (a -> b) -> a -> b
$ Result -> Maybe (TreeItem IO)
treeitem Result
s ]
treehash :: Hash
treehash = if Bool
we_changed then Index -> Tree IO -> Hash
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 }
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exists Bool -> Bool -> Bool
&& Bool
we_changed) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Item -> Int64 -> Hash -> IO ()
updateItem Item
item 0 Hash
treehash
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ $WResult :: Bool -> Int -> Maybe (TreeItem IO) -> Item -> Result
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 TreeItem IO -> Maybe (TreeItem IO)
forall a. a -> Maybe a
Just (TreeItem IO -> Maybe (TreeItem IO))
-> TreeItem IO -> Maybe (TreeItem IO)
forall a b. (a -> b) -> a -> b
$ Tree IO -> TreeItem IO
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree IO
tree
else Maybe (TreeItem IO)
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
index state :: State
state item :: Item
item = do
FileStatus
st <- String -> IO FileStatus
getFileStatus (Item -> String
iPath Item
item)
EpochTime
mtime <- Int64 -> EpochTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> EpochTime) -> IO Int64 -> IO EpochTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr Int64 -> IO Int64
forall a. (Storable a, Num a, Bits a) => Ptr a -> IO a
xlatePeek64 (Ptr Int64 -> IO Int64) -> Ptr Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ Item -> Ptr Int64
iAux Item
item)
Int64
size <- Ptr Int64 -> IO Int64
forall a. (Storable a, Num a, Bits a) => Ptr a -> IO a
xlatePeek64 (Ptr Int64 -> IO Int64) -> Ptr Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ Item -> Ptr Int64
iSize Item
item
FileID
fileid <- FileID -> FileID
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileID -> FileID) -> IO FileID -> IO FileID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr FileID -> IO FileID
forall a. (Storable a, Num a, Bits a) => Ptr a -> IO a
xlatePeek64 (Ptr FileID -> IO FileID) -> Ptr FileID -> IO FileID
forall a b. (a -> b) -> a -> b
$ Item -> Ptr FileID
iFileID Item
item)
FileID
fileid' <- FileID -> Maybe FileID -> FileID
forall a. a -> Maybe a -> a
fromMaybe FileID
fileid (Maybe FileID -> FileID) -> IO (Maybe FileID) -> IO FileID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe FileID)
getFileID' (String -> IO (Maybe FileID)) -> String -> IO (Maybe FileID)
forall a b. (a -> b) -> a -> b
$ Item -> String
iPath Item
item)
let mtime' :: EpochTime
mtime' = FileStatus -> EpochTime
modificationTime FileStatus
st
size' :: Int64
size' = FileOffset -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileOffset -> Int64) -> FileOffset -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> FileOffset
fileSize FileStatus
st
readblob :: IO ByteString
readblob = FileSegment -> IO ByteString
readSegment (Index -> String
forall (m :: * -> *). IndexM m -> String
basedir Index
index String -> ShowS
</> (Item -> String
iPath Item
item), Maybe (Int64, Int)
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 EpochTime -> EpochTime -> Bool
forall a. Eq a => a -> a -> Bool
/= EpochTime
mtime' Bool -> Bool -> Bool
|| Int64
size Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
size'
hash :: Hash
hash = Item -> Hash
iHash' Item
item
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
exists Bool -> Bool -> Bool
&& Bool
we_changed) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do Hash
hash' <- ByteString -> Hash
sha256 (ByteString -> Hash) -> IO ByteString -> IO Hash
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'
Item -> EpochTime -> IO ()
forall a. Enum a => Item -> a -> IO ()
updateTime Item
item EpochTime
mtime'
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileID
fileid FileID -> FileID -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Item -> FileID -> IO ()
updateFileID Item
item FileID
fileid'
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ $WResult :: Bool -> Int -> Maybe (TreeItem IO) -> Item -> Result
Result { changed :: Bool
changed = Bool -> Bool
not Bool
exists Bool -> Bool -> Bool
|| Bool
we_changed
, next :: Int
next = State -> Int
start State
state Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Item -> Int
itemNext Item
item
, treeitem :: Maybe (TreeItem IO)
treeitem = if Bool
exists then TreeItem IO -> Maybe (TreeItem IO)
forall a. a -> Maybe a
Just (TreeItem IO -> Maybe (TreeItem IO))
-> TreeItem IO -> Maybe (TreeItem IO)
forall a b. (a -> b) -> a -> b
$ Blob IO -> TreeItem IO
forall (m :: * -> *). Blob m -> TreeItem m
File (Blob IO -> TreeItem IO) -> Blob IO -> TreeItem IO
forall a b. (a -> b) -> a -> b
$ IO ByteString -> Hash -> Blob IO
forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob IO ByteString
readblob Hash
hash else Maybe (TreeItem IO)
forall a. Maybe a
Nothing
, resitem :: Item
resitem = Item
item }
updateIndex :: Index -> IO (Tree IO)
updateIndex :: Index -> IO (Tree IO)
updateIndex EmptyIndex = Tree IO -> IO (Tree IO)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree IO
forall (m :: * -> *). Tree m
emptyTree
updateIndex index :: Index
index =
do let initial :: State
initial = $WState :: Int -> AnchoredPath -> Int -> State
State { start :: Int
start = Int
size_magic
, dirlength :: Int
dirlength = 0
, path :: AnchoredPath
path = [Name] -> AnchoredPath
AnchoredPath [] }
Result
res <- Index -> State -> IO Result
readItem Index
index State
initial
case Result -> Maybe (TreeItem IO)
treeitem Result
res of
Just (SubTree tree :: Tree IO
tree) -> Tree IO -> IO (Tree IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree IO -> IO (Tree IO)) -> Tree IO -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ (AnchoredPath -> TreeItem IO -> Bool) -> Tree IO -> Tree IO
forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
filter (Index -> AnchoredPath -> TreeItem IO -> Bool
forall (m :: * -> *).
IndexM m -> AnchoredPath -> TreeItem m -> Bool
predicate Index
index) Tree IO
tree
_ -> String -> IO (Tree IO)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Unexpected failure in updateIndex!"
listFileIDs :: Index -> IO ([((AnchoredPath, ItemType), FileID)])
listFileIDs :: Index -> IO [((AnchoredPath, ItemType), FileID)]
listFileIDs EmptyIndex = [((AnchoredPath, ItemType), FileID)]
-> IO [((AnchoredPath, ItemType), FileID)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
listFileIDs index :: Index
index =
do let initial :: State
initial = $WState :: Int -> AnchoredPath -> Int -> State
State { start :: Int
start = Int
size_magic
, dirlength :: Int
dirlength = 0
, path :: AnchoredPath
path = [Name] -> AnchoredPath
AnchoredPath [] }
ResultF
res <- Index -> State -> IO ResultF
readItemFileIDs Index
index State
initial
[((AnchoredPath, ItemType), FileID)]
-> IO [((AnchoredPath, ItemType), FileID)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([((AnchoredPath, ItemType), FileID)]
-> IO [((AnchoredPath, ItemType), FileID)])
-> [((AnchoredPath, ItemType), FileID)]
-> IO [((AnchoredPath, ItemType), FileID)]
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
index state :: State
state = do
Item
item <- ForeignPtr () -> Int -> IO Item
peekItem (Index -> ForeignPtr ()
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
ResultF -> IO ResultF
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
index state :: State
state item :: Item
item =
do FileID
fileid <- FileID -> FileID
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileID -> FileID) -> IO FileID -> IO FileID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr FileID -> IO FileID
forall a. (Storable a, Num a, Bits a) => Ptr a -> IO a
xlatePeek64 (Ptr FileID -> IO FileID) -> Ptr FileID -> IO FileID
forall a b. (a -> b) -> a -> b
$ Item -> Ptr FileID
iFileID Item
item)
Int
following <- Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> IO Int64 -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Int64 -> IO Int64
forall a. (Storable a, Num a, Bits a) => Ptr a -> IO a
xlatePeek64 (Item -> Ptr Int64
iAux Item
item)
let name :: Item -> Int -> Name
name it :: Item
it dirlen :: Int
dirlen = ByteString -> Name
unsafeMakeName (ByteString -> Name) -> ByteString -> Name
forall a b. (a -> b) -> a -> b
$ (Int -> ByteString -> ByteString
B.drop (Int
dirlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Item -> ByteString
iDescriptor Item
it)
namelength :: Int
namelength = (ByteString -> Int
B.length (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ Item -> ByteString
iDescriptor Item
item) Int -> Int -> Int
forall a. Num a => a -> a -> a
- (State -> Int
dirlength State
state)
myname :: Name
myname = Item -> Int -> Name
name Item
item (State -> Int
dirlength State
state)
substate :: State
substate = State
state { start :: Int
start = State -> Int
start State
state Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Item -> Int
itemNext Item
item
, path :: AnchoredPath
path = State -> AnchoredPath
path State
state AnchoredPath -> Name -> AnchoredPath
`appendPath` Name
myname
, dirlength :: Int
dirlength = if Name
myname Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Name
unsafeMakeName (Char -> ByteString
BC.singleton '.')
then State -> Int
dirlength State
state
else State -> Int
dirlength State
state Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
namelength }
subs :: Int -> IO [(Name, ResultF)]
subs off :: Int
off | Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
following = do
ResultF
result <- Index -> State -> IO ResultF
readItemFileIDs Index
index (State -> IO ResultF) -> State -> IO ResultF
forall a b. (a -> b) -> a -> b
$ State
substate { start :: Int
start = Int
off }
[(Name, ResultF)]
rest <- Int -> IO [(Name, ResultF)]
subs (Int -> IO [(Name, ResultF)]) -> Int -> IO [(Name, ResultF)]
forall a b. (a -> b) -> a -> b
$ ResultF -> Int
nextF ResultF
result
[(Name, ResultF)] -> IO [(Name, ResultF)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, ResultF)] -> IO [(Name, ResultF)])
-> [(Name, ResultF)] -> IO [(Name, ResultF)]
forall a b. (a -> b) -> a -> b
$! (Item -> Int -> Name
name (ResultF -> Item
resitemF ResultF
result) (Int -> Name) -> Int -> Name
forall a b. (a -> b) -> a -> b
$ State -> Int
dirlength State
substate, ResultF
result) (Name, ResultF) -> [(Name, ResultF)] -> [(Name, ResultF)]
forall a. a -> [a] -> [a]
: [(Name, ResultF)]
rest
subs coff :: Int
coff | Int
coff Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
following = [(Name, ResultF)] -> IO [(Name, ResultF)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = String -> IO [(Name, ResultF)]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO [(Name, ResultF)]) -> String -> IO [(Name, ResultF)]
forall a b. (a -> b) -> a -> b
$ "Offset mismatch at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
coff String -> ShowS
forall a. [a] -> [a] -> [a]
++
" (ends at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
following String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
[(Name, ResultF)]
inferiors <- Int -> IO [(Name, ResultF)]
subs (Int -> IO [(Name, ResultF)]) -> Int -> IO [(Name, ResultF)]
forall a b. (a -> b) -> a -> b
$ State -> Int
start State
substate
ResultF -> IO ResultF
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultF -> IO ResultF) -> ResultF -> IO ResultF
forall a b. (a -> b) -> a -> b
$ $WResultF :: Int -> Item -> [((AnchoredPath, ItemType), FileID)] -> ResultF
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)((AnchoredPath, ItemType), FileID)
-> [((AnchoredPath, ItemType), FileID)]
-> [((AnchoredPath, ItemType), FileID)]
forall a. a -> [a] -> [a]
:((Name, ResultF) -> [((AnchoredPath, ItemType), FileID)])
-> [(Name, ResultF)] -> [((AnchoredPath, ItemType), FileID)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ResultF -> [((AnchoredPath, ItemType), FileID)]
_fileIDs (ResultF -> [((AnchoredPath, ItemType), FileID)])
-> ((Name, ResultF) -> ResultF)
-> (Name, ResultF)
-> [((AnchoredPath, ItemType), FileID)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, ResultF) -> ResultF
forall a b. (a, b) -> b
snd) [(Name, ResultF)]
inferiors) }
readFileFileID :: Index -> State -> Item -> IO ResultF
readFileFileID :: Index -> State -> Item -> IO ResultF
readFileFileID _ state :: State
state item :: Item
item =
do FileID
fileid' <- FileID -> FileID
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileID -> FileID) -> IO FileID -> IO FileID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr FileID -> IO FileID
forall a. (Storable a, Num a, Bits a) => Ptr a -> IO a
xlatePeek64 (Ptr FileID -> IO FileID) -> Ptr FileID -> IO FileID
forall a b. (a -> b) -> a -> b
$ Item -> Ptr FileID
iFileID Item
item)
let name :: Item -> Int -> Name
name it :: Item
it dirlen :: Int
dirlen = ByteString -> Name
unsafeMakeName (ByteString -> Name) -> ByteString -> Name
forall a b. (a -> b) -> a -> b
$ (Int -> ByteString -> ByteString
B.drop (Int
dirlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Item -> ByteString
iDescriptor Item
it)
myname :: Name
myname = Item -> Int -> Name
name Item
item (State -> Int
dirlength State
state)
ResultF -> IO ResultF
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultF -> IO ResultF) -> ResultF -> IO ResultF
forall a b. (a -> b) -> a -> b
$ $WResultF :: Int -> Item -> [((AnchoredPath, ItemType), FileID)] -> ResultF
ResultF { nextF :: Int
nextF = State -> Int
start State
state Int -> Int -> Int
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 -> Name -> AnchoredPath
`appendPath` Name
myname, ItemType
BlobType), FileID
fileid')] }
readIndex :: FilePath -> (Tree IO -> Hash) -> IO Index
readIndex :: String -> (Tree IO -> Hash) -> IO Index
readIndex indexpath :: String
indexpath ht :: Tree IO -> Hash
ht = do
(mmap_ptr :: ForeignPtr ()
mmap_ptr, mmap_size :: Int
mmap_size) <- String -> Int -> IO (ForeignPtr (), Int)
forall a. String -> Int -> IO (ForeignPtr a, Int)
mmapIndex String
indexpath 0
String
base <- IO String
getCurrentDirectory
Index -> IO Index
forall (m :: * -> *) a. Monad m => a -> m a
return (Index -> IO Index) -> Index -> IO Index
forall a b. (a -> b) -> a -> b
$ if Int
mmap_size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then Index
forall (m :: * -> *). IndexM m
EmptyIndex
else Index :: forall (m :: * -> *).
ForeignPtr ()
-> String
-> (Tree m -> Hash)
-> (AnchoredPath -> TreeItem m -> Bool)
-> IndexM m
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 = \_ _ -> Bool
True }
formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO ()
formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO ()
formatIndex mmap_ptr :: ForeignPtr ()
mmap_ptr old :: Tree IO
old reference :: Tree IO
reference =
do Int
_ <- TreeItem IO -> AnchoredPath -> Int -> IO Int
forall (m :: * -> *). TreeItem m -> AnchoredPath -> Int -> IO Int
create (Tree IO -> TreeItem IO
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree IO
reference) ([Name] -> AnchoredPath
AnchoredPath []) Int
size_magic
ByteString -> ByteString -> IO ()
unsafePokeBS ByteString
magic (String -> ByteString
BC.pack "HSI5")
where magic :: ByteString
magic = ForeignPtr Word8 -> Int -> Int -> ByteString
fromForeignPtr (ForeignPtr () -> ForeignPtr Word8
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr ()
mmap_ptr) 0 4
create :: TreeItem m -> AnchoredPath -> Int -> IO Int
create (File _) path' :: AnchoredPath
path' off :: 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 "" AnchoredPath
path'
case Tree IO -> AnchoredPath -> Maybe (TreeItem IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree IO
old AnchoredPath
path' of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ti :: TreeItem IO
ti -> do FileStatus
st <- String -> IO FileStatus
getFileStatus String
flatpath
let hash :: Hash
hash = TreeItem IO -> 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 (FileOffset -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral FileOffset
size) Hash
hash
Item -> EpochTime -> IO ()
forall a. Enum a => Item -> a -> IO ()
updateTime Item
i EpochTime
mtime
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Item -> Int
itemNext Item
i
create (SubTree s :: Tree m
s) path' :: AnchoredPath
path' off :: Int
off =
do Item
i <- ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item
createItem ItemType
TreeType AnchoredPath
path' ForeignPtr ()
mmap_ptr Int
off
case Tree IO -> AnchoredPath -> Maybe (TreeItem IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree IO
old AnchoredPath
path' of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ti :: TreeItem IO
ti | TreeItem IO -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem IO
ti Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
NoHash -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> Item -> Int64 -> Hash -> IO ()
updateItem Item
i 0 (Hash -> IO ()) -> Hash -> IO ()
forall a b. (a -> b) -> a -> b
$ TreeItem IO -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem IO
ti
let subs :: [(Name, TreeItem m)] -> IO Int
subs [] = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Item -> Int
itemNext Item
i
subs ((name :: Name
name,x :: TreeItem m
x):xs :: [(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 (Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
s)
Ptr Int64 -> Int64 -> IO ()
forall a. (Storable a, Num a, Bits a) => Ptr a -> a -> IO ()
xlatePoke64 (Item -> Ptr Int64
iAux Item
i) (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lastOff)
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
lastOff
create (Stub _ _) path' :: AnchoredPath
path' _ =
String -> IO Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Int) -> String -> IO Int
forall a b. (a -> b) -> a -> b
$ "Cannot create index from stubbed Tree at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
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 indexpath :: String
indexpath hashtree' :: Tree IO -> Hash
hashtree' ref :: Tree IO
ref =
do Tree IO
old_idx <- Index -> IO (Tree IO)
updateIndex (Index -> IO (Tree IO)) -> IO Index -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> (Tree IO -> Hash) -> IO Index
readIndex String
indexpath Tree IO -> Hash
hashtree'
Tree IO
reference <- Tree IO -> IO (Tree IO)
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ AnchoredPath -> Int
itemAllocSize AnchoredPath
p | (p :: AnchoredPath
p, _) <- Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
reference ]
Bool
exist <- String -> IO Bool
doesFileExist String
indexpath
#if mingw32_HOST_OS
when exist $ renameFile indexpath (indexpath <.> "old")
#else
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exist (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
indexpath
#endif
(mmap_ptr :: ForeignPtr ()
mmap_ptr, _) <- String -> Int -> IO (ForeignPtr (), 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_idx Tree IO
reference
String -> (Tree IO -> Hash) -> IO Index
readIndex String
indexpath Tree IO -> Hash
hashtree'
indexFormatValid :: FilePath -> IO Bool
indexFormatValid :: String -> IO Bool
indexFormatValid path' :: String
path' = do
Bool
v <- do ByteString
magic <- String -> Maybe (Int64, Int) -> IO ByteString
mmapFileByteString String
path' ((Int64, Int) -> Maybe (Int64, Int)
forall a. a -> Maybe a
Just (0, Int
size_magic))
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ case ByteString -> String
BC.unpack ByteString
magic of
"HSI5" -> Bool
True
_ -> Bool
False
IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_::SomeException) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
v
instance FilterTree IndexM IO where
filter :: (AnchoredPath -> TreeItem IO -> Bool) -> Index -> Index
filter _ EmptyIndex = Index
forall (m :: * -> *). IndexM m
EmptyIndex
filter p :: AnchoredPath -> TreeItem IO -> Bool
p index :: Index
index = Index
index { predicate :: AnchoredPath -> TreeItem IO -> Bool
predicate = \a :: AnchoredPath
a b :: TreeItem IO
b -> Index -> AnchoredPath -> TreeItem IO -> Bool
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' (String -> IO (Maybe FileID))
-> (AnchoredPath -> String) -> AnchoredPath -> IO (Maybe FileID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AnchoredPath -> String
anchorPath ""
getFileID' :: FilePath -> IO (Maybe FileID)
getFileID' :: String -> IO (Maybe FileID)
getFileID' fp :: 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 (FileID -> Maybe FileID
forall a. a -> Maybe a
Just (FileID -> Maybe FileID)
-> (FileStatus -> FileID) -> FileStatus -> Maybe FileID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> FileID
F.fileID) (FileStatus -> Maybe FileID) -> IO FileStatus -> IO (Maybe FileID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
F.getSymbolicLinkStatus String
fp
#endif
else Maybe FileID -> IO (Maybe FileID)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FileID
forall a. Maybe a
Nothing
unsafePokeBS :: BC.ByteString -> BC.ByteString -> IO ()
unsafePokeBS :: ByteString -> ByteString -> IO ()
unsafePokeBS to :: ByteString
to from :: ByteString
from =
do let (fp_to :: ForeignPtr Word8
fp_to, off_to :: Int
off_to, len_to :: Int
len_to) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
to
(fp_from :: ForeignPtr Word8
fp_from, off_from :: Int
off_from, len_from :: Int
len_from) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
from
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len_to Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
len_from) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Length mismatch in unsafePokeBS: from = "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len_from String -> ShowS
forall a. [a] -> [a] -> [a]
++ " /= to = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len_to
ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp_from ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \p_from :: Ptr Word8
p_from ->
ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp_to ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \p_to :: Ptr Word8
p_to ->
Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memcpy (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
p_to Int
off_to)
(Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
p_from Int
off_from)
(Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len_to)
align :: Integral a => a -> a -> a
align :: a -> a -> a
align boundary :: a
boundary i :: a
i = case a
i a -> a -> a
forall a. Integral a => a -> a -> a
`rem` a
boundary of
0 -> a
i
x :: a
x -> a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
boundary a -> a -> a
forall a. Num a => a -> a -> a
- a
x
{-# INLINE align #-}
xlate32 :: (Num a, Bits a) => a -> a
xlate64 :: (Num a, Bits a) => a -> a
#ifdef LITTLEENDIAN
xlate32 :: a -> a
xlate32 = a -> a
forall a. a -> a
id
xlate64 :: a -> a
xlate64 = a -> a
forall a. a -> a
id
#endif
#ifdef BIGENDIAN
bytemask :: (Num a, Bits a) => a
bytemask = 255
xlate32 a = ((a .&. (bytemask `shift` 0)) `shiftL` 24) .|.
((a .&. (bytemask `shift` 8)) `shiftL` 8) .|.
((a .&. (bytemask `shift` 16)) `rotateR` 8) .|.
((a .&. (bytemask `shift` 24)) `rotateR` 24)
xlate64 a = ((a .&. (bytemask `shift` 0)) `shiftL` 56) .|.
((a .&. (bytemask `shift` 8)) `shiftL` 40) .|.
((a .&. (bytemask `shift` 16)) `shiftL` 24) .|.
((a .&. (bytemask `shift` 24)) `shiftL` 8) .|.
((a .&. (bytemask `shift` 32)) `rotateR` 8) .|.
((a .&. (bytemask `shift` 40)) `rotateR` 24) .|.
((a .&. (bytemask `shift` 48)) `rotateR` 40) .|.
((a .&. (bytemask `shift` 56)) `rotateR` 56)
#endif