vhd (empty) → 0.1
raw patch · 16 files changed
+1109/−0 lines, 16 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, cereal, mmap, random, storable-endian, test-framework, test-framework-quickcheck2, text, time
Files
- Data/VHD.hs +147/−0
- Data/VHD/Bat.hs +76/−0
- Data/VHD/Bitmap.hs +38/−0
- Data/VHD/Block.hs +83/−0
- Data/VHD/CheckSum.hs +43/−0
- Data/VHD/Context.hs +82/−0
- Data/VHD/Geometry.hs +30/−0
- Data/VHD/Serialize.hs +184/−0
- Data/VHD/Types.hs +112/−0
- Data/VHD/Utils.hs +20/−0
- LICENCE +29/−0
- README +1/−0
- Setup.hs +2/−0
- Tests.hs +89/−0
- Vhd.hs +106/−0
- vhd.cabal +67/−0
+ Data/VHD.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.VHD+ ( create+ , CreateParameters(..)+ , defaultCreateParameters+ , getInfo+ -- * block related operations+ , Block+ , readBlock+ , writeBlock+ , withBlock+ -- * ctx related operations+ , Context(..)+ , withVhdContext+ , extendBlock+ -- * exported Types+ , module Data.VHD.Types+ ) where++import Control.Applicative+import Control.Exception+import Control.Monad+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as B+import Data.ByteString.Char8 ()+import Data.Serialize+import Data.VHD.Serialize+import Data.VHD.Types+import Data.VHD.Bat+import Data.VHD.Block+import Data.VHD.Context+import Data.VHD.Utils+import Data.VHD.Geometry+import Data.VHD.CheckSum+import Data.Bits+import Data.Maybe+import Data.Word+import Data.Time.Clock.POSIX++import System.IO++data CreateParameters = CreateParameters+ { blockSize :: BlockSize+ , size :: Size+ , timeStamp :: Maybe TimeStamp+ , uuid :: Maybe UniqueId+ , useBatmap :: Bool+ } deriving (Show,Eq)++defaultCreateParameters = CreateParameters+ { blockSize = 2 * 1024 * 1024+ , size = 0+ , timeStamp = Nothing+ , uuid = Nothing+ , useBatmap = False+ }++-- | grab the header and footer from a vhd file.+getInfo :: FilePath -> IO (Either String (Header, Footer))+getInfo filePath = withFile filePath ReadMode $ \handle -> do+ footer <- decode <$> B.hGet handle 512+ header <- decode <$> B.hGet handle 1024+ case (footer, header) of+ (Left err, _) -> return $ Left err+ (_, Left err) -> return $ Left err+ (Right f, Right h) -> return $ Right (h,f)++-- | create an empty vhd with the specified parameters+create :: FilePath -> CreateParameters -> IO ()+create filePath createParams+ | size createParams == 0 = error "cannot create a 0-sized VHD"+ | otherwise = do+ nowUnixEpoch <- fromIntegral . fromEnum <$> getPOSIXTime+ let nowVhdEpoch = fromIntegral (nowUnixEpoch - y2k)+ uniqueid <- randomUniqueId+ create' filePath $ createParams+ { uuid = Just $ maybe uniqueid id $ uuid createParams+ , timeStamp = Just $ maybe nowVhdEpoch id $ timeStamp createParams+ }+ where+ y2k :: Word64+ y2k = 946684800 -- seconds from the unix epoch to the vhd epoch++create' :: FilePath -> CreateParameters -> IO ()+create' filePath createParams =+ withFile filePath WriteMode $ \handle -> do+ B.hPut handle $ encode footer+ B.hPut handle $ encode header+ hAlign handle (fromIntegral sectorLength)+ -- create a BAT with every entry initialized to 0xffffffff.+ B.hPut handle $ B.replicate (fromIntegral batSize) 0xff++ -- maybe create a batmap+ when (useBatmap createParams) $ do+ hAlign handle (fromIntegral sectorLength)+ headerPos <- hTell handle+ B.hPut handle $ encode $ BatmapHeader+ { batmapHeaderCookie = cookie "tdbatmap"+ , batmapHeaderOffset = fromIntegral (headerPos + fromIntegral sectorLength)+ , batmapHeaderSize = (maxTableEntries `div` 8) `divRoundUp` sectorLength+ , batmapHeaderVersion = Version 1 2+ , batmapHeaderCheckSum = 0xffffffff+ }+ hAlign handle (fromIntegral sectorLength)+ B.hPut handle $ B.replicate (fromIntegral (maxTableEntries `div` 8)) 0x0++ hAlign handle (fromIntegral sectorLength)+ B.hPut handle $ encode footer+ where+ virtualSize = size createParams+ maxTableEntries = fromIntegral (virtualSize `divRoundUp` fromIntegral (blockSize createParams))+ batSize = (maxTableEntries * 4) `roundUpToModulo` sectorLength+ batPadSize = batSize - maxTableEntries * 4+ footerSize = 512+ headerSize = 1024++ footer = adjustFooterChecksum $ Footer+ { footerCookie = cookie "conectix"+ , footerIsTemporaryDisk = False+ , footerFormatVersion = Version 1 0+ , footerDataOffset = footerSize+ , footerTimeStamp = fromJust $ timeStamp createParams+ , footerCreatorApplication = creatorApplication "tap\0"+ , footerCreatorVersion = if useBatmap createParams then Version 1 3 else Version 1 0+ , footerCreatorHostOs = CreatorHostOsWindows+ , footerOriginalSize = virtualSize+ , footerCurrentSize = virtualSize+ , footerDiskGeometry = diskGeometry (virtualSize `div` fromIntegral sectorLength)+ , footerDiskType = DiskTypeDynamic+ , footerCheckSum = 0+ , footerUniqueId = fromJust $ uuid createParams+ , footerIsSavedState = False+ }+ header = adjustHeaderChecksum $ Header+ { headerCookie = cookie "cxsparse"+ , headerDataOffset = 0xffffffffffffffff+ , headerTableOffset = footerSize + headerSize+ , headerVersion = Version 1 0+ , headerMaxTableEntries = maxTableEntries+ , headerBlockSize = blockSize createParams+ , headerCheckSum = 0+ , headerParentUniqueId = uniqueId $ B.replicate 16 0+ , headerParentTimeStamp = 0+ , headerReserved1 = B.replicate 4 0+ , headerParentUnicodeName = parentUnicodeName ""+ , headerParentLocatorEntries = parentLocatorEntries $ replicate 8 (ParentLocatorEntry $ B.replicate 24 0)+ }
+ Data/VHD/Bat.hs view
@@ -0,0 +1,76 @@+module Data.VHD.Bat+ ( Bat(..)+ , batGetSize+ , batRead+ , batWrite+ , batMmap+ , batIterate+ , batUpdateChecksum+ ) where++import Data.Word+import Data.Bits+import Data.Storable.Endian+import Foreign.Ptr+import Foreign.Storable++import Data.VHD.Types+import Data.VHD.Serialize+import Data.VHD.Utils+import Data.VHD.Bitmap++import Control.Monad++import System.IO.MMap++data Batmap = Batmap Bitmap Int+data Bat = Bat (Ptr Word32) (Ptr Word32) (Maybe Batmap)++sectorLength = 512++batmapSet n (Batmap bitmap _) = bitmapSet bitmap n++batmapChecksum :: Batmap -> IO CheckSum+batmapChecksum (Batmap (Bitmap p) sz) = complement `fmap` foldM addByte 0 [0..(sz-1)]+ where addByte acc i = (p `peekElemOff` i) >>= \w -> return (acc + fromIntegral w)++-- | returns the padded size of a BAT+batGetSize :: Header -> Footer -> Int+batGetSize header footer = fromIntegral ((maxEntries * 4) `roundUpToModulo` sectorLength)+ where+ diskSize = footerCurrentSize footer+ blockSize = headerBlockSize header+ ents = diskSize `divRoundUp` fromIntegral blockSize+ maxEntries = headerMaxTableEntries header++batRead :: Bat -> Int -> IO Word32+batRead (Bat bptr _ _) n = peekBE ptr+ where ptr = bptr `plusPtr` (n*4)++batWrite :: Bat -> Int -> Word32 -> IO ()+batWrite (Bat bptr _ bmap) n v = pokeBE ptr v >> maybe (return ()) (batmapSet n) bmap+ where ptr = bptr `plusPtr` (n*4)++batMmap :: FilePath -> Header -> Footer -> Maybe BatmapHeader -> (Bat -> IO a) -> IO a+batMmap file header footer batmapHeader f =+ mmapWithFilePtr file ReadWrite (Just offsetSize) $ \(ptr, sz) ->+ let batmap = Batmap (Bitmap (castPtr (ptr `plusPtr` batmapOffset))) batmapSize in+ let batendPtr = ptr `plusPtr` batSize in+ f (Bat (castPtr ptr) batendPtr (maybe Nothing (const $ Just batmap) batmapHeader))+ where+ absoluteOffset = fromIntegral (headerTableOffset header)+ offsetSize = (absoluteOffset, fromIntegral (batSize + maybe 0 (const 512) batmapHeader + batmapSize))+ batmapOffset = batSize + fromIntegral sectorLength+ batSize = batGetSize header footer+ batmapSize = maybe 0 (fromIntegral . (* sectorLength) . batmapHeaderSize) batmapHeader++batIterate :: Bat -> Int -> (Int -> Word32 -> IO ()) -> IO ()+batIterate bat nb f = forM_ [0..(nb-1)] (\i -> batRead bat i >>= \n -> f i n)++-- | update checksum in the batmap if the batmap exists+batUpdateChecksum :: Bat -> IO ()+batUpdateChecksum (Bat _ _ Nothing) = return ()+batUpdateChecksum (Bat _ endptr (Just batmap)) = do+ let batmapCheckSumPtr = endptr `plusPtr` (8+8+4+4)+ checkSum <- batmapChecksum batmap+ pokeBE batmapCheckSumPtr checkSum
+ Data/VHD/Bitmap.hs view
@@ -0,0 +1,38 @@+module Data.VHD.Bitmap+ ( Bitmap (..)+ , bitmapGet+ , bitmapSet+ , bitmapSetRange+ , bitmapClear+ ) where++import Foreign.Ptr+import Foreign.Storable+import Data.Word+import Data.Bits++data Bitmap = Bitmap (Ptr Word8)++bitmapGet :: Bitmap -> Int -> IO Bool+bitmapGet (Bitmap ptr) n = test `fmap` peekByteOff ptr offset+ where+ test :: Word8 -> Bool+ test = flip testBit (7-bit)+ (offset, bit) = n `divMod` 8++bitmapModify :: Bitmap -> Int -> (Int -> Word8 -> Word8) -> IO ()+bitmapModify (Bitmap bptr) n f = peek ptr >>= poke ptr . f (7-bit)+ where+ ptr = bptr `plusPtr` offset+ (offset, bit) = n `divMod` 8++bitmapSet :: Bitmap -> Int -> IO ()+bitmapSet bitmap n = bitmapModify bitmap n (flip setBit)++bitmapSetRange :: Bitmap -> Int -> Int -> IO ()+bitmapSetRange bitmap start end+ | start < end = bitmapSet bitmap start >> bitmapSetRange bitmap (start + 1) end+ | otherwise = return ()++bitmapClear :: Bitmap -> Int -> IO ()+bitmapClear bitmap n = bitmapModify bitmap n (flip clearBit)
+ Data/VHD/Block.hs view
@@ -0,0 +1,83 @@+module Data.VHD.Block+ ( Block+ , Sector+ , bitmapSizeOfBlock+ , bitmapOfBlock+ , withBlock+ , readBlock+ , writeBlock+ , sectorLength+ ) where++import Foreign.Ptr+import Foreign.Storable+import Data.Word+import Data.Bits++import Data.VHD.Utils+import Data.VHD.Types+import Data.VHD.Bat+import Data.VHD.Bitmap++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Internal as B++import Control.Monad++import System.IO.MMap++data Block = Block BlockSize (Ptr Word8)+data Sector = Sector (Ptr Word8)++sectorLength :: Word32+sectorLength = 512++-- | this is the padded size of the bitmap for a specific blocksize+bitmapSizeOfBlock :: BlockSize -> Int+bitmapSizeOfBlock blockSize = fromIntegral ((nbSector `divRoundUp` 8) `roundUpToModulo` sectorLength)+ where nbSector = blockSize `divRoundUp` sectorLength++-- | get a bitmap type out of a block type.+-- the bitmap happens to be at the beginning of the block.+bitmapOfBlock :: Block -> Bitmap+bitmapOfBlock (Block _ ptr) = Bitmap ptr++dataOfBlock :: Block -> Ptr Word8+dataOfBlock (Block bs ptr) = ptr `plusPtr` (bitmapSizeOfBlock bs)++-- | mmap a block using a filepath, a blocksize+withBlock :: FilePath -> BlockSize -> Word32 -> (Block -> IO a) -> IO a+withBlock file bs sectorOff f = mmapWithFilePtr file ReadWrite (Just offsetSize) $ \(ptr, sz) ->+ f (Block bs $ castPtr ptr)+ where+ absoluteOffset = fromIntegral (fromIntegral sectorOff * sectorLength)+ offsetSize = (absoluteOffset, fromIntegral bs + fromIntegral bitmapSize)+ nbSector = (bs `divRoundUp` sectorLength)+ bitmapSize = (nbSector `divRoundUp` 8) `roundUpToModulo` sectorLength++readBlock :: Block -> Int -> Int -> IO ByteString+readBlock block offsetStart offsetEnd = do+ -- for the moment, assume we're reading from a dynamic disk.+ -- later on, we'll also need to handle differencing disks here.+ B.create length (\bsptr -> B.memcpy (castPtr bsptr) (dataPtr `plusPtr` offsetStart) (fromIntegral length))+ where+ length = offsetEnd - offsetStart+ bitmapPtr = bitmapOfBlock block+ dataPtr = dataOfBlock block+ sectorStart = fromIntegral offsetStart `div` sectorLength+ sectorEnd = fromIntegral offsetEnd `div` sectorLength++writeBlock :: Block -> ByteString -> Int -> IO ()+writeBlock block content offset = do+ -- sectors need to be prepared for differential disk if the bitmap was clear before,+ -- at the moment assumption is it's 0ed+ bitmapSetRange bitmapPtr (fromIntegral sectorStart) (fromIntegral sectorEnd)+ B.unsafeUseAsCString content (\bsptr -> B.memcpy (dataPtr `plusPtr` offset) (castPtr bsptr) (fromIntegral length))+ where+ length = B.length content+ bitmapPtr = bitmapOfBlock block+ dataPtr = dataOfBlock block+ sectorStart = fromIntegral offset `div` sectorLength+ sectorEnd = fromIntegral (offset + B.length content) `div` sectorLength
+ Data/VHD/CheckSum.hs view
@@ -0,0 +1,43 @@+module Data.VHD.CheckSum+ ( adjustFooterChecksum+ , adjustHeaderChecksum+ , verifyFooterChecksum+ , verifyHeaderChecksum+ ) where++import Data.VHD.Types+import Data.VHD.Serialize++import Data.Bits+import Data.Word+import Data.Serialize++import qualified Data.ByteString as B++plus :: CheckSum -> Word8 -> CheckSum+plus a b = a + fromIntegral b++getHeaderChecksum :: Header -> CheckSum+getHeaderChecksum header = complement $ B.foldl' plus 0 headerData+ where+ headerData = encode $ header { headerCheckSum = 0 }++getFooterChecksum :: Footer -> CheckSum+getFooterChecksum footer = complement $ B.foldl' plus 0 footerData+ where footerData = encode $ footer { footerCheckSum = 0 }++adjustFooterChecksum :: Footer -> Footer+adjustFooterChecksum f = f { footerCheckSum = checksum }+ where checksum = getFooterChecksum f++adjustHeaderChecksum :: Header -> Header+adjustHeaderChecksum h = h { headerCheckSum = checksum }+ where checksum = getHeaderChecksum h++verifyFooterChecksum :: Footer -> Bool+verifyFooterChecksum f = footerCheckSum f == checksum+ where checksum = getFooterChecksum f++verifyHeaderChecksum :: Header -> Bool+verifyHeaderChecksum h = headerCheckSum h == checksum+ where checksum = getHeaderChecksum h
+ Data/VHD/Context.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.VHD.Context+ ( Context(..)+ , withVhdContext+ , extendBlock+ ) where++import Data.VHD.Block+import Data.VHD.Bat+import Data.VHD.Types+import Data.VHD.Utils+import Data.VHD.Serialize++import Data.Serialize (decode, encode)++import qualified Data.ByteString as B+import Data.ByteString.Char8 ()+import Data.IORef++import System.IO++import Control.Applicative ((<$>))+import Control.Monad++data Context = Context+ { ctxBatPtr :: Bat+ , ctxHeader :: Header+ , ctxFooter :: Footer+ , ctxHandle :: Handle+ , ctxFilePath :: FilePath+ , ctxBModified :: IORef Bool+ }++withVhdContext file f = do+ withFile file ReadWriteMode $ \handle -> do+ footer <- either error id . decode <$> B.hGet handle 512+ header <- either error id . decode <$> B.hGet handle 1024+ mBatmapHdr <- if footerCreatorVersion footer == Version 1 3+ then do+ -- skip the BAT, and try reading the batmap header+ hSeek handle RelativeSeek (fromIntegral $ batGetSize header footer)+ batmapHdr <- decode <$> B.hGet handle 512+ case batmapHdr of+ Left _ -> return Nothing+ Right bHdr ->+ if batmapHeaderCookie bHdr == cookie "tdbatmap"+ then return $ Just bHdr+ else return Nothing+ else return Nothing+ batMmap file header footer mBatmapHdr $ \bat -> do+ bmodified <- newIORef False+ a <- f $ Context+ { ctxBatPtr = bat+ , ctxHeader = header+ , ctxFooter = footer+ , ctxHandle = handle+ , ctxFilePath = file+ , ctxBModified = bmodified+ }+ modified <- readIORef bmodified+ when (modified) $ batUpdateChecksum bat+ return a++-- | create empty block at the end+extendBlock ctx n = do+ hSeek (ctxHandle ctx) SeekFromEnd 512+ x <- hTell (ctxHandle ctx)+ -- paranoid check+ let (sector, m) = x `divMod` 512+ unless (m == 0) $ error "wrong sector alignment"+ batWrite (ctxBatPtr ctx) n (fromIntegral sector)+ modifyIORef (ctxBModified ctx) (const True)++ B.hPut (ctxHandle ctx) (B.replicate fullSize 0)++ hAlign (ctxHandle ctx) (fromIntegral sectorLength)+ B.hPut (ctxHandle ctx) $ encode (ctxFooter ctx)++ where+ fullSize = bitmapSize + fromIntegral blockSize+ bitmapSize = bitmapSizeOfBlock blockSize+ blockSize = headerBlockSize $ ctxHeader ctx
+ Data/VHD/Geometry.hs view
@@ -0,0 +1,30 @@+module Data.VHD.Geometry where++import Data.VHD.Types+import Data.Word++-- | Calculates disk geometry using the algorithm presented in+-- | the virtual hard disk image format specification (v 1.0).+diskGeometry :: Word64 -> DiskGeometry+diskGeometry totalSectors' =+ let (sectorsPerTrack, heads, cylindersTimesHeads) = calculate in+ let cylinders = cylindersTimesHeads `div` heads in+ DiskGeometry+ (fromIntegral cylinders)+ (fromIntegral heads)+ (fromIntegral sectorsPerTrack)+ where+ totalSectors = min totalSectors' (65535 * 16 * 255)+ calculate+ | totalSectors > 65536 * 16 * 63 = (255, 16, totalSectors `div` 255)+ | otherwise =+ let sectorsPerTrack = 17 in+ let cylindersTimesHeads = totalSectors `div` 17 in+ let heads = max 4 $ (cylindersTimesHeads + 1023) `div` 1024 in+ let (sectorsPerTrack', heads', cylindersTimesHeads') =+ if cylindersTimesHeads >= heads * 1024 || heads > 16+ then (31, 16, totalSectors `div` 31)+ else (sectorsPerTrack, heads, cylindersTimesHeads) in+ if cylindersTimesHeads' >= heads' * 1024+ then (63, 16, totalSectors `div` 63)+ else (sectorsPerTrack', heads', cylindersTimesHeads')
+ Data/VHD/Serialize.hs view
@@ -0,0 +1,184 @@+module Data.VHD.Serialize where++import Control.Applicative+import Control.Exception+import Control.Monad+import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.VHD.Types+import Data.Serialize+import Data.Serialize.Get+import Data.Serialize.Put+import Data.Text.Encoding+import qualified Data.Text as T++instance Serialize Header where+ get = Header+ <$> getCookie+ <*> getDataOffset+ <*> getTableOffset+ <*> getVersion+ <*> getMaxTableEntries+ <*> getBlockSize+ <*> getCheckSum+ <*> getParentUniqueId+ <*> getParentTimeStamp+ <*> getByteString 4+ <*> getParentUnicodeName+ <*> getParentLocatorEntries+ <* getHeaderPadding+ put h = do+ putCookie $ headerCookie h+ putDataOffset $ headerDataOffset h+ putTableOffset $ headerTableOffset h+ putVersion $ headerVersion h+ putMaxTableEntries $ headerMaxTableEntries h+ putBlockSize $ headerBlockSize h+ putCheckSum $ headerCheckSum h+ putParentUniqueId $ headerParentUniqueId h+ putParentTimeStamp $ headerParentTimeStamp h+ putByteString $ headerReserved1 h+ putParentUnicodeName $ headerParentUnicodeName h+ putParentLocatorEntries $ headerParentLocatorEntries h+ putHeaderPadding++instance Serialize Footer where+ get = Footer+ <$> getCookie+ <*> getIsTemporaryDisk+ <*> getFormatVersion+ <*> getDataOffset+ <*> getTimeStamp+ <*> getCreatorApplication+ <*> getCreatorVersion+ <*> getCreatorHostOs+ <*> getOriginalSize+ <*> getCurrentSize+ <*> getDiskGeometry+ <*> getDiskType+ <*> getCheckSum+ <*> getUniqueId+ <*> getIsSavedState+ <* getFooterPadding+ put f = do+ putCookie $ footerCookie f+ putIsTemporaryDisk $ footerIsTemporaryDisk f+ putFormatVersion $ footerFormatVersion f+ putDataOffset $ footerDataOffset f+ putTimeStamp $ footerTimeStamp f+ putCreatorApplication $ footerCreatorApplication f+ putCreatorVersion $ footerCreatorVersion f+ putCreatorHostOs $ footerCreatorHostOs f+ putOriginalSize $ footerOriginalSize f+ putCurrentSize $ footerCurrentSize f+ putDiskGeometry $ footerDiskGeometry f+ putDiskType $ footerDiskType f+ putCheckSum $ footerCheckSum f+ putUniqueId $ footerUniqueId f+ putIsSavedState $ footerIsSavedState f+ putFooterPadding++instance Serialize BatmapHeader where+ get = BatmapHeader+ <$> getCookie+ <*> getDataOffset+ <*> getWord32be+ <*> getVersion+ <*> getCheckSum+ put b = do+ putCookie $ batmapHeaderCookie b+ putDataOffset $ batmapHeaderOffset b+ putWord32be $ batmapHeaderSize b+ putVersion $ batmapHeaderVersion b+ putCheckSum $ batmapHeaderCheckSum b++footerPaddingLength = 427+getFooterPadding = getByteString footerPaddingLength+putFooterPadding = putByteString $ B.replicate footerPaddingLength 0++headerPaddingLength = 256+getHeaderPadding = skip headerPaddingLength+putHeaderPadding = putByteString $ B.replicate headerPaddingLength 0++getCookie = cookie <$> getByteString 8+putCookie (Cookie c) = putByteString c++getBlockSize = getWord32be+putBlockSize = putWord32be+getCheckSum = getWord32be+putCheckSum = putWord32be+getCurrentSize = getWord64be+putCurrentSize = putWord64be+getDataOffset = getWord64be+putDataOffset = putWord64be+getMaxTableEntries = getWord32be+putMaxTableEntries = putWord32be+getOriginalSize = getWord64be+putOriginalSize = putWord64be+getParentTimeStamp = getWord32be+putParentTimeStamp = putWord32be+getTableOffset = getWord64be+putTableOffset = putWord64be+getTimeStamp = getWord32be+putTimeStamp = putWord32be++getCreatorApplication = creatorApplication <$> getByteString 4+putCreatorApplication (CreatorApplication c) = putByteString c++getCreatorHostOs = convert <$> getWord32be where+ convert 0x4D616320 = CreatorHostOsMacintosh+ convert 0x5769326B = CreatorHostOsWindows+ convert _ = CreatorHostOsUnknown+putCreatorHostOs v = putWord32be $ case v of+ CreatorHostOsMacintosh -> 0x4D616320+ CreatorHostOsWindows -> 0x5769326B+ CreatorHostOsUnknown -> 0++getDiskType = convert <$> getWord32be where+ convert 2 = DiskTypeFixed+ convert 3 = DiskTypeDynamic+ convert 4 = DiskTypeDifferencing+ convert _ = error "invalid disk type"+putDiskType v = putWord32be $ case v of+ DiskTypeFixed -> 2+ DiskTypeDynamic -> 3+ DiskTypeDifferencing -> 4++getDiskGeometry = DiskGeometry <$> getWord16be <*> getWord8 <*> getWord8+putDiskGeometry (DiskGeometry c h s) = putWord16be c >> putWord8 h >> putWord8 s++getIsTemporaryDisk = (\n -> n .&. 1 == 1) <$> getWord32be+putIsTemporaryDisk i = putWord32be ((if i then 1 else 0) .|. 0x2)++getIsSavedState = (== 1) <$> getWord8+putIsSavedState i = putWord8 (if i then 1 else 0)++getUniqueId = UniqueId <$> getByteString 16+putUniqueId (UniqueId i) = putByteString i++getParentUniqueId = getUniqueId+putParentUniqueId = putUniqueId++getVersion = Version <$> getWord16be <*> getWord16be+putVersion (Version major minor) = putWord16be major >> putWord16be minor++getCreatorVersion = getVersion+putCreatorVersion = putVersion+getFormatVersion = getVersion+putFormatVersion = putVersion++getParentUnicodeName = parentUnicodeName . demarshall <$> getByteString 512+ where demarshall = takeWhile ((/=) '\0') . T.unpack . decodeUtf16BE+putParentUnicodeName (ParentUnicodeName c)+ | blen > 512 = error "parent unicode name length is greater than 512"+ | otherwise = putByteString b >> putByteString (B.replicate (512 - blen) 0)+ where+ b = encodeUtf16BE $ T.pack c+ blen = B.length b++getParentLocatorEntry = parentLocatorEntry <$> getByteString 24+putParentLocatorEntry (ParentLocatorEntry e) = putByteString e++getParentLocatorEntries = parentLocatorEntries <$> replicateM 8 getParentLocatorEntry+putParentLocatorEntries (ParentLocatorEntries es) = mapM_ putParentLocatorEntry es
+ Data/VHD/Types.hs view
@@ -0,0 +1,112 @@+module Data.VHD.Types where++import Control.Exception+import Control.Monad+import qualified Data.ByteString as B+import Data.Word+import System.Random+import Text.Printf+import Data.List+import Data.Text.Encoding+import qualified Data.Text as T++data Header = Header+ { headerCookie :: Cookie+ , headerDataOffset :: Offset+ , headerTableOffset :: Offset+ , headerVersion :: Version+ , headerMaxTableEntries :: EntryCount+ , headerBlockSize :: BlockSize+ , headerCheckSum :: CheckSum+ , headerParentUniqueId :: UniqueId+ , headerParentTimeStamp :: TimeStamp+ , headerReserved1 :: B.ByteString+ , headerParentUnicodeName :: ParentUnicodeName+ , headerParentLocatorEntries :: ParentLocatorEntries+ } deriving (Show,Eq)++data Footer = Footer+ { footerCookie :: Cookie+ , footerIsTemporaryDisk :: Bool+ , footerFormatVersion :: Version+ , footerDataOffset :: Offset+ , footerTimeStamp :: TimeStamp+ , footerCreatorApplication :: CreatorApplication+ , footerCreatorVersion :: Version+ , footerCreatorHostOs :: CreatorHostOs+ , footerOriginalSize :: Size+ , footerCurrentSize :: Size+ , footerDiskGeometry :: DiskGeometry+ , footerDiskType :: DiskType+ , footerCheckSum :: CheckSum+ , footerUniqueId :: UniqueId+ , footerIsSavedState :: Bool+ } deriving (Show,Eq)++data BatmapHeader = BatmapHeader+ { batmapHeaderCookie :: Cookie+ , batmapHeaderOffset :: Offset+ , batmapHeaderSize :: Word32+ , batmapHeaderVersion :: Version+ , batmapHeaderCheckSum :: CheckSum+ } deriving (Show,Eq)++type BlockSize = Word32+type DiskGeometryCylinders = Word16+type DiskGeometryHeads = Word8+type DiskGeometrySectorsPerTrack = Word8+type CheckSum = Word32+type EntryCount = Word32+type Offset = Word64+type Size = Word64+type TimeStamp = Word32++data Version = Version VersionMajor VersionMinor deriving (Show,Eq)+type VersionMajor = Word16+type VersionMinor = Word16++data CreatorHostOs+ = CreatorHostOsUnknown+ | CreatorHostOsWindows+ | CreatorHostOsMacintosh deriving (Show,Eq)++data DiskGeometry = DiskGeometry+ DiskGeometryCylinders+ DiskGeometryHeads+ DiskGeometrySectorsPerTrack deriving (Show,Eq)++data DiskType+ = DiskTypeFixed+ | DiskTypeDynamic+ | DiskTypeDifferencing deriving (Show,Eq)++newtype Cookie = Cookie B.ByteString deriving (Show,Eq)+newtype CreatorApplication = CreatorApplication B.ByteString deriving (Show,Eq)+newtype ParentLocatorEntry = ParentLocatorEntry B.ByteString deriving (Show,Eq)+newtype ParentUnicodeName = ParentUnicodeName String deriving (Show,Eq)+newtype UniqueId = UniqueId B.ByteString deriving (Eq)++instance Show UniqueId where+ show (UniqueId b) = intercalate "-" $ map disp [[0..3],[4,5],[6,7],[8,9],[10..15]]+ where disp = concatMap (printf "%02x" . B.index b)++newtype ParentLocatorEntries = ParentLocatorEntries [ParentLocatorEntry] deriving (Show,Eq)++cookie c = assert (B.length c == 8) $ Cookie c+creatorApplication a = assert (B.length a == 4) $ CreatorApplication a+parentLocatorEntries e = assert ( length e == 8) $ ParentLocatorEntries e+parentLocatorEntry e = assert (B.length e == 24) $ ParentLocatorEntry e+uniqueId i = assert (B.length i == 16) $ UniqueId i++parentUnicodeName n+ | encodedLength > 512 = error "parent unicode name length need to be < 512 bytes"+ | otherwise = ParentUnicodeName n+ where+ encodedLength = B.length $ encodeUtf16BE $ T.pack n++randomUniqueId :: IO UniqueId+randomUniqueId+ = liftM (uniqueId . B.pack)+ $ replicateM 16+ $ liftM fromIntegral+ $ randomRIO (0 :: Int, 255)
+ Data/VHD/Utils.hs view
@@ -0,0 +1,20 @@+module Data.VHD.Utils+ ( divRoundUp+ , roundUpToModulo+ , hAlign+ ) where++import Control.Monad (unless)+import System.IO+import qualified Data.ByteString as B++divRoundUp a b = let (d,m) = a `divMod` b in d + if m > 0 then 1 else 0++roundUpToModulo n m+ | n `mod` m == 0 = n+ | otherwise = n + m - (n `mod` m)++-- | align an handle to the next modulo+hAlign :: Handle -> Int -> IO ()+hAlign h n = hTell h >>= \i -> unless ((i `mod` fromIntegral n) == 0) (realign i)+ where realign i = B.hPut h $ B.replicate (n - fromIntegral (i `mod` fromIntegral n)) 0
+ LICENCE view
@@ -0,0 +1,29 @@+Copyright (c) Citrix Systems Inc. 2011. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Citrix Systems Inc. nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,1 @@+A library for inspecting and manipulating virtual hard disk (VHD) files.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Tests.hs view
@@ -0,0 +1,89 @@+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+ ]
+ Vhd.hs view
@@ -0,0 +1,106 @@+import Data.VHD+import Data.VHD.Types+import Data.VHD.Block+import Data.VHD.Context+import Data.VHD.Bat+import Data.VHD.CheckSum+import System.Environment (getArgs)+import System.IO+import Text.Printf+import Control.Monad+import Data.Char++import Data.IORef++import qualified Data.ByteString as B++showBlockSize i+ | i < 1024 = printf "%d bytes" i+ | i < (1024^2) = printf "%d kilobytes" (i`div`1024)+ | i < (1024^3) = printf "%d megabytes" (i`div`(1024^2))+ | otherwise = printf "%d gigabytes" (i`div`(1024^3))++cmdCreate [name,size] = create name $ defaultCreateParameters { size = (read size) * 1024 * 1024, useBatmap = True }+cmdCreate _ = error "usage: create <name> <size Mb>"++cmdRead [file] = withVhdContext file $ \ctx -> do+ let hdr = ctxHeader ctx+ let ftr = ctxFooter ctx+ mapM_ (\(f,s) -> putStrLn (f ++ " : " ++ s))+ [ ("cookie ", show $ headerCookie hdr)+ , ("version ", show $ headerVersion hdr)+ , ("max-table-entries", show $ headerMaxTableEntries hdr)+ , ("block-size ", showBlockSize $ headerBlockSize hdr)+ , ("header-checksum ", printf "%08x (%s)" (headerCheckSum hdr)+ (if verifyHeaderChecksum hdr then "valid" else "invalid"))+ , ("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 ", printf "%08x (%s)" (footerCheckSum ftr)+ (if verifyFooterChecksum ftr then "valid" else "invalid"))+ , ("uuid ", show $ footerUniqueId ftr)+ , ("timestamp ", show $ footerTimeStamp ftr)+ ]+ allocated <- newIORef 0+ batIterate (ctxBatPtr ctx) (fromIntegral $ headerMaxTableEntries hdr) $ \i n -> do+ unless (n == 0xffffffff) $ modifyIORef allocated ((+) 1) >> printf "BAT[%.5x] = %08x\n" i n+ nb <- readIORef allocated+ putStrLn ("block allocated : " ++ show nb ++ "/" ++ show (headerMaxTableEntries hdr))+cmdRead _ = error "usage: read <file>"++cmdPropGet [file, key] = withVhdContext file $ \ctx -> do+ case map toLower key of+ "max-table-entries" -> putStrLn $ show $ headerMaxTableEntries $ ctxHeader ctx+ "blocksize" -> putStrLn $ show $ headerBlockSize $ ctxHeader ctx+ "disk-type" -> putStrLn $ show $ footerDiskType $ ctxFooter ctx+ "current-size" -> putStrLn $ show $ footerCurrentSize $ ctxFooter ctx+ "uuid" -> putStrLn $ show $ footerUniqueId $ ctxFooter ctx+ "parent-uuid" -> putStrLn $ show $ headerParentUniqueId $ ctxHeader ctx+ "parent-timestamp" -> putStrLn $ show $ headerParentTimeStamp $ ctxHeader ctx+ "parent-filepath" -> putStrLn $ show $ headerParentUnicodeName $ ctxHeader ctx+ "timestamp" -> putStrLn $ show $ footerTimeStamp $ ctxFooter ctx+ _ -> error "unknown key"+cmdPropGet _ = error "usage: prop-get <file> <key>"++cmdConvert [fileRaw,fileVhd,size] = do+ create fileVhd $ defaultCreateParameters+ { size = read size * 1024 * 1024+ , useBatmap = True+ }+ withVhdContext fileVhd $ \ctx -> do+ withFile fileRaw ReadMode $ \handle -> do+ loop ctx handle 0+ where+ loop ctx handle offset = do+ srcblock <- B.hGet handle (fromIntegral blockSize)+ if B.null srcblock+ then return ()+ else do+ unless (isBlockZero srcblock) $ do+ let blockNb = offset `div` fromIntegral blockSize+ extendBlock ctx blockNb+ sectorOff <- batRead (ctxBatPtr ctx) blockNb+ withBlock (ctxFilePath ctx) (headerBlockSize $ ctxHeader ctx) sectorOff $ \block ->+ writeBlock block srcblock 0+ putStrLn ("block " ++ show (offset `div` fromIntegral blockSize) ++ " written")+ -- do something with block+ loop ctx handle (offset + fromIntegral (B.length srcblock))+++ isBlockZero = B.all ((==) 0)+ blockSize = 2 * 1024 * 1024+cmdConvert _ = error "usage: convert <raw file> <vhd file> <size Mb>"++main = do+ args <- getArgs+ case args of+ "create":xs -> cmdCreate xs+ "read":xs -> cmdRead xs+ "convert":xs -> cmdConvert xs+ "prop-get":xs -> cmdPropGet xs
+ vhd.cabal view
@@ -0,0 +1,67 @@+Name: vhd+Version: 0.1+Synopsis: Implementation of the Virtual Hard Disk (VHD) disk format+Description: Provide a toolbox of function to manipulate VHD files.+Author: Jonathan Knowles, Vincent Hanquez+Maintainer: jonathan.knowles@eu.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+Data-files: README++Flag test+ Description: Build unit test+ Default: False++Flag executable+ Description: Build executables+ Default: False++Library+ Build-depends: base >= 4 && < 5+ , bytestring+ , mmap+ , text+ , time+ , cereal+ , random+ , storable-endian+ Exposed-modules: Data.VHD+ Other-modules: Data.VHD.Bat+ Data.VHD.Bitmap+ Data.VHD.Block+ Data.VHD.CheckSum+ Data.VHD.Context+ Data.VHD.Geometry+ Data.VHD.Serialize+ Data.VHD.Types+ Data.VHD.Utils++Executable Tests+ Main-Is: Tests.hs+ if flag(test)+ Buildable: True+ Build-depends: base >= 3 && < 5+ , QuickCheck >= 2+ , bytestring+ , test-framework >= 0.3+ , test-framework-quickcheck2 >= 0.2+ else+ Buildable: False++Executable vhd+ Main-Is: Vhd.hs+ if flag(executable)+ Buildable: True+ Build-depends: base >= 3 && < 5+ else+ Buildable: False++source-repository head+ type: git+ location: git://github.com/jonathanknowles/hs-vhd