diff --git a/Data/VHD.hs b/Data/VHD.hs new file mode 100644 --- /dev/null +++ b/Data/VHD.hs @@ -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) + } diff --git a/Data/VHD/Bat.hs b/Data/VHD/Bat.hs new file mode 100644 --- /dev/null +++ b/Data/VHD/Bat.hs @@ -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 diff --git a/Data/VHD/Bitmap.hs b/Data/VHD/Bitmap.hs new file mode 100644 --- /dev/null +++ b/Data/VHD/Bitmap.hs @@ -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) diff --git a/Data/VHD/Block.hs b/Data/VHD/Block.hs new file mode 100644 --- /dev/null +++ b/Data/VHD/Block.hs @@ -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 diff --git a/Data/VHD/CheckSum.hs b/Data/VHD/CheckSum.hs new file mode 100644 --- /dev/null +++ b/Data/VHD/CheckSum.hs @@ -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 diff --git a/Data/VHD/Context.hs b/Data/VHD/Context.hs new file mode 100644 --- /dev/null +++ b/Data/VHD/Context.hs @@ -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 diff --git a/Data/VHD/Geometry.hs b/Data/VHD/Geometry.hs new file mode 100644 --- /dev/null +++ b/Data/VHD/Geometry.hs @@ -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') diff --git a/Data/VHD/Serialize.hs b/Data/VHD/Serialize.hs new file mode 100644 --- /dev/null +++ b/Data/VHD/Serialize.hs @@ -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 diff --git a/Data/VHD/Types.hs b/Data/VHD/Types.hs new file mode 100644 --- /dev/null +++ b/Data/VHD/Types.hs @@ -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) diff --git a/Data/VHD/Utils.hs b/Data/VHD/Utils.hs new file mode 100644 --- /dev/null +++ b/Data/VHD/Utils.hs @@ -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 diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,1 @@ +A library for inspecting and manipulating virtual hard disk (VHD) files. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -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 + ] diff --git a/Vhd.hs b/Vhd.hs new file mode 100644 --- /dev/null +++ b/Vhd.hs @@ -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 " + +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 " + +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 " + +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 " + +main = do + args <- getArgs + case args of + "create":xs -> cmdCreate xs + "read":xs -> cmdRead xs + "convert":xs -> cmdConvert xs + "prop-get":xs -> cmdPropGet xs diff --git a/vhd.cabal b/vhd.cabal new file mode 100644 --- /dev/null +++ b/vhd.cabal @@ -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