packages feed

vhd 0.2 → 0.2.1

raw patch · 24 files changed

+1754/−997 lines, 24 filesdep +byteabledep +cipher-aesdep +cryptohashdep ~QuickCheckdep ~basedep ~test-framework

Dependencies added: byteable, cipher-aes, cryptohash, directory, vhd

Dependency ranges changed: QuickCheck, base, test-framework, test-framework-quickcheck2

Files

Data/BitSet.hs view
@@ -1,100 +1,104 @@ module Data.BitSet-	( BitSet-	, empty-	, fromByteString-	, fromRange-	, toList-	, isEmpty-	, intersect-	, union-	, subtract-	)-	where+    ( 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+data BitSet a = BitSet B.ByteString -instance Eq BitSet-	where (BitSet b1) == (BitSet b2) = b1' == b2'-		where (b1', b2') = byteStringsPad b1 b2+instance Eq (BitSet a) where+    (BitSet b1) == (BitSet b2) = b1' == b2'+        where (b1', b2') = byteStringsPad b1 b2 -instance Show BitSet where show = show . toList+instance Show a => Show (BitSet a) where+    show = show . toList -empty :: BitSet+empty :: Num a => BitSet a empty = BitSet B.empty -fromByteString :: B.ByteString -> BitSet+fromByteString :: Num a => B.ByteString -> BitSet a fromByteString = BitSet -fromRange :: Int -> Int -> BitSet+fromRange :: Int -> Int -> BitSet a 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]+    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]+        | otherwise                    = error "cannot happen" -	(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)+    (loByteFloor, loBit) = lo `divMod` 8+    (hiByteFloor, hiBit) = hi `divMod` 8+    loByteCeiling = (lo + 7) `div` 8+    --hiByteCeiling = (hi + 7) `div` 8 -	clearBytes = B.replicate (loByteFloor                ) 0x00-	setBytes   = B.replicate (hiByteFloor - loByteCeiling) 0xff+    clearBytes = B.replicate (fromIntegral loByteFloor) 0x00+    setBytes   = B.replicate (fromIntegral (hiByteFloor - loByteCeiling)) 0xff -	riseByte = B.singleton $ setBits 0 loBit     8-	fallByte = B.singleton $ setBits 0     0 hiBit-	humpByte = B.singleton $ setBits 0 loBit hiBit+    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 ..]+toList :: BitSet a -> [Int]+toList (BitSet b) = map snd $ filter fst $ zip (byteStringBits b) [0..] -isEmpty :: BitSet -> Bool+isEmpty :: BitSet a -> Bool isEmpty (BitSet b) = B.all (== 0) b -intersect :: BitSet -> BitSet -> BitSet-union     :: BitSet -> BitSet -> BitSet-subtract  :: BitSet -> BitSet -> BitSet+intersect :: BitSet a -> BitSet a -> BitSet a+union     :: BitSet a -> BitSet a -> BitSet a+subtract  :: BitSet a -> BitSet a -> BitSet a  intersect = binaryOp (.&.) union     = binaryOp (.|.) subtract  = binaryOp (\x y -> x .&. complement y) +binaryOp :: (Word8 -> Word8 -> Word8) -> BitSet a -> BitSet b -> BitSet c binaryOp f (BitSet b1) (BitSet b2) =-	BitSet $ byteStringPackZipWith f b1' b2'-	where (b1', b2') = byteStringsPad b1 b2+    BitSet $ byteStringPackZipWith f b1' b2'+  where (b1', b2') = byteStringsPad b1 b2 +byteStringBits :: B.ByteString -> [Bool] byteStringBits byteString = do-	word <- B.unpack byteString-	bit <- word8Bits word-	return bit+    word <- B.unpack byteString+    word8Bits word  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+    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+setBits acc loBit hiBit+    | loBit < hiBit = setBits (setBit acc loBit) (loBit + 1) hiBit+    | otherwise     = acc  word8Bits :: Word8 -> [Bool] word8Bits w = map (testBit w) [0 .. 7]
Data/Range.hs view
@@ -3,16 +3,15 @@ {-# LANGUAGE TypeSynonymInstances   #-}  module Data.Range-	( Range-	, RangeLength-	, range-	, length-	, minimum-	, maximum-	) where+    ( 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
Data/Vhd.hs view
@@ -2,72 +2,87 @@ {-# LANGUAGE TupleSections     #-}  module Data.Vhd-	( create-	, CreateParameters (..)-	, defaultCreateParameters-	, getInfo-	, snapshot-	, readData-	, readDataRange-	, writeDataRange-	, withVhd-	, module Data.Vhd.Types-	) where+    ( create+    , CreateParameters (..)+    , defaultCreateParameters+    , getInfo+    , snapshot+    , readData+    , readDataRange+    , writeDataRange+    , withVhd+    , module Data.Vhd.Types+    , module Data.Vhd.Header+    , module Data.Vhd.Checksum+    , module Data.Vhd.Footer+    , module Data.Vhd.UniqueId+    ) where  import Control.Applicative import Control.Monad-import Data.BitSet+import Data.BitSet as 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.Monoid (mempty) import Data.Vhd.Bat-import Data.Vhd.Block hiding (readData, readDataRange, writeDataRange)+import Data.Vhd.Block (Block, BlockDataMapper) 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.Header+import Data.Vhd.Footer+import Data.Vhd.UniqueId import Data.Vhd.Utils+import Data.Vhd.Time+import Data.Vhd.Const+import Data.Vhd.Batmap 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]-	}+    { vhdBlockCount :: VirtualBlockCount+    , vhdBlockSize  :: BlockSize+    , vhdNodes      :: [VhdNode]+    } +vhdSectorPerBlock :: Vhd -> Word32+vhdSectorPerBlock vhd = sz `div` Block.sectorLength+  where BlockSize sz = vhdBlockSize vhd+ virtualSize :: Vhd -> VirtualByteCount-virtualSize vhd = fromIntegral (vhdBlockCount vhd) * fromIntegral (vhdBlockSize vhd)+virtualSize vhd = fromIntegral (vhdBlockCount vhd) * fromIntegral bsz+  where BlockSize bsz = vhdBlockSize vhd  withVhd :: FilePath -> (Vhd -> IO a) -> IO a-withVhd = withVhdInner [] where+withVhd = withVhdInner []+  where -	blockCount node = headerMaxTableEntries $ nodeHeader node-	blockSize  node = headerBlockSize       $ nodeHeader node-	diskType   node = footerDiskType        $ nodeFooter node+    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+    withVhdInner accumulatedNodes filePath f =+        withVhdNode filePath $ \node -> do+            if diskType node == DiskTypeDifferencing+                then withVhdInner (node : accumulatedNodes) (parentPath node) f+                else do+                    validateBlockSize $ blockSize node+                    f $ Vhd+                        -- TODO: require consistent block count and size across all nodes.+                        { vhdBlockCount = blockCount node+                        , vhdBlockSize  = 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.@@ -84,248 +99,260 @@ -- 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+validateBlockSize :: BlockSize -> IO ()+validateBlockSize (BlockSize value)+    | integerValue > integerLimit =+        error "Cannot open VHD file with block size greater than upper bound of platform integer."+    | otherwise =+        return ()+    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)+    { createBlockSize         :: BlockSize+    , createDiskType          :: DiskType+    , createParentTimeStamp   :: Maybe VhdDiffTime+    , createParentUnicodeName :: Maybe ParentUnicodeName+    , createParentUniqueId    :: Maybe UniqueId+    , createTimeStamp         :: Maybe VhdDiffTime+    , createUuid              :: Maybe UniqueId+    , createUseBatmap         :: Bool+    , createVirtualSize       :: VirtualByteCount+    } deriving (Show, Eq) +defaultCreateParameters :: CreateParameters defaultCreateParameters = CreateParameters-	{ createBlockSize         = 2 * 1024 * 1024-	, createDiskType          = DiskTypeDynamic-	, createParentTimeStamp   = Nothing-	, createParentUnicodeName = Nothing-	, createParentUniqueId    = Nothing-	, createTimeStamp         = Nothing-	, createUuid              = Nothing-	, createUseBatmap         = False-	, createVirtualSize       = 0-	}+    { 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)+    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+    | createVirtualSize createParams == 0 = error "cannot create a 0-sized VHD"+    | otherwise                           = do+        nowVhdEpoch <- getVHDTime+        uniqueid    <- randomUniqueId+        create' filePath $ createParams+            { createTimeStamp = Just $ maybe nowVhdEpoch id $ createTimeStamp createParams+            , createUuid      = Just $ maybe uniqueid    id $ createUuid      createParams+            }  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+    withFile filePath WriteMode $ \handle -> do+        B.hPut handle $ encode footer+        B.hPut handle $ encode header+        hAlign handle 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 sectorLength+            headerPos <- hTell handle+            B.hPut handle $ encode $ batmapHeader headerPos+            hAlign handle sectorLength+            B.hPut handle $ B.replicate (fromIntegral (maxTableEntries `div` 8)) 0x0+        hAlign handle 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+    where+        BlockSize bsz   = createBlockSize createParams+        virtSize        = createVirtualSize createParams -		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-			}+        maxTableEntries = fromIntegral (virtSize `divRoundUp` fromIntegral bsz)+        batSize         = (maxTableEntries * 4) `roundUpToModulo` sectorLength+        footerSize      = 512+        headerSize      = 1024 -		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)-			}+        footer = adjustChecksum $ 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       = virtSize+            , footerCurrentSize        = virtSize+            , footerDiskGeometry       = diskGeometry (virtSize `div` Block.sectorLength)+            , footerDiskType           = createDiskType createParams+            , footerChecksum           = mempty+            , footerUniqueId           = fromJust $ createUuid createParams+            , footerIsSavedState       = False+            } +        header = adjustChecksum $ Header+            { headerCookie               = cookie "cxsparse"+            , headerDataOffset           = 0xffffffffffffffff+            , headerTableOffset          = footerSize + headerSize+            , headerVersion              = Version 1 0+            , headerMaxTableEntries      = maxTableEntries+            , headerBlockSize            = createBlockSize createParams+            , headerChecksum             = mempty+            , headerParentUniqueId       = fromMaybe (uniqueId $ B.replicate 16 0) (createParentUniqueId createParams)+            , headerParentTimeStamp      = fromMaybe (VhdDiffTime 0) (createParentTimeStamp createParams)+            , headerReserved1            = B.replicate 4 0+            , headerParentUnicodeName    = fromMaybe (parentUnicodeName "") (createParentUnicodeName createParams)+            , headerParentLocatorEntries = ParentLocatorEntries $ replicate 8 nullParentLocatorEntry+            }++        batmapHeader headerPos = BatmapHeader+            { batmapHeaderCookie   = cookie "tdbatmap"+            , batmapHeaderOffset   = fromIntegral (headerPos + sectorLength)+            , batmapHeaderSize     = (maxTableEntries `div` 8) `divRoundUp` sectorLength+            , batmapHeaderVersion  = Version 1 2+            , batmapHeaderChecksum = mempty+            , batmapHeaderMarker   = 0+            , batmapHeaderKeyHash  = KeyHash Nothing+            , batmapHeaderReserved = B.replicate 418 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)+    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         = hasBatmap 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+--+-- TODO: modify this function to read sub-blocks where appropriate.+readDataRange :: Vhd     -- ^ Vhd chain to read from+              -> Word64  -- ^ offset address in the VHD+              -> Word64  -- ^ number of byte to read+              -> IO BL.ByteString+readDataRange vhd offset len+    | offset + len > virtualSize vhd = error "cannot read data past end of VHD."+    | otherwise = trim . BL.fromChunks <$> mapM (readDataBlock vhd) [blockFirst..blockLast]+  where+        (blockFirst,BlockByteAddress toDrop,_) = vaddrToBlock startAddr (vhdBlockSize vhd)+        (blockLast,_,_)       = vaddrToBlock endAddr (vhdBlockSize vhd)+        trim       = BL.take (fromIntegral len) . BL.drop (fromIntegral toDrop)+        startAddr = VirtualByteAddress offset+        endAddr   = VirtualByteAddress (offset + len)  -- | 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+writeDataRange :: Vhd           -- ^ Vhd chain to write to+               -> Word64        -- ^ offset address in the VHD+               -> BL.ByteString -- ^ the data to write in the VHD+               -> IO ()+writeDataRange vhd iniOffset iniContent = write (VirtualByteAddress iniOffset) iniContent+  where+    write :: VirtualByteAddress -> BL.ByteString -> IO ()+    write offset content+        | offset > VirtualByteAddress offsetMax = error "cannot write data past end of VHD."+        | BL.null content        = return ()+        | otherwise              = do+            sectorOffset <- lookupOrCreateBlock node blockNumber+            withMappedBlock node sectorOffset blockNumber $ \block -> do+                Block.writeDataRange bmap block blockOffset chunk+                write offsetNext contentNext+                where+                    (blockNumber, blockOffset, chunkLength)  = vaddrToBlock offset blockSize+                    chunk        = B.concat $ BL.toChunks $ fst contentSplit+                    contentSplit = BL.splitAt (fromIntegral chunkLength) content+                    contentNext  = snd contentSplit+                    offsetNext   = vaddrNextBlock offset blockSize -	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+    (_,bmap) = getVhdBlockMapper node -	bat       = nodeBat node-	file      = nodeFilePath node-	node      = head $ vhdNodes vhd-	offsetMax = virtualSize vhd-	blockSize = fromIntegral $ vhdBlockSize vhd+    node      = head $ vhdNodes vhd+    offsetMax = virtualSize vhd+    blockSize = vhdBlockSize vhd --- | Reads a block of data from the given virtual address of the given VHD.+-- | Reads all available data from the given virtual block 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.+readDataBlock vhd virtualBlockAddress =+    readDataBlockRange vhd virtualBlockAddress 0 (vhdSectorPerBlock vhd) -	buildResult :: IO ()-	buildResult = do-		B.memset resultPtr 0 (fromIntegral blockSize)-		copySectorsFromNodes sectorsToRead =<< nodeOffsets+-- | Reads data from the given sector range of the given virtual block of the given VHD.+readDataBlockRange :: Vhd -> VirtualBlockAddress -> BlockSectorAddress -> Word32 -> IO B.ByteString+readDataBlockRange vhd virtualBlockAddress sectorOffset sectorCount =+    B.create+        (fromIntegral $ sectorCount * Block.sectorLength)+        (unsafeReadDataBlockRange vhd virtualBlockAddress sectorOffset sectorCount) -	blockSize = vhdBlockSize vhd+-- | Unsafely reads data from the given sector range of the given virtual block of the given VHD.+unsafeReadDataBlockRange :: Vhd+                         -> VirtualBlockAddress+                         -> BlockSectorAddress+                         -> Word32+                         -> Ptr Word8+                         -> IO ()+unsafeReadDataBlockRange vhd virtualBlockAddress sectorOffset sectorCount resultPtr = do+    _ <- B.memset resultPtr 0 $ fromIntegral $ sectorCount * sectorLength+    copySectorsFromNodes sectorsToRead =<< nodeOffsets+  where+    sectorsToRead = fromRange (fromIntegral lo) (fromIntegral hi)+      where (BlockSectorAddress lo) = sectorOffset+            hi = lo + sectorCount -	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) virtualBlockAddress -	nodeOffsets :: IO [(VhdNode, PhysicalSectorAddress)]-	nodeOffsets = fmap catMaybes $ mapM maybeNodeOffset $ vhdNodes vhd where-		maybeNodeOffset node = (fmap . fmap) (node, ) $-			lookupBlock (nodeBat node) blockNumber+    copySectorsFromNodes :: BitSet BlockSectorAddress -> [(VhdNode, PhysicalSectorAddress)] -> IO ()+    copySectorsFromNodes _                []                  = return ()+    copySectorsFromNodes sectorsRequested (nodeOffset : tailNodes)+        | BitSet.isEmpty sectorsRequested = return ()+        | otherwise = do sectorsMissing <- copySectorsFromNode sectorsRequested nodeOffset+                         copySectorsFromNodes sectorsMissing tailNodes -	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 BlockSectorAddress -> (VhdNode, PhysicalSectorAddress) -> IO (BitSet BlockSectorAddress)+    copySectorsFromNode sectorsRequested (node, physicalSectorOfBlock) =+        Block.withBlock (nodeFilePath node) (vhdBlockSize vhd) 0+            physicalSectorOfBlock $ copySectorsFromNodeBlock sectorsRequested bmap+      where (bmap,_) = getVhdBlockMapper node -	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+    copySectorsFromNodeBlock :: BitSet BlockSectorAddress -> Maybe BlockDataMapper -> Block -> IO (BitSet BlockSectorAddress)+    copySectorsFromNodeBlock sectorsRequested bmap block = do+        sectorsPresentByteString <- Block.readBitmap block+        let sectorsPresent = fromByteString sectorsPresentByteString+            sectorsMissing = sectorsRequested `subtract`  sectorsPresent+            sectorsToCopy  = sectorsRequested `intersect` sectorsPresent+        mapM_ (copySectorFromNodeBlock bmap block) (map fromIntegral $ BitSet.toList sectorsToCopy)+        return sectorsMissing -	byteOffsetOfSector :: BlockSectorAddress -> BlockByteAddress-	byteOffsetOfSector = (*) $ fromIntegral sectorLength+    copySectorFromNodeBlock :: Maybe BlockDataMapper -> Block -> BlockSectorAddress -> IO ()+    copySectorFromNodeBlock bmap block sectorToCopy =+        Block.unsafeReadDataRange bmap block sourceByteOffset Block.sectorLength target+      where+            sourceByteOffset = Block.blockSectorToByte sectorToCopy+            (BlockByteAddress targetByteOffset) = Block.blockSectorToByte (sectorToCopy - sectorOffset)+            target = plusPtr resultPtr $ fromIntegral $ targetByteOffset
Data/Vhd/Bat.hs view
@@ -1,99 +1,91 @@ module Data.Vhd.Bat-	( Bat (..)-	, batGetSize-	, containsBlock-	, lookupBlock-	, unsafeLookupBlock-	, hasBitmap-	, batWrite-	, batMmap-	, batIterate-	, batUpdateChecksum-	) where+    ( Bat (..)+    , batGetSize+    , batmapHeaderModify+    , hasBatmap+    , containsBlock+    , lookupBlock+    , batWrite+    , batMmap+    , batIterate+    ) where  import Control.Monad-import Data.Bits+import Control.Applicative+import Control.Concurrent.MVar+import qualified Data.ByteString.Internal as B+import Data.Byteable import Data.Storable.Endian-import Data.Word import Foreign.Ptr-import Foreign.Storable-import Data.Vhd.Bitmap-import Data.Vhd.Serialize+import Data.Serialize (encode)+import Data.Vhd.Batmap import Data.Vhd.Types+import Data.Vhd.Header+import Data.Vhd.Footer+import Data.Vhd.Const 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+data Bat      = Bat+    { batStart  :: Ptr PhysicalSectorAddress+    , batEnd    :: Ptr PhysicalSectorAddress+    , batBatmap :: Maybe (MVar BatmapHeader)+    } +emptyEntry :: PhysicalSectorAddress 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)+hasBatmap :: Bat -> Bool+hasBatmap = maybe False (const True) . batBatmap  -- | 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+batGetSize header _ = 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+containsBlock bat vba = maybe False (const True) `fmap` lookupBlock bat vba  -- | 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.+--   address. 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)+lookupBlock (Bat bptr _ _) (VirtualBlockAddress n) = justBlock `fmap` peekBE ptr+    where ptr = bptr `plusPtr` ((fromIntegral n) * 4)+          justBlock psa | psa == emptyEntry = Nothing+                        | otherwise         = Just psa  -- | 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)+batWrite (Bat bptr _ _) (VirtualBlockAddress n) v = pokeBE ptr v+  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+    mmapWithFilePtr file ReadWrite (Just offsetSize) $ \(ptr, _) -> do+        m <- case batmapHeader of+                Nothing -> return Nothing+                Just bh -> Just <$> newMVar bh+        let batendPtr = ptr `plusPtr` batSize+        f $ Bat (castPtr ptr) batendPtr m+  where+        absoluteOffset = fromIntegral (headerTableOffset header)+        offsetSize     = (absoluteOffset, fromIntegral (batSize + maybe 0 sized batmapHeader + batmapSize))+        --batmapOffset   = batSize + sized (undefined :: BatmapHeader)+        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)+batmapHeaderModify :: Bat -> (BatmapHeader -> BatmapHeader) -> IO ()+batmapHeaderModify bat f =+    case batBatmap bat of+        Nothing  -> return ()+        Just batmapMvar -> modifyMVar_ batmapMvar $ \batmapHdr -> do+            let newbatmapHdr = f batmapHdr+            withBytePtr (encode $ newbatmapHdr) $ \src -> B.memcpy (castPtr $ batEnd bat) src (sized batmapHdr)+            return newbatmapHdr --- | 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+batIterate :: Bat -> VirtualBlockAddress -> (VirtualBlockAddress -> Maybe PhysicalSectorAddress -> IO ()) -> IO ()+batIterate bat nb f = forM_ [0 .. (nb - 1)] (\i -> lookupBlock bat i >>= \n -> f i n)
+ Data/Vhd/Batmap.hs view
@@ -0,0 +1,73 @@+module Data.Vhd.Batmap+    ( BatmapHeader(..)+    , KeyHash(..)+    , batmapSetKeyHash+    , batmapClearKeyHash+    ) where++import Control.Applicative+import qualified Data.ByteString as B+import Data.Serialize+import Data.Word+import Data.Vhd.Serialize+import Data.Vhd.Types+import Data.Vhd.Checksum++data BatmapHeader = BatmapHeader+    { batmapHeaderCookie       :: Cookie+    , batmapHeaderOffset       :: PhysicalByteAddress+    , batmapHeaderSize         :: Word32+    , batmapHeaderVersion      :: Version+    , batmapHeaderChecksum     :: Checksum+    , batmapHeaderMarker       :: Word8+    , batmapHeaderKeyHash      :: KeyHash+    , batmapHeaderReserved     :: B.ByteString+    } deriving (Show, Eq)++newtype KeyHash = KeyHash (Maybe (B.ByteString, B.ByteString))+    deriving (Show,Eq)++instance Serialize BatmapHeader where+    get = BatmapHeader+        <$> getCookie+        <*> getDataOffset+        <*> getWord32be+        <*> getVersion+        <*> get+        <*> getWord8+        <*> get+        <*> getByteString 418+    put b = do+        putCookie     $ batmapHeaderCookie   b+        putDataOffset $ batmapHeaderOffset   b+        putWord32be   $ batmapHeaderSize     b+        putVersion    $ batmapHeaderVersion  b+        put           $ batmapHeaderChecksum b+        putWord8      $ batmapHeaderMarker   b+        put           $ batmapHeaderKeyHash  b+        putByteString $ batmapHeaderReserved b++instance Serialize KeyHash where+    get = do+        c <- getWord8+        if c /= 1+            then return $ KeyHash Nothing+            else do nonce <- getByteString 32+                    hash  <- getByteString 32+                    return $ KeyHash (Just (nonce, hash))+    put (KeyHash Nothing) = putByteString $ B.replicate (32+32+1) 0+    put (KeyHash (Just (nonce, hash))) = do+        putWord8 1+        putByteString nonce+        putByteString hash++instance Sized BatmapHeader where+    sized _ = 512++batmapClearKeyHash :: BatmapHeader -> BatmapHeader+batmapClearKeyHash bhdr = bhdr { batmapHeaderKeyHash = KeyHash Nothing }++batmapSetKeyHash :: B.ByteString -> B.ByteString -> BatmapHeader -> BatmapHeader+batmapSetKeyHash nonce hash bhdr+    | B.length nonce /= 32 || B.length hash /= 32 = error "not valid keyhash"+    | otherwise = bhdr { batmapHeaderKeyHash = KeyHash (Just (nonce, hash)) }
Data/Vhd/Bitmap.hs view
@@ -1,10 +1,10 @@ module Data.Vhd.Bitmap-	( Bitmap (..)-	, bitmapGet-	, bitmapSet-	, bitmapSetRange-	, bitmapClear-	) where+    ( Bitmap (..)+    , bitmapGet+    , bitmapSet+    , bitmapSetRange+    , bitmapClear+    ) where  import Data.Bits import Data.Word@@ -15,24 +15,24 @@  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+    where+        test :: Word8 -> Bool+        test = flip testBit (7 - nBit)+        (offset, nBit) = 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+bitmapModify (Bitmap bptr) n f = peek ptr >>= poke ptr . f (7 - nBit)+    where+        ptr = bptr `plusPtr` offset+        (offset, nBit) = 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 ()+    | 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
@@ -1,113 +1,192 @@ module Data.Vhd.Block-	( Block-	, Sector-	, bitmapSizeOfBlockSize-	, bitmapOfBlock-	, withBlock-	, readBitmap-	, readData-	, readDataRange-	, unsafeReadData-	, unsafeReadDataRange-	, writeDataRange-	, sectorLength-	) where+    ( Block+    , blockAddr+    , BlockDataMapper+    , sectorPerBlock+    , blockSectorToByte+    , bitmapSizeOfBlockSize+    , bitmapOfBlock+    , withBlock+    , readBitmap+    , readData+    , readDataRange+    , unsafeReadData+    , unsafeReadDataRange+    , writeDataRange+    -- * sector manipulation+    , readSector+    , writeSector+    , sectorLength+    , iterateSectors+    ) 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.Const import Data.Vhd.Utils import Data.Word+import Control.Applicative+import Control.Monad import Foreign.Ptr-import Foreign.Storable+import Foreign.ForeignPtr (newForeignPtr_) import System.IO.MMap+import Data.Byteable -data Block = Block BlockByteCount (Ptr Word8)-data Sector = Sector (Ptr Word8)-data Data = Data (Ptr Word8)+type BlockDataMapper = VirtualBlockAddress -> BlockByteAddress -> ByteString -> ByteString -sectorLength :: Word32-sectorLength = 512+data Block = Block+    { blockSize :: BlockSize           -- ^ block size in bytes+    , blockAddr :: VirtualBlockAddress -- ^ block address+    , blockPtr  :: Ptr Word8           -- ^ block data pointer+    } +newtype Data = Data (Ptr Word8)++blockSectorToByte :: BlockSectorAddress -> BlockByteAddress+blockSectorToByte (BlockSectorAddress s) = BlockByteAddress (s * sectorLength)++sectorPerBlock :: Block -> BlockSectorAddress+sectorPerBlock block = BlockSectorAddress (fromIntegral bsz `div` sectorLength)+ where BlockSize bsz = blockSize block+ -- | Finds the padded size (in bytes) of the bitmap for a given block. bitmapSizeOfBlock :: Block -> Int-bitmapSizeOfBlock (Block blockSize _) = bitmapSizeOfBlockSize blockSize+bitmapSizeOfBlock block = bitmapSizeOfBlockSize $ blockSize block  -- | 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+bitmapSizeOfBlockSize :: BlockSize -> Int+bitmapSizeOfBlockSize (BlockSize blocksz) = fromIntegral ((nbSector `divRoundUp` 8) `roundUpToModulo` sectorLength)+  where nbSector = blocksz `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+bitmapOfBlock block = Bitmap $ blockPtr block  -- | Retrieves the data for the given block. dataOfBlock :: Block -> Data-dataOfBlock (Block bs ptr) = Data $ ptr `plusPtr` (bitmapSizeOfBlockSize bs)+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)+withBlock :: FilePath -> BlockSize -> VirtualBlockAddress -> PhysicalSectorAddress -> (Block -> IO a) -> IO a+withBlock file blocksz@(BlockSize bsz) vba sectorOffset f =+    mmapWithFilePtr file ReadWrite (Just (offset, len)) $ \(ptr, _) ->+        f (Block blocksz vba $ castPtr ptr)+  where+        offset = (fromIntegral sectorOffset) * sectorLength+        len = (fromIntegral bsz) + (fromIntegral $ bitmapSizeOfBlockSize blocksz)  -- | 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+readBitmap block = B.create (fromIntegral len) create+  where+        len = bitmapSizeOfBlock block+        create byteStringPtr = B.memcpy target source (fromIntegral len) 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)+readData :: Maybe BlockDataMapper -> Block -> IO ByteString+readData blockMapper block = readDataRange blockMapper block 0 sz+  where (BlockSize sz) = blockSize 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)+readDataRange :: Maybe BlockDataMapper -> Block -> BlockByteAddress -> Word32 -> IO ByteString+readDataRange blockDataMapper block offset len = B.create (fromIntegral len) $+    unsafeReadDataRange blockDataMapper block offset len  -- | Unsafely reads all available data from the specified block.-unsafeReadData :: Block -> Ptr Word8 -> IO ()-unsafeReadData block =-	unsafeReadDataRange block 0 (fromIntegral $ blockSizeOfBlock block)+unsafeReadData :: Maybe BlockDataMapper -> Block -> Ptr Word8 -> IO ()+unsafeReadData blockDataMapper block =+    unsafeReadDataRange blockDataMapper block 0 (fromIntegral sz)+  where (BlockSize sz) = blockSize 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)+unsafeReadDataRange :: Maybe BlockDataMapper -- ^ an optional data mapper function+                    -> Block                 -- ^ the block+                    -> BlockByteAddress      -- ^ offset in bytes on this block+                    -> Word32                -- ^ number of bytes+                    -> Ptr Word8             -- ^ output buffer+                    -> IO ()+unsafeReadDataRange blockDataMapper block bba@(BlockByteAddress offset) len target =+    case blockDataMapper of+        Nothing   -> B.memcpy target source (fromIntegral len)+        Just bmap -> do fptr <- newForeignPtr_ source+                        let mappedSource = bmap (blockAddr block) bba $ B.fromForeignPtr fptr 0 (fromIntegral len)+                        withBytePtr mappedSource $ \src ->+                            B.memcpy target src (fromIntegral len)+  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+writeDataRange :: Maybe BlockDataMapper+               -> Block+               -> BlockByteAddress+               -> ByteString+               -> IO ()+writeDataRange blockMapper block bba@(BlockByteAddress 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 (maybe id (\bm -> bm (blockAddr block) bba) blockMapper $ content) (\source -> B.memcpy target (castPtr source) len)+  where+        len         = fromIntegral $ B.length content+        bitmap      = bitmapOfBlock block+        target      = (pointerOfData $ dataOfBlock block) `plusPtr` (fromIntegral offset)+        sectorStart = offset `div` sectorLength+        sectorEnd   = (fromIntegral offset + B.length content) `div` sectorLength++-- | Return the whole sector of a specific block if present+readSector :: Maybe BlockDataMapper -- ^ an optional data mapper function+           -> Block                 -- ^ the mapped block+           -> BlockSectorAddress    -- ^ the sector address+           -> IO (Maybe ByteString)+readSector blockMapper block (BlockSectorAddress bsa) =+    allocated >>= \isAllocated ->+        case isAllocated of+            False -> return Nothing+            True  -> Just . applyMapper <$> B.create sectorLength copy+  where+        allocated = bitmapGet bitmap (fromIntegral bsa)+        applyMapper = maybe id (\bm -> bm (blockAddr block) bba) blockMapper+        bba    = BlockByteAddress $ fromIntegral offset+        bitmap = bitmapOfBlock block+        offset = fromIntegral bsa * sectorLength+        addr   = (pointerOfData $ dataOfBlock block) `plusPtr` offset+        copy dst = B.memcpy dst addr sectorLength++-- | Write the whole sector of a specific block+--+-- the content passed need to be the size of the sector length+writeSector :: Maybe BlockDataMapper -- ^ an optional data mapper function+            -> Block                 -- ^ the mapped block+            -> BlockSectorAddress    -- ^ the sector address+            -> ByteString            -- ^ content (of sector length)+            -> IO ()+writeSector blockMapper block (BlockSectorAddress bsa) content+    | B.length content /= sectorLength = error "writeSector data need to be sector'ed size"+    | otherwise                        = do+        bitmapSet bitmap (fromIntegral bsa)+        B.unsafeUseAsCString (applyMapper content) $ \source ->+            B.memcpy target (castPtr source) sectorLength+  where+        applyMapper = maybe id (\bm -> bm (blockAddr block) bba) blockMapper+        bba    = BlockByteAddress $ fromIntegral offset+        bitmap = bitmapOfBlock block+        offset = fromIntegral bsa * sectorLength+        target = (pointerOfData $ dataOfBlock block) `plusPtr` offset++iterateSectors :: Block+               -> (BlockSectorAddress -> Bool -> IO ())+               -> IO ()+iterateSectors block f =+    forM_ [0..(nbSectors-1)] $ \sector@(BlockSectorAddress bsa) ->+        bitmapGet (bitmapOfBlock block) (fromIntegral bsa) >>= f sector+  where nbSectors = sectorPerBlock block
Data/Vhd/Checksum.hs view
@@ -1,41 +1,47 @@ module Data.Vhd.Checksum-	( adjustFooterChecksum-	, adjustHeaderChecksum-	, verifyFooterChecksum-	, verifyHeaderChecksum-	) where+    ( Checksum(..)+    , CheckSumable(..)+    , checksumCalculate+    , verifyChecksum+    , adjustChecksum+    ) where  import Data.Bits+import Data.Monoid 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+newtype Checksum = Checksum Word32+    deriving (Show,Eq) -getHeaderChecksum :: Header -> Checksum-getHeaderChecksum header = complement $ B.foldl' plus 0 headerData-	where-		headerData = encode $ header { headerChecksum = 0 }+instance Serialize Checksum where+    put (Checksum v) = putWord32be v+    get = Checksum `fmap` getWord32be -getFooterChecksum :: Footer -> Checksum-getFooterChecksum footer = complement $ B.foldl' plus 0 footerData-	where footerData = encode $ footer { footerChecksum = 0 }+instance Monoid Checksum where+    mempty = Checksum 0+    mappend (Checksum a) (Checksum b) = Checksum (a+b) -adjustFooterChecksum :: Footer -> Footer-adjustFooterChecksum f = f { footerChecksum = checksum }-	where checksum = getFooterChecksum f+class Serialize a => CheckSumable a where+    calculateChecksum :: a -> Checksum+    getChecksum       :: a -> Checksum+    setChecksum       :: Checksum -> a -> a -adjustHeaderChecksum :: Header -> Header-adjustHeaderChecksum h = h { headerChecksum = checksum }-	where checksum = getHeaderChecksum h+adjustChecksum :: CheckSumable a => a -> a+adjustChecksum a = setChecksum checksum a+  where checksum = calculateChecksum a -verifyFooterChecksum :: Footer -> Bool-verifyFooterChecksum f = footerChecksum f == checksum-	where checksum = getFooterChecksum f+verifyChecksum :: CheckSumable a => a -> Bool+verifyChecksum a = expected == got+  where expected = getChecksum a+        got      = calculateChecksum a -verifyHeaderChecksum :: Header -> Bool-verifyHeaderChecksum h = headerChecksum h == checksum-	where checksum = getHeaderChecksum h+checksumPlus :: Checksum -> Word8 -> Checksum+checksumPlus (Checksum a) b = Checksum (a + fromIntegral b)++checksumComplement :: Checksum -> Checksum+checksumComplement (Checksum s) = Checksum (complement s)++checksumCalculate :: B.ByteString -> Checksum+checksumCalculate = checksumComplement . B.foldl' checksumPlus (Checksum 0)
+ Data/Vhd/Crypt.hs view
@@ -0,0 +1,80 @@+module Data.Vhd.Crypt+    ( VhdCryptKey(..)+    , VhdCryptContext+    , findImplicitCryptFile+    , findImplicitCryptKey+    , openCryptKey+    , vhdCryptInit+    , vhdEncrypt+    , vhdDecrypt+    , calculateHash+    ) where++import Control.Applicative ((<$>))+import Data.List (isSuffixOf)+import Data.Bits (shiftR)+import Data.Vhd.Types (VirtualBlockAddress(..), BlockByteAddress(..))+import Crypto.Hash.SHA256 (hash)+import Crypto.Cipher.AES+import System.FilePath+import System.Directory+import qualified Data.ByteString as B++newtype VhdCryptKey     = VhdCryptKey B.ByteString++newtype VhdCryptContext = VhdCryptContext (AES,AES)++-- | Find implicit cryptographic key associated with a vhd node.+--+-- given a vhd node called "a.vhd" or "a", this function will looks for+-- "a,aes-xts-plain,512.key" and "a,aes-xts-plain,256.key"+--+findImplicitCryptFile :: FilePath -> IO (Maybe FilePath)+findImplicitCryptFile filepath = loop allCryptFiles+  where baseName | ".vhd" `isSuffixOf` filepath = dropExtension filepath+                 | otherwise                    = filepath+        suffixes = [ ",aes-xts-plain,512.key", ",aes-xts-plain,256.key" ]+        allCryptFiles = map (baseName ++) suffixes++        loop []     = return Nothing+        loop (f:fs) = do e <- doesFileExist f+                         if e then return (Just f) else loop fs++findImplicitCryptKey :: FilePath -> IO (Maybe VhdCryptKey)+findImplicitCryptKey filepath = do+    fpr <- findImplicitCryptFile filepath+    case fpr of+        Nothing -> return Nothing+        Just fp -> Just <$> openCryptKey fp++openCryptKey :: FilePath -> IO VhdCryptKey+openCryptKey fp = VhdCryptKey <$> B.readFile fp++calculateHash :: B.ByteString -> VhdCryptKey -> B.ByteString+calculateHash nonce (VhdCryptKey cryptKey) = hash $ B.concat [nonce, cryptKey]++vhdCryptInit :: VhdCryptKey -> Maybe VhdCryptContext+vhdCryptInit (VhdCryptKey cryptKey)+    | B.length cryptKey /= 32 && B.length cryptKey /= 64 = Nothing+    | otherwise               =+        let (k1,k2) = B.splitAt ((B.length  cryptKey) `div` 2) cryptKey+         in Just $ VhdCryptContext (initAES k1, initAES k2)++-- | Encrypt using VhdCryptContext+vhdEncrypt :: VhdCryptContext -> VirtualBlockAddress -> BlockByteAddress -> B.ByteString -> B.ByteString+vhdEncrypt (VhdCryptContext cc) blockN blockOffset bs =+    encryptXTS cc (blockAddressToIV blockN blockOffset) 0 bs++-- | Decrypt using VhdCryptContext+vhdDecrypt :: VhdCryptContext -> VirtualBlockAddress -> BlockByteAddress -> B.ByteString -> B.ByteString+vhdDecrypt (VhdCryptContext cc) blockN blockOffset bs =+    decryptXTS cc (blockAddressToIV blockN blockOffset) 0 bs++-- | Create an IV in big endian mode of the virtual block address+blockAddressToIV :: VirtualBlockAddress -> BlockByteAddress -> B.ByteString+blockAddressToIV (VirtualBlockAddress n) (BlockByteAddress bba) = B.pack [a,b,c,d,0,0,0,0,0,0,0,0,0,0,0,0]+  where a = fromIntegral s+        b = fromIntegral (s `shiftR` 8)+        c = fromIntegral (s `shiftR` 16)+        d = fromIntegral (s `shiftR` 24)+        s = 2*2*1024*n + (bba `div` 512) -- FIXME de-hardcode : blocksize and sector size
+ Data/Vhd/Footer.hs view
@@ -0,0 +1,83 @@+module Data.Vhd.Footer+    ( Footer(..)+    ) where++import Control.Applicative+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Serialize+import Data.Monoid+import Data.Vhd.Types+import Data.Vhd.Serialize+import Data.Vhd.UniqueId+import Data.Vhd.Time+import Data.Vhd.Checksum++data Footer = Footer+    { footerCookie             :: Cookie+    , footerIsTemporaryDisk    :: Bool+    , footerFormatVersion      :: Version+    , footerDataOffset         :: PhysicalByteAddress+    , footerTimeStamp          :: VhdDiffTime+    , footerCreatorApplication :: CreatorApplication+    , footerCreatorVersion     :: Version+    , footerCreatorHostOs      :: CreatorHostOs+    , footerOriginalSize       :: VirtualByteCount+    , footerCurrentSize        :: VirtualByteCount+    , footerDiskGeometry       :: DiskGeometry+    , footerDiskType           :: DiskType+    , footerChecksum           :: Checksum+    , footerUniqueId           :: UniqueId+    , footerIsSavedState       :: Bool+    } deriving (Show, Eq)++instance Sized Footer where+    sized _ = 512++instance CheckSumable Footer where+    getChecksum = footerChecksum+    setChecksum v footer = footer { footerChecksum = v }+    calculateChecksum footer = checksumCalculate $ encode $ footer { footerChecksum = mempty }++instance Serialize Footer where+    get = Footer+        <$> getCookie+        <*> getIsTemporaryDisk+        <*> getFormatVersion+        <*> getDataOffset+        <*> getTimeStamp+        <*> getCreatorApplication+        <*> getCreatorVersion+        <*> getCreatorHostOs+        <*> getOriginalSize+        <*> getCurrentSize+        <*> getDiskGeometry+        <*> getDiskType+        <*> get+        <*> 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+        put                   $ footerChecksum           f+        putUniqueId           $ footerUniqueId           f+        putIsSavedState       $ footerIsSavedState       f+        putFooterPadding++footerPaddingLength :: Int+footerPaddingLength = 427+getFooterPadding :: Get ByteString+getFooterPadding = getByteString footerPaddingLength+putFooterPadding :: Put+putFooterPadding = putByteString $ B.replicate footerPaddingLength 0
Data/Vhd/Geometry.hs view
@@ -7,24 +7,24 @@ -- | 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')+    let (sectorsPerTrack, heads, cylindersTimesHeads) = calculate in+    let cylinders = cylindersTimesHeads `div` heads in+    DiskGeometry+        (fromIntegral cylinders)+        (fromIntegral heads)+        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/Header.hs view
@@ -0,0 +1,74 @@+module Data.Vhd.Header+    ( Header(..)+    ) where++import Control.Applicative+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Serialize+import Data.Monoid (mempty)+import Data.Vhd.Types+import Data.Vhd.Serialize+import Data.Vhd.UniqueId+import Data.Vhd.Checksum+import Data.Vhd.Time++data Header = Header+    { headerCookie               :: Cookie+    , headerDataOffset           :: PhysicalByteAddress+    , headerTableOffset          :: PhysicalByteAddress+    , headerVersion              :: Version+    , headerMaxTableEntries      :: VirtualBlockCount+    , headerBlockSize            :: BlockSize+    , headerChecksum             :: Checksum+    , headerParentUniqueId       :: UniqueId+    , headerParentTimeStamp      :: VhdDiffTime+    , headerReserved1            :: ByteString+    , headerParentUnicodeName    :: ParentUnicodeName+    , headerParentLocatorEntries :: ParentLocatorEntries+    } deriving (Show, Eq)++instance Sized Header where+    sized _ = 1024++instance CheckSumable Header where+    getChecksum = headerChecksum+    setChecksum v header = header { headerChecksum = v }+    calculateChecksum header = checksumCalculate $ encode $ header { headerChecksum = mempty }++instance Serialize Header where+    get = Header+        <$> getCookie+        <*> getDataOffset+        <*> getTableOffset+        <*> getVersion+        <*> getMaxTableEntries+        <*> getBlockSize+        <*> get+        <*> getParentUniqueId+        <*> getParentTimeStamp+        <*> getByteString 4+        <*> getParentUnicodeName+        <*> get+        <*  getHeaderPadding+    put h = do+        putCookie               $ headerCookie               h+        putDataOffset           $ headerDataOffset           h+        putTableOffset          $ headerTableOffset          h+        putVersion              $ headerVersion              h+        putMaxTableEntries      $ headerMaxTableEntries      h+        putBlockSize            $ headerBlockSize            h+        put                     $ headerChecksum             h+        putParentUniqueId       $ headerParentUniqueId       h+        putParentTimeStamp      $ headerParentTimeStamp      h+        putByteString           $ headerReserved1            h+        putParentUnicodeName    $ headerParentUnicodeName    h+        put $ headerParentLocatorEntries h+        putHeaderPadding++headerPaddingLength :: Int+headerPaddingLength = 256+getHeaderPadding :: Get ()+getHeaderPadding = skip headerPaddingLength+putHeaderPadding :: Put+putHeaderPadding = putByteString $ B.replicate headerPaddingLength 0
+ Data/Vhd/Lowlevel.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Vhd.Lowlevel+    ( readHeader+    , readFooter+    , writeHeader+    , writeFooter+    ) where++import Control.Applicative+import qualified Data.ByteString as B+import Data.Serialize+import Data.Vhd.Checksum+import Data.Vhd.Header+import Data.Vhd.Footer+import Prelude hiding (subtract)+import System.IO++-- | read footer directly from a vhd file.+readFooter :: FilePath -> IO (Either String Footer)+readFooter filepath = withFile filepath ReadMode $ \handle ->+    decode <$> B.hGet handle 512++-- | read header directly from a vhd file+readHeader :: FilePath -> IO (Either String Header)+readHeader filepath = withFile filepath ReadMode $ \handle -> do+    hSeek handle AbsoluteSeek 512+    decode <$> B.hGet handle 1024++-- | re-write both footer in a VHD file+writeFooter :: FilePath -> Footer -> IO ()+writeFooter filePath footer = do+    withFile filePath ReadWriteMode $ \handle -> do+        B.hPut handle footerBs+        hSeek handle SeekFromEnd 512+        B.hPut handle footerBs+  where+    footerBs = encode $ adjustChecksum footer++-- | re-write an header in a VHD file+writeHeader :: FilePath -> Header -> IO ()+writeHeader filePath header = do+    withFile filePath ReadWriteMode $ \handle -> do+        hSeek handle AbsoluteSeek 512+        B.hPut handle headerBs+  where+    headerBs = encode $ adjustChecksum header
Data/Vhd/Node.hs view
@@ -1,11 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}  module Data.Vhd.Node-	( VhdNode (..)-	, containsBlock-	, lookupOrCreateBlock-	, withVhdNode-	) where+    ( VhdNode (..)+    , getVhdBlockMapper+    , containsBlock+    , lookupOrCreateBlock+    , openCryptKey+    , withVhdNode+    , withMappedBlock+    , iterateBlocks+    , iterateBlockSectors+    , batmapHeaderChange+    ) where  import Control.Applicative ((<$>)) import Control.Monad@@ -14,74 +20,135 @@ import Data.IORef import Data.Serialize (decode, encode) import Data.Vhd.Block+import Data.Vhd.Header+import Data.Vhd.Footer+import Data.Vhd.Batmap import qualified Data.Vhd.Bat as Bat import Data.Vhd.Types+import Data.Vhd.Serialize () import Data.Vhd.Utils-import Data.Vhd.Serialize+import Data.Vhd.Crypt+import System.Directory import System.IO +-- | Represent one VHD file, possibly part of a VHD chain data VhdNode = VhdNode-	{ nodeBat      :: Bat.Bat-	, nodeHeader   :: Header-	, nodeFooter   :: Footer-	, nodeHandle   :: Handle-	, nodeFilePath :: FilePath-	, nodeModified :: IORef Bool-	}+    { nodeBat      :: Bat.Bat+    , nodeHeader   :: Header+    , nodeFooter   :: Footer+    , nodeHandle   :: Handle+    , nodeCryptCtx :: Maybe VhdCryptContext+    , nodeFilePath :: FilePath+    , nodeModified :: IORef Bool+    } +-- | return the (reading, writing) blockDataMapper for a giving node+getVhdBlockMapper :: VhdNode -> (Maybe BlockDataMapper, Maybe BlockDataMapper)+getVhdBlockMapper node =+    (vhdDecrypt `fmap` nodeCryptCtx node, vhdEncrypt `fmap` nodeCryptCtx node)+ 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+    e   <- doesFileExist filePath+    unless e $ error "file doesn't exist"+    key <- findImplicitCryptKey filePath+    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+        -- make sure the key match+        case key of+            Nothing -> return ()+            Just k  -> case batmapHeaderKeyHash `fmap` mBatmapHdr of+                        Just (KeyHash (Just (nonce, expected))) -> do+                            when (expected /= calculateHash nonce k) $ error "keyhash differ"+                        _             -> return ()+        -- now mmap the bat+        Bat.batMmap filePath header footer mBatmapHdr $ \bat -> do+            bmodified <- newIORef False+            a <- f $ VhdNode+                { nodeBat      = bat+                , nodeHeader   = header+                , nodeFooter   = footer+                , nodeHandle   = handle+                , nodeCryptCtx = fmap initCryptContext key+                , nodeFilePath = filePath+                , nodeModified = bmodified+                }+            return a+  where initCryptContext ck = maybe (error "invalid crypt key") id $ vhdCryptInit ck +-- | Return the physical sector of a specific block, or create a new one if this block+-- has not been allocated yet lookupOrCreateBlock :: VhdNode -> VirtualBlockAddress -> IO PhysicalSectorAddress lookupOrCreateBlock node blockNumber = do-	unlessM (Bat.containsBlock (nodeBat node) blockNumber) $ appendEmptyBlock node blockNumber-	Bat.unsafeLookupBlock (nodeBat node) blockNumber+    mpsa <- Bat.lookupBlock (nodeBat node) blockNumber+    case mpsa of+        Nothing  -> appendEmptyBlock node blockNumber+        Just psa -> return psa  containsBlock :: VhdNode -> VirtualBlockAddress -> IO Bool containsBlock node = Bat.containsBlock (nodeBat node) --- | create empty block at the end-appendEmptyBlock :: VhdNode -> VirtualBlockAddress -> IO ()+batmapHeaderChange :: VhdNode -> (BatmapHeader -> BatmapHeader) -> IO ()+batmapHeaderChange node f = Bat.batmapHeaderModify (nodeBat node) f++-- | Create a new empty block at the end of the vhd file+appendEmptyBlock :: VhdNode -> VirtualBlockAddress -> IO PhysicalSectorAddress 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+    -- seek to the end of the file minus the footer+    hSeek (nodeHandle node) SeekFromEnd 512++    pos <- hTell (nodeHandle node)+    let sector = addrToSector (fromIntegral pos)++    Bat.batWrite (nodeBat node) n sector+    modifyIORef (nodeModified node) (const True)+    -- write bitmap, then write block with the optional block data mapper+    B.hPut (nodeHandle node) $ B.replicate bitmapSize 0+    B.hPut (nodeHandle node) $ maybe id (\cc -> vhdEncrypt cc n 0) (nodeCryptCtx node) $ B.replicate (fromIntegral bsz) 0+    -- align to the next sector length and then re-write the footer+    hAlign (nodeHandle node) sectorLength+    B.hPut (nodeHandle node) $ encode (nodeFooter node)+    return sector+  where+        bitmapSize = bitmapSizeOfBlockSize blockSize+        blockSize@(BlockSize bsz)  = headerBlockSize $ nodeHeader node++withMappedBlock :: VhdNode -> PhysicalSectorAddress -> VirtualBlockAddress -> (Block -> IO a) -> IO a+withMappedBlock vhd psa vba f = withBlock (nodeFilePath vhd) blockSize vba psa f+  where blockSize = headerBlockSize $ nodeHeader vhd++-- | Iterate Present blocks in a vhd file+iterateBlocks :: VhdNode          -- ^ the vhd file+              -> (Block -> IO ()) -- ^ callback+              -> IO ()+iterateBlocks vhd f = mapM_ callAt [0..(nbBlocks-1)]+  where nbBlocks = VirtualBlockAddress $ headerMaxTableEntries $ nodeHeader vhd+        callAt vba = do+            mpsa <- Bat.lookupBlock (nodeBat vhd) vba+            case mpsa of+                Nothing  -> return ()+                Just psa -> withMappedBlock vhd psa vba f++-- | Iterate sectors in a specific block+iterateBlockSectors :: VhdNode             -- ^ the vhd file+                    -> VirtualBlockAddress -- ^ block address+                    -> (Block -> BlockSectorAddress -> Bool -> IO ()) -- ^ callback+                    -> IO ()+iterateBlockSectors vhd vba f = do+    mpsa <- Bat.lookupBlock (nodeBat vhd) vba+    case mpsa of+        Nothing  -> return ()+        Just psa -> withMappedBlock vhd psa vba (\block -> iterateSectors block (f block))
Data/Vhd/Serialize.hs view
@@ -1,113 +1,27 @@ module Data.Vhd.Serialize where  import Control.Applicative-import Control.Exception import Control.Monad import Data.Bits+import Data.Word+import Data.Byteable 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+import Data.Vhd.UniqueId+import Data.Vhd.Time +getCookie :: Get Cookie getCookie = cookie <$> getByteString 8+putCookie :: Cookie -> Put putCookie (Cookie c) = putByteString c -getBlockSize       = getWord32be-putBlockSize       = putWord32be-getChecksum        = getWord32be-putChecksum        = putWord32be+getBlockSize :: Get BlockSize+getBlockSize       = BlockSize <$> getWord32be+putBlockSize :: BlockSize -> Put+putBlockSize (BlockSize sz) = putWord32be sz getCurrentSize     = getWord64be putCurrentSize     = putWord64be getDataOffset      = getWord64be@@ -116,69 +30,107 @@ putMaxTableEntries = putWord32be getOriginalSize    = getWord64be putOriginalSize    = putWord64be-getParentTimeStamp = getWord32be-putParentTimeStamp = putWord32be+getTableOffset :: Get Word64 getTableOffset     = getWord64be+putTableOffset :: Word64 -> Put putTableOffset     = putWord64be-getTimeStamp       = getWord32be-putTimeStamp       = putWord32be +getParentTimeStamp :: Get VhdDiffTime+getParentTimeStamp = getTimeStamp+putParentTimeStamp :: VhdDiffTime -> Put+putParentTimeStamp = putTimeStamp++getTimeStamp :: Get VhdDiffTime+getTimeStamp                  = VhdDiffTime <$> getWord32be+putTimeStamp :: VhdDiffTime -> Put+putTimeStamp (VhdDiffTime ts) = putWord32be ts++getCreatorApplication :: Get CreatorApplication getCreatorApplication = creatorApplication <$> getByteString 4+putCreatorApplication :: CreatorApplication -> Put putCreatorApplication (CreatorApplication c) = putByteString c +getCreatorHostOs :: Get CreatorHostOs getCreatorHostOs = convert <$> getWord32be where-	convert 0x4D616320 = CreatorHostOsMacintosh-	convert 0x5769326B = CreatorHostOsWindows-	convert _          = CreatorHostOsUnknown+    convert 0x4D616320 = CreatorHostOsMacintosh+    convert 0x5769326B = CreatorHostOsWindows+    convert _          = CreatorHostOsUnknown+putCreatorHostOs :: CreatorHostOs -> Put putCreatorHostOs v = putWord32be $ case v of-	CreatorHostOsMacintosh -> 0x4D616320-	CreatorHostOsWindows   -> 0x5769326B-	CreatorHostOsUnknown   -> 0+    CreatorHostOsMacintosh -> 0x4D616320+    CreatorHostOsWindows   -> 0x5769326B+    CreatorHostOsUnknown   -> 0 +getDiskType :: Get DiskType getDiskType = convert <$> getWord32be where-	convert 2 = DiskTypeFixed-	convert 3 = DiskTypeDynamic-	convert 4 = DiskTypeDifferencing-	convert _ = error "invalid disk type"+    convert 2 = DiskTypeFixed+    convert 3 = DiskTypeDynamic+    convert 4 = DiskTypeDifferencing+    convert _ = error "invalid disk type"+putDiskType :: DiskType -> Put putDiskType v = putWord32be $ case v of-	DiskTypeFixed        -> 2-	DiskTypeDynamic      -> 3-	DiskTypeDifferencing -> 4+    DiskTypeFixed        -> 2+    DiskTypeDynamic      -> 3+    DiskTypeDifferencing -> 4 +getDiskGeometry :: Get DiskGeometry getDiskGeometry = DiskGeometry <$> getWord16be <*> getWord8 <*> getWord8+putDiskGeometry :: DiskGeometry -> Put putDiskGeometry (DiskGeometry c h s) = putWord16be c >> putWord8 h >> putWord8 s +getIsTemporaryDisk :: Get Bool getIsTemporaryDisk = (\n -> n .&. 1 == 1) <$> getWord32be+putIsTemporaryDisk :: Bool -> Put putIsTemporaryDisk i = putWord32be ((if i then 1 else 0) .|. 0x2) +getIsSavedState :: Get Bool getIsSavedState = (== 1) <$> getWord8+putIsSavedState :: Bool -> Put putIsSavedState i = putWord8 (if i then 1 else 0) -getUniqueId = UniqueId <$> getByteString 16-putUniqueId (UniqueId i) = putByteString i+getUniqueId :: Get UniqueId+getUniqueId = uniqueId <$> getByteString 16+putUniqueId :: UniqueId -> Put+putUniqueId uid = putByteString $ toBytes uid +getParentUniqueId :: Get UniqueId getParentUniqueId = getUniqueId++putParentUniqueId :: UniqueId -> Put putParentUniqueId = putUniqueId +getVersion :: Get Version getVersion = Version <$> getWord16be <*> getWord16be+putVersion :: Version -> Put putVersion (Version major minor) = putWord16be major >> putWord16be minor +getCreatorVersion :: Get Version getCreatorVersion = getVersion+putCreatorVersion :: Version -> Put putCreatorVersion = putVersion++getFormatVersion :: Get Version getFormatVersion  = getVersion+putFormatVersion :: Version -> Put putFormatVersion  = putVersion  getParentUnicodeName = parentUnicodeName . demarshall <$> getByteString 512-	where demarshall = takeWhile ((/=) '\0') . T.unpack . decodeUtf16BE+    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+    | 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+instance Serialize ParentLocatorEntry where+    get = ParentLocatorEntry <$> getWord32be+                             <*> getWord32be+                             <*> getWord32be+                             <*> (getWord32be *> getWord64be)+    put ent = mapM_ putWord32be [locatorCode ent,locatorDataSpace ent,locatorDataLength ent,0]+           >> putWord64be (locatorDataOffset ent) -getParentLocatorEntries = parentLocatorEntries <$> replicateM 8 getParentLocatorEntry-putParentLocatorEntries (ParentLocatorEntries es) = mapM_ putParentLocatorEntry es+instance Serialize ParentLocatorEntries where+    get = ParentLocatorEntries <$> replicateM 8 get+    put (ParentLocatorEntries es) = mapM_ put es
+ Data/Vhd/Time.hs view
@@ -0,0 +1,30 @@+module Data.Vhd.Time+    ( VhdDiffTime(..)+    , getVHDTime+    , toPosixSeconds+    , toUTCTime+    ) where++import Data.Word+import Control.Applicative+import Data.Time.Clock.POSIX+import Data.Time.Clock++-- | Represent number of seconds since VHD epoch.+newtype VhdDiffTime = VhdDiffTime Word32+    deriving (Show,Read,Eq,Ord)++y2k :: Word64+y2k = 946684800 -- seconds from the unix epoch to the vhd epoch ++-- | return the current time in vhd epoch time.+getVHDTime :: IO VhdDiffTime+getVHDTime = do+    nowUnixEpoch <- truncate <$> getPOSIXTime+    return $ VhdDiffTime $ fromIntegral (nowUnixEpoch - y2k)++toPosixSeconds :: VhdDiffTime -> POSIXTime+toPosixSeconds (VhdDiffTime ts) = fromIntegral (fromIntegral ts + y2k)++toUTCTime :: VhdDiffTime -> UTCTime+toUTCTime = posixSecondsToUTCTime . toPosixSeconds
Data/Vhd/Types.hs view
@@ -1,122 +1,118 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} 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.Vhd.Const 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)+class Sized a where+    sized :: Num n => a -> n -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)+-- | block size+newtype BlockSize = BlockSize Word32+    deriving (Show,Eq,Ord,Num) -data BatmapHeader = BatmapHeader-	{ batmapHeaderCookie       :: Cookie-	, batmapHeaderOffset       :: PhysicalByteAddress-	, batmapHeaderSize         :: Word32-	, batmapHeaderVersion      :: Version-	, batmapHeaderChecksum     :: Checksum-	} deriving (Show, Eq)+-- | The offset from the beginning of a block in bytes+newtype BlockByteAddress = BlockByteAddress Word32+    deriving (Show,Eq,Ord,Num) -type BlockByteAddress            = Word32-type BlockByteCount              = Word32-type BlockSectorAddress          = Word32-type BlockSectorCount            = Word32+-- | The offset from the beginning of a block in sectors+newtype BlockSectorAddress = BlockSectorAddress Word32+    deriving (Show,Eq,Ord,Num,Enum)++-- | The absolute number of the block+newtype VirtualBlockAddress = VirtualBlockAddress Word32+    deriving (Show,Eq,Ord,Num,Enum)++-- | An absolute address in byte in the vhd content space+newtype VirtualByteAddress = VirtualByteAddress Word64+    deriving (Show,Eq,Ord,Num,Enum)++ 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 +vaddrPlus :: VirtualByteAddress -> Word64 -> VirtualByteAddress+vaddrPlus (VirtualByteAddress b) w = VirtualByteAddress (b + w)++vaddrToBlock :: VirtualByteAddress -> BlockSize -> (VirtualBlockAddress, BlockByteAddress, Word32)+vaddrToBlock (VirtualByteAddress b) (BlockSize blocksz) =+    (VirtualBlockAddress $ fromIntegral d, fromIntegral m, blocksz - fromIntegral m)+  where (d,m) = b `divMod` fromIntegral blocksz++-- | increment the virtual address to align to the next block+vaddrNextBlock :: VirtualByteAddress -> BlockSize -> VirtualByteAddress+vaddrNextBlock (VirtualByteAddress b) (BlockSize blocksz) =+    VirtualByteAddress (((b `div` sz) * sz) + sz)+  where sz = fromIntegral blocksz++addrToSector :: Word64 -> PhysicalSectorAddress+addrToSector w = fromIntegral (w `div` sectorLength)+ data Version      = Version VersionMajor VersionMinor deriving (Show, Eq) type VersionMajor = Word16 type VersionMinor = Word16  data CreatorHostOs-	= CreatorHostOsUnknown-	| CreatorHostOsWindows-	| CreatorHostOsMacintosh deriving (Show, Eq)+    = CreatorHostOsUnknown+    | CreatorHostOsWindows+    | CreatorHostOsMacintosh deriving (Show, Eq)  data DiskGeometry = DiskGeometry-	DiskGeometryCylinders-	DiskGeometryHeads-	DiskGeometrySectorsPerTrack deriving (Show, Eq)+    DiskGeometryCylinders+    DiskGeometryHeads+    DiskGeometrySectorsPerTrack deriving (Show, Eq)  data DiskType-	= DiskTypeFixed-	| DiskTypeDynamic-	| DiskTypeDifferencing deriving (Show, Eq)+    = 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)+data ParentLocatorEntry = ParentLocatorEntry+    { locatorCode  :: Word32+    , locatorDataSpace  :: Word32+    , locatorDataLength :: Word32+    , locatorDataOffset :: Word64+    } deriving (Show, 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)+nullParentLocatorEntry :: ParentLocatorEntry+nullParentLocatorEntry = ParentLocatorEntry 0 0 0 0 +newtype ParentUnicodeName    = ParentUnicodeName  String       deriving (Show, Eq)+ newtype ParentLocatorEntries = ParentLocatorEntries [ParentLocatorEntry] deriving (Show, Eq) +-- | smart constructor for Cookie+cookie :: B.ByteString -> Cookie cookie               c = assert (B.length c ==   8) $ Cookie               c++-- | smart constructor for CreatorApplication+creatorApplication :: B.ByteString -> CreatorApplication creatorApplication   a = assert (B.length a ==   4) $ CreatorApplication   a++-- | smart constructor for ParentLocatorEntries+parentLocatorEntries :: [ParentLocatorEntry] -> ParentLocatorEntries 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 :: [Char] -> ParentUnicodeName 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)+    | encodedLength > 512 = error "parent unicode name length must be <= 512 bytes"+    | otherwise           = ParentUnicodeName n+   where+        encodedLength = B.length $ encodeUtf16BE $ T.pack n
+ Data/Vhd/UniqueId.hs view
@@ -0,0 +1,57 @@+module Data.Vhd.UniqueId+    ( UniqueId+    , uniqueId+    , randomUniqueId+    ) where++import Control.Exception+import Control.Monad+import Data.Char+import Data.List+import Data.Byteable+import System.Random+import qualified Data.ByteString as B+import Text.Printf++newtype UniqueId = UniqueId B.ByteString deriving (Eq)++-- | smart constructor for uniqueId+uniqueId :: B.ByteString -> UniqueId+uniqueId i = assert (B.length i ==  16) $ UniqueId             i++instance Byteable UniqueId where+    toBytes (UniqueId b) = b++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)++instance Read UniqueId where+    readsPrec _ r = let (t,d) = splitAt 36 r+                     in case ofString t of+                            Nothing  -> []+                            Just uid -> [(uid, d)]++ofString :: String -> Maybe UniqueId+ofString s+    | length s /= 36 = Nothing+    | head r0 /= '-' = Nothing+    | head r1 /= '-' = Nothing+    | head r2 /= '-' = Nothing+    | head r3 /= '-' = Nothing+    | otherwise      = Just $ UniqueId $ B.pack (unhex a8 ++ unhex b4 ++ unhex c4 ++ unhex d4 ++ unhex (drop 1 r3))+  where (a8, r0) = splitAt 8 s+        (b4, r1) = splitAt 4 $ drop 1 r0+        (c4, r2) = splitAt 4 $ drop 1 r1+        (d4, r3) = splitAt 4 $ drop 1 r2++        unhex []         = []+        unhex (v1:v2:xs) = fromIntegral (digitToInt v1 * 16 + digitToInt v2) : unhex xs+        unhex _          = error "internal error in unhex"++randomUniqueId :: IO UniqueId+randomUniqueId+    = liftM (uniqueId . B.pack)+    $ replicateM 16+    $ liftM fromIntegral+    $ randomRIO (0 :: Int, 255)
Data/Vhd/Utils.hs view
@@ -1,34 +1,37 @@ module Data.Vhd.Utils-	( divRoundUp-	, resolveColocatedFilePath-	, roundUpToModulo-	, hAlign-	, unlessM-	) where+    ( divRoundUp+    , resolveColocatedFilePath+    , roundUpToModulo+    , hAlign+    , unlessM+    ) where  import Control.Monad (unless) import qualified Data.ByteString as B import System.FilePath.Posix import System.IO +divRoundUp :: Integral a => a -> a -> a 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+    if isAbsolute colocatedFilePath+        then colocatedFilePath+        else takeDirectory baseFilePath </> colocatedFilePath +roundUpToModulo :: Integral a => a -> a -> a roundUpToModulo n m-	| n `mod` m == 0 = n-	| otherwise      = n + m - (n `mod` 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+    where realign i = B.hPut h $ B.replicate (n - fromIntegral (i `mod` fromIntegral n)) 0 +unlessM :: Monad m => m Bool -> m () -> m () unlessM condition elseBranch = do-	c <- condition-	unless c elseBranch+    c <- condition+    unless c elseBranch
− Tests.hs 
@@ -1,89 +0,0 @@-import Test.QuickCheck-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--instance Arbitrary Version where-	arbitrary = Version <$> arbitrary <*> arbitrary--instance Arbitrary UniqueId where-	arbitrary = uniqueId . B.pack <$> replicateM 16 arbitrary--instance Arbitrary Cookie where-	arbitrary = cookie . B.pack <$> replicateM 8 arbitrary--instance Arbitrary CreatorApplication where-	arbitrary = creatorApplication . B.pack <$> replicateM 4 arbitrary--instance Arbitrary ParentLocatorEntry where-	arbitrary = parentLocatorEntry . B.pack <$> replicateM 24 arbitrary--instance Arbitrary ParentLocatorEntries where-	arbitrary = parentLocatorEntries <$> replicateM 8 arbitrary--instance Arbitrary ParentUnicodeName where-	arbitrary = parentUnicodeName <$> replicateM 64 (arbitrary `suchThat` (\w -> w /= '\0'))--instance Arbitrary DiskGeometry where-	arbitrary = DiskGeometry <$> arbitrary <*> arbitrary <*> arbitrary--instance Arbitrary DiskType where-	arbitrary = elements [ DiskTypeFixed, DiskTypeDynamic, DiskTypeDifferencing ]--instance Arbitrary CreatorHostOs where-	arbitrary = elements [ CreatorHostOsUnknown, CreatorHostOsWindows, CreatorHostOsMacintosh ]--instance Arbitrary Header where-	arbitrary = Header-		<$> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> (pure $ B.replicate 4 0)-		<*> arbitrary-		<*> arbitrary--instance Arbitrary Footer where-	arbitrary = Footer-		<$> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary-		<*> arbitrary--prop_header_marshalling_id :: Header -> Bool-prop_header_marshalling_id h = decode (encode h) == Right h--prop_footer_marshalling_id :: Footer -> Bool-prop_footer_marshalling_id f = decode (encode f) == Right f--marshallingTests =-	[ testProperty "header identity" prop_header_marshalling_id-	, testProperty "footer identity" prop_footer_marshalling_id-	]--main = defaultMain-	[ testGroup "marshalling" marshallingTests-	]
+ Tests/Tests.hs view
@@ -0,0 +1,104 @@+import Test.QuickCheck+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.Checksum+import Data.Vhd.Types+import Data.Vhd.Header+import Data.Vhd.Footer+import Data.Vhd.UniqueId+import Data.Vhd.Serialize+import Data.Vhd.Time+import Data.Monoid++instance Arbitrary Version where+    arbitrary = Version <$> arbitrary <*> arbitrary++instance Arbitrary UniqueId where+    arbitrary = uniqueId . B.pack <$> replicateM 16 arbitrary++instance Arbitrary Cookie where+    arbitrary = cookie . B.pack <$> replicateM 8 arbitrary++instance Arbitrary CreatorApplication where+    arbitrary = creatorApplication . B.pack <$> replicateM 4 arbitrary++instance Arbitrary ParentLocatorEntry where+    arbitrary = ParentLocatorEntry <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary ParentLocatorEntries where+    arbitrary = parentLocatorEntries <$> replicateM 8 arbitrary++instance Arbitrary ParentUnicodeName where+    arbitrary = parentUnicodeName <$> replicateM 64 (arbitrary `suchThat` (\w -> w /= '\0'))++instance Arbitrary DiskGeometry where+    arbitrary = DiskGeometry <$> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary BlockSize where+    arbitrary = return $ BlockSize (2*1024*1024)++instance Arbitrary DiskType where+    arbitrary = elements [ DiskTypeFixed, DiskTypeDynamic, DiskTypeDifferencing ]++instance Arbitrary CreatorHostOs where+    arbitrary = elements [ CreatorHostOsUnknown, CreatorHostOsWindows, CreatorHostOsMacintosh ]++instance Arbitrary VhdDiffTime where+    arbitrary = VhdDiffTime <$> arbitrary++instance Arbitrary Header where+    arbitrary = Header+        <$> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> (pure $ B.replicate 4 0)+        <*> arbitrary+        <*> arbitrary++instance Arbitrary Checksum where+    arbitrary = return mempty++instance Arbitrary Footer where+    arbitrary = Footer+        <$> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary+        <*> arbitrary++prop_header_marshalling_id :: Header -> Bool+prop_header_marshalling_id h = decode (encode h) == Right h++prop_footer_marshalling_id :: Footer -> Bool+prop_footer_marshalling_id f = decode (encode f) == Right f++marshallingTests =+    [ testProperty "header identity" prop_header_marshalling_id+    , testProperty "footer identity" prop_footer_marshalling_id+    ]++main = defaultMain+    [ testGroup "marshalling" marshallingTests+    ]
+ Tools/Vhd.hs view
@@ -0,0 +1,246 @@+import Control.Applicative+import Control.Concurrent.MVar+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.Lowlevel+import Data.Vhd.Bat+import Data.Vhd.Crypt+import qualified Data.Vhd.Block as Block+import Data.Vhd.Checksum+import Data.Vhd.Node+import Data.Vhd.Types+import Data.Vhd.Batmap+import Data.Vhd.Time+import System.Environment (getArgs)+import System.Console.GetOpt+import System.IO+import Text.Printf+import Data.Word++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>"++cmdTranslate opts [fileVhd, resumeFile]+    | isEncrypt && isDecrypt = error "encryption and decryption are exclusive option"+    | isEncrypt == False && isDecrypt == False = error "need either to encrypt or decrypt. doing nothing"+    | otherwise = do+        (writeBmap, changeBatmapHdrF) <-+            case hasEncryptFile of+                Just file -> do+                    key  <- openCryptKey file+                    let bmap  = maybe (error "invalid crypt key") vhdEncrypt $ vhdCryptInit key+                        nonce = B.replicate 32 0+                    return (Just bmap, batmapSetKeyHash nonce (calculateHash nonce key))+                Nothing -> return (Nothing, batmapClearKeyHash)+            +        withVhdNode fileVhd $ \vhd -> do+            let (dbmap,_) = getVhdBlockMapper vhd+            iterateBlocks vhd $ \block ->+                Block.iterateSectors block $ \bsa isAllocated -> do+                    --putStrLn ("blockAddr: " ++ show (Block.blockAddr block) ++ " sector " ++ show bsa ++ " is allocated: " ++ show isAllocated)+                    case isAllocated of+                        True -> do r <- Block.readSector dbmap block bsa+                                   case r of+                                       Nothing -> error "inconsistency: sector should be allocated"+                                       Just b  -> Block.writeSector writeBmap block bsa b+                        False -> return ()+            batmapHeaderChange vhd changeBatmapHdrF+            -- FIXME: set new hash if available+            return ()+  where isDecrypt = Decrypt `elem` opts+        isEncrypt = maybe False (const True) hasEncryptFile+        hasEncryptFile = foldl (\acc o -> case o of+                                    Encrypt f -> Just f+                                    otherwise -> acc) Nothing opts++cmdTranslate _ _ = error "usage: translate <vhd file> <resume file>"++cmdCreate _ [name, size] =+    create name $ defaultCreateParameters+        { createVirtualSize = read size * 1024 * 1024 }+cmdCreate _ _ = error "usage: create <name> <size MiB>"++cmdExtract opts [fileVhd, fileRaw] = do+    case foldl getRange (0,0) opts of+        (0,0)            -> withVhd fileVhd $ readData >=> BL.writeFile fileRaw+        (startOffset,sz) -> withVhd fileVhd $ \vhd ->+                            withFile fileRaw WriteMode $ \dst ->+                            copyByBlock vhd dst (1024*1024) startOffset sz+  where getRange (_  ,sz) (Offset s) = (getByteStr s, sz)+        getRange (off,_ ) (Size s)   = (off, getByteStr s)+        getRange acc      _          = acc+        getByteStr s = case span isDigit s of+            ("", _)      -> error ("expecting a number with optional suffix, got: " ++ s)+            (n,  suffix) -> let mul = case map toLower suffix of+                                            "k" -> 1024+                                            "m" -> 1024 * 1024+                                            "g" -> 1024 * 1024 * 1024+                                            ""  -> 1+                                            _   -> error ("unknown suffix: " ++ suffix ++ " in " ++ s)+                             in read n * mul+        -- copy block of chunkSize size+        copyByBlock vhd dst chunkSize offset sz = loop offset sz+          where loop off left+                    | left < chunkSize = readDataRange vhd off left >>= BL.hPut dst+                    | otherwise      = do+                        readDataRange vhd off chunkSize >>= BL.hPut dst+                        loop (off + chunkSize) (left - chunkSize)+cmdExtract _ _ = error "usage: extract <vhd file> <raw file>"++cmdPropGet _ [file, field] = withVhdNode file $ \node -> do+    case map toLower field 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 field"+cmdPropGet _ _ = error "usage: prop-get <file> <field>"++cmdRead opts [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  ", showChecksum (headerChecksum hdr) (verifyChecksum hdr))+        , ("parent-uuid      ", show $ headerParentUniqueId hdr)+        , ("parent-filepath  ", show $ headerParentUnicodeName hdr)+        , ("parent-timestamp ", showTimestamp $ headerParentTimeStamp hdr)+        ]+    let (ParentLocatorEntries ents) = headerParentLocatorEntries hdr+    putStrLn "locators:"+    forM_ (zip ents [0..]) $ \(ent,i) -> do+        printf "  %d: code=%.8x space=%.8x len=%.8x offset=%.16x\n"+                (i :: Int) (locatorCode ent) (locatorDataSpace ent) (locatorDataSpace ent) (locatorDataOffset ent)+        return ()++    mapM_ (\(f, s) -> putStrLn (f ++ " : " ++ s))+        [ ("disk-geometry    ", show $ footerDiskGeometry ftr)+        , ("original-size    ", showSize $ footerOriginalSize ftr)+        , ("current-size     ", showSize $ footerOriginalSize ftr)+        , ("type             ", show $ footerDiskType ftr)+        , ("footer-checksum  ", showChecksum (footerChecksum ftr) (verifyChecksum ftr))+        , ("uuid             ", show $ footerUniqueId ftr)+        , ("timestamp        ", showTimestamp $ footerTimeStamp ftr)+        ]+    let bat = nodeBat node+    case batBatmap bat of+        Nothing        -> putStrLn "* no batmap"+        Just batmapHdrMvar -> do+            batmapHdr <- readMVar batmapHdrMvar+            putStrLn "BATMAP:"+            mapM_ (\(f, s) -> putStrLn ("  " ++ f ++ " : " ++ s))+                [ ("version         ", show $ headerVersion hdr)+                , ("keyhash         ", showKeyHash $ batmapHeaderKeyHash batmapHdr)+                , ("batmap-checksum ", showChecksum (batmapHeaderChecksum batmapHdr) False)+                ]++    allocated <- newIORef 0+    batIterate (nodeBat node) (fromIntegral $ headerMaxTableEntries hdr) $ \i@(VirtualBlockAddress a) n -> do+        case n of+            Nothing  -> return ()+            Just psa -> modifyIORef allocated ((+) 1) >> when (DumpBat `elem` opts) (printf "BAT[%.5x] = %08x\n" a psa)+    nb <- readIORef allocated+    putStrLn ("blocks allocated  : " ++ show nb ++ "/" ++ show (headerMaxTableEntries hdr))+  where showKeyHash (KeyHash Nothing) = "nothing"+        showKeyHash (KeyHash (Just (nonce, hash))) = "nonce=" ++ show nonce ++ ", hash=" ++ show hash+cmdRead _ _ = error "usage: read <file>"++cmdSnapshot _ [fileVhdParent, fileVhdChild] =+    withVhd fileVhdParent $ \vhdParent -> snapshot vhdParent fileVhdChild+cmdSnapshot _ _ = error "usage: snapshot <parent vhd file> <child vhd file>"++showBlockSize (BlockSize bsz) = showSize bsz++showSize 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))++showChecksum (Checksum checksum) isValid =+    printf "%08x (%s)" checksum (if isValid then "valid" else "invalid")++showTimestamp timestamp@(VhdDiffTime r) =+    let utc = toUTCTime timestamp+     in show r ++ "s since VHD epoch (" ++ show utc ++ ")"++cmdHelp _ _ = usage Nothing++cmdPropSetUuid _ args = do+    let (file,uuidStr) = case args of+                        [f, u] -> (f,u)+                        _      -> error "usage: vhd <set-uuid> <file> <newuuid>"+    let uuid = read uuidStr+    footer <- either error id <$> readFooter file+    writeFooter file $ footer { footerUniqueId = uuid }++data OptFlag =+      Help+    | Offset String+    | Size String+    | DumpBat+    | Decrypt+    | Encrypt String+    deriving (Show,Eq)++knownCommands :: [ (String, [String] -> IO ()) ]+knownCommands =+    [ ("convert",  wrapOpt cmdConvert [helpOpt])+    , ("create",   wrapOpt cmdCreate [helpOpt])+    , ("extract",  wrapOpt cmdExtract [helpOpt,offsetOpt,sizeOpt])+    , ("prop-get", wrapOpt cmdPropGet [helpOpt])+    , ("set-uuid", wrapOpt cmdPropSetUuid [helpOpt])+    , ("read"    , wrapOpt cmdRead [helpOpt,dumpBatOpt])+    , ("snapshot", wrapOpt cmdSnapshot [helpOpt])+    , ("translate", wrapOpt cmdTranslate [helpOpt,decryptOpt,encryptOpt])+    , ("help"    , wrapOpt cmdHelp [])+    ]+  where wrapOpt f opts xs =+            case getOpt Permute opts xs of+                (o,n,[])   | Help `elem` o -> usage Nothing+                           | otherwise     -> f o n+                (_,_,errs)                 -> mapM_ putStrLn errs >> putStrLn (usageInfo "" opts)+        helpOpt   = Option ['h'] ["help"] (NoArg Help) "ask for help"+        offsetOpt = Option ['o'] ["offset"] (ReqArg Offset "offset") "change the start offset"+        sizeOpt   = Option ['z'] ["size"] (ReqArg Size "size") "size in bytes"+        dumpBatOpt= Option []    ["dump-bat"] (NoArg DumpBat) "dump bat allocation"+        decryptOpt= Option []    ["decrypt"] (NoArg Decrypt) "decrypt the vhd"+        encryptOpt= Option []    ["encrypt"] (ReqArg Encrypt "file") "encrypt the vhd using a key specified from the file"++usage msg = do+    maybe (return ()) putStrLn msg+    putStrLn "usage: vhd <command>"+    putStrLn ""+    mapM_ (putStrLn . ("  " ++) . fst) knownCommands++main = do+    args <- getArgs+    case args of+        []       -> usage Nothing+        cmd : xs -> case lookup cmd knownCommands of+                        Nothing -> usage $ Just ("unknown command: " ++ cmd)+                        Just f  -> f xs
− Vhd.hs 
@@ -1,103 +0,0 @@-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--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>"--cmdCreate [name, size] =-	create name $ defaultCreateParameters-		{ createVirtualSize = read size * 1024 * 1024 }-cmdCreate _ = error "usage: create <name> <size MiB>"--cmdExtract [fileVhd, fileRaw] = withVhd fileVhd $ readData >=> BL.writeFile fileRaw-cmdExtract _                  = error "usage: extract <vhd file> <raw file>"--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] = 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  ", 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))-		[ ("disk-geometry    ", show $ footerDiskGeometry ftr)-		, ("original-size    ", showBlockSize $ footerOriginalSize ftr)-		, ("current-size     ", showBlockSize $ footerOriginalSize ftr)-		, ("type             ", show $ footerDiskType ftr)-		, ("footer-checksum  ", showChecksum (footerChecksum ftr) (verifyFooterChecksum ftr))-		, ("uuid             ", show $ footerUniqueId ftr)-		, ("timestamp        ", show $ footerTimeStamp ftr)-		]-	allocated <- newIORef 0-	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 ("blocks allocated  : " ++ show nb ++ "/" ++ show (headerMaxTableEntries hdr))-cmdRead _ = error "usage: read <file>"--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))--showChecksum checksum isValid =-	printf "%08x (%s)" checksum (if isValid then "valid" else "invalid")--main = do-	args <- getArgs-	case args of-		"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,23 +1,19 @@ Name:                vhd-Version:             0.2+Version:             0.2.1 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+Maintainer:          vincent.hanquez@citrix.com Copyright:           Citrix Systems Inc. License:             BSD3 License-file:        LICENCE Stability:           Experimental Category:            System Build-type:          Simple-Homepage:            https://github.com/jonathanknowles/hs-vhd-Cabal-version:       >=1.6+Homepage:            https://github.com/vincenthz/hs-vhd+Cabal-version:       >=1.8 Data-files:          README -Flag test-  Description:       Build unit tests-  Default:           False- Flag executable   Description:       Build executables   Default:           False@@ -25,46 +21,80 @@ Library   Build-depends:     base >= 4 && < 5                    , bytestring+                   , byteable                    , filepath+                   , directory                    , mmap                    , text                    , time                    , cereal                    , random                    , storable-endian+                   , cipher-aes >= 0.2.0+                   , cryptohash   Exposed-modules:   Data.Vhd+                     Data.Vhd.Lowlevel+                     Data.Vhd.Time   Other-modules:     Data.BitSet                      Data.Range                      Data.Vhd.Bat+                     Data.Vhd.Batmap+                     Data.Vhd.Crypt                      Data.Vhd.Bitmap                      Data.Vhd.Block                      Data.Vhd.Checksum+                     Data.Vhd.Header+                     Data.Vhd.Footer                      Data.Vhd.Node                      Data.Vhd.Geometry                      Data.Vhd.Serialize                      Data.Vhd.Types                      Data.Vhd.Utils+                     Data.Vhd.UniqueId+  ghc-options:       -Wall -fwarn-tabs -Executable           Tests-  Main-Is:           Tests.hs-  if flag(test)-    Buildable:       True-    Build-depends:   base >= 3 && < 5-                   , QuickCheck >= 2+Test-Suite test-vhd+  type:              exitcode-stdio-1.0+  hs-source-dirs:    Tests .+  main-is:           Tests.hs+  build-depends:     base                    , bytestring-                   , test-framework >= 0.3-                   , test-framework-quickcheck2 >= 0.2-  else-    Buildable:       False+                   , byteable+                   , test-framework >= 0.3.3+                   , test-framework-quickcheck2+                   , QuickCheck >= 2.4.0.1+                   , bytestring+                   , filepath+                   , mmap+                   , text+                   , time+                   , cereal+                   , random+                   , vhd+                   , cryptohash  Executable           vhd   Main-Is:           Vhd.hs+  hs-source-dirs:    Tools .   if flag(executable)     Buildable:       True     Build-depends:   base >= 3 && < 5+                   , bytestring+                   , byteable+                   , filepath+                   , directory+                   , mmap+                   , text+                   , time+                   , cereal+                   , random+                   , storable-endian+                   , vhd+                   , cipher-aes >= 0.2.0+                   , cryptohash   else     Buildable:       False  source-repository head   type:     git-  location: git://github.com/jonathanknowles/hs-vhd+  location: git://github.com/vincenthz/hs-vhd