module Data.Vhd
( 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 as BitSet
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Internal as B
import Data.Maybe
import Data.Serialize
import Data.Monoid (mempty)
import Data.Vhd.Bat
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.Ptr
import Prelude hiding (subtract)
import System.FilePath.Posix
import System.IO
data Vhd = Vhd
{ 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 bsz
where BlockSize bsz = vhdBlockSize vhd
withVhd :: FilePath -> (Vhd -> IO a) -> IO a
withVhd = withVhdInner []
where
blockCount node = headerMaxTableEntries $ nodeHeader node
blockSize node = headerBlockSize $ nodeHeader node
diskType node = footerDiskType $ nodeFooter node
withVhdInner accumulatedNodes filePath f =
withVhdNode filePath $ \node -> do
if diskType node == DiskTypeDifferencing
then withVhdInner (node : accumulatedNodes) (parentPath node) f
else do
validateBlockSize $ blockSize node
f $ Vhd
{ vhdBlockCount = blockCount node
, vhdBlockSize = blockSize node
, vhdNodes = reverse $ node : accumulatedNodes
}
where parentPath node = resolveColocatedFilePath filePath p
where ParentUnicodeName p = headerParentUnicodeName $ nodeHeader node
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 :: 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
}
getInfo :: FilePath -> IO (Either String (Header, Footer))
getInfo filePath = withFile filePath ReadMode $ \handle -> do
footer <- decode <$> B.hGet handle 512
header <- decode <$> B.hGet handle 1024
case (footer, header) of
(Left err, _) -> return $ Left err
(_, Left err) -> return $ Left err
(Right f, Right h) -> return $ Right (h, f)
create :: FilePath -> CreateParameters -> IO ()
create filePath createParams
| 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 sectorLength
B.hPut handle $ B.replicate (fromIntegral batSize) 0xff
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
BlockSize bsz = createBlockSize createParams
virtSize = createVirtualSize createParams
maxTableEntries = fromIntegral (virtSize `divRoundUp` fromIntegral bsz)
batSize = (maxTableEntries * 4) `roundUpToModulo` sectorLength
footerSize = 512
headerSize = 1024
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 = hasBatmap headNodeBat
, createVirtualSize = virtualSize parentVhd
}
where headNode = head $ vhdNodes parentVhd
headNodeBat = nodeBat headNode
headNodeFooter = nodeFooter headNode
parentFilePath = makeRelative (takeDirectory childFilePath) (nodeFilePath headNode)
readData :: Vhd -> IO BL.ByteString
readData vhd = readDataRange vhd 0 (virtualSize vhd)
readDataRange :: Vhd
-> Word64
-> Word64
-> 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)
writeDataRange :: Vhd
-> Word64
-> BL.ByteString
-> 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
(_,bmap) = getVhdBlockMapper node
node = head $ vhdNodes vhd
offsetMax = virtualSize vhd
blockSize = vhdBlockSize vhd
readDataBlock :: Vhd -> VirtualBlockAddress -> IO B.ByteString
readDataBlock vhd virtualBlockAddress =
readDataBlockRange vhd virtualBlockAddress 0 (vhdSectorPerBlock 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)
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
nodeOffsets :: IO [(VhdNode, PhysicalSectorAddress)]
nodeOffsets = fmap catMaybes $ mapM maybeNodeOffset $ vhdNodes vhd
where maybeNodeOffset node = (fmap . fmap) (node, ) $ lookupBlock (nodeBat node) virtualBlockAddress
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
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
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
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