diff --git a/Data/BitSet.hs b/Data/BitSet.hs --- a/Data/BitSet.hs +++ b/Data/BitSet.hs @@ -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] diff --git a/Data/Range.hs b/Data/Range.hs --- a/Data/Range.hs +++ b/Data/Range.hs @@ -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 diff --git a/Data/Vhd.hs b/Data/Vhd.hs --- a/Data/Vhd.hs +++ b/Data/Vhd.hs @@ -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 diff --git a/Data/Vhd/Bat.hs b/Data/Vhd/Bat.hs --- a/Data/Vhd/Bat.hs +++ b/Data/Vhd/Bat.hs @@ -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) diff --git a/Data/Vhd/Batmap.hs b/Data/Vhd/Batmap.hs new file mode 100644 --- /dev/null +++ b/Data/Vhd/Batmap.hs @@ -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)) } diff --git a/Data/Vhd/Bitmap.hs b/Data/Vhd/Bitmap.hs --- a/Data/Vhd/Bitmap.hs +++ b/Data/Vhd/Bitmap.hs @@ -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) diff --git a/Data/Vhd/Block.hs b/Data/Vhd/Block.hs --- a/Data/Vhd/Block.hs +++ b/Data/Vhd/Block.hs @@ -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 diff --git a/Data/Vhd/Checksum.hs b/Data/Vhd/Checksum.hs --- a/Data/Vhd/Checksum.hs +++ b/Data/Vhd/Checksum.hs @@ -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) diff --git a/Data/Vhd/Crypt.hs b/Data/Vhd/Crypt.hs new file mode 100644 --- /dev/null +++ b/Data/Vhd/Crypt.hs @@ -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 diff --git a/Data/Vhd/Footer.hs b/Data/Vhd/Footer.hs new file mode 100644 --- /dev/null +++ b/Data/Vhd/Footer.hs @@ -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 diff --git a/Data/Vhd/Geometry.hs b/Data/Vhd/Geometry.hs --- a/Data/Vhd/Geometry.hs +++ b/Data/Vhd/Geometry.hs @@ -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') diff --git a/Data/Vhd/Header.hs b/Data/Vhd/Header.hs new file mode 100644 --- /dev/null +++ b/Data/Vhd/Header.hs @@ -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 diff --git a/Data/Vhd/Lowlevel.hs b/Data/Vhd/Lowlevel.hs new file mode 100644 --- /dev/null +++ b/Data/Vhd/Lowlevel.hs @@ -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 diff --git a/Data/Vhd/Node.hs b/Data/Vhd/Node.hs --- a/Data/Vhd/Node.hs +++ b/Data/Vhd/Node.hs @@ -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)) diff --git a/Data/Vhd/Serialize.hs b/Data/Vhd/Serialize.hs --- a/Data/Vhd/Serialize.hs +++ b/Data/Vhd/Serialize.hs @@ -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 diff --git a/Data/Vhd/Time.hs b/Data/Vhd/Time.hs new file mode 100644 --- /dev/null +++ b/Data/Vhd/Time.hs @@ -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 diff --git a/Data/Vhd/Types.hs b/Data/Vhd/Types.hs --- a/Data/Vhd/Types.hs +++ b/Data/Vhd/Types.hs @@ -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 diff --git a/Data/Vhd/UniqueId.hs b/Data/Vhd/UniqueId.hs new file mode 100644 --- /dev/null +++ b/Data/Vhd/UniqueId.hs @@ -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) diff --git a/Data/Vhd/Utils.hs b/Data/Vhd/Utils.hs --- a/Data/Vhd/Utils.hs +++ b/Data/Vhd/Utils.hs @@ -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 diff --git a/Tests.hs b/Tests.hs deleted file mode 100644 --- a/Tests.hs +++ /dev/null @@ -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 - ] diff --git a/Tests/Tests.hs b/Tests/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests/Tests.hs @@ -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 + ] diff --git a/Tools/Vhd.hs b/Tools/Vhd.hs new file mode 100644 --- /dev/null +++ b/Tools/Vhd.hs @@ -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 " + +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 " + +cmdCreate _ [name, size] = + create name $ defaultCreateParameters + { createVirtualSize = read size * 1024 * 1024 } +cmdCreate _ _ = error "usage: create " + +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 " + +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 " + +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 " + +cmdSnapshot _ [fileVhdParent, fileVhdChild] = + withVhd fileVhdParent $ \vhdParent -> snapshot vhdParent fileVhdChild +cmdSnapshot _ _ = error "usage: snapshot " + +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 " + 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 " + 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 diff --git a/Vhd.hs b/Vhd.hs deleted file mode 100644 --- a/Vhd.hs +++ /dev/null @@ -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 " - -cmdCreate [name, size] = - create name $ defaultCreateParameters - { createVirtualSize = read size * 1024 * 1024 } -cmdCreate _ = error "usage: create " - -cmdExtract [fileVhd, fileRaw] = withVhd fileVhd $ readData >=> BL.writeFile fileRaw -cmdExtract _ = error "usage: extract " - -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 " - -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 " - -cmdSnapshot [fileVhdParent, fileVhdChild] = - withVhd fileVhdParent $ \vhdParent -> snapshot vhdParent fileVhdChild -cmdSnapshot _ = error "usage: snapshot " - -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 diff --git a/vhd.cabal b/vhd.cabal --- a/vhd.cabal +++ b/vhd.cabal @@ -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