--  Copyright (C) 2009-2011 Petr Rockai
--            (C) 2013 Jose Neder
--  BSD3
{-# LANGUAGE MultiParamTypeClasses #-}

-- | This module contains plain tree indexing code. The index itself is a
-- CACHE: you should only ever use it as an optimisation and never as a primary
-- storage. In practice, this means that when we change index format, the
-- application is expected to throw the old index away and build a fresh
-- index. Please note that tracking index validity is out of scope for this
-- module: this is responsibility of your application. It is advisable that in
-- your validity tracking code, you also check for format validity (see
-- 'indexFormatValid') and scrap and re-create index when needed.
--
-- The index is a binary file that overlays a hashed tree over the working
-- copy. This means that every working file and directory has an entry in the
-- index, that contains its path and hash and validity data. The validity data
-- is a timestamp plus the file size. The file hashes are sha256's of the
-- file's content. It also contains the fileid to track moved files.
--
-- There are two entry types, a file entry and a directory entry. Both have a
-- common binary format (see 'Item'). The on-disk format is described by
-- the section /Index format/ below.
--
-- For each file, the index has a copy of the file's last modification
-- timestamp taken at the instant when the hash has been computed. This means
-- that when file size and timestamp of a file in working tree matches those in
-- the index, we assume that the hash stored in the index for given file is
-- valid. These hashes are then exposed in the resulting 'Tree' object, and can
-- be leveraged by eg. 'diffTrees' to compare many files quickly.
--
-- You may have noticed that we also keep hashes of directories. These are
-- assumed to be valid whenever the complete subtree has been valid. At any
-- point, as soon as a size or timestamp mismatch is found, the working file in
-- question is opened, its hash (and timestamp and size) is recomputed and
-- updated in-place in the index file (everything lives at a fixed offset and
-- is fixed size, so this isn't an issue). This is also true of directories:
-- when a file in a directory changes hash, this triggers recomputation of all
-- of its parent directory hashes; moreover this is done efficiently -- each
-- directory is updated at most once during an update run.
--
-- /Endianness/
--
-- Since version 6 (magic == "HSI6"), the file format depends on the endianness
-- of the architecture. To account for the (rare) case where darcs executables
-- from different architectures operate on the same repo, we make an additional
-- check in indexFormatValid to detect whether the file's endianness differs
-- from what we expect. If this is detected, the file is considered invalid and
-- will be re-created.
--
-- /Index format/
--
-- The index starts with a header consisting of a 4 bytes magic word, followed
-- by a 4 byte word to indicate the endianness of the encoding. This word
-- should, when read directly from the mmapped file, be equal to 1.
--
-- After the header comes the actual content of the index, which is a
-- sequence of 'Item's. An 'Item' consists of:
--
-- * size: item size, 8 bytes
-- * aux: timestamp (for file) or offset to sibling (for dir), 8 bytes
-- * fileid: inode or fhandle of the item, 8 bytes
-- * hash: sha256 of content, 32 bytes
-- * descriptor length: >= 2 due to type and null, 4 bytes
-- * descriptor:
--   * type: 'D' or 'F', one byte
--   * path: flattened path, variable >= 0
-- * null: terminating null byte
-- * alignment padding: 0 to 3 bytes
--
-- Each 'Item' is 4 byte aligned. Thus the descriptor length must be
-- rounded up to get the position of the next item using 'align'. Similar,
-- when determining the aux (offset to sibling) for dir items.
--
-- With directories, the aux holds the offset of the next sibling item in the
-- index, so we can efficiently skip reading the whole subtree starting at a
-- given directory (by just seeking aux bytes forward). The items are
-- pre-ordered with respect to directory structure -- the directory comes first
-- and after it come all its items. Cf. 'openIndex'.
--
-- For files, the aux field holds a timestamp.
--
-- Internally, the item is stored as a pointer to the first field (iBase)
-- from which we directly read off the first three fields (size, aux, fileid),
-- and a ByteString for the rest (iHashAndDescriptor), up to but not including
-- the terminating null byte.
--
-- TODO
--
-- The null byte terminator seems useless.
--
-- We could as well use a single plain pointer for the item. The dumpIndex
-- function demonstrates how this could be done.
--
-- Another possible improvement is to store only the Name of an item, not the
-- full path. We need to keep track of the current path anyway when traversing
-- the index.

module Darcs.Util.Index
    ( openIndex
    , updateIndexFrom
    , indexFormatValid
    , treeFromIndex
    , listFileIDs
    , Index
    , filter
    , getFileID
    , IndexEntry(..)
    , dumpIndex
    -- for testing
    , align
    ) where

import Darcs.Prelude hiding ( readFile, writeFile, filter )

import Darcs.Util.ByteString ( readSegment, decodeLocale )
import qualified Darcs.Util.File ( getFileStatus )
import Darcs.Util.Global ( debugMessage )
import Darcs.Util.Hash ( Hash(..), mkHash, rawHash, sha256 )
import Darcs.Util.Tree
import Darcs.Util.Tree.Hashed ( darcsTreeHash )
import Darcs.Util.Path
    ( AnchoredPath(..)
    , realPath
    , anchoredRoot
    , Name
    , rawMakeName
    , appendPath
    , flatten
    )
import Darcs.Util.Progress ( beginTedious, endTedious, finishedOneIO )

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
    , nullForeignPtr
    , toForeignPtr
    )
import qualified Data.ByteString.Short.Internal as BS

import Data.Int( Int64, Int32 )
import Data.Word( Word8 )
import Data.IORef( )
import Data.Maybe( fromJust, isJust, isNothing )
import Data.Typeable( Typeable )

import Foreign.Marshal.Utils ( copyBytes )
import Foreign.Storable
import Foreign.ForeignPtr( ForeignPtr, withForeignPtr, castForeignPtr )
import Foreign.Ptr( Ptr, plusPtr )

import System.IO ( hPutStrLn, stderr )
import System.IO.MMap( mmapFileForeignPtr, mmapWithFilePtr, Mode(..) )
import System.Directory( doesFileExist, getCurrentDirectory )
import System.Directory( renameFile )
import System.FilePath( (<.>) )

import qualified System.Posix.Files as F ( fileID )
import System.FilePath ( (</>) )
import qualified System.Posix.Files as F
    ( modificationTimeHiRes, fileSize, isDirectory, isSymbolicLink
    , FileStatus
    )
import System.Posix.Types ( FileID, FileOffset )

--------------------------
-- Indexed trees
--

-- | Description of a a single indexed item. The structure itself does not
-- contain any data, just pointers to the underlying mmap (bytestring is a
-- pointer + offset + length).
--
-- The structure is recursive-ish (as opposed to flat-ish structure, which is
-- used by git...) It turns out that it's hard to efficiently read a flat index
-- with our internal data structures -- we need to turn the flat index into a
-- recursive Tree object, which is rather expensive... As a bonus, we can also
-- efficiently implement subtree queries this way (cf. 'openIndex').
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
$cshowsPrec :: Int -> Item -> ShowS
showsPrec :: Int -> Item -> ShowS
$cshow :: Item -> String
show :: Item -> String
$cshowList :: [Item] -> ShowS
showList :: [Item] -> ShowS
Show

index_version :: B.ByteString
index_version :: ByteString
index_version = String -> ByteString
BC.pack String
"HSI7"

-- | Stored to the index to verify we are on the same endianness when reading
-- it back. We will treat the index as invalid in this case so user code will
-- regenerate it.
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 -- the magic word, first 4 bytes of the index
size_endianness_indicator :: Int
size_endianness_indicator = Int
4 -- second 4 bytes of the index
size_header :: Int
size_header = Int
size_magic Int -> Int -> Int
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 -- file/directory size (Int64)
size_aux :: Int
size_aux = Int
8 -- aux (Int64)
size_fileid :: Int
size_fileid = Int
8 -- fileid (inode or fhandle FileID)
size_dsclen :: Int
size_dsclen = Int
4 -- this many bytes store the length of the descriptor
size_hash :: Int
size_hash = Int
32 -- hash representation
size_type, size_null :: Int
size_type :: Int
size_type = Int
1 -- ItemType: 'D' for directory, 'F' for file
size_null :: Int
size_null = Int
1 -- null byte at the end of path

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 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 AnchoredPath
apath = Int -> Int -> Int
forall a. Integral a => a -> a -> a
align Int
4 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$
  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
+ Int
size_hash Int -> Int -> Int
forall a. Num a => a -> a -> a
+
  Int
size_type Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length (AnchoredPath -> ByteString
flatten AnchoredPath
apath) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_null

itemSize :: Item -> Int
itemSize :: Item -> Int
itemSize 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) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_null

itemNext :: Item -> Int
itemNext :: Item -> Int
itemNext Item
i = Int -> Int -> Int
forall a. Integral a => a -> a -> a
align Int
4 (Item -> Int
itemSize Item
i)

-- iDescriptor is:
--  * one byte for type of item ('D' or 'F')
--  * flattened path (w/o terminating null byte)
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

-- The "drop 1" here gets rid of the item type.
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 Int
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 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 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 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 Item
i = ByteString -> Word8
unsafeHead (Item -> ByteString
iDescriptor Item
i) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'D'

type FileStatus = Maybe F.FileStatus

-- We deal with hi res timestamps by noting that the actual resolution is in
-- nanoseconds. If we count the nanoseconds since the epoch we will overflow
-- (1<<63)/(1e9*60*60*24*366) =~ 290 years after the epoch. Comfortable.
modificationTime :: FileStatus -> Int64
modificationTime :: FileStatus -> Int64
modificationTime = Int64 -> (FileStatus -> Int64) -> FileStatus -> Int64
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int64
0 (POSIXTime -> Int64
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (POSIXTime -> Int64)
-> (FileStatus -> POSIXTime) -> FileStatus -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
*POSIXTime
1e9) (POSIXTime -> POSIXTime)
-> (FileStatus -> POSIXTime) -> FileStatus -> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> POSIXTime
F.modificationTimeHiRes)

fileSize :: FileStatus -> FileOffset
fileSize :: FileStatus -> FileOffset
fileSize = FileOffset
-> (FileStatus -> FileOffset) -> FileStatus -> FileOffset
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FileOffset
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

fileID :: FileStatus -> FileID
fileID :: FileStatus -> FileID
fileID = FileID -> (FileStatus -> FileID) -> FileStatus -> FileID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FileID
0 FileStatus -> FileID
F.fileID

-- | Lay out the basic index item structure in memory. The memory location is
-- given by a ForeignPointer () and an offset. The path and type given are
-- written out, and a corresponding Item is given back. The remaining bits of
-- the item can be filled out using 'update'.
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 (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 Char
'D' else Char
'F'
          , AnchoredPath -> ByteString
flatten AnchoredPath
apath -- this (currently) gives "." for anchoredRoot
          , Word8 -> ByteString
B.singleton Word8
0
          ]
      (ForeignPtr Word8
dsc_fp, Int
dsc_start, 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
$ \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
$ \Ptr Word8
dsc_p -> do
      Ptr () -> Int -> Int32 -> IO ()
forall b. Ptr b -> 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) (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dsc_len :: Int32)
      Ptr Any -> Ptr Any -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes
        (Ptr () -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr ()
p (Int -> Ptr Any) -> Int -> Ptr Any
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 Any
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

-- | Read the on-disk representation into internal data structure.
--
-- See the module-level section /Index format/ for details on how the index
-- is structured.
peekItem :: ForeignPtr () -> Int -> IO Item
peekItem :: ForeignPtr () -> Int -> IO Item
peekItem ForeignPtr ()
fp 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
$ \Ptr ()
p -> do
    Int32
nl' :: Int32 <- Ptr () -> Int -> IO Int32
forall b. Ptr b -> 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
<= Int32
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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)
            -- Note that iHashAndDescriptor does not include the terminating
            -- null byte, so we have to subtract its size here.
            (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
- Int
size_null)
    Item -> IO Item
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Item -> IO Item) -> Item -> IO Item
forall a b. (a -> b) -> a -> b
$! 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}

-- | Update an existing 'Item' with new size and hash. The hash must be
-- not be 'Nothing'.
updateItem :: Item -> Int64 -> Hash -> IO ()
updateItem :: Item -> Int64 -> Hash -> IO ()
updateItem Item
item Int64
size Hash
hash =
    do Ptr Int64 -> Int64 -> IO ()
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 = Ptr FileID -> FileID -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Item -> Ptr FileID
iFileID Item
item) FileID
fileid

updateAux :: Item -> Int64 -> IO ()
updateAux :: Item -> Int64 -> IO ()
updateAux Item
item Int64
aux = Ptr Int64 -> Int64 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Item -> Ptr Int64
iAux Item
item) Int64
aux

updateTime :: Item -> Int64 -> IO ()
updateTime :: Item -> Int64 -> IO ()
updateTime Item
item Int64
mtime = Item -> Int64 -> IO ()
updateAux Item
item Int64
mtime

iHash' :: Item -> Maybe Hash
iHash' :: Item -> Maybe Hash
iHash' Item
i = let ih :: ByteString
ih = Item -> ByteString
iHash Item
i in if ByteString
ih ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
nullHash then Maybe Hash
forall a. Maybe a
Nothing else Hash -> Maybe Hash
forall a. a -> Maybe a
Just (ByteString -> Hash
mkHash ByteString
ih)

nullHash :: B.ByteString
nullHash :: ByteString
nullHash = Int -> Word8 -> ByteString
B.replicate Int
size_hash Word8
0

-- | Gives a ForeignPtr to mmapped index, which can be used for reading and
-- updates. The req_size parameter, if non-0, expresses the requested size of
-- the index file. mmapIndex will grow the index if it is smaller than this.
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 <- 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
Darcs.Util.File.getFileStatus String
indexpath
  let size :: Int
size = case Int
req_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 of
        Bool
True -> Int
req_size
        Bool
False | Int
act_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
size_header -> Int
act_size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
size_header
              | Bool
otherwise -> Int
0
  case Int
size of
    Int
0 -> (ForeignPtr a, Int) -> IO (ForeignPtr a, Int)
forall a. a -> IO a
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)
    Int
_ -> do (ForeignPtr a
x, Int
_, Int
_) <- 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 (Int64
0, Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_header))
            (ForeignPtr a, Int) -> IO (ForeignPtr a, Int)
forall a. a -> IO a
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 -> AnchoredPath -> TreeItem m -> Bool
predicate :: AnchoredPath -> TreeItem m -> Bool }
              | EmptyIndex

type Index = IndexM IO

-- FIXME This is not really a state: we modify it only when we recurse
-- down into a dir item, so this is rather more like an environment.
-- Instead of passing it explicitly we could use ReaderT.

-- | When we traverse the index, we keep track of some data about the
-- current parent directory.
data State = State
  { State -> Int
dirlength :: !Int     -- ^ length in bytes of current path prefix,
                          --   includes the trailing path separator
  , State -> AnchoredPath
path :: !AnchoredPath -- ^ path of the current directory
  , State -> Int
start :: !Int         -- ^ offset of current directory in the index
  }

-- * Reading items from the index

data Result = Result
  { Result -> Bool
changed :: !Bool
  -- ^ Whether item has changed since the last update to the index.
  , Result -> Int
next :: !Int
  -- ^ Position of the next item, in bytes.
  , Result -> Maybe (TreeItem IO)
treeitem :: !(Maybe (TreeItem IO))
  -- ^ Nothing in case of the item doesn't exist in the tree
  -- or is filtered by a FilterTree. Or a TreeItem otherwise.
  , Result -> Item
resitem :: !Item
  -- ^ The item extracted.
  }

readItem :: String -> Index -> State -> IO Result
readItem :: String -> Index -> State -> IO Result
readItem String
progressKey Index
index 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 Item -> IO Result
readDir  Item
item
                else Item -> IO Result
readFile Item
item
    String -> String -> IO ()
finishedOneIO String
progressKey (Item -> String
iPath Item
item)
    Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res'
  where

    readDir :: Item -> IO Result
readDir 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 => 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 <- Ptr FileID -> IO FileID
forall a. Storable a => Ptr a -> IO a
peek (Ptr FileID -> IO FileID) -> Ptr FileID -> IO FileID
forall a b. (a -> b) -> a -> b
$ Item -> Ptr FileID
iFileID 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
== FileID
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Item -> FileID -> IO ()
updateFileID Item
item (FileStatus -> FileID
fileID FileStatus
st)
      let substate :: State
substate = Item -> State -> State
substateof Item
item State
state
          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) -> Maybe Hash -> TreeItem IO
forall (m :: * -> *). m (Tree m) -> Maybe Hash -> TreeItem m
Stub IO (Tree IO)
forall a. HasCallStack => a
undefined Maybe Hash
forall a. Maybe a
Nothing)
          oldhash :: Maybe Hash
oldhash = Item -> Maybe Hash
iHash' Item
item
          subs :: Int -> IO [(Maybe Name, Result)]
subs Int
off =
             case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
off Int
following of
               Ordering
LT -> do
                 Result
result <- String -> Index -> State -> IO Result
readItem String
progressKey Index
index (State -> IO Result) -> State -> IO Result
forall a b. (a -> b) -> a -> b
$ State
substate { start = off }
                 [(Maybe Name, Result)]
rest <- Int -> IO [(Maybe Name, Result)]
subs (Int -> IO [(Maybe Name, Result)])
-> Int -> IO [(Maybe Name, Result)]
forall a b. (a -> b) -> a -> b
$ Result -> Int
next Result
result
                 [(Maybe Name, Result)] -> IO [(Maybe Name, Result)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Maybe Name, Result)] -> IO [(Maybe Name, Result)])
-> [(Maybe Name, Result)] -> IO [(Maybe Name, Result)]
forall a b. (a -> b) -> a -> b
$! (Item -> State -> Maybe Name
nameof (Result -> Item
resitem Result
result) State
substate, Result
result) (Maybe Name, Result)
-> [(Maybe Name, Result)] -> [(Maybe Name, Result)]
forall a. a -> [a] -> [a]
: [(Maybe Name, Result)]
rest
               Ordering
EQ -> [(Maybe Name, Result)] -> IO [(Maybe Name, Result)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
               Ordering
GT ->
                 String -> IO [(Maybe Name, Result)]
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO [(Maybe Name, Result)])
-> String -> IO [(Maybe Name, Result)]
forall a b. (a -> b) -> a -> b
$
                   String
"Offset mismatch at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
off String -> ShowS
forall a. [a] -> [a] -> [a]
++
                   String
" (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]
++ String
")"
      [(Maybe Name, Result)]
inferiors <- if Bool
want then Int -> IO [(Maybe Name, Result)]
subs (Int -> IO [(Maybe Name, Result)])
-> Int -> IO [(Maybe Name, Result)]
forall a b. (a -> b) -> a -> b
$ State -> Int
start State
substate
                           else [(Maybe Name, Result)] -> IO [(Maybe Name, Result)]
forall a. a -> IO a
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 | (Maybe Name
_, Result
x) <- [(Maybe Name, Result)]
inferiors ] Bool -> Bool -> Bool
|| Bool
nullleaf
          nullleaf :: Bool
nullleaf = [(Maybe Name, Result)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe Name, Result)]
inferiors Bool -> Bool -> Bool
&& Maybe Hash -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Hash
oldhash
          tree' :: Tree IO
tree' =
            -- Note the partial pattern match on 'Just n' below is justified
            -- as we are traversing sub items here, which means 'Nothing' is
            -- impossible, see 'substateof' for details.
            [(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)
              | (Just Name
n, Result
s) <- [(Maybe 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 :: Maybe Hash
treehash = if Bool
we_changed then Hash -> Maybe Hash
forall a. a -> Maybe a
Just (Tree IO -> Hash
forall (m :: * -> *). Tree m -> Hash
darcsTreeHash Tree IO
tree') else Maybe Hash
oldhash
          tree :: Tree IO
tree = Tree IO
tree' { treeHash = 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
$
          -- fromJust is justified because we_changed implies (isJust treehash)
          Item -> Int64 -> Hash -> IO ()
updateItem Item
item Int64
0 (Maybe Hash -> Hash
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Hash
treehash)
      Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
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 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 :: Item -> IO Result
readFile Item
item = do
           FileStatus
st <- String -> IO FileStatus
getFileStatus (Item -> String
iPath Item
item)
           Int64
mtime <- Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int64) -> IO Int64 -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr Int64 -> IO Int64
forall a. Storable a => Ptr a -> IO a
peek (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 => Ptr a -> IO a
peek (Ptr Int64 -> IO Int64) -> Ptr Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ Item -> Ptr Int64
iSize Item
item
           FileID
fileid <- Ptr FileID -> IO FileID
forall a. Storable a => Ptr a -> IO a
peek (Ptr FileID -> IO FileID) -> Ptr FileID -> IO FileID
forall a b. (a -> b) -> a -> b
$ Item -> Ptr FileID
iFileID Item
item
           let mtime' :: Int64
mtime' = FileStatus -> Int64
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 = Int64
mtime Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
mtime' Bool -> Bool -> Bool
|| Int64
size Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
size'
               hash :: Maybe Hash
hash = Item -> Maybe 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 a b. (a -> b) -> IO a -> IO b
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 -> Int64 -> IO ()
updateTime Item
item Int64
mtime'
                   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FileID
fileid FileID -> FileID -> Bool
forall a. Eq a => a -> a -> Bool
== FileID
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Item -> FileID -> IO ()
updateFileID Item
item (FileStatus -> FileID
fileID FileStatus
st)
           Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
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 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 -> Maybe Hash -> Blob IO
forall (m :: * -> *). m ByteString -> Maybe Hash -> Blob m
Blob IO ByteString
readblob Maybe Hash
hash
                                else Maybe (TreeItem IO)
forall a. Maybe a
Nothing
                           , resitem :: Item
resitem = Item
item }


data CorruptIndex = CorruptIndex String deriving (CorruptIndex -> CorruptIndex -> Bool
(CorruptIndex -> CorruptIndex -> Bool)
-> (CorruptIndex -> CorruptIndex -> Bool) -> Eq CorruptIndex
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CorruptIndex -> CorruptIndex -> Bool
== :: CorruptIndex -> CorruptIndex -> Bool
$c/= :: CorruptIndex -> CorruptIndex -> Bool
/= :: CorruptIndex -> CorruptIndex -> Bool
Eq, Typeable)
instance Exception CorruptIndex
instance Show CorruptIndex where show :: CorruptIndex -> String
show (CorruptIndex String
s) = String
s

-- | Get the 'Name' of an 'Item' in the given 'State'. This fails for
-- the root 'Item' because it has no 'Name', so we return 'Nothing'.
nameof :: Item -> State -> Maybe Name
nameof :: Item -> State -> Maybe Name
nameof Item
item State
state
  | Item -> ByteString
iDescriptor Item
item ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"D." = Maybe Name
forall a. Maybe a
Nothing
  | Bool
otherwise =
      case ByteString -> Either String Name
rawMakeName (ByteString -> Either String Name)
-> ByteString -> Either String Name
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop (State -> Int
dirlength State
state Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Item -> ByteString
iDescriptor Item
item of
        Left String
msg -> CorruptIndex -> Maybe Name
forall a e. Exception e => e -> a
throw (String -> CorruptIndex
CorruptIndex String
msg)
        Right Name
name -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name

-- | 'Maybe' append a 'Name' to an 'AnchoredPath'.
maybeAppendName :: AnchoredPath -> Maybe Name -> AnchoredPath
maybeAppendName :: AnchoredPath -> Maybe Name -> AnchoredPath
maybeAppendName AnchoredPath
parent = AnchoredPath
-> (Name -> AnchoredPath) -> Maybe Name -> AnchoredPath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AnchoredPath
parent (AnchoredPath
parent AnchoredPath -> Name -> AnchoredPath
`appendPath`)

-- | Calculate the next 'State' when entering an 'Item'. Works for the
-- top-level 'Item' i.e. the root directory only because we handle that
-- specially.
substateof :: Item -> State -> State
substateof :: Item -> State -> State
substateof Item
item State
state =
  State
state
    { start = start state + itemNext item
    , path = path state `maybeAppendName` myname
    , dirlength =
        case myname of
          Maybe Name
Nothing ->
            -- We are entering the root item. The current path prefix remains
            -- empty, so its length (which must be 0) doesn't change.
            State -> Int
dirlength State
state
          Just Name
_ ->
            -- This works because the 'iDescriptor' is always one byte larger
            -- than the actual name. So @dirlength state@ will also be greater
            -- by 1, which accounts for the path separator when we strip the
            -- directory prefix from the full path.
            ByteString -> Int
B.length (Item -> ByteString
iDescriptor Item
item)
    }
  where
    myname :: Maybe Name
myname = Item -> State -> Maybe Name
nameof Item
item State
state

-- * Reading (only) file IDs from the index

-- FIXME this seems copy-pasted from the code above and then adapted
-- to the purpose. Should factor out the traversal of the index as a
-- higher order function.

data ResultF = ResultF
  { ResultF -> Int
nextF :: !Int
  -- ^ Position of the next item, in bytes.
  , ResultF -> Item
resitemF :: !Item
  -- ^ The item extracted.
  , ResultF -> [((AnchoredPath, ItemType), FileID)]
_fileIDs :: [((AnchoredPath, ItemType), FileID)]
  -- ^ The fileids of the files and folders inside,
  -- in a folder item and its own fileid for file item).
  }

-- | Return a list containing all the file/folder names in an index, with
-- their respective ItemType and FileID.
listFileIDs :: Index -> IO ([((AnchoredPath, ItemType), FileID)])
listFileIDs :: Index -> IO [((AnchoredPath, ItemType), FileID)]
listFileIDs Index
EmptyIndex = [((AnchoredPath, ItemType), FileID)]
-> IO [((AnchoredPath, ItemType), FileID)]
forall a. a -> IO a
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
       [((AnchoredPath, ItemType), FileID)]
-> IO [((AnchoredPath, ItemType), FileID)]
forall a. a -> IO a
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 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 a. a -> IO a
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 <- Ptr FileID -> IO FileID
forall a. Storable a => Ptr a -> IO a
peek (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 => 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 Int -> Int -> Ordering
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 (State -> IO ResultF) -> State -> IO ResultF
forall a b. (a -> b) -> a -> b
$ State
substate {start = off}
                  [(Maybe Name, ResultF)]
rest <- Int -> IO [(Maybe Name, ResultF)]
subs (Int -> IO [(Maybe Name, ResultF)])
-> Int -> IO [(Maybe Name, ResultF)]
forall a b. (a -> b) -> a -> b
$ ResultF -> Int
nextF ResultF
result
                  [(Maybe Name, ResultF)] -> IO [(Maybe Name, ResultF)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Maybe Name, ResultF)] -> IO [(Maybe Name, ResultF)])
-> [(Maybe Name, ResultF)] -> IO [(Maybe Name, ResultF)]
forall a b. (a -> b) -> a -> b
$! (Item -> State -> Maybe Name
nameof (ResultF -> Item
resitemF ResultF
result) State
substate, ResultF
result) (Maybe Name, ResultF)
-> [(Maybe Name, ResultF)] -> [(Maybe Name, ResultF)]
forall a. a -> [a] -> [a]
: [(Maybe Name, ResultF)]
rest
                Ordering
EQ -> [(Maybe Name, ResultF)] -> IO [(Maybe Name, ResultF)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                Ordering
GT ->
                  String -> IO [(Maybe Name, ResultF)]
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO [(Maybe Name, ResultF)])
-> String -> IO [(Maybe Name, ResultF)]
forall a b. (a -> b) -> a -> b
$
                    String
"Offset mismatch at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
off String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    String
" (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]
++ String
")"
       [(Maybe Name, ResultF)]
inferiors <- Int -> IO [(Maybe Name, ResultF)]
subs (Int -> IO [(Maybe Name, ResultF)])
-> Int -> IO [(Maybe Name, ResultF)]
forall a b. (a -> b) -> a -> b
$ State -> Int
start State
substate
       ResultF -> IO ResultF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultF -> IO ResultF) -> ResultF -> IO ResultF
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)((AnchoredPath, ItemType), FileID)
-> [((AnchoredPath, ItemType), FileID)]
-> [((AnchoredPath, ItemType), FileID)]
forall a. a -> [a] -> [a]
:((Maybe Name, ResultF) -> [((AnchoredPath, ItemType), FileID)])
-> [(Maybe 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)])
-> ((Maybe Name, ResultF) -> ResultF)
-> (Maybe Name, ResultF)
-> [((AnchoredPath, ItemType), FileID)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Name, ResultF) -> ResultF
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' <- Ptr FileID -> IO FileID
forall a. Storable a => Ptr a -> IO a
peek (Ptr FileID -> IO FileID) -> Ptr FileID -> IO FileID
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
       ResultF -> IO ResultF
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultF -> IO ResultF) -> ResultF -> IO ResultF
forall a b. (a -> b) -> a -> b
$ 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 -> Maybe Name -> AnchoredPath
`maybeAppendName` Maybe Name
myname, ItemType
BlobType), FileID
fileid')] }

-- * Reading and writing 'Tree's from/to the index

-- | Initialize an 'Index' from the given index file.
openIndex :: FilePath -> IO Index
openIndex :: String -> IO Index
openIndex String
indexpath = do
  (ForeignPtr ()
mmap_ptr, Int
mmap_size) <- String -> Int -> IO (ForeignPtr (), Int)
forall a. String -> Int -> IO (ForeignPtr a, Int)
mmapIndex String
indexpath Int
0
  String
base <- IO String
getCurrentDirectory
  Index -> IO Index
forall a. a -> IO a
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
== Int
0 then Index
forall (m :: * -> *). IndexM m
EmptyIndex
                             else Index { mmap :: ForeignPtr ()
mmap = ForeignPtr ()
mmap_ptr
                                        , basedir :: String
basedir = String
base
                                        , 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
_ <- 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) (AnchoredPath
anchoredRoot) Int
size_header
       ByteString -> ByteString -> IO ()
unsafePokeBS ByteString
magic ByteString
index_version
       ForeignPtr () -> (Ptr () -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
mmap_ptr ((Ptr () -> IO ()) -> IO ()) -> (Ptr () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr ()
ptr ->
         Ptr () -> Int -> Int32 -> IO ()
forall b. Ptr b -> Int -> Int32 -> IO ()
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 (ForeignPtr () -> ForeignPtr Word8
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
                  -- TODO calling getFileStatus here is both slightly
                  -- inefficient and slightly race-prone
                  FileStatus
st <- String -> IO FileStatus
getFileStatus (Item -> String
iPath Item
i)
                  Item -> FileID -> IO ()
updateFileID Item
i (FileStatus -> FileID
fileID FileStatus
st)
                  case Tree IO -> AnchoredPath -> Maybe (TreeItem IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree IO
old AnchoredPath
path' of
                    Maybe (TreeItem IO)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Just TreeItem IO
ti -> do let hash :: Maybe Hash
hash = TreeItem IO -> Maybe Hash
forall (m :: * -> *). TreeItem m -> Maybe Hash
itemHash TreeItem IO
ti
                                      mtime :: Int64
mtime = FileStatus -> Int64
modificationTime FileStatus
st
                                      size :: FileOffset
size = FileStatus -> FileOffset
fileSize FileStatus
st
                                  -- TODO prove that isNothing hash is impossible
                                  Item -> Int64 -> Hash -> IO ()
updateItem Item
i (FileOffset -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral FileOffset
size) (Maybe Hash -> Hash
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Hash
hash)
                                  Item -> Int64 -> IO ()
updateTime Item
i Int64
mtime
                  Int -> IO Int
forall a. a -> IO a
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 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
                  FileStatus
st <- String -> IO FileStatus
getFileStatus (Item -> String
iPath Item
i)
                  Item -> FileID -> IO ()
updateFileID Item
i (FileStatus -> FileID
fileID FileStatus
st)
                  case Tree IO -> AnchoredPath -> Maybe (TreeItem IO)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree IO
old AnchoredPath
path' of
                    Maybe (TreeItem IO)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Just TreeItem IO
ti ->
                      case TreeItem IO -> Maybe Hash
forall (m :: * -> *). TreeItem m -> Maybe Hash
itemHash TreeItem IO
ti of
                        Maybe Hash
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Just Hash
h -> Item -> Int64 -> Hash -> IO ()
updateItem Item
i Int64
0 Hash
h
                  let subs :: [(Name, TreeItem m)] -> IO Int
subs [] = Int -> IO Int
forall a. a -> IO a
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,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 (Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
s)
                  Ptr Int64 -> Int64 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Item -> Ptr Int64
iAux Item
i) (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lastOff)
                  Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
lastOff
          create (Stub m (Tree m)
_ Maybe Hash
_) AnchoredPath
path' Int
_ =
               String -> IO Int
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Int) -> String -> IO Int
forall a b. (a -> b) -> a -> b
$ String
"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'

-- | Add and remove entries in the given 'Index' to make it match the given
-- 'Tree'. If an object in the 'Tree' does not exist in the current working
-- directory, its index entry will have zero hash, size, aux, and fileID. For
-- the hash this translates to 'Nothing', see 'iHash''.
updateIndexFrom :: FilePath -> Tree IO -> IO Index
updateIndexFrom :: String -> Tree IO -> IO Index
updateIndexFrom String
indexpath Tree IO
ref =
    do String -> IO ()
debugMessage String
"Updating the index ..."
       Tree IO
old_tree <- Index -> IO (Tree IO)
treeFromIndex (Index -> IO (Tree IO)) -> IO Index -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO Index
openIndex String
indexpath
       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 a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ AnchoredPath -> Int
itemAllocSize AnchoredPath
p | (AnchoredPath
p, TreeItem IO
_) <- Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
reference ]
       Bool
exist <- String -> IO Bool
doesFileExist String
indexpath
       -- Note that the file is still open via the mmaped pointer in
       -- the open index, and we /are/ going to write the index using
       -- that pointer. If we could rely on posix semantics,
       -- we would just delete the file. However, on windows this
       -- would fail, so instead we rename it.
       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 -> String -> IO ()
renameFile String
indexpath (String
indexpath String -> ShowS
<.> String
"old")
       (ForeignPtr ()
mmap_ptr, Int
_) <- 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_tree Tree IO
reference
       String -> IO ()
debugMessage String
"Done updating the index, reopening it ..."
       String -> IO Index
openIndex String
indexpath

-- | Read an 'Index', starting with the root, to create a 'Tree'.
treeFromIndex :: Index -> IO (Tree IO)
treeFromIndex :: Index -> IO (Tree IO)
treeFromIndex Index
EmptyIndex = Tree IO -> IO (Tree IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Tree IO
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 }
           -- This is not a typo! As a side-effect of reading a tree from the
           -- index, it also gets updated and this is what can take a long time
           -- since it may involve reading all files in the working tree that
           -- are also in pristine+pending (to compute their hashes)
           progressKey :: String
progressKey = String
"Updating the index"
       String -> IO ()
beginTedious String
progressKey
       Result
res <- String -> Index -> State -> IO Result
readItem String
progressKey Index
index State
initial
       String -> IO ()
endTedious String
progressKey
       case Result -> Maybe (TreeItem IO)
treeitem Result
res of
         Just (SubTree Tree IO
tree) -> Tree IO -> IO (Tree IO)
forall a. a -> IO a
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
         Maybe (TreeItem IO)
_ -> String -> IO (Tree IO)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected failure in treeFromIndex!"

-- | Check that a given file is an index file with a format we can handle. You
-- should remove and re-create the index whenever this is not true.
indexFormatValid :: FilePath -> IO Bool
indexFormatValid :: String -> IO Bool
indexFormatValid String
path' =
  do
    (ForeignPtr Any
start, Int
_, Int
_) <- String
-> Mode -> Maybe (Int64, Int) -> IO (ForeignPtr Any, Int, Int)
forall a.
String -> Mode -> Maybe (Int64, Int) -> IO (ForeignPtr a, Int, Int)
mmapFileForeignPtr String
path' Mode
ReadOnly ((Int64, Int) -> Maybe (Int64, Int)
forall a. a -> Maybe a
Just (Int64
0, Int
size_header))
    let magic :: ByteString
magic = ForeignPtr Word8 -> Int -> Int -> ByteString
fromForeignPtr (ForeignPtr Any -> ForeignPtr Word8
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr Any
start) Int
0 Int
4
    Int32
endianness_indicator <- ForeignPtr Any -> (Ptr Any -> IO Int32) -> IO Int32
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Any
start ((Ptr Any -> IO Int32) -> IO Int32)
-> (Ptr Any -> IO Int32) -> IO Int32
forall a b. (a -> b) -> a -> b
$ \Ptr Any
ptr -> Ptr Any -> Int -> IO Int32
forall b. Ptr b -> Int -> IO Int32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
ptr Int
4
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
      ByteString
index_version ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
magic Bool -> Bool -> Bool
&& Int32
index_endianness_indicator Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
endianness_indicator
  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 a. a -> IO a
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 = Index
forall (m :: * -> *). IndexM m
EmptyIndex
    filter AnchoredPath -> TreeItem IO -> Bool
p Index
index = Index
index { predicate = \AnchoredPath
a 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 }


-- * Getting the file ID from a path

-- | For a given path, get the corresponding fileID from the filesystem.
getFileID :: AnchoredPath -> IO (Maybe FileID)
getFileID :: AnchoredPath -> IO (Maybe FileID)
getFileID AnchoredPath
p = (FileStatus -> FileID) -> FileStatus -> Maybe FileID
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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
getFileStatus (AnchoredPath -> String
realPath AnchoredPath
p)

-- * Low-level utilities

-- Wow, unsafe.
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
       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 a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"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]
++ String
" /= 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
$ \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
$ \Ptr Word8
p_to ->
           Ptr Any -> Ptr Any -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes
                  (Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
p_to Int
off_to)
                  (Ptr Word8 -> Int -> Ptr Any
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 :: forall a. Integral a => a -> a -> a
align a
boundary a
i = case a
i a -> a -> a
forall a. Integral a => a -> a -> a
`rem` a
boundary of
                     a
0 -> a
i
                     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 #-}

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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Warning: ignoring symbolic link " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
path
          FileStatus -> IO FileStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FileStatus
forall a. Maybe a
Nothing
    FileStatus
_ -> FileStatus -> IO FileStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FileStatus
mst

data IndexEntry = IndexEntry
  { IndexEntry -> Int64
ieSize :: Int64
  , IndexEntry -> Int64
ieAux :: Int64
  , IndexEntry -> FileID
ieFileID :: FileID
  , IndexEntry -> Maybe Hash
ieHash :: Maybe Hash
  , IndexEntry -> Char
ieType :: Char
  , IndexEntry -> AnchoredPath
iePath :: AnchoredPath
  }

dumpIndex :: FilePath -> IO [IndexEntry]
dumpIndex :: String -> IO [IndexEntry]
dumpIndex String
indexpath =
  String
-> Mode
-> Maybe (Int64, Int)
-> ((Ptr (), Int) -> IO [IndexEntry])
-> IO [IndexEntry]
forall a.
String
-> Mode -> Maybe (Int64, Int) -> ((Ptr (), Int) -> IO a) -> IO a
mmapWithFilePtr String
indexpath Mode
ReadOnly Maybe (Int64, Int)
forall a. Maybe a
Nothing (((Ptr (), Int) -> IO [IndexEntry]) -> IO [IndexEntry])
-> ((Ptr (), Int) -> IO [IndexEntry]) -> IO [IndexEntry]
forall a b. (a -> b) -> a -> b
$ \(Ptr ()
ptr, Int
size) -> do
    ShortByteString
magic <- Ptr () -> Int -> IO ShortByteString
forall a. Ptr a -> Int -> IO ShortByteString
BS.createFromPtr Ptr ()
ptr Int
4
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ShortByteString
magic ShortByteString -> ShortByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> ShortByteString
BS.toShort ByteString
index_version) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"index format is invalid"
    Int -> Ptr Any -> IO [IndexEntry]
forall {b}. Int -> Ptr b -> IO [IndexEntry]
readEntries (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
size_header) (Ptr ()
ptr Ptr () -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
size_header)
  where
    readEntries :: Int -> Ptr b -> IO [IndexEntry]
readEntries Int
s Ptr b
_ | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int -> Int
next Int
0) = [IndexEntry] -> IO [IndexEntry]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    readEntries Int
s Ptr b
p = do
      (IndexEntry
entry, Int
fwd) <- Ptr b -> IO (IndexEntry, Int)
forall {a}. Ptr a -> IO (IndexEntry, Int)
readEntry Ptr b
p
      [IndexEntry]
entries <- Int -> Ptr b -> IO [IndexEntry]
readEntries (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fwd) (Ptr b
p Ptr b -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
fwd)
      [IndexEntry] -> IO [IndexEntry]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IndexEntry
entry IndexEntry -> [IndexEntry] -> [IndexEntry]
forall a. a -> [a] -> [a]
: [IndexEntry]
entries)
    readEntry :: Ptr a -> IO (IndexEntry, Int)
readEntry Ptr a
p = do
      Int64
ieSize <- Ptr a -> Int -> IO Int64
forall b. Ptr b -> Int -> IO Int64
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
p Int
off_size
      Int64
ieAux <- Ptr a -> Int -> IO Int64
forall b. Ptr b -> Int -> IO Int64
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
p Int
off_aux
      FileID
ieFileID <- Ptr a -> Int -> IO FileID
forall b. Ptr b -> Int -> IO FileID
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
p Int
off_fileid
      Maybe Hash
ieHash <- do
        ShortByteString
h <- Ptr Any -> Int -> IO ShortByteString
forall a. Ptr a -> Int -> IO ShortByteString
BS.createFromPtr (Ptr a
p Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off_hash) Int
size_hash
        Maybe Hash -> IO (Maybe Hash)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Hash -> IO (Maybe Hash)) -> Maybe Hash -> IO (Maybe Hash)
forall a b. (a -> b) -> a -> b
$ if ShortByteString
h ShortByteString -> ShortByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ShortByteString
shortNullHash then Maybe Hash
forall a. Maybe a
Nothing else Hash -> Maybe Hash
forall a. a -> Maybe a
Just (ShortByteString -> Hash
SHA256 ShortByteString
h)
      Int32
dsclen :: Int32 <- Ptr a -> Int -> IO Int32
forall b. Ptr b -> Int -> IO Int32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
p Int
off_dsclen
      Char
ieType <- Word8 -> Char
b2c (Word8 -> Char) -> IO Word8 -> IO Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr a -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr a
p Int
off_dsc
      ByteString
path <-
        ShortByteString -> ByteString
BS.fromShort (ShortByteString -> ByteString)
-> IO ShortByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Ptr Any -> Int -> IO ShortByteString
forall a. Ptr a -> Int -> IO ShortByteString
BS.createFromPtr (Ptr a
p Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off_path) (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
dsclen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
size_type Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
size_null)
      AnchoredPath
iePath <-
        (String -> IO AnchoredPath)
-> (AnchoredPath -> IO AnchoredPath)
-> Either String AnchoredPath
-> IO AnchoredPath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO AnchoredPath
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail AnchoredPath -> IO AnchoredPath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String AnchoredPath -> IO AnchoredPath)
-> Either String AnchoredPath -> IO AnchoredPath
forall a b. (a -> b) -> a -> b
$ [Name] -> AnchoredPath
AnchoredPath ([Name] -> AnchoredPath)
-> Either String [Name] -> Either String AnchoredPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Either String Name)
-> [ByteString] -> Either String [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ByteString -> Either String Name
rawMakeName (Char -> ByteString -> [ByteString]
BC.split Char
'/' (ByteString -> ByteString
fixRoot ByteString
path))
      (IndexEntry, Int) -> IO (IndexEntry, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IndexEntry {Char
Int64
Maybe Hash
FileID
AnchoredPath
ieSize :: Int64
ieAux :: Int64
ieFileID :: FileID
ieHash :: Maybe Hash
ieType :: Char
iePath :: AnchoredPath
ieSize :: Int64
ieAux :: Int64
ieFileID :: FileID
ieHash :: Maybe Hash
ieType :: Char
iePath :: AnchoredPath
..}, Int -> Int
next (ByteString -> Int
B.length ByteString
path))
    b2c :: Word8 -> Char
    b2c :: Word8 -> Char
b2c = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    off_path :: Int
off_path = Int
off_dsc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_type
    next :: Int -> Int
next Int
pathlen =
      Int -> Int -> Int
forall a. Integral a => a -> a -> a
align Int
4 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ 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_hash Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_dsclen
              Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_type Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pathlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size_null
    fixRoot :: ByteString -> ByteString
fixRoot ByteString
s | ByteString
s ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"." = ByteString
BC.empty
    fixRoot ByteString
s = ByteString
s
    shortNullHash :: ShortByteString
shortNullHash = ByteString -> ShortByteString
BS.toShort ByteString
nullHash