module Storage.Hashed.Index( readIndex, updateIndexFrom, readOrUpgradeIndex
, indexFormatValid )
where
import Prelude hiding ( lookup, readFile, writeFile, catch )
import Storage.Hashed.Utils
import Storage.Hashed.Tree
import Storage.Hashed.AnchoredPath
import Data.Int( Int64, Int32 )
import qualified Data.Set as S
import qualified Data.Map as M
import Bundled.Posix( getFileStatusBS, modificationTime,
getFileStatus, fileSize, fileExists, EpochTime )
import System.IO.MMap( mmapFileForeignPtr, Mode(..) )
import System.IO( openBinaryFile, hGetChar, hClose, IOMode(..) )
import System.Directory( removeFile, doesFileExist )
import Control.Monad( when )
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Internal( toForeignPtr, fromForeignPtr, memcpy
, nullForeignPtr )
import Data.IORef( newIORef, readIORef, modifyIORef, IORef )
import Data.Maybe( fromJust, isJust )
import Data.Bits( Bits )
import Foreign.Storable
import Foreign.ForeignPtr
import Foreign.Ptr
data Item = Item { iPath :: BS.ByteString
, iName :: BS.ByteString
, iHash :: BS.ByteString
, iSize :: Ptr Int64
, iAux :: Ptr Int64
} deriving Show
itemSize :: Item -> Int
itemSize i = 4 + (BS.length $ iPath i) + 1 + 64 + 16
itemSizeI :: (Num a) => Item -> a
itemSizeI = fromIntegral . itemSize
itemIsDir :: Item -> Bool
itemIsDir i = BS.last (iPath i) == '/'
noslashpath :: Item -> FilePath
noslashpath i = BS.unpack $ itemIsDir i ? (BS.init $ iPath i, iPath i)
xlatePeek64 :: (Storable a, Bits a) => Ptr a -> IO a
xlatePeek64 = fmap xlate64 . peek
xlatePoke64 :: (Storable a, Bits a) => Ptr a -> a -> IO ()
xlatePoke64 ptr v = poke ptr (xlate64 v)
createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item
createItem typ path fp off =
do let name = BS.concat [ flatten path,
(typ == TreeType) ? (BS.singleton '/', BS.empty),
BS.singleton '\0' ]
(namefp, nameoff, namel) = toForeignPtr name
withForeignPtr fp $ \p ->
withForeignPtr namefp $ \namep ->
do pokeByteOff p off namel
memcpy (plusPtr p $ off + 4)
(plusPtr namep nameoff)
(fromIntegral namel)
peekItem fp off Nothing
peekItem :: ForeignPtr () -> Int -> Maybe Int -> IO Item
peekItem fp off dirlen =
withForeignPtr fp $ \p -> do
nl' :: Int32 <- xlate32 `fmap` peekByteOff p off
let nl = fromIntegral nl'
path = fromForeignPtr (castForeignPtr fp) (off + 4) (nl 1)
path_noslash = (BS.last path == '/') ? (BS.init path, path)
hash = fromForeignPtr (castForeignPtr fp) (off + 4 + nl) 64
name = snd $ case dirlen of
Just split -> BS.splitAt split path_noslash
Nothing -> BS.spanEnd (/= '/') path_noslash
return $! Item { iName = name
, iPath = path
, iHash = hash
, iSize = plusPtr p (off + 4 + nl + 64)
, iAux = plusPtr p (off + 4 + nl + 64 + 8)
}
update :: Item -> Maybe EpochTime -> Hash -> IO ()
update item mtime (Hash (Just size, hash)) =
do xlatePoke64 (iSize item) size
pokeBS (iHash item) hash
when (isJust mtime) $ xlatePoke64 (iAux item)
(fromIntegral $ fromEnum $ fromJust mtime)
update _ _ _ = fail "Index.update requires a hash with size included."
iHash' :: Item -> IO Hash
iHash' i = do size <- xlatePeek64 $ iSize i
return $ hashSetSize (Hash (undefined, iHash i)) size
mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int)
mmapIndex indexpath req_size = do
exist <- doesFileExist indexpath
act_size <- if exist then fileSize `fmap` getFileStatus indexpath
else return 0
let size :: Int
size = fromIntegral $
if req_size > 0 then fromIntegral req_size else act_size
case size of
0 -> return (castForeignPtr nullForeignPtr, size)
_ -> do (x, _) <- mmapFileForeignPtr indexpath
ReadWrite (Just (0, size + 4))
return (x, size)
readIndex' :: FilePath -> (Tree -> Hash)
-> IO (Tree, IORef (M.Map AnchoredPath Item))
readIndex' indexpath hashtree = do
(mmap, mmap_size) <- mmapIndex indexpath 0
dirs_changed <- newIORef S.empty
item_map <- newIORef M.empty
let readItem :: AnchoredPath -> Int -> Int -> IO (Item, Maybe TreeItem)
readItem parent_path off dl =
do item <- peekItem mmap off (Just dl)
x <- if itemIsDir item then readDir parent_path item off dl
else readFile parent_path item
when (isJust x) $ modifyIORef item_map $ \m ->
M.insert (parent_path `appendPath` (Name $ iName item)) item m
return (item, x)
readDir :: AnchoredPath -> Item -> Int -> Int -> IO (Maybe TreeItem)
readDir parent_path item off dl =
do dirend <- xlatePeek64 $ iAux item
st <- getFileStatus (noslashpath item)
let this_path = parent_path `appendPath` (Name $ iName item)
nl = BS.length (iName item)
dl' = dl + (nl == 0) ? (0, 1 + nl)
subs coff | coff < dirend = do
(idx_item, tree_item) <- readItem this_path
(fromIntegral coff) dl'
next <- if itemIsDir idx_item
then xlatePeek64 $ iAux idx_item
else return $ coff + itemSizeI idx_item
rest <- subs next
case tree_item of
Nothing -> return $! rest
Just ti -> return $! (Name $ iName idx_item, ti) : rest
subs coff | coff == dirend = return []
| otherwise = fail "Offset mismatch."
updateHash path tree =
do changed <- S.member path `fmap` readIORef dirs_changed
let hash = hashtree tree
tree' = tree { treeHash = Just hash }
if changed
then do update item Nothing hash
return tree'
else return tree
treehash <- iHash' item
let rt = Stub (do s <- subs $ fromIntegral (off + itemSize item)
return $ (makeTree s)
{ finish = updateHash this_path
, treeHash = Just treehash })
(Just treehash)
return $ if fileExists st then Just rt else Nothing
readFile parent_path item =
do st <- getFileStatusBS (iPath item)
mtime <- fromIntegral `fmap` (xlatePeek64 $ iAux item)
size <- xlatePeek64 $ iSize item
let mtime' = modificationTime st
size' = fileSize st
readblob = readSegment (BS.unpack $ iPath item, Nothing)
when ( mtime /= mtime' || size /= fromIntegral size' ) $
do hash_' <- sha256 `fmap` readblob
let hash' = hashSetSize hash_' (fromIntegral size')
update item (Just mtime') hash'
modifyIORef dirs_changed $ \s ->
S.union (S.fromList $ parent_path : parents parent_path) s
hash <- iHash' item
if fileExists st
then return $ Just $ File (Blob readblob $ Just hash)
else return Nothing
if mmap_size > 0 then
do (_, Just (Stub root h)) <- readItem (AnchoredPath []) 4 (2)
tree <- root
return (tree { treeHash = h }, item_map)
else return (emptyTree, item_map)
readIndex :: FilePath -> (Tree -> Hash) -> IO Tree
readIndex x y = fst `fmap` readIndex' x y
updateIndexFrom :: FilePath -> (Tree -> Hash) -> Tree -> IO Tree
updateIndexFrom indexpath hashtree ref =
do (oldidx', item_map') <- readIndex' indexpath hashtree
expand oldidx'
item_map <- readIORef item_map'
reference <- expand ref
let typeLen TreeType = 1
typeLen BlobType = 0
paths = [ (p, itemType i) | (p, i) <- list reference ]
len = 87 + sum [ typeLen typ + 84 + 1 + length (anchorPath "" p)
| (p, typ) <- paths ]
exist <- doesFileExist indexpath
when exist $ removeFile indexpath
(mmap, _) <- mmapIndex indexpath len
let magic = fromForeignPtr (castForeignPtr mmap) 0 4
create (File _) path off =
do i <- createItem BlobType path mmap off
case M.lookup path item_map of
Nothing -> return ()
Just item -> do mtime <- xlatePeek64 $ iAux item
hash <- iHash' item
update i (Just $ fromIntegral mtime) hash
return $ off + itemSize i
create (SubTree s) path off =
do i <- createItem TreeType path mmap off
case M.lookup path item_map of
Nothing -> return ()
Just item -> iHash' item >>= update i Nothing
let subs [] = return $ off + itemSize i
subs ((name,x):xs) = do
let path' = path `appendPath` name
noff <- subs xs
create x path' noff
lastOff <- subs (listImmediate s)
xlatePoke64 (iAux i) (fromIntegral lastOff)
return lastOff
create (Stub _ _) path _ =
fail $ "Cannot create index from stubbed Tree at " ++ show path
pokeBS magic (BS.pack "HSI1")
create (SubTree reference) (AnchoredPath []) 4
readIndex indexpath hashtree
indexFormatValid :: FilePath -> IO Bool
indexFormatValid path = do
fd <- openBinaryFile path ReadMode
magic <- sequence [ hGetChar fd | _ <- [1..4] :: [Int] ]
hClose fd
return $ case magic of
"HSI1" -> True
_ -> False
readOrUpgradeIndex :: FilePath -> (Tree -> Hash) -> IO Tree -> IO Tree
readOrUpgradeIndex path hashtree getref = do
valid <- indexFormatValid path
if valid then readIndex path hashtree
else do ref <- getref >>= expand
removeFile path
updateIndexFrom path hashtree ref