vhd 0.1 → 0.2
raw patch · 26 files changed
+1303/−906 lines, 26 filesdep +filepathnew-uploader
Dependencies added: filepath
Files
- Data/BitSet.hs +101/−0
- Data/Range.hs +32/−0
- Data/VHD.hs +0/−147
- Data/VHD/Bat.hs +0/−76
- Data/VHD/Bitmap.hs +0/−38
- Data/VHD/Block.hs +0/−83
- Data/VHD/CheckSum.hs +0/−43
- Data/VHD/Context.hs +0/−82
- Data/VHD/Geometry.hs +0/−30
- Data/VHD/Serialize.hs +0/−184
- Data/VHD/Types.hs +0/−112
- Data/VHD/Utils.hs +0/−20
- Data/Vhd.hs +331/−0
- Data/Vhd/Bat.hs +99/−0
- Data/Vhd/Bitmap.hs +38/−0
- Data/Vhd/Block.hs +113/−0
- Data/Vhd/Checksum.hs +41/−0
- Data/Vhd/Geometry.hs +30/−0
- Data/Vhd/Node.hs +87/−0
- Data/Vhd/Serialize.hs +184/−0
- Data/Vhd/Types.hs +122/−0
- Data/Vhd/Utils.hs +34/−0
- README +1/−1
- Tests.hs +4/−4
- Vhd.hs +69/−72
- vhd.cabal +17/−14
+ Data/BitSet.hs view
@@ -0,0 +1,101 @@+module Data.BitSet+ ( BitSet+ , empty+ , fromByteString+ , fromRange+ , toList+ , isEmpty+ , intersect+ , union+ , subtract+ )+ where++import Control.Exception+import Data.Bits+import qualified Data.ByteString as B+import Data.Word+import Prelude hiding (subtract)++data BitSet = BitSet B.ByteString++instance Eq BitSet+ where (BitSet b1) == (BitSet b2) = b1' == b2'+ where (b1', b2') = byteStringsPad b1 b2++instance Show BitSet where show = show . toList++empty :: BitSet+empty = BitSet B.empty++fromByteString :: B.ByteString -> BitSet+fromByteString = BitSet++fromRange :: Int -> Int -> BitSet+fromRange lo hi = BitSet generate where++ generate+ | lo < 0 = error "lower bound cannot be less than zero."+ | lo > hi = error "lower bound cannot be greater than upper bound."+ | lo == hi = B.empty+ | lo == 0 && hiBit == 0 = setBytes+ | loBit == 0 && hiBit == 0 = B.concat [clearBytes, setBytes]+ | loBit == 0 && hiBit /= 0 = B.concat [clearBytes, setBytes, fallByte]+ | loBit /= 0 && hiBit == 0 = B.concat [clearBytes, riseByte, setBytes]+ | loByteFloor == hiByteFloor = B.concat [clearBytes, humpByte]+ | loByteCeiling == hiByteFloor = B.concat [clearBytes, riseByte, fallByte]+ | loByteCeiling < hiByteFloor = B.concat [clearBytes, riseByte, setBytes, fallByte]++ (loBit, loByteFloor, loByteCeiling) = (lo `mod` 8, lo `div` 8, (lo + 7) `div` 8)+ (hiBit, hiByteFloor, hiByteCeiling) = (hi `mod` 8, hi `div` 8, (hi + 7) `div` 8)++ clearBytes = B.replicate (loByteFloor ) 0x00+ setBytes = B.replicate (hiByteFloor - loByteCeiling) 0xff++ riseByte = B.singleton $ setBits 0 loBit 8+ fallByte = B.singleton $ setBits 0 0 hiBit+ humpByte = B.singleton $ setBits 0 loBit hiBit++toList :: BitSet -> [Int]+toList (BitSet b) = map snd $ filter fst $ zip (byteStringBits b) [0 ..]++isEmpty :: BitSet -> Bool+isEmpty (BitSet b) = B.all (== 0) b++intersect :: BitSet -> BitSet -> BitSet+union :: BitSet -> BitSet -> BitSet+subtract :: BitSet -> BitSet -> BitSet++intersect = binaryOp (.&.)+union = binaryOp (.|.)+subtract = binaryOp (\x y -> x .&. complement y)++binaryOp f (BitSet b1) (BitSet b2) =+ BitSet $ byteStringPackZipWith f b1' b2'+ where (b1', b2') = byteStringsPad b1 b2++byteStringBits byteString = do+ word <- B.unpack byteString+ bit <- word8Bits word+ return bit++byteStringPackZipWith :: (Word8 -> Word8 -> Word8) -> B.ByteString -> B.ByteString -> B.ByteString+byteStringPackZipWith = ((B.pack .) .) . B.zipWith++byteStringsPad :: B.ByteString -> B.ByteString -> (B.ByteString, B.ByteString)+byteStringsPad b1 b2 =+ if length1 < length2+ then (B.append b1 (B.replicate (length2 - length1) 0), b2)+ else (b1, B.append b2 (B.replicate (length1 - length2) 0))+ where+ length1 = B.length b1+ length2 = B.length b2++setBits :: Bits a => a -> Int -> Int -> a+setBits value loBit hiBit = if loBit < hiBit+ then setBits (setBit value loBit) (loBit + 1) hiBit+ else value++word8Bits :: Word8 -> [Bool]+word8Bits w = map (testBit w) [0 .. 7]+
+ Data/Range.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Data.Range+ ( Range+ , RangeLength+ , range+ , length+ , minimum+ , maximum+ ) where++import Control.Exception+import Data.Word+import Prelude hiding (length, minimum, maximum)++data Range a = Range a a++class (Integral a, Integral b) => RangeLength a b | a -> b++range :: RangeLength a b => a -> a -> Range a+range a b = assert (a <= b) $ Range a b++length :: RangeLength a b => Range a -> b+length (Range a b) = fromIntegral $ b - a++minimum :: Range a -> a+minimum (Range a _) = a++maximum :: Range a -> a+maximum (Range _ a) = a
− Data/VHD.hs
@@ -1,147 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Data.VHD- ( create- , CreateParameters(..)- , defaultCreateParameters- , getInfo- -- * block related operations- , Block- , readBlock- , writeBlock- , withBlock- -- * ctx related operations- , Context(..)- , withVhdContext- , extendBlock- -- * exported Types- , module Data.VHD.Types- ) where--import Control.Applicative-import Control.Exception-import Control.Monad-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString as B-import Data.ByteString.Char8 ()-import Data.Serialize-import Data.VHD.Serialize-import Data.VHD.Types-import Data.VHD.Bat-import Data.VHD.Block-import Data.VHD.Context-import Data.VHD.Utils-import Data.VHD.Geometry-import Data.VHD.CheckSum-import Data.Bits-import Data.Maybe-import Data.Word-import Data.Time.Clock.POSIX--import System.IO--data CreateParameters = CreateParameters- { blockSize :: BlockSize- , size :: Size- , timeStamp :: Maybe TimeStamp- , uuid :: Maybe UniqueId- , useBatmap :: Bool- } deriving (Show,Eq)--defaultCreateParameters = CreateParameters- { blockSize = 2 * 1024 * 1024- , size = 0- , timeStamp = Nothing- , uuid = Nothing- , useBatmap = False- }---- | grab the header and footer from a vhd file.-getInfo :: FilePath -> IO (Either String (Header, Footer))-getInfo filePath = withFile filePath ReadMode $ \handle -> do- footer <- decode <$> B.hGet handle 512- header <- decode <$> B.hGet handle 1024- case (footer, header) of- (Left err, _) -> return $ Left err- (_, Left err) -> return $ Left err- (Right f, Right h) -> return $ Right (h,f)---- | create an empty vhd with the specified parameters-create :: FilePath -> CreateParameters -> IO ()-create filePath createParams- | size createParams == 0 = error "cannot create a 0-sized VHD"- | otherwise = do- nowUnixEpoch <- fromIntegral . fromEnum <$> getPOSIXTime- let nowVhdEpoch = fromIntegral (nowUnixEpoch - y2k)- uniqueid <- randomUniqueId- create' filePath $ createParams- { uuid = Just $ maybe uniqueid id $ uuid createParams- , timeStamp = Just $ maybe nowVhdEpoch id $ timeStamp createParams- }- where- y2k :: Word64- y2k = 946684800 -- seconds from the unix epoch to the vhd epoch--create' :: FilePath -> CreateParameters -> IO ()-create' filePath createParams =- withFile filePath WriteMode $ \handle -> do- B.hPut handle $ encode footer- B.hPut handle $ encode header- hAlign handle (fromIntegral sectorLength)- -- create a BAT with every entry initialized to 0xffffffff.- B.hPut handle $ B.replicate (fromIntegral batSize) 0xff-- -- maybe create a batmap- when (useBatmap createParams) $ do- hAlign handle (fromIntegral sectorLength)- headerPos <- hTell handle- B.hPut handle $ encode $ BatmapHeader- { batmapHeaderCookie = cookie "tdbatmap"- , batmapHeaderOffset = fromIntegral (headerPos + fromIntegral sectorLength)- , batmapHeaderSize = (maxTableEntries `div` 8) `divRoundUp` sectorLength- , batmapHeaderVersion = Version 1 2- , batmapHeaderCheckSum = 0xffffffff- }- hAlign handle (fromIntegral sectorLength)- B.hPut handle $ B.replicate (fromIntegral (maxTableEntries `div` 8)) 0x0-- hAlign handle (fromIntegral sectorLength)- B.hPut handle $ encode footer- where- virtualSize = size createParams- maxTableEntries = fromIntegral (virtualSize `divRoundUp` fromIntegral (blockSize createParams))- batSize = (maxTableEntries * 4) `roundUpToModulo` sectorLength- batPadSize = batSize - maxTableEntries * 4- footerSize = 512- headerSize = 1024-- footer = adjustFooterChecksum $ Footer- { footerCookie = cookie "conectix"- , footerIsTemporaryDisk = False- , footerFormatVersion = Version 1 0- , footerDataOffset = footerSize- , footerTimeStamp = fromJust $ timeStamp createParams- , footerCreatorApplication = creatorApplication "tap\0"- , footerCreatorVersion = if useBatmap createParams then Version 1 3 else Version 1 0- , footerCreatorHostOs = CreatorHostOsWindows- , footerOriginalSize = virtualSize- , footerCurrentSize = virtualSize- , footerDiskGeometry = diskGeometry (virtualSize `div` fromIntegral sectorLength)- , footerDiskType = DiskTypeDynamic- , footerCheckSum = 0- , footerUniqueId = fromJust $ uuid createParams- , footerIsSavedState = False- }- header = adjustHeaderChecksum $ Header- { headerCookie = cookie "cxsparse"- , headerDataOffset = 0xffffffffffffffff- , headerTableOffset = footerSize + headerSize- , headerVersion = Version 1 0- , headerMaxTableEntries = maxTableEntries- , headerBlockSize = blockSize createParams- , headerCheckSum = 0- , headerParentUniqueId = uniqueId $ B.replicate 16 0- , headerParentTimeStamp = 0- , headerReserved1 = B.replicate 4 0- , headerParentUnicodeName = parentUnicodeName ""- , headerParentLocatorEntries = parentLocatorEntries $ replicate 8 (ParentLocatorEntry $ B.replicate 24 0)- }
− Data/VHD/Bat.hs
@@ -1,76 +0,0 @@-module Data.VHD.Bat- ( Bat(..)- , batGetSize- , batRead- , batWrite- , batMmap- , batIterate- , batUpdateChecksum- ) where--import Data.Word-import Data.Bits-import Data.Storable.Endian-import Foreign.Ptr-import Foreign.Storable--import Data.VHD.Types-import Data.VHD.Serialize-import Data.VHD.Utils-import Data.VHD.Bitmap--import Control.Monad--import System.IO.MMap--data Batmap = Batmap Bitmap Int-data Bat = Bat (Ptr Word32) (Ptr Word32) (Maybe Batmap)--sectorLength = 512--batmapSet n (Batmap bitmap _) = bitmapSet bitmap n--batmapChecksum :: Batmap -> IO CheckSum-batmapChecksum (Batmap (Bitmap p) sz) = complement `fmap` foldM addByte 0 [0..(sz-1)]- where addByte acc i = (p `peekElemOff` i) >>= \w -> return (acc + fromIntegral w)---- | returns the padded size of a BAT-batGetSize :: Header -> Footer -> Int-batGetSize header footer = fromIntegral ((maxEntries * 4) `roundUpToModulo` sectorLength)- where- diskSize = footerCurrentSize footer- blockSize = headerBlockSize header- ents = diskSize `divRoundUp` fromIntegral blockSize- maxEntries = headerMaxTableEntries header--batRead :: Bat -> Int -> IO Word32-batRead (Bat bptr _ _) n = peekBE ptr- where ptr = bptr `plusPtr` (n*4)--batWrite :: Bat -> Int -> Word32 -> IO ()-batWrite (Bat bptr _ bmap) n v = pokeBE ptr v >> maybe (return ()) (batmapSet n) bmap- where ptr = bptr `plusPtr` (n*4)--batMmap :: FilePath -> Header -> Footer -> Maybe BatmapHeader -> (Bat -> IO a) -> IO a-batMmap file header footer batmapHeader f =- mmapWithFilePtr file ReadWrite (Just offsetSize) $ \(ptr, sz) ->- let batmap = Batmap (Bitmap (castPtr (ptr `plusPtr` batmapOffset))) batmapSize in- let batendPtr = ptr `plusPtr` batSize in- f (Bat (castPtr ptr) batendPtr (maybe Nothing (const $ Just batmap) batmapHeader))- where- absoluteOffset = fromIntegral (headerTableOffset header)- offsetSize = (absoluteOffset, fromIntegral (batSize + maybe 0 (const 512) batmapHeader + batmapSize))- batmapOffset = batSize + fromIntegral sectorLength- batSize = batGetSize header footer- batmapSize = maybe 0 (fromIntegral . (* sectorLength) . batmapHeaderSize) batmapHeader--batIterate :: Bat -> Int -> (Int -> Word32 -> IO ()) -> IO ()-batIterate bat nb f = forM_ [0..(nb-1)] (\i -> batRead bat i >>= \n -> f i n)---- | update checksum in the batmap if the batmap exists-batUpdateChecksum :: Bat -> IO ()-batUpdateChecksum (Bat _ _ Nothing) = return ()-batUpdateChecksum (Bat _ endptr (Just batmap)) = do- let batmapCheckSumPtr = endptr `plusPtr` (8+8+4+4)- checkSum <- batmapChecksum batmap- pokeBE batmapCheckSumPtr checkSum
− Data/VHD/Bitmap.hs
@@ -1,38 +0,0 @@-module Data.VHD.Bitmap- ( Bitmap (..)- , bitmapGet- , bitmapSet- , bitmapSetRange- , bitmapClear- ) where--import Foreign.Ptr-import Foreign.Storable-import Data.Word-import Data.Bits--data Bitmap = Bitmap (Ptr Word8)--bitmapGet :: Bitmap -> Int -> IO Bool-bitmapGet (Bitmap ptr) n = test `fmap` peekByteOff ptr offset- where- test :: Word8 -> Bool- test = flip testBit (7-bit)- (offset, bit) = n `divMod` 8--bitmapModify :: Bitmap -> Int -> (Int -> Word8 -> Word8) -> IO ()-bitmapModify (Bitmap bptr) n f = peek ptr >>= poke ptr . f (7-bit)- where- ptr = bptr `plusPtr` offset- (offset, bit) = n `divMod` 8--bitmapSet :: Bitmap -> Int -> IO ()-bitmapSet bitmap n = bitmapModify bitmap n (flip setBit)--bitmapSetRange :: Bitmap -> Int -> Int -> IO ()-bitmapSetRange bitmap start end- | start < end = bitmapSet bitmap start >> bitmapSetRange bitmap (start + 1) end- | otherwise = return ()--bitmapClear :: Bitmap -> Int -> IO ()-bitmapClear bitmap n = bitmapModify bitmap n (flip clearBit)
− Data/VHD/Block.hs
@@ -1,83 +0,0 @@-module Data.VHD.Block- ( Block- , Sector- , bitmapSizeOfBlock- , bitmapOfBlock- , withBlock- , readBlock- , writeBlock- , sectorLength- ) where--import Foreign.Ptr-import Foreign.Storable-import Data.Word-import Data.Bits--import Data.VHD.Utils-import Data.VHD.Types-import Data.VHD.Bat-import Data.VHD.Bitmap--import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as B-import qualified Data.ByteString.Internal as B--import Control.Monad--import System.IO.MMap--data Block = Block BlockSize (Ptr Word8)-data Sector = Sector (Ptr Word8)--sectorLength :: Word32-sectorLength = 512---- | this is the padded size of the bitmap for a specific blocksize-bitmapSizeOfBlock :: BlockSize -> Int-bitmapSizeOfBlock blockSize = fromIntegral ((nbSector `divRoundUp` 8) `roundUpToModulo` sectorLength)- where nbSector = blockSize `divRoundUp` sectorLength---- | get a bitmap type out of a block type.--- the bitmap happens to be at the beginning of the block.-bitmapOfBlock :: Block -> Bitmap-bitmapOfBlock (Block _ ptr) = Bitmap ptr--dataOfBlock :: Block -> Ptr Word8-dataOfBlock (Block bs ptr) = ptr `plusPtr` (bitmapSizeOfBlock bs)---- | mmap a block using a filepath, a blocksize-withBlock :: FilePath -> BlockSize -> Word32 -> (Block -> IO a) -> IO a-withBlock file bs sectorOff f = mmapWithFilePtr file ReadWrite (Just offsetSize) $ \(ptr, sz) ->- f (Block bs $ castPtr ptr)- where- absoluteOffset = fromIntegral (fromIntegral sectorOff * sectorLength)- offsetSize = (absoluteOffset, fromIntegral bs + fromIntegral bitmapSize)- nbSector = (bs `divRoundUp` sectorLength)- bitmapSize = (nbSector `divRoundUp` 8) `roundUpToModulo` sectorLength--readBlock :: Block -> Int -> Int -> IO ByteString-readBlock block offsetStart offsetEnd = do- -- for the moment, assume we're reading from a dynamic disk.- -- later on, we'll also need to handle differencing disks here.- B.create length (\bsptr -> B.memcpy (castPtr bsptr) (dataPtr `plusPtr` offsetStart) (fromIntegral length))- where- length = offsetEnd - offsetStart- bitmapPtr = bitmapOfBlock block- dataPtr = dataOfBlock block- sectorStart = fromIntegral offsetStart `div` sectorLength- sectorEnd = fromIntegral offsetEnd `div` sectorLength--writeBlock :: Block -> ByteString -> Int -> IO ()-writeBlock block content offset = do- -- sectors need to be prepared for differential disk if the bitmap was clear before,- -- at the moment assumption is it's 0ed- bitmapSetRange bitmapPtr (fromIntegral sectorStart) (fromIntegral sectorEnd)- B.unsafeUseAsCString content (\bsptr -> B.memcpy (dataPtr `plusPtr` offset) (castPtr bsptr) (fromIntegral length))- where- length = B.length content- bitmapPtr = bitmapOfBlock block- dataPtr = dataOfBlock block- sectorStart = fromIntegral offset `div` sectorLength- sectorEnd = fromIntegral (offset + B.length content) `div` sectorLength
− Data/VHD/CheckSum.hs
@@ -1,43 +0,0 @@-module Data.VHD.CheckSum- ( adjustFooterChecksum- , adjustHeaderChecksum- , verifyFooterChecksum- , verifyHeaderChecksum- ) where--import Data.VHD.Types-import Data.VHD.Serialize--import Data.Bits-import Data.Word-import Data.Serialize--import qualified Data.ByteString as B--plus :: CheckSum -> Word8 -> CheckSum-plus a b = a + fromIntegral b--getHeaderChecksum :: Header -> CheckSum-getHeaderChecksum header = complement $ B.foldl' plus 0 headerData- where- headerData = encode $ header { headerCheckSum = 0 }--getFooterChecksum :: Footer -> CheckSum-getFooterChecksum footer = complement $ B.foldl' plus 0 footerData- where footerData = encode $ footer { footerCheckSum = 0 }--adjustFooterChecksum :: Footer -> Footer-adjustFooterChecksum f = f { footerCheckSum = checksum }- where checksum = getFooterChecksum f--adjustHeaderChecksum :: Header -> Header-adjustHeaderChecksum h = h { headerCheckSum = checksum }- where checksum = getHeaderChecksum h--verifyFooterChecksum :: Footer -> Bool-verifyFooterChecksum f = footerCheckSum f == checksum- where checksum = getFooterChecksum f--verifyHeaderChecksum :: Header -> Bool-verifyHeaderChecksum h = headerCheckSum h == checksum- where checksum = getHeaderChecksum h
− Data/VHD/Context.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Data.VHD.Context- ( Context(..)- , withVhdContext- , extendBlock- ) where--import Data.VHD.Block-import Data.VHD.Bat-import Data.VHD.Types-import Data.VHD.Utils-import Data.VHD.Serialize--import Data.Serialize (decode, encode)--import qualified Data.ByteString as B-import Data.ByteString.Char8 ()-import Data.IORef--import System.IO--import Control.Applicative ((<$>))-import Control.Monad--data Context = Context- { ctxBatPtr :: Bat- , ctxHeader :: Header- , ctxFooter :: Footer- , ctxHandle :: Handle- , ctxFilePath :: FilePath- , ctxBModified :: IORef Bool- }--withVhdContext file f = do- withFile file ReadWriteMode $ \handle -> do- footer <- either error id . decode <$> B.hGet handle 512- header <- either error id . decode <$> B.hGet handle 1024- mBatmapHdr <- if footerCreatorVersion footer == Version 1 3- then do- -- skip the BAT, and try reading the batmap header- hSeek handle RelativeSeek (fromIntegral $ batGetSize header footer)- batmapHdr <- decode <$> B.hGet handle 512- case batmapHdr of- Left _ -> return Nothing- Right bHdr ->- if batmapHeaderCookie bHdr == cookie "tdbatmap"- then return $ Just bHdr- else return Nothing- else return Nothing- batMmap file header footer mBatmapHdr $ \bat -> do- bmodified <- newIORef False- a <- f $ Context- { ctxBatPtr = bat- , ctxHeader = header- , ctxFooter = footer- , ctxHandle = handle- , ctxFilePath = file- , ctxBModified = bmodified- }- modified <- readIORef bmodified- when (modified) $ batUpdateChecksum bat- return a---- | create empty block at the end-extendBlock ctx n = do- hSeek (ctxHandle ctx) SeekFromEnd 512- x <- hTell (ctxHandle ctx)- -- paranoid check- let (sector, m) = x `divMod` 512- unless (m == 0) $ error "wrong sector alignment"- batWrite (ctxBatPtr ctx) n (fromIntegral sector)- modifyIORef (ctxBModified ctx) (const True)-- B.hPut (ctxHandle ctx) (B.replicate fullSize 0)-- hAlign (ctxHandle ctx) (fromIntegral sectorLength)- B.hPut (ctxHandle ctx) $ encode (ctxFooter ctx)-- where- fullSize = bitmapSize + fromIntegral blockSize- bitmapSize = bitmapSizeOfBlock blockSize- blockSize = headerBlockSize $ ctxHeader ctx
− Data/VHD/Geometry.hs
@@ -1,30 +0,0 @@-module Data.VHD.Geometry where--import Data.VHD.Types-import Data.Word---- | Calculates disk geometry using the algorithm presented in--- | the virtual hard disk image format specification (v 1.0).-diskGeometry :: Word64 -> DiskGeometry-diskGeometry totalSectors' =- let (sectorsPerTrack, heads, cylindersTimesHeads) = calculate in- let cylinders = cylindersTimesHeads `div` heads in- DiskGeometry- (fromIntegral cylinders)- (fromIntegral heads)- (fromIntegral sectorsPerTrack)- where- totalSectors = min totalSectors' (65535 * 16 * 255)- calculate- | totalSectors > 65536 * 16 * 63 = (255, 16, totalSectors `div` 255)- | otherwise =- let sectorsPerTrack = 17 in- let cylindersTimesHeads = totalSectors `div` 17 in- let heads = max 4 $ (cylindersTimesHeads + 1023) `div` 1024 in- let (sectorsPerTrack', heads', cylindersTimesHeads') =- if cylindersTimesHeads >= heads * 1024 || heads > 16- then (31, 16, totalSectors `div` 31)- else (sectorsPerTrack, heads, cylindersTimesHeads) in- if cylindersTimesHeads' >= heads' * 1024- then (63, 16, totalSectors `div` 63)- else (sectorsPerTrack', heads', cylindersTimesHeads')
− Data/VHD/Serialize.hs
@@ -1,184 +0,0 @@-module Data.VHD.Serialize where--import Control.Applicative-import Control.Exception-import Control.Monad-import Data.Bits-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.VHD.Types-import Data.Serialize-import Data.Serialize.Get-import Data.Serialize.Put-import Data.Text.Encoding-import qualified Data.Text as T--instance Serialize Header where- get = Header- <$> getCookie- <*> getDataOffset- <*> getTableOffset- <*> getVersion- <*> getMaxTableEntries- <*> getBlockSize- <*> getCheckSum- <*> getParentUniqueId- <*> getParentTimeStamp- <*> getByteString 4- <*> getParentUnicodeName- <*> getParentLocatorEntries- <* getHeaderPadding- put h = do- putCookie $ headerCookie h- putDataOffset $ headerDataOffset h- putTableOffset $ headerTableOffset h- putVersion $ headerVersion h- putMaxTableEntries $ headerMaxTableEntries h- putBlockSize $ headerBlockSize h- putCheckSum $ headerCheckSum h- putParentUniqueId $ headerParentUniqueId h- putParentTimeStamp $ headerParentTimeStamp h- putByteString $ headerReserved1 h- putParentUnicodeName $ headerParentUnicodeName h- putParentLocatorEntries $ headerParentLocatorEntries h- putHeaderPadding--instance Serialize Footer where- get = Footer- <$> getCookie- <*> getIsTemporaryDisk- <*> getFormatVersion- <*> getDataOffset- <*> getTimeStamp- <*> getCreatorApplication- <*> getCreatorVersion- <*> getCreatorHostOs- <*> getOriginalSize- <*> getCurrentSize- <*> getDiskGeometry- <*> getDiskType- <*> getCheckSum- <*> getUniqueId- <*> getIsSavedState- <* getFooterPadding- put f = do- putCookie $ footerCookie f- putIsTemporaryDisk $ footerIsTemporaryDisk f- putFormatVersion $ footerFormatVersion f- putDataOffset $ footerDataOffset f- putTimeStamp $ footerTimeStamp f- putCreatorApplication $ footerCreatorApplication f- putCreatorVersion $ footerCreatorVersion f- putCreatorHostOs $ footerCreatorHostOs f- putOriginalSize $ footerOriginalSize f- putCurrentSize $ footerCurrentSize f- putDiskGeometry $ footerDiskGeometry f- putDiskType $ footerDiskType f- putCheckSum $ footerCheckSum f- putUniqueId $ footerUniqueId f- putIsSavedState $ footerIsSavedState f- putFooterPadding--instance Serialize BatmapHeader where- get = BatmapHeader- <$> getCookie- <*> getDataOffset- <*> getWord32be- <*> getVersion- <*> getCheckSum- put b = do- putCookie $ batmapHeaderCookie b- putDataOffset $ batmapHeaderOffset b- putWord32be $ batmapHeaderSize b- putVersion $ batmapHeaderVersion b- putCheckSum $ batmapHeaderCheckSum b--footerPaddingLength = 427-getFooterPadding = getByteString footerPaddingLength-putFooterPadding = putByteString $ B.replicate footerPaddingLength 0--headerPaddingLength = 256-getHeaderPadding = skip headerPaddingLength-putHeaderPadding = putByteString $ B.replicate headerPaddingLength 0--getCookie = cookie <$> getByteString 8-putCookie (Cookie c) = putByteString c--getBlockSize = getWord32be-putBlockSize = putWord32be-getCheckSum = getWord32be-putCheckSum = putWord32be-getCurrentSize = getWord64be-putCurrentSize = putWord64be-getDataOffset = getWord64be-putDataOffset = putWord64be-getMaxTableEntries = getWord32be-putMaxTableEntries = putWord32be-getOriginalSize = getWord64be-putOriginalSize = putWord64be-getParentTimeStamp = getWord32be-putParentTimeStamp = putWord32be-getTableOffset = getWord64be-putTableOffset = putWord64be-getTimeStamp = getWord32be-putTimeStamp = putWord32be--getCreatorApplication = creatorApplication <$> getByteString 4-putCreatorApplication (CreatorApplication c) = putByteString c--getCreatorHostOs = convert <$> getWord32be where- convert 0x4D616320 = CreatorHostOsMacintosh- convert 0x5769326B = CreatorHostOsWindows- convert _ = CreatorHostOsUnknown-putCreatorHostOs v = putWord32be $ case v of- CreatorHostOsMacintosh -> 0x4D616320- CreatorHostOsWindows -> 0x5769326B- CreatorHostOsUnknown -> 0--getDiskType = convert <$> getWord32be where- convert 2 = DiskTypeFixed- convert 3 = DiskTypeDynamic- convert 4 = DiskTypeDifferencing- convert _ = error "invalid disk type"-putDiskType v = putWord32be $ case v of- DiskTypeFixed -> 2- DiskTypeDynamic -> 3- DiskTypeDifferencing -> 4--getDiskGeometry = DiskGeometry <$> getWord16be <*> getWord8 <*> getWord8-putDiskGeometry (DiskGeometry c h s) = putWord16be c >> putWord8 h >> putWord8 s--getIsTemporaryDisk = (\n -> n .&. 1 == 1) <$> getWord32be-putIsTemporaryDisk i = putWord32be ((if i then 1 else 0) .|. 0x2)--getIsSavedState = (== 1) <$> getWord8-putIsSavedState i = putWord8 (if i then 1 else 0)--getUniqueId = UniqueId <$> getByteString 16-putUniqueId (UniqueId i) = putByteString i--getParentUniqueId = getUniqueId-putParentUniqueId = putUniqueId--getVersion = Version <$> getWord16be <*> getWord16be-putVersion (Version major minor) = putWord16be major >> putWord16be minor--getCreatorVersion = getVersion-putCreatorVersion = putVersion-getFormatVersion = getVersion-putFormatVersion = putVersion--getParentUnicodeName = parentUnicodeName . demarshall <$> getByteString 512- where demarshall = takeWhile ((/=) '\0') . T.unpack . decodeUtf16BE-putParentUnicodeName (ParentUnicodeName c)- | blen > 512 = error "parent unicode name length is greater than 512"- | otherwise = putByteString b >> putByteString (B.replicate (512 - blen) 0)- where- b = encodeUtf16BE $ T.pack c- blen = B.length b--getParentLocatorEntry = parentLocatorEntry <$> getByteString 24-putParentLocatorEntry (ParentLocatorEntry e) = putByteString e--getParentLocatorEntries = parentLocatorEntries <$> replicateM 8 getParentLocatorEntry-putParentLocatorEntries (ParentLocatorEntries es) = mapM_ putParentLocatorEntry es
− Data/VHD/Types.hs
@@ -1,112 +0,0 @@-module Data.VHD.Types where--import Control.Exception-import Control.Monad-import qualified Data.ByteString as B-import Data.Word-import System.Random-import Text.Printf-import Data.List-import Data.Text.Encoding-import qualified Data.Text as T--data Header = Header- { headerCookie :: Cookie- , headerDataOffset :: Offset- , headerTableOffset :: Offset- , headerVersion :: Version- , headerMaxTableEntries :: EntryCount- , headerBlockSize :: BlockSize- , headerCheckSum :: CheckSum- , headerParentUniqueId :: UniqueId- , headerParentTimeStamp :: TimeStamp- , headerReserved1 :: B.ByteString- , headerParentUnicodeName :: ParentUnicodeName- , headerParentLocatorEntries :: ParentLocatorEntries- } deriving (Show,Eq)--data Footer = Footer- { footerCookie :: Cookie- , footerIsTemporaryDisk :: Bool- , footerFormatVersion :: Version- , footerDataOffset :: Offset- , footerTimeStamp :: TimeStamp- , footerCreatorApplication :: CreatorApplication- , footerCreatorVersion :: Version- , footerCreatorHostOs :: CreatorHostOs- , footerOriginalSize :: Size- , footerCurrentSize :: Size- , footerDiskGeometry :: DiskGeometry- , footerDiskType :: DiskType- , footerCheckSum :: CheckSum- , footerUniqueId :: UniqueId- , footerIsSavedState :: Bool- } deriving (Show,Eq)--data BatmapHeader = BatmapHeader- { batmapHeaderCookie :: Cookie- , batmapHeaderOffset :: Offset- , batmapHeaderSize :: Word32- , batmapHeaderVersion :: Version- , batmapHeaderCheckSum :: CheckSum- } deriving (Show,Eq)--type BlockSize = Word32-type DiskGeometryCylinders = Word16-type DiskGeometryHeads = Word8-type DiskGeometrySectorsPerTrack = Word8-type CheckSum = Word32-type EntryCount = Word32-type Offset = Word64-type Size = Word64-type TimeStamp = Word32--data Version = Version VersionMajor VersionMinor deriving (Show,Eq)-type VersionMajor = Word16-type VersionMinor = Word16--data CreatorHostOs- = CreatorHostOsUnknown- | CreatorHostOsWindows- | CreatorHostOsMacintosh deriving (Show,Eq)--data DiskGeometry = DiskGeometry- DiskGeometryCylinders- DiskGeometryHeads- DiskGeometrySectorsPerTrack deriving (Show,Eq)--data DiskType- = DiskTypeFixed- | DiskTypeDynamic- | DiskTypeDifferencing deriving (Show,Eq)--newtype Cookie = Cookie B.ByteString deriving (Show,Eq)-newtype CreatorApplication = CreatorApplication B.ByteString deriving (Show,Eq)-newtype ParentLocatorEntry = ParentLocatorEntry B.ByteString deriving (Show,Eq)-newtype ParentUnicodeName = ParentUnicodeName String deriving (Show,Eq)-newtype UniqueId = UniqueId B.ByteString deriving (Eq)--instance Show UniqueId where- show (UniqueId b) = intercalate "-" $ map disp [[0..3],[4,5],[6,7],[8,9],[10..15]]- where disp = concatMap (printf "%02x" . B.index b)--newtype ParentLocatorEntries = ParentLocatorEntries [ParentLocatorEntry] deriving (Show,Eq)--cookie c = assert (B.length c == 8) $ Cookie c-creatorApplication a = assert (B.length a == 4) $ CreatorApplication a-parentLocatorEntries e = assert ( length e == 8) $ ParentLocatorEntries e-parentLocatorEntry e = assert (B.length e == 24) $ ParentLocatorEntry e-uniqueId i = assert (B.length i == 16) $ UniqueId i--parentUnicodeName n- | encodedLength > 512 = error "parent unicode name length need to be < 512 bytes"- | otherwise = ParentUnicodeName n- where- encodedLength = B.length $ encodeUtf16BE $ T.pack n--randomUniqueId :: IO UniqueId-randomUniqueId- = liftM (uniqueId . B.pack)- $ replicateM 16- $ liftM fromIntegral- $ randomRIO (0 :: Int, 255)
− Data/VHD/Utils.hs
@@ -1,20 +0,0 @@-module Data.VHD.Utils- ( divRoundUp- , roundUpToModulo- , hAlign- ) where--import Control.Monad (unless)-import System.IO-import qualified Data.ByteString as B--divRoundUp a b = let (d,m) = a `divMod` b in d + if m > 0 then 1 else 0--roundUpToModulo n m- | n `mod` m == 0 = n- | otherwise = n + m - (n `mod` m)---- | align an handle to the next modulo-hAlign :: Handle -> Int -> IO ()-hAlign h n = hTell h >>= \i -> unless ((i `mod` fromIntegral n) == 0) (realign i)- where realign i = B.hPut h $ B.replicate (n - fromIntegral (i `mod` fromIntegral n)) 0
+ Data/Vhd.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Data.Vhd+ ( create+ , CreateParameters (..)+ , defaultCreateParameters+ , getInfo+ , snapshot+ , readData+ , readDataRange+ , writeDataRange+ , withVhd+ , module Data.Vhd.Types+ ) where++import Control.Applicative+import Control.Monad+import Data.BitSet+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Unsafe as B+import Data.Maybe+import Data.Serialize+import Data.Time.Clock.POSIX+import Data.Vhd.Bat+import Data.Vhd.Block hiding (readData, readDataRange, writeDataRange)+import qualified Data.Vhd.Block as Block+import Data.Vhd.Checksum+import Data.Vhd.Geometry+import Data.Vhd.Node+import Data.Vhd.Types+import Data.Vhd.Utils+import Data.Word+import Foreign.C.String+import Foreign.C.Types+import Foreign.Ptr+import Prelude hiding (subtract)+import System.FilePath.Posix+import System.IO++data Vhd = Vhd+ { vhdBlockCount :: VirtualBlockCount+ , vhdBlockSize :: BlockByteCount+ , vhdNodes :: [VhdNode]+ }++virtualSize :: Vhd -> VirtualByteCount+virtualSize vhd = fromIntegral (vhdBlockCount vhd) * fromIntegral (vhdBlockSize vhd)++withVhd :: FilePath -> (Vhd -> IO a) -> IO a+withVhd = withVhdInner [] where++ blockCount node = headerMaxTableEntries $ nodeHeader node+ blockSize node = headerBlockSize $ nodeHeader node+ diskType node = footerDiskType $ nodeFooter node++ withVhdInner accumulatedNodes filePath f =+ withVhdNode filePath $ \node ->+ if diskType node == DiskTypeDifferencing+ then withVhdInner (node : accumulatedNodes) (parentPath node) f+ else f $ Vhd+ -- TODO: require consistent block count and size across all nodes.+ { vhdBlockCount = blockCount node+ , vhdBlockSize = validateBlockSize $ blockSize node+ , vhdNodes = reverse $ node : accumulatedNodes+ }+ where parentPath node = resolveColocatedFilePath filePath p+ where ParentUnicodeName p = headerParentUnicodeName $ nodeHeader node++-- The VHD specification requires an unsigned 32-bit word to encode the+-- block size of a VHD.+--+-- However, this library provides:+-- a. operations to copy data from a block into a strict ByteString.+-- b. operations to copy data from a strict ByteString into a block.+--+-- Furthermore:+-- c. for all bytestrings b: (length of b) ≤ (maxBound :: Int).+-- d. for some systems: (maxBound :: Word32) > (maxBound :: Int).+--+-- This opens the (very remote) possibility of subtle bugs on attempting+-- to open a VHD with (block size) > (maxBound :: Int). Therefore, this+-- function fails fast on attempting to open such a VHD file.+--+validateBlockSize :: BlockByteCount -> BlockByteCount+validateBlockSize value =+ if integerValue > integerLimit+ then error+ ( "Cannot open VHD file with block size " +++ "greater than upper bound of platform integer." )+ else value+ where+ integerValue = fromIntegral (value ) :: Integer+ integerLimit = fromIntegral (maxBound :: Int) :: Integer++data CreateParameters = CreateParameters+ { createBlockSize :: BlockByteCount+ , createDiskType :: DiskType+ , createParentTimeStamp :: Maybe TimeStamp+ , createParentUnicodeName :: Maybe ParentUnicodeName+ , createParentUniqueId :: Maybe UniqueId+ , createTimeStamp :: Maybe TimeStamp+ , createUuid :: Maybe UniqueId+ , createUseBatmap :: Bool+ , createVirtualSize :: VirtualByteCount+ } deriving (Show, Eq)++defaultCreateParameters = CreateParameters+ { createBlockSize = 2 * 1024 * 1024+ , createDiskType = DiskTypeDynamic+ , createParentTimeStamp = Nothing+ , createParentUnicodeName = Nothing+ , createParentUniqueId = Nothing+ , createTimeStamp = Nothing+ , createUuid = Nothing+ , createUseBatmap = False+ , createVirtualSize = 0+ }++-- | Retrieves the header and footer from a VHD file.+getInfo :: FilePath -> IO (Either String (Header, Footer))+getInfo filePath = withFile filePath ReadMode $ \handle -> do+ footer <- decode <$> B.hGet handle 512+ header <- decode <$> B.hGet handle 1024+ case (footer, header) of+ (Left err, _) -> return $ Left err+ (_, Left err) -> return $ Left err+ (Right f, Right h) -> return $ Right (h, f)++-- | Creates an empty VHD file with the specified parameters.+create :: FilePath -> CreateParameters -> IO ()+create filePath createParams+ | createVirtualSize createParams == 0 = error "cannot create a 0-sized VHD"+ | otherwise = do+ nowUnixEpoch <- fromIntegral . fromEnum <$> getPOSIXTime+ let nowVhdEpoch = fromIntegral (nowUnixEpoch - y2k)+ uniqueid <- randomUniqueId+ create' filePath $ createParams+ { createTimeStamp = Just $ maybe nowVhdEpoch id $ createTimeStamp createParams+ , createUuid = Just $ maybe uniqueid id $ createUuid createParams+ }+ where+ y2k :: Word64+ y2k = 946684800 -- seconds from the unix epoch to the vhd epoch++create' :: FilePath -> CreateParameters -> IO ()+create' filePath createParams =++ withFile filePath WriteMode $ \handle -> do+ B.hPut handle $ encode footer+ B.hPut handle $ encode header+ hAlign handle (fromIntegral sectorLength)+ -- create a BAT with every entry initialized to 0xffffffff.+ B.hPut handle $ B.replicate (fromIntegral batSize) 0xff+ -- maybe create a batmap+ when (createUseBatmap createParams) $ do+ hAlign handle (fromIntegral sectorLength)+ headerPos <- hTell handle+ B.hPut handle $ encode $ BatmapHeader+ { batmapHeaderCookie = cookie "tdbatmap"+ , batmapHeaderOffset = fromIntegral (headerPos + fromIntegral sectorLength)+ , batmapHeaderSize = (maxTableEntries `div` 8) `divRoundUp` sectorLength+ , batmapHeaderVersion = Version 1 2+ , batmapHeaderChecksum = 0xffffffff+ }+ hAlign handle (fromIntegral sectorLength)+ B.hPut handle $ B.replicate (fromIntegral (maxTableEntries `div` 8)) 0x0+ hAlign handle (fromIntegral sectorLength)+ B.hPut handle $ encode footer++ where+ virtualSize = createVirtualSize createParams+ maxTableEntries = fromIntegral (virtualSize `divRoundUp` fromIntegral (createBlockSize createParams))+ batSize = (maxTableEntries * 4) `roundUpToModulo` sectorLength+ batPadSize = batSize - maxTableEntries * 4+ footerSize = 512+ headerSize = 1024++ footer = adjustFooterChecksum $ Footer+ { footerCookie = cookie "conectix"+ , footerIsTemporaryDisk = False+ , footerFormatVersion = Version 1 0+ , footerDataOffset = footerSize+ , footerTimeStamp = fromJust $ createTimeStamp createParams+ , footerCreatorApplication = creatorApplication "tap\0"+ , footerCreatorVersion = if createUseBatmap createParams then Version 1 3 else Version 1 0+ , footerCreatorHostOs = CreatorHostOsWindows+ , footerOriginalSize = virtualSize+ , footerCurrentSize = virtualSize+ , footerDiskGeometry = diskGeometry (virtualSize `div` fromIntegral sectorLength)+ , footerDiskType = createDiskType createParams+ , footerChecksum = 0+ , footerUniqueId = fromJust $ createUuid createParams+ , footerIsSavedState = False+ }++ header = adjustHeaderChecksum $ Header+ { headerCookie = cookie "cxsparse"+ , headerDataOffset = 0xffffffffffffffff+ , headerTableOffset = footerSize + headerSize+ , headerVersion = Version 1 0+ , headerMaxTableEntries = maxTableEntries+ , headerBlockSize = createBlockSize createParams+ , headerChecksum = 0+ , headerParentUniqueId = fromMaybe (uniqueId $ B.replicate 16 0) (createParentUniqueId createParams)+ , headerParentTimeStamp = fromMaybe 0 (createParentTimeStamp createParams)+ , headerReserved1 = B.replicate 4 0+ , headerParentUnicodeName = fromMaybe (parentUnicodeName "") (createParentUnicodeName createParams)+ , headerParentLocatorEntries = parentLocatorEntries $ replicate 8 (ParentLocatorEntry $ B.replicate 24 0)+ }++snapshot :: Vhd -> FilePath -> IO ()+snapshot parentVhd childFilePath = do+ create childFilePath $ CreateParameters+ { createBlockSize = vhdBlockSize parentVhd+ , createDiskType = DiskTypeDifferencing+ , createParentTimeStamp = Just $ footerTimeStamp headNodeFooter+ , createParentUniqueId = Just $ footerUniqueId headNodeFooter+ , createParentUnicodeName = Just $ parentUnicodeName parentFilePath+ , createTimeStamp = Nothing+ , createUuid = Nothing+ , createUseBatmap = hasBitmap headNodeBat+ , createVirtualSize = virtualSize parentVhd+ }+ where+ headNode = head $ vhdNodes parentVhd+ headNodeBat = nodeBat headNode+ headNodeFooter = nodeFooter headNode+ parentFilePath = makeRelative (takeDirectory childFilePath) (nodeFilePath headNode)++-- | Reads data from the whole virtual address space of the given VHD.+readData :: Vhd -> IO BL.ByteString+readData vhd = readDataRange vhd 0 (virtualSize vhd)++-- | Reads data from the given virtual address range of the given VHD.+readDataRange :: Vhd -> VirtualByteAddress -> VirtualByteCount -> IO BL.ByteString+readDataRange vhd offset length =+ if offset + length > virtualSize vhd+ then error "cannot read data past end of VHD."+ else fmap (trim . BL.fromChunks) (sequence blocks)+ where+ blocks = map (readDataBlock vhd) [blockFirst .. blockLast]+ blockFirst = fromIntegral $ (offset ) `div` blockSize+ blockLast = fromIntegral $ (offset + length - 1) `div` blockSize+ blockSize = fromIntegral $ vhdBlockSize vhd+ trim = BL.take toTake . BL.drop toDrop+ where+ toTake = fromIntegral $ length+ toDrop = fromIntegral $ offset `mod` blockSize++-- | Writes data to the given virtual address of the given VHD.+writeDataRange :: Vhd -> VirtualByteAddress -> BL.ByteString -> IO ()+writeDataRange vhd offset content = write (fromIntegral offset) content where++ write offset content+ | offset > offsetMax = error "cannot write data past end of VHD."+ | BL.null content = return ()+ | otherwise = do+ sectorOffset <- lookupOrCreateBlock node (fromIntegral blockNumber)+ withBlock file (fromIntegral blockSize) sectorOffset $ \block -> do+ Block.writeDataRange block (fromIntegral blockOffset) chunk+ write offsetNext contentNext+ where+ blockNumber = (fromIntegral $ offset `div` blockSize) :: VirtualBlockAddress+ blockOffset = offset `mod` blockSize+ chunk = B.concat $ BL.toChunks $ fst contentSplit+ chunkLength = fromIntegral $ blockSize - (offset `mod` blockSize)+ contentSplit = BL.splitAt chunkLength content+ contentNext = snd contentSplit+ offsetNext = ((offset `div` blockSize) * blockSize) + blockSize++ bat = nodeBat node+ file = nodeFilePath node+ node = head $ vhdNodes vhd+ offsetMax = virtualSize vhd+ blockSize = fromIntegral $ vhdBlockSize vhd++-- | Reads a block of data from the given virtual address of the given VHD.+readDataBlock :: Vhd -> VirtualBlockAddress -> IO B.ByteString+readDataBlock vhd blockNumber =+ B.create+ (fromIntegral $ blockSize)+ (unsafeReadDataBlock vhd blockNumber)+ where+ blockSize = vhdBlockSize vhd++-- | Reads a block of data from the given virtual address of the given VHD.+unsafeReadDataBlock :: Vhd -> VirtualBlockAddress -> Ptr Word8 -> IO ()+unsafeReadDataBlock vhd blockNumber resultPtr = buildResult where++ -- To do: modify this function so that it can read a sub-block.++ buildResult :: IO ()+ buildResult = do+ B.memset resultPtr 0 (fromIntegral blockSize)+ copySectorsFromNodes sectorsToRead =<< nodeOffsets++ blockSize = vhdBlockSize vhd++ sectorsToRead = fromRange 0 $ fromIntegral $ blockSize `div` sectorLength++ nodeOffsets :: IO [(VhdNode, PhysicalSectorAddress)]+ nodeOffsets = fmap catMaybes $ mapM maybeNodeOffset $ vhdNodes vhd where+ maybeNodeOffset node = (fmap . fmap) (node, ) $+ lookupBlock (nodeBat node) blockNumber++ copySectorsFromNodes :: BitSet -> [(VhdNode, PhysicalSectorAddress)] -> IO ()+ copySectorsFromNodes sectorsToCopy [] = return ()+ copySectorsFromNodes sectorsToCopy (nodeOffset : tail) =+ if Data.BitSet.isEmpty sectorsToCopy then return () else do+ sectorsMissing <- copySectorsFromNode sectorsToCopy nodeOffset+ copySectorsFromNodes sectorsMissing tail++ copySectorsFromNode :: BitSet -> (VhdNode, PhysicalSectorAddress) -> IO BitSet+ copySectorsFromNode sectorsRequested (node, sectorOffset) =+ withBlock (nodeFilePath node) blockSize sectorOffset $ \block -> do+ sectorsPresentByteString <- Block.readBitmap block+ let sectorsPresent = fromByteString sectorsPresentByteString+ let sectorsMissing = sectorsRequested `subtract` sectorsPresent+ let sectorsToCopy = sectorsRequested `intersect` sectorsPresent+ mapM_+ (\offset -> unsafeReadDataRange block offset+ (fromIntegral sectorLength)+ (resultPtr `plusPtr` (fromIntegral offset)))+ (map (byteOffsetOfSector . fromIntegral) $ toList sectorsToCopy)+ return sectorsMissing++ byteOffsetOfSector :: BlockSectorAddress -> BlockByteAddress+ byteOffsetOfSector = (*) $ fromIntegral sectorLength
+ Data/Vhd/Bat.hs view
@@ -0,0 +1,99 @@+module Data.Vhd.Bat+ ( Bat (..)+ , batGetSize+ , containsBlock+ , lookupBlock+ , unsafeLookupBlock+ , hasBitmap+ , batWrite+ , batMmap+ , batIterate+ , batUpdateChecksum+ ) where++import Control.Monad+import Data.Bits+import Data.Storable.Endian+import Data.Word+import Foreign.Ptr+import Foreign.Storable+import Data.Vhd.Bitmap+import Data.Vhd.Serialize+import Data.Vhd.Types+import Data.Vhd.Utils+import System.IO.MMap++data Bat = Bat BatStart BatEnd (Maybe Batmap)+type BatStart = Ptr PhysicalSectorAddress+type BatEnd = Ptr PhysicalSectorAddress+data Batmap = Batmap Bitmap Int++sectorLength = 512++emptyEntry = 0xffffffff++hasBitmap (Bat _ _ (Nothing)) = False+hasBitmap (Bat _ _ (Just bm)) = True++batmapSet :: VirtualBlockAddress -> Batmap -> IO ()+batmapSet n (Batmap bitmap _) = bitmapSet bitmap (fromIntegral n)++batmapChecksum :: Batmap -> IO Checksum+batmapChecksum (Batmap (Bitmap p) sz) = complement `fmap` foldM addByte 0 [0 .. (sz - 1)]+ where addByte acc i = (p `peekElemOff` i) >>= \w -> return (acc + fromIntegral w)++-- | Returns the padded size (in bytes) of the given BAT.+batGetSize :: Header -> Footer -> Int+batGetSize header footer = fromIntegral ((maxEntries * 4) `roundUpToModulo` sectorLength)+ where+ maxEntries = headerMaxTableEntries header++-- | Returns true if (and only if) the given BAT contains an entry for the+-- block at the given virtual address.+containsBlock :: Bat -> VirtualBlockAddress -> IO Bool+containsBlock = (fmap (/= emptyEntry) .) . unsafeLookupBlock++-- | Returns the physical sector address for the block at the given virtual+-- address, if (and only if) the given BAT contains an entry for that block.+lookupBlock :: Bat -> VirtualBlockAddress -> IO (Maybe PhysicalSectorAddress)+lookupBlock b n =+ fmap+ (\x -> if x == emptyEntry then Nothing else Just x)+ (unsafeLookupBlock b n)++-- | Returns the physical sector address for the block at the given virtual+-- address. The value returned is valid if (and only if) the specified BAT+-- contains an entry for that block.+unsafeLookupBlock :: Bat -> VirtualBlockAddress -> IO PhysicalSectorAddress+unsafeLookupBlock (Bat bptr _ _) n = peekBE ptr+ where ptr = bptr `plusPtr` ((fromIntegral n) * 4)++-- | Sets the physical sector address for the block at the given virtual+-- address, in the specified BAT.+batWrite :: Bat -> VirtualBlockAddress -> PhysicalSectorAddress -> IO ()+batWrite (Bat bptr _ bmap) n v = pokeBE ptr v >> maybe (return ()) (batmapSet n) bmap+ where ptr = bptr `plusPtr` ((fromIntegral n) * 4)++batMmap :: FilePath -> Header -> Footer -> Maybe BatmapHeader -> (Bat -> IO a) -> IO a+batMmap file header footer batmapHeader f =+ mmapWithFilePtr file ReadWrite (Just offsetSize) $ \(ptr, sz) ->+ let batmap = Batmap (Bitmap (castPtr (ptr `plusPtr` batmapOffset))) batmapSize in+ let batendPtr = ptr `plusPtr` batSize in+ f . Bat (castPtr ptr) batendPtr $ fmap (const batmap) batmapHeader+ where+ absoluteOffset = fromIntegral (headerTableOffset header)+ offsetSize = (absoluteOffset, fromIntegral (batSize + maybe 0 (const 512) batmapHeader + batmapSize))+ batmapOffset = batSize + fromIntegral sectorLength+ batSize = batGetSize header footer+ batmapSize = maybe 0 (fromIntegral . (* sectorLength) . batmapHeaderSize) batmapHeader++batIterate :: Bat -> VirtualBlockAddress -> (VirtualBlockAddress -> PhysicalSectorAddress -> IO ()) -> IO ()+batIterate bat nb f = forM_ [0 .. (nb - 1)] (\i -> unsafeLookupBlock bat i >>= \n -> f i n)++-- | Updates the checksum in the batmap, if the batmap exists.+batUpdateChecksum :: Bat -> IO ()+batUpdateChecksum (Bat _ _ Nothing) = return ()+batUpdateChecksum (Bat _ endptr (Just batmap)) = do+ let batmapChecksumPtr = endptr `plusPtr` (8+8+4+4)+ checksum <- batmapChecksum batmap+ pokeBE batmapChecksumPtr checksum
+ Data/Vhd/Bitmap.hs view
@@ -0,0 +1,38 @@+module Data.Vhd.Bitmap+ ( Bitmap (..)+ , bitmapGet+ , bitmapSet+ , bitmapSetRange+ , bitmapClear+ ) where++import Data.Bits+import Data.Word+import Foreign.Ptr+import Foreign.Storable++data Bitmap = Bitmap (Ptr Word8)++bitmapGet :: Bitmap -> Int -> IO Bool+bitmapGet (Bitmap ptr) n = test `fmap` peekByteOff ptr offset+ where+ test :: Word8 -> Bool+ test = flip testBit (7 - bit)+ (offset, bit) = n `divMod` 8++bitmapModify :: Bitmap -> Int -> (Int -> Word8 -> Word8) -> IO ()+bitmapModify (Bitmap bptr) n f = peek ptr >>= poke ptr . f (7 - bit)+ where+ ptr = bptr `plusPtr` offset+ (offset, bit) = n `divMod` 8++bitmapSet :: Bitmap -> Int -> IO ()+bitmapSet bitmap n = bitmapModify bitmap n (flip setBit)++bitmapSetRange :: Bitmap -> Int -> Int -> IO ()+bitmapSetRange bitmap start end+ | start < end = bitmapSet bitmap start >> bitmapSetRange bitmap (start + 1) end+ | otherwise = return ()++bitmapClear :: Bitmap -> Int -> IO ()+bitmapClear bitmap n = bitmapModify bitmap n (flip clearBit)
+ Data/Vhd/Block.hs view
@@ -0,0 +1,113 @@+module Data.Vhd.Block+ ( Block+ , Sector+ , bitmapSizeOfBlockSize+ , bitmapOfBlock+ , withBlock+ , readBitmap+ , readData+ , readDataRange+ , unsafeReadData+ , unsafeReadDataRange+ , writeDataRange+ , sectorLength+ ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Internal as B+import Data.Vhd.Bat+import Data.Vhd.Bitmap+import Data.Vhd.Types+import Data.Vhd.Utils+import Data.Word+import Foreign.Ptr+import Foreign.Storable+import System.IO.MMap++data Block = Block BlockByteCount (Ptr Word8)+data Sector = Sector (Ptr Word8)+data Data = Data (Ptr Word8)++sectorLength :: Word32+sectorLength = 512++-- | Finds the padded size (in bytes) of the bitmap for a given block.+bitmapSizeOfBlock :: Block -> Int+bitmapSizeOfBlock (Block blockSize _) = bitmapSizeOfBlockSize blockSize++-- | Finds the padded size (in bytes) of the bitmap for a given block size.+bitmapSizeOfBlockSize :: BlockByteCount -> Int+bitmapSizeOfBlockSize blockSize = fromIntegral ((nbSector `divRoundUp` 8) `roundUpToModulo` sectorLength)+ where nbSector = blockSize `divRoundUp` sectorLength++-- | Retrieves the bitmap for the given block.+bitmapOfBlock :: Block -> Bitmap+bitmapOfBlock (Block _ ptr) = Bitmap ptr++-- | Finds the size (in bytes) of data stored within the block.+blockSizeOfBlock :: Block -> BlockByteCount+blockSizeOfBlock (Block bs _) = bs++-- | Retrieves the data for the given block.+dataOfBlock :: Block -> Data+dataOfBlock (Block bs ptr) = Data $ ptr `plusPtr` (bitmapSizeOfBlockSize bs)++-- | Obtains a direct pointer to the given data.+pointerOfData :: Data -> Ptr Word8+pointerOfData (Data ptr) = ptr++-- | Maps into memory a block of the given size, at the given file path and sector address.+withBlock :: FilePath -> BlockByteCount -> PhysicalSectorAddress -> (Block -> IO a) -> IO a+withBlock file blockSize sectorOffset f =+ mmapWithFilePtr file ReadWrite (Just (offset, length)) $ \(ptr, sz) ->+ f (Block blockSize $ castPtr ptr)+ where+ offset = (fromIntegral sectorOffset) * (fromIntegral sectorLength)+ length = (fromIntegral blockSize) + (fromIntegral $ bitmapSizeOfBlockSize blockSize)++-- | Reads into memory the contents of the bitmap for the specified block.+readBitmap :: Block -> IO ByteString+readBitmap block =+ B.create (fromIntegral length) create where+ length = bitmapSizeOfBlock block+ create byteStringPtr = B.memcpy target source (fromIntegral length) where+ source = case bitmapOfBlock block of Bitmap b -> b+ target = castPtr byteStringPtr++-- | Reads all available data from the specified block.+readData :: Block -> IO ByteString+readData block =+ readDataRange block 0 (fromIntegral $ blockSizeOfBlock block)++-- | Reads a range of data from within the specified block.+readDataRange :: Block -> BlockByteAddress -> BlockByteCount -> IO ByteString+readDataRange block offset length =+ B.create (fromIntegral length) (unsafeReadDataRange block offset length)++-- | Unsafely reads all available data from the specified block.+unsafeReadData :: Block -> Ptr Word8 -> IO ()+unsafeReadData block =+ unsafeReadDataRange block 0 (fromIntegral $ blockSizeOfBlock block)++-- | Unsafely reads a range of data from within the specified block.+unsafeReadDataRange :: Block -> BlockByteAddress -> BlockByteCount -> Ptr Word8 -> IO ()+unsafeReadDataRange block offset length target =+ B.memcpy target source (fromIntegral length)+ where+ source = (pointerOfData $ dataOfBlock block) `plusPtr` (fromIntegral offset)++-- | Writes data to the given byte address of the specified block.+writeDataRange :: Block -> BlockByteAddress -> ByteString -> IO ()+writeDataRange block offset content = do+ -- sectors need to be prepared for differential disk if the bitmap was clear before,+ -- at the moment assumption is it's 0ed+ bitmapSetRange bitmap (fromIntegral sectorStart) (fromIntegral sectorEnd)+ B.unsafeUseAsCString content (\source -> B.memcpy target (castPtr source) length)+ where+ length = fromIntegral $ B.length content+ bitmap = bitmapOfBlock block+ target = (pointerOfData $ dataOfBlock block) `plusPtr` (fromIntegral offset)+ sectorStart = fromIntegral offset `div` sectorLength+ sectorEnd = fromIntegral (fromIntegral offset + B.length content) `div` sectorLength
+ Data/Vhd/Checksum.hs view
@@ -0,0 +1,41 @@+module Data.Vhd.Checksum+ ( adjustFooterChecksum+ , adjustHeaderChecksum+ , verifyFooterChecksum+ , verifyHeaderChecksum+ ) where++import Data.Bits+import qualified Data.ByteString as B+import Data.Serialize+import Data.Vhd.Serialize+import Data.Vhd.Types+import Data.Word++plus :: Checksum -> Word8 -> Checksum+plus a b = a + fromIntegral b++getHeaderChecksum :: Header -> Checksum+getHeaderChecksum header = complement $ B.foldl' plus 0 headerData+ where+ headerData = encode $ header { headerChecksum = 0 }++getFooterChecksum :: Footer -> Checksum+getFooterChecksum footer = complement $ B.foldl' plus 0 footerData+ where footerData = encode $ footer { footerChecksum = 0 }++adjustFooterChecksum :: Footer -> Footer+adjustFooterChecksum f = f { footerChecksum = checksum }+ where checksum = getFooterChecksum f++adjustHeaderChecksum :: Header -> Header+adjustHeaderChecksum h = h { headerChecksum = checksum }+ where checksum = getHeaderChecksum h++verifyFooterChecksum :: Footer -> Bool+verifyFooterChecksum f = footerChecksum f == checksum+ where checksum = getFooterChecksum f++verifyHeaderChecksum :: Header -> Bool+verifyHeaderChecksum h = headerChecksum h == checksum+ where checksum = getHeaderChecksum h
+ Data/Vhd/Geometry.hs view
@@ -0,0 +1,30 @@+module Data.Vhd.Geometry where++import Data.Vhd.Types+import Data.Word++-- | Calculates disk geometry using the algorithm presented in+-- | the virtual hard disk image format specification (v 1.0).+diskGeometry :: Word64 -> DiskGeometry+diskGeometry totalSectors' =+ let (sectorsPerTrack, heads, cylindersTimesHeads) = calculate in+ let cylinders = cylindersTimesHeads `div` heads in+ DiskGeometry+ (fromIntegral cylinders)+ (fromIntegral heads)+ (fromIntegral sectorsPerTrack)+ where+ totalSectors = min totalSectors' (65535 * 16 * 255)+ calculate+ | totalSectors > 65536 * 16 * 63 = (255, 16, totalSectors `div` 255)+ | otherwise =+ let sectorsPerTrack = 17 in+ let cylindersTimesHeads = totalSectors `div` 17 in+ let heads = max 4 $ (cylindersTimesHeads + 1023) `div` 1024 in+ let (sectorsPerTrack', heads', cylindersTimesHeads') =+ if cylindersTimesHeads >= heads * 1024 || heads > 16+ then (31, 16, totalSectors `div` 31)+ else (sectorsPerTrack, heads, cylindersTimesHeads) in+ if cylindersTimesHeads' >= heads' * 1024+ then (63, 16, totalSectors `div` 63)+ else (sectorsPerTrack', heads', cylindersTimesHeads')
+ Data/Vhd/Node.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Vhd.Node+ ( VhdNode (..)+ , containsBlock+ , lookupOrCreateBlock+ , withVhdNode+ ) where++import Control.Applicative ((<$>))+import Control.Monad+import qualified Data.ByteString as B+import Data.ByteString.Char8 ()+import Data.IORef+import Data.Serialize (decode, encode)+import Data.Vhd.Block+import qualified Data.Vhd.Bat as Bat+import Data.Vhd.Types+import Data.Vhd.Utils+import Data.Vhd.Serialize+import System.IO++data VhdNode = VhdNode+ { nodeBat :: Bat.Bat+ , nodeHeader :: Header+ , nodeFooter :: Footer+ , nodeHandle :: Handle+ , nodeFilePath :: FilePath+ , nodeModified :: IORef Bool+ }++withVhdNode :: FilePath -> (VhdNode -> IO a) -> IO a+withVhdNode filePath f = do+ withFile filePath ReadWriteMode $ \handle -> do+ footer <- either error id . decode <$> B.hGet handle 512+ header <- either error id . decode <$> B.hGet handle 1024+ mBatmapHdr <- if footerCreatorVersion footer == Version 1 3+ then do+ -- skip the BAT, and try reading the batmap header+ hSeek handle RelativeSeek (fromIntegral $ Bat.batGetSize header footer)+ batmapHdr <- decode <$> B.hGet handle 512+ case batmapHdr of+ Left _ -> return Nothing+ Right bHdr ->+ if batmapHeaderCookie bHdr == cookie "tdbatmap"+ then return $ Just bHdr+ else return Nothing+ else return Nothing+ Bat.batMmap filePath header footer mBatmapHdr $ \bat -> do+ bmodified <- newIORef False+ a <- f $ VhdNode+ { nodeBat = bat+ , nodeHeader = header+ , nodeFooter = footer+ , nodeHandle = handle+ , nodeFilePath = filePath+ , nodeModified = bmodified+ }+ modified <- readIORef bmodified+ when (modified) $ Bat.batUpdateChecksum bat+ return a++lookupOrCreateBlock :: VhdNode -> VirtualBlockAddress -> IO PhysicalSectorAddress+lookupOrCreateBlock node blockNumber = do+ unlessM (Bat.containsBlock (nodeBat node) blockNumber) $ appendEmptyBlock node blockNumber+ Bat.unsafeLookupBlock (nodeBat node) blockNumber++containsBlock :: VhdNode -> VirtualBlockAddress -> IO Bool+containsBlock node = Bat.containsBlock (nodeBat node)++-- | create empty block at the end+appendEmptyBlock :: VhdNode -> VirtualBlockAddress -> IO ()+appendEmptyBlock node n = do+ hSeek (nodeHandle node) SeekFromEnd 512+ x <- hTell (nodeHandle node)+ -- paranoid check+ let (sector, m) = x `divMod` 512+ unless (m == 0) $ error "wrong sector alignment"+ Bat.batWrite (nodeBat node) n (fromIntegral sector)+ modifyIORef (nodeModified node) (const True)+ B.hPut (nodeHandle node) (B.replicate fullSize 0)+ hAlign (nodeHandle node) (fromIntegral sectorLength)+ B.hPut (nodeHandle node) $ encode (nodeFooter node)+ where+ fullSize = bitmapSize + fromIntegral blockSize+ bitmapSize = bitmapSizeOfBlockSize blockSize+ blockSize = headerBlockSize $ nodeHeader node
+ Data/Vhd/Serialize.hs view
@@ -0,0 +1,184 @@+module Data.Vhd.Serialize where++import Control.Applicative+import Control.Exception+import Control.Monad+import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Serialize+import Data.Serialize.Get+import Data.Serialize.Put+import qualified Data.Text as T+import Data.Text.Encoding+import Data.Vhd.Types++instance Serialize Header where+ get = Header+ <$> getCookie+ <*> getDataOffset+ <*> getTableOffset+ <*> getVersion+ <*> getMaxTableEntries+ <*> getBlockSize+ <*> getChecksum+ <*> getParentUniqueId+ <*> getParentTimeStamp+ <*> getByteString 4+ <*> getParentUnicodeName+ <*> getParentLocatorEntries+ <* getHeaderPadding+ put h = do+ putCookie $ headerCookie h+ putDataOffset $ headerDataOffset h+ putTableOffset $ headerTableOffset h+ putVersion $ headerVersion h+ putMaxTableEntries $ headerMaxTableEntries h+ putBlockSize $ headerBlockSize h+ putChecksum $ headerChecksum h+ putParentUniqueId $ headerParentUniqueId h+ putParentTimeStamp $ headerParentTimeStamp h+ putByteString $ headerReserved1 h+ putParentUnicodeName $ headerParentUnicodeName h+ putParentLocatorEntries $ headerParentLocatorEntries h+ putHeaderPadding++instance Serialize Footer where+ get = Footer+ <$> getCookie+ <*> getIsTemporaryDisk+ <*> getFormatVersion+ <*> getDataOffset+ <*> getTimeStamp+ <*> getCreatorApplication+ <*> getCreatorVersion+ <*> getCreatorHostOs+ <*> getOriginalSize+ <*> getCurrentSize+ <*> getDiskGeometry+ <*> getDiskType+ <*> getChecksum+ <*> getUniqueId+ <*> getIsSavedState+ <* getFooterPadding+ put f = do+ putCookie $ footerCookie f+ putIsTemporaryDisk $ footerIsTemporaryDisk f+ putFormatVersion $ footerFormatVersion f+ putDataOffset $ footerDataOffset f+ putTimeStamp $ footerTimeStamp f+ putCreatorApplication $ footerCreatorApplication f+ putCreatorVersion $ footerCreatorVersion f+ putCreatorHostOs $ footerCreatorHostOs f+ putOriginalSize $ footerOriginalSize f+ putCurrentSize $ footerCurrentSize f+ putDiskGeometry $ footerDiskGeometry f+ putDiskType $ footerDiskType f+ putChecksum $ footerChecksum f+ putUniqueId $ footerUniqueId f+ putIsSavedState $ footerIsSavedState f+ putFooterPadding++instance Serialize BatmapHeader where+ get = BatmapHeader+ <$> getCookie+ <*> getDataOffset+ <*> getWord32be+ <*> getVersion+ <*> getChecksum+ put b = do+ putCookie $ batmapHeaderCookie b+ putDataOffset $ batmapHeaderOffset b+ putWord32be $ batmapHeaderSize b+ putVersion $ batmapHeaderVersion b+ putChecksum $ batmapHeaderChecksum b++footerPaddingLength = 427+getFooterPadding = getByteString footerPaddingLength+putFooterPadding = putByteString $ B.replicate footerPaddingLength 0++headerPaddingLength = 256+getHeaderPadding = skip headerPaddingLength+putHeaderPadding = putByteString $ B.replicate headerPaddingLength 0++getCookie = cookie <$> getByteString 8+putCookie (Cookie c) = putByteString c++getBlockSize = getWord32be+putBlockSize = putWord32be+getChecksum = getWord32be+putChecksum = putWord32be+getCurrentSize = getWord64be+putCurrentSize = putWord64be+getDataOffset = getWord64be+putDataOffset = putWord64be+getMaxTableEntries = getWord32be+putMaxTableEntries = putWord32be+getOriginalSize = getWord64be+putOriginalSize = putWord64be+getParentTimeStamp = getWord32be+putParentTimeStamp = putWord32be+getTableOffset = getWord64be+putTableOffset = putWord64be+getTimeStamp = getWord32be+putTimeStamp = putWord32be++getCreatorApplication = creatorApplication <$> getByteString 4+putCreatorApplication (CreatorApplication c) = putByteString c++getCreatorHostOs = convert <$> getWord32be where+ convert 0x4D616320 = CreatorHostOsMacintosh+ convert 0x5769326B = CreatorHostOsWindows+ convert _ = CreatorHostOsUnknown+putCreatorHostOs v = putWord32be $ case v of+ CreatorHostOsMacintosh -> 0x4D616320+ CreatorHostOsWindows -> 0x5769326B+ CreatorHostOsUnknown -> 0++getDiskType = convert <$> getWord32be where+ convert 2 = DiskTypeFixed+ convert 3 = DiskTypeDynamic+ convert 4 = DiskTypeDifferencing+ convert _ = error "invalid disk type"+putDiskType v = putWord32be $ case v of+ DiskTypeFixed -> 2+ DiskTypeDynamic -> 3+ DiskTypeDifferencing -> 4++getDiskGeometry = DiskGeometry <$> getWord16be <*> getWord8 <*> getWord8+putDiskGeometry (DiskGeometry c h s) = putWord16be c >> putWord8 h >> putWord8 s++getIsTemporaryDisk = (\n -> n .&. 1 == 1) <$> getWord32be+putIsTemporaryDisk i = putWord32be ((if i then 1 else 0) .|. 0x2)++getIsSavedState = (== 1) <$> getWord8+putIsSavedState i = putWord8 (if i then 1 else 0)++getUniqueId = UniqueId <$> getByteString 16+putUniqueId (UniqueId i) = putByteString i++getParentUniqueId = getUniqueId+putParentUniqueId = putUniqueId++getVersion = Version <$> getWord16be <*> getWord16be+putVersion (Version major minor) = putWord16be major >> putWord16be minor++getCreatorVersion = getVersion+putCreatorVersion = putVersion+getFormatVersion = getVersion+putFormatVersion = putVersion++getParentUnicodeName = parentUnicodeName . demarshall <$> getByteString 512+ where demarshall = takeWhile ((/=) '\0') . T.unpack . decodeUtf16BE+putParentUnicodeName (ParentUnicodeName c)+ | blen > 512 = error "parent unicode name length is greater than 512"+ | otherwise = putByteString b >> putByteString (B.replicate (512 - blen) 0)+ where+ b = encodeUtf16BE $ T.pack c+ blen = B.length b++getParentLocatorEntry = parentLocatorEntry <$> getByteString 24+putParentLocatorEntry (ParentLocatorEntry e) = putByteString e++getParentLocatorEntries = parentLocatorEntries <$> replicateM 8 getParentLocatorEntry+putParentLocatorEntries (ParentLocatorEntries es) = mapM_ putParentLocatorEntry es
+ Data/Vhd/Types.hs view
@@ -0,0 +1,122 @@+module Data.Vhd.Types where++import Control.Exception+import Control.Monad+import qualified Data.ByteString as B+import Data.List+import qualified Data.Text as T+import Data.Text.Encoding+import Data.Word+import System.Random+import Text.Printf++data Header = Header+ { headerCookie :: Cookie+ , headerDataOffset :: PhysicalByteAddress+ , headerTableOffset :: PhysicalByteAddress+ , headerVersion :: Version+ , headerMaxTableEntries :: VirtualBlockCount+ , headerBlockSize :: BlockByteCount+ , headerChecksum :: Checksum+ , headerParentUniqueId :: UniqueId+ , headerParentTimeStamp :: TimeStamp+ , headerReserved1 :: B.ByteString+ , headerParentUnicodeName :: ParentUnicodeName+ , headerParentLocatorEntries :: ParentLocatorEntries+ } deriving (Show, Eq)++data Footer = Footer+ { footerCookie :: Cookie+ , footerIsTemporaryDisk :: Bool+ , footerFormatVersion :: Version+ , footerDataOffset :: PhysicalByteAddress+ , footerTimeStamp :: TimeStamp+ , footerCreatorApplication :: CreatorApplication+ , footerCreatorVersion :: Version+ , footerCreatorHostOs :: CreatorHostOs+ , footerOriginalSize :: VirtualByteCount+ , footerCurrentSize :: VirtualByteCount+ , footerDiskGeometry :: DiskGeometry+ , footerDiskType :: DiskType+ , footerChecksum :: Checksum+ , footerUniqueId :: UniqueId+ , footerIsSavedState :: Bool+ } deriving (Show, Eq)++data BatmapHeader = BatmapHeader+ { batmapHeaderCookie :: Cookie+ , batmapHeaderOffset :: PhysicalByteAddress+ , batmapHeaderSize :: Word32+ , batmapHeaderVersion :: Version+ , batmapHeaderChecksum :: Checksum+ } deriving (Show, Eq)++type BlockByteAddress = Word32+type BlockByteCount = Word32+type BlockSectorAddress = Word32+type BlockSectorCount = Word32+type DiskGeometryCylinders = Word16+type DiskGeometryHeads = Word8+type DiskGeometrySectorsPerTrack = Word8+type Checksum = Word32+type PhysicalByteAddress = Word64+type PhysicalByteCount = Word64+type PhysicalSectorAddress = Word32+type PhysicalSectorCount = Word32+type TimeStamp = Word32+type VirtualBlockAddress = Word32+type VirtualBlockCount = Word32+type VirtualByteAddress = Word64+type VirtualByteCount = Word64+type VirtualSectorAddress = Word32+type VirtualSectorCount = Word32++data Version = Version VersionMajor VersionMinor deriving (Show, Eq)+type VersionMajor = Word16+type VersionMinor = Word16++data CreatorHostOs+ = CreatorHostOsUnknown+ | CreatorHostOsWindows+ | CreatorHostOsMacintosh deriving (Show, Eq)++data DiskGeometry = DiskGeometry+ DiskGeometryCylinders+ DiskGeometryHeads+ DiskGeometrySectorsPerTrack deriving (Show, Eq)++data DiskType+ = DiskTypeFixed+ | DiskTypeDynamic+ | DiskTypeDifferencing deriving (Show, Eq)++newtype Cookie = Cookie B.ByteString deriving (Show, Eq)+newtype CreatorApplication = CreatorApplication B.ByteString deriving (Show, Eq)+newtype ParentLocatorEntry = ParentLocatorEntry B.ByteString deriving (Show, Eq)+newtype ParentUnicodeName = ParentUnicodeName String deriving (Show, Eq)+newtype UniqueId = UniqueId B.ByteString deriving (Eq)++instance Show UniqueId where+ show (UniqueId b) = intercalate "-" $ map disp [[0 .. 3], [4, 5], [6, 7], [8, 9], [10 .. 15]]+ where disp = concatMap (printf "%02x" . B.index b)++newtype ParentLocatorEntries = ParentLocatorEntries [ParentLocatorEntry] deriving (Show, Eq)++cookie c = assert (B.length c == 8) $ Cookie c+creatorApplication a = assert (B.length a == 4) $ CreatorApplication a+parentLocatorEntries e = assert ( length e == 8) $ ParentLocatorEntries e+parentLocatorEntry e = assert (B.length e == 24) $ ParentLocatorEntry e+uniqueId i = assert (B.length i == 16) $ UniqueId i++parentUnicodeName n+ | encodedLength > 512 = error "parent unicode name length must be <= 512 bytes"+ | otherwise = ParentUnicodeName n+ where+ encodedLength = B.length $ encodeUtf16BE $ T.pack n++randomUniqueId :: IO UniqueId+randomUniqueId+ = liftM (uniqueId . B.pack)+ $ replicateM 16+ $ liftM fromIntegral+ $ randomRIO (0 :: Int, 255)
+ Data/Vhd/Utils.hs view
@@ -0,0 +1,34 @@+module Data.Vhd.Utils+ ( divRoundUp+ , resolveColocatedFilePath+ , roundUpToModulo+ , hAlign+ , unlessM+ ) where++import Control.Monad (unless)+import qualified Data.ByteString as B+import System.FilePath.Posix+import System.IO++divRoundUp a b = let (d, m) = a `divMod` b in d + if m > 0 then 1 else 0++resolveColocatedFilePath :: FilePath -> FilePath -> FilePath+resolveColocatedFilePath baseFilePath colocatedFilePath =+ if isAbsolute colocatedFilePath+ then colocatedFilePath+ else takeDirectory baseFilePath </> colocatedFilePath++roundUpToModulo n m+ | n `mod` m == 0 = n+ | otherwise = n + m - (n `mod` m)++-- | align an handle to the next modulo+hAlign :: Handle -> Int -> IO ()+hAlign h n = hTell h >>= \i -> unless ((i `mod` fromIntegral n) == 0) (realign i)+ where realign i = B.hPut h $ B.replicate (n - fromIntegral (i `mod` fromIntegral n)) 0++unlessM condition elseBranch = do+ c <- condition+ unless c elseBranch+
README view
@@ -1,1 +1,1 @@-A library for inspecting and manipulating virtual hard disk (VHD) files.+Provides functions to inspect and manipulate virtual hard disk (VHD) files, according to the VHD specification (version 1.0).
Tests.hs view
@@ -1,14 +1,14 @@ import Test.QuickCheck-import Test.Framework(defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2(testProperty)+import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty) import Control.Applicative import Control.Monad import qualified Data.ByteString as B import Data.Serialize-import Data.VHD.Types-import Data.VHD.Serialize+import Data.Vhd.Types+import Data.Vhd.Serialize instance Arbitrary Version where arbitrary = Version <$> arbitrary <*> arbitrary
Vhd.hs view
@@ -1,106 +1,103 @@-import Data.VHD-import Data.VHD.Types-import Data.VHD.Block-import Data.VHD.Context-import Data.VHD.Bat-import Data.VHD.CheckSum+import Control.Monad+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Char+import Data.IORef+import Data.Vhd+import Data.Vhd.Bat+import qualified Data.Vhd.Block as Block+import Data.Vhd.Checksum+import Data.Vhd.Node+import Data.Vhd.Types import System.Environment (getArgs) import System.IO import Text.Printf-import Control.Monad-import Data.Char -import Data.IORef+cmdConvert [fileRaw, fileVhd, size] = convert =<< rawSizeBytes where+ vhdSizeMiB = read size+ vhdSizeBytes = vhdSizeMiB * 1024 * 1024+ rawSizeBytes = fmap fromIntegral $ withFile fileRaw ReadMode hFileSize+ convert rawSizeBytes+ | vhdSizeMiB `mod` 2 /= 0 = error+ "specified VHD size is not a multiple of 2 MiB."+ | vhdSizeBytes < rawSizeBytes = error+ "specified VHD size is not large enough to contain raw data."+ | otherwise = do+ create fileVhd $ defaultCreateParameters+ { createVirtualSize = vhdSizeBytes }+ withVhd fileVhd $ \vhd -> BL.readFile fileRaw >>= writeDataRange vhd 0+cmdConvert _ = error "usage: convert <raw file> <vhd file> <size MiB>" -import qualified Data.ByteString as B+cmdCreate [name, size] =+ create name $ defaultCreateParameters+ { createVirtualSize = read size * 1024 * 1024 }+cmdCreate _ = error "usage: create <name> <size MiB>" -showBlockSize i- | i < 1024 = printf "%d bytes" i- | i < (1024^2) = printf "%d kilobytes" (i`div`1024)- | i < (1024^3) = printf "%d megabytes" (i`div`(1024^2))- | otherwise = printf "%d gigabytes" (i`div`(1024^3))+cmdExtract [fileVhd, fileRaw] = withVhd fileVhd $ readData >=> BL.writeFile fileRaw+cmdExtract _ = error "usage: extract <vhd file> <raw file>" -cmdCreate [name,size] = create name $ defaultCreateParameters { size = (read size) * 1024 * 1024, useBatmap = True }-cmdCreate _ = error "usage: create <name> <size Mb>"+cmdPropGet [file, key] = withVhdNode file $ \node -> do+ case map toLower key of+ "max-table-entries" -> putStrLn $ show $ headerMaxTableEntries $ nodeHeader node+ "blocksize" -> putStrLn $ show $ headerBlockSize $ nodeHeader node+ "disk-type" -> putStrLn $ show $ footerDiskType $ nodeFooter node+ "current-size" -> putStrLn $ show $ footerCurrentSize $ nodeFooter node+ "uuid" -> putStrLn $ show $ footerUniqueId $ nodeFooter node+ "parent-uuid" -> putStrLn $ show $ headerParentUniqueId $ nodeHeader node+ "parent-timestamp" -> putStrLn $ show $ headerParentTimeStamp $ nodeHeader node+ "parent-filepath" -> putStrLn $ show $ headerParentUnicodeName $ nodeHeader node+ "timestamp" -> putStrLn $ show $ footerTimeStamp $ nodeFooter node+ _ -> error "unknown key"+cmdPropGet _ = error "usage: prop-get <file> <key>" -cmdRead [file] = withVhdContext file $ \ctx -> do- let hdr = ctxHeader ctx- let ftr = ctxFooter ctx- mapM_ (\(f,s) -> putStrLn (f ++ " : " ++ s))+cmdRead [file] = withVhdNode file $ \node -> do+ let hdr = nodeHeader node+ let ftr = nodeFooter node+ mapM_ (\(f, s) -> putStrLn (f ++ " : " ++ s)) [ ("cookie ", show $ headerCookie hdr) , ("version ", show $ headerVersion hdr) , ("max-table-entries", show $ headerMaxTableEntries hdr) , ("block-size ", showBlockSize $ headerBlockSize hdr)- , ("header-checksum ", printf "%08x (%s)" (headerCheckSum hdr)- (if verifyHeaderChecksum hdr then "valid" else "invalid"))+ , ("header-checksum ", showChecksum (headerChecksum hdr) (verifyHeaderChecksum hdr)) , ("parent-uuid ", show $ headerParentUniqueId hdr) , ("parent-filepath ", show $ headerParentUnicodeName hdr) , ("parent-timestamp ", show $ headerParentTimeStamp hdr) ]- mapM_ (\(f,s) -> putStrLn (f ++ " : " ++ s))+ mapM_ (\(f, s) -> putStrLn (f ++ " : " ++ s)) [ ("disk-geometry ", show $ footerDiskGeometry ftr) , ("original-size ", showBlockSize $ footerOriginalSize ftr) , ("current-size ", showBlockSize $ footerOriginalSize ftr) , ("type ", show $ footerDiskType ftr)- , ("footer-checksum ", printf "%08x (%s)" (footerCheckSum ftr)- (if verifyFooterChecksum ftr then "valid" else "invalid"))+ , ("footer-checksum ", showChecksum (footerChecksum ftr) (verifyFooterChecksum ftr)) , ("uuid ", show $ footerUniqueId ftr) , ("timestamp ", show $ footerTimeStamp ftr) ] allocated <- newIORef 0- batIterate (ctxBatPtr ctx) (fromIntegral $ headerMaxTableEntries hdr) $ \i n -> do+ batIterate (nodeBat node) (fromIntegral $ headerMaxTableEntries hdr) $ \i n -> do unless (n == 0xffffffff) $ modifyIORef allocated ((+) 1) >> printf "BAT[%.5x] = %08x\n" i n nb <- readIORef allocated- putStrLn ("block allocated : " ++ show nb ++ "/" ++ show (headerMaxTableEntries hdr))+ putStrLn ("blocks allocated : " ++ show nb ++ "/" ++ show (headerMaxTableEntries hdr)) cmdRead _ = error "usage: read <file>" -cmdPropGet [file, key] = withVhdContext file $ \ctx -> do- case map toLower key of- "max-table-entries" -> putStrLn $ show $ headerMaxTableEntries $ ctxHeader ctx- "blocksize" -> putStrLn $ show $ headerBlockSize $ ctxHeader ctx- "disk-type" -> putStrLn $ show $ footerDiskType $ ctxFooter ctx- "current-size" -> putStrLn $ show $ footerCurrentSize $ ctxFooter ctx- "uuid" -> putStrLn $ show $ footerUniqueId $ ctxFooter ctx- "parent-uuid" -> putStrLn $ show $ headerParentUniqueId $ ctxHeader ctx- "parent-timestamp" -> putStrLn $ show $ headerParentTimeStamp $ ctxHeader ctx- "parent-filepath" -> putStrLn $ show $ headerParentUnicodeName $ ctxHeader ctx- "timestamp" -> putStrLn $ show $ footerTimeStamp $ ctxFooter ctx- _ -> error "unknown key"-cmdPropGet _ = error "usage: prop-get <file> <key>"--cmdConvert [fileRaw,fileVhd,size] = do- create fileVhd $ defaultCreateParameters- { size = read size * 1024 * 1024- , useBatmap = True- }- withVhdContext fileVhd $ \ctx -> do- withFile fileRaw ReadMode $ \handle -> do- loop ctx handle 0- where- loop ctx handle offset = do- srcblock <- B.hGet handle (fromIntegral blockSize)- if B.null srcblock- then return ()- else do- unless (isBlockZero srcblock) $ do- let blockNb = offset `div` fromIntegral blockSize- extendBlock ctx blockNb- sectorOff <- batRead (ctxBatPtr ctx) blockNb- withBlock (ctxFilePath ctx) (headerBlockSize $ ctxHeader ctx) sectorOff $ \block ->- writeBlock block srcblock 0- putStrLn ("block " ++ show (offset `div` fromIntegral blockSize) ++ " written")- -- do something with block- loop ctx handle (offset + fromIntegral (B.length srcblock))+cmdSnapshot [fileVhdParent, fileVhdChild] =+ withVhd fileVhdParent $ \vhdParent -> snapshot vhdParent fileVhdChild+cmdSnapshot _ = error "usage: snapshot <parent vhd file> <child vhd file>" +showBlockSize i+ | i < 1024 = printf "%d bytes" i+ | i < (1024^2) = printf "%d KiB" (i `div` 1024)+ | i < (1024^3) = printf "%d MiB" (i `div` (1024^2))+ | otherwise = printf "%d GiB" (i `div` (1024^3)) - isBlockZero = B.all ((==) 0)- blockSize = 2 * 1024 * 1024-cmdConvert _ = error "usage: convert <raw file> <vhd file> <size Mb>"+showChecksum checksum isValid =+ printf "%08x (%s)" checksum (if isValid then "valid" else "invalid") main = do args <- getArgs case args of- "create":xs -> cmdCreate xs- "read":xs -> cmdRead xs- "convert":xs -> cmdConvert xs- "prop-get":xs -> cmdPropGet xs+ "convert" : xs -> cmdConvert xs+ "create" : xs -> cmdCreate xs+ "extract" : xs -> cmdExtract xs+ "prop-get" : xs -> cmdPropGet xs+ "read" : xs -> cmdRead xs+ "snapshot" : xs -> cmdSnapshot xs
vhd.cabal view
@@ -1,7 +1,7 @@ Name: vhd-Version: 0.1-Synopsis: Implementation of the Virtual Hard Disk (VHD) disk format-Description: Provide a toolbox of function to manipulate VHD files.+Version: 0.2+Synopsis: Provides functions to inspect and manipulate virtual hard disk (VHD) files.+Description: Provides functions to inspect and manipulate virtual hard disk (VHD) files, according to the VHD specification (version 1.0). Author: Jonathan Knowles, Vincent Hanquez Maintainer: jonathan.knowles@eu.citrix.com Copyright: Citrix Systems Inc.@@ -15,7 +15,7 @@ Data-files: README Flag test- Description: Build unit test+ Description: Build unit tests Default: False Flag executable@@ -25,22 +25,25 @@ Library Build-depends: base >= 4 && < 5 , bytestring+ , filepath , mmap , text , time , cereal , random , storable-endian- Exposed-modules: Data.VHD- Other-modules: Data.VHD.Bat- Data.VHD.Bitmap- Data.VHD.Block- Data.VHD.CheckSum- Data.VHD.Context- Data.VHD.Geometry- Data.VHD.Serialize- Data.VHD.Types- Data.VHD.Utils+ Exposed-modules: Data.Vhd+ Other-modules: Data.BitSet+ Data.Range+ Data.Vhd.Bat+ Data.Vhd.Bitmap+ Data.Vhd.Block+ Data.Vhd.Checksum+ Data.Vhd.Node+ Data.Vhd.Geometry+ Data.Vhd.Serialize+ Data.Vhd.Types+ Data.Vhd.Utils Executable Tests Main-Is: Tests.hs