module Storage.Hashed.Utils where
import Prelude hiding ( lookup, catch )
import qualified Bundled.SHA256 as SHA
import System.Mem( performGC )
import System.IO.MMap( mmapFileByteString )
import Bundled.Posix( getFileStatus, fileSize )
import System.Directory( getCurrentDirectory, setCurrentDirectory )
import System.FilePath( (</>), isAbsolute )
import Data.Int( Int64 )
import Control.Exception.Extensible( catch, bracket, SomeException(..) )
import Control.Monad( when )
import Foreign.ForeignPtr( withForeignPtr )
import Foreign.Ptr( plusPtr )
import Data.ByteString.Internal( toForeignPtr, memcpy )
import Data.Bits( (.&.), (.|.), shift, shiftL, shiftR, Bits )
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as BS
newtype Hash = Hash (Maybe Int64, BS.ByteString) deriving (Show, Eq, Read)
makeHash :: BS.ByteString -> Hash
makeHash str = case BS.split '-' str of
[h] -> Hash (Nothing, h)
[s, h] -> Hash (Just $ read $ BS.unpack s, h)
_ -> error $ "Bad hash string " ++ show str
hashSetSize :: Hash -> Int64 -> Hash
hashSetSize (Hash (_,h)) s = Hash (Just s, h)
type FileSegment = (FilePath, Maybe (Int64, Int))
sha256 :: BL.ByteString -> Hash
sha256 = makeHash . BS.pack . SHA.sha256 . BS.concat . BL.toChunks
readSegment :: FileSegment -> IO BL.ByteString
readSegment (f,range) = do
x <- mmapFileByteString f range
`catch` (\(_::SomeException) -> do
size <- fileSize `fmap` getFileStatus f
if size == 0
then return BS.empty
else performGC >> mmapFileByteString f range)
return $ BL.fromChunks [x]
withCurrentDirectory :: FilePath -> IO a -> IO a
withCurrentDirectory name =
bracket
(do cwd <- getCurrentDirectory
when (name /= "") (setCurrentDirectory name)
return cwd)
(\oldwd -> setCurrentDirectory oldwd
`catch` \(_::SomeException) -> return ())
. const
(?) :: Bool -> (a, a) -> a
w ? (a,b) = if w then a else b
makeAbsolute :: FilePath -> IO FilePath
makeAbsolute p = do
cwd <- getCurrentDirectory
return $! isAbsolute p ? (p, cwd </> p)
pokeBS :: BS.ByteString -> BS.ByteString -> IO ()
pokeBS to from =
do let (fp_to, off_to, len_to) = toForeignPtr to
(fp_from, off_from, len_from) = toForeignPtr from
when (len_to /= len_from) $ fail $ "Length mismatch in pokeBS: from = "
++ show len_from ++ " /= to = " ++ show len_to
withForeignPtr fp_from $ \p_from ->
withForeignPtr fp_to $ \p_to ->
memcpy (plusPtr p_to off_to)
(plusPtr p_from off_from)
(fromIntegral len_to)
xlate32 :: (Bits a) => a -> a
xlate64 :: (Bits a) => a -> a
#ifdef LITTLEENDIAN
xlate32 = id
xlate64 = id
#endif
#ifdef BIGENDIAN
bytemask :: (Bits a) => a
bytemask = 255
xlate32 a = ((a .&. (bytemask `shift` 0) `shiftL` 24)) .|.
((a .&. (bytemask `shift` 8) `shiftL` 8)) .|.
((a .&. (bytemask `shift` 16) `shiftR` 8)) .|.
((a .&. (bytemask `shift` 24) `shiftR` 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) `shiftR` 8)) .|.
((a .&. (bytemask `shift` 40) `shiftR` 24)) .|.
((a .&. (bytemask `shift` 48) `shiftR` 40)) .|.
((a .&. (bytemask `shift` 56) `shiftR` 56))
#endif