#define FILEPATH FilePath
module System.Linux.Btrfs
(
FileSize, ObjectType, ObjectId, InodeNum, SubvolId, CompressionType(..)
, cloneFd, clone, cloneNew
, cloneRangeFd, cloneRange
, CloneResult(..)
, cloneRangeIfSameFd, cloneRangeIfSame
, createSubvol
, destroySubvol
, snapshotFd, snapshot
, getSubvolReadOnlyFd, getSubvolReadOnly
, setSubvolReadOnlyFd, setSubvolReadOnly
, getSubvolFd, getSubvol
, lookupSubvolFd, lookupSubvol
, resolveSubvolFd, resolveSubvol
, rootSubvol
, listSubvolsFd, listSubvols
, listSubvolPathsFd, listSubvolPaths
, childSubvolsFd, childSubvols
, childSubvolPathsFd, childSubvolPaths
, SubvolInfo(..)
, getSubvolInfoFd, getSubvolInfo
, getSubvolByUuidFd, getSubvolByUuid
, getSubvolByReceivedUuidFd, getSubvolByReceivedUuid
, defragFd, defrag
, DefragRangeArgs(..), defaultDefragRangeArgs
, defragRangeFd, defragRange
, syncFd, sync
, startSyncFd, startSync
, waitSyncFd, waitSync
, resolveLogicalFd, resolveLogical
, resolveInodeFd, resolveInode
, lookupInodeFd, lookupInode
, getFileNoCOWFd, getFileNoCOW
, setFileNoCOWFd, setFileNoCOW
, SearchKey(..)
, defaultSearchKey
, SearchHeader(..)
, treeSearchFd, treeSearch
, treeSearchListFd, treeSearchList
, findFirstItemFd, findFirstItem
) where
import System.Posix.Types
import System.Posix.IO hiding (openFd)
import System.Posix.Files
import System.Posix.Signals
import System.IO.Error
import Control.Exception
import Control.Monad
import Data.IORef
import Data.Time.Clock (UTCTime)
import Data.Monoid
import System.Linux.Btrfs.FilePathLike
import Foreign
import Foreign.C.Types
import Foreign.C.String (CStringLen)
import Foreign.C.Error
import Data.Word.Endian
import System.Linux.Btrfs.Time
import System.Linux.Btrfs.UUID
foreign import ccall safe
ioctl :: Fd -> CULong -> Ptr a -> IO CInt
foreign import ccall unsafe "ioctl"
ioctl_fast :: Fd -> CULong -> Ptr a -> IO CInt
type FileSize = Word64
type ObjectType = Word8
type ObjectId = Word64
type InodeNum = ObjectId
type SubvolId = ObjectId
data CompressionType = Zlib | LZO
deriving (Show, Read, Eq, Enum, Bounded)
cloneFd :: Fd -> Fd -> IO ()
cloneFd srcFd dstFd =
throwErrnoIfMinus1_ "cloneFd" $
ioctl_fast dstFd (1074041865) srcFdP
where
srcFdP = intPtrToPtr (fromIntegral srcFd)
clone
:: FILEPATH
-> FILEPATH
-> IO ()
clone srcPath dstPath =
withFd srcPath ReadOnly $ \srcFd ->
withFd dstPath WriteOnly $ \dstFd ->
cloneFd srcFd dstFd
cloneNew :: FILEPATH -> FILEPATH -> IO ()
cloneNew srcPath dstPath =
withFd srcPath ReadOnly $ \srcFd -> do
stat <- getFdStatus srcFd
let mode = fileMode stat
bracket (openFd dstPath WriteOnly (Just mode) defaultFileFlags {trunc = True}) closeFd $ \dstFd ->
cloneFd srcFd dstFd
cloneRangeFd :: Fd -> FileSize -> FileSize -> Fd -> FileSize -> IO ()
cloneRangeFd srcFd srcOff srcLen dstFd dstOff =
allocaBytesZero ((32)) $ \cra -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) cra (fromIntegral srcFd :: Int64)
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) cra (srcOff :: Word64)
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) cra (srcLen :: Word64)
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) cra (dstOff :: Word64)
throwErrnoIfMinus1_ "cloneRangeFd" $
ioctl_fast dstFd (1075876877) cra
cloneRange
:: FILEPATH
-> FileSize
-> FileSize
-> FILEPATH
-> FileSize
-> IO ()
cloneRange srcPath srcOff srcLen dstPath dstOff =
withFd srcPath ReadOnly $ \srcFd ->
withFd dstPath WriteOnly $ \dstFd ->
cloneRangeFd srcFd srcOff srcLen dstFd dstOff
data SameExtentInfoIn = SameExtentInfoIn
Fd
FileSize
instance Storable SameExtentInfoIn where
sizeOf _ = ((32))
alignment _ = alignment (undefined :: CInt)
poke ptr (SameExtentInfoIn dstFd dstOff) = do
memset ptr 0 ((32))
let dstFd' = fromIntegral dstFd :: Int64
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr dstFd'
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr dstOff
peek _ = error "not implemented"
data SameExtentInfoOut = SameExtentInfoOut
Int32
FileSize
instance Storable SameExtentInfoOut where
sizeOf _ = ((32))
alignment _ = alignment (undefined :: CInt)
poke _ _ = error "not implemented"
peek ptr = do
status <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) ptr
bytes <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr
return (SameExtentInfoOut status bytes)
data CloneResult
= CRError IOError
| CRDataDiffers
| CRSuccess FileSize
deriving (Show, Eq)
cloneRangeIfSameFd :: Fd -> FileSize -> FileSize -> [(Fd, FileSize)] -> IO [CloneResult]
cloneRangeIfSameFd srcFd srcOff srcLen dsts = do
unless (dstCount <= maxCount) $
ioError $ flip ioeSetErrorString ("too many destination files (more than " ++
show maxCount ++ ")")
$ mkIOError illegalOperationErrorType "cloneRangeIfSameFd" Nothing Nothing
allocaBytes saSize $ \sa -> do
memset sa 0 ((24))
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) sa srcOff
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) sa srcLen
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) sa dstCount'
let info = ((\hsc_ptr -> hsc_ptr `plusPtr` 24)) sa
pokeArray info (map (uncurry SameExtentInfoIn) dsts)
throwErrnoIfMinus1_ "cloneRangeIfSameFd" $
ioctl srcFd (3222836278) sa
res <- peekArray dstCount info
return $ flip map res $ \(SameExtentInfoOut status bytes) ->
if status == 0 then
CRSuccess bytes
else if status == (1) then
CRDataDiffers
else if status <= 0 then
CRError $ errnoToIOError "cloneRangeIfSameFd"
(Errno $ fromIntegral $ status)
Nothing Nothing
else
error $ "unknown status value (" ++ show status ++ ")"
where
saSize = ((24)) +
dstCount * ((32))
dstCount = length dsts
dstCount' = fromIntegral dstCount :: Word64
maxCount = fromIntegral (maxBound :: Word16)
cloneRangeIfSame
:: FILEPATH
-> FileSize
-> FileSize
-> [(FILEPATH, FileSize)]
-> IO [CloneResult]
cloneRangeIfSame srcPath srcOff srcLen dstsP0 =
withFd srcPath ReadOnly $ \srcFd ->
loop srcFd (reverse dstsP0) []
where
loop srcFd ((dstPath, dstOff) : dstsP) dsts =
withFd dstPath WriteOnly $ \fd ->
loop srcFd dstsP ((fd, dstOff) : dsts)
loop srcFd [] dsts =
cloneRangeIfSameFd srcFd srcOff srcLen dsts
simpleSubvolOp :: String -> FILEPATH -> CULong -> IO ()
simpleSubvolOp loc path req =
withSplitPathOpenParent loc (4087) path $ \(cName, l) dirFd ->
allocaBytesZero ((4096)) $ \iva -> do
let ivaName = ((\hsc_ptr -> hsc_ptr `plusPtr` 8)) iva
copyBytes ivaName cName l
throwErrnoIfMinus1_ loc $
ioctl dirFd req iva
createSubvol :: FILEPATH -> IO ()
createSubvol path =
simpleSubvolOp "createSubvol" path (1342215182)
destroySubvol :: FILEPATH -> IO ()
destroySubvol path =
simpleSubvolOp "destroySubvol" path (1342215183)
snapshotFd :: Fd -> FILEPATH -> Bool -> IO ()
snapshotFd srcFd dstPath readOnly =
withSplitPathOpenParent "snapshotFd" (4039) dstPath $ \(cName, l) dirFd ->
allocaBytesZero ((4096)) $ \iva -> do
let ivaName = ((\hsc_ptr -> hsc_ptr `plusPtr` 56)) iva
copyBytes ivaName cName l
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) iva (fromIntegral srcFd :: Int64)
when readOnly $
setFlags (((\hsc_ptr -> hsc_ptr `plusPtr` 16)) iva)
((2) :: Word64)
throwErrnoIfMinus1_ "snapshotFd" $
ioctl dirFd (1342215191) iva
snapshot
:: FILEPATH
-> FILEPATH
-> Bool
-> IO ()
snapshot srcPath dstPath readOnly =
withFd srcPath ReadOnly $ \srcFd ->
snapshotFd srcFd dstPath readOnly
getSubvolReadOnlyFd :: Fd -> IO Bool
getSubvolReadOnlyFd fd =
alloca $ \flagsPtr -> do
throwErrnoIfMinus1_ "getSubvolReadOnlyFd" $
ioctl fd (2148045849) flagsPtr
flags <- peek flagsPtr :: IO Word64
return (flags .&. (2) /= 0)
getSubvolReadOnly :: FILEPATH -> IO Bool
getSubvolReadOnly path = withFd path ReadOnly getSubvolReadOnlyFd
setSubvolReadOnlyFd :: Fd -> Bool -> IO ()
setSubvolReadOnlyFd fd readOnly =
alloca $ \flagsPtr -> do
throwErrnoIfMinus1_ "setSubvolReadOnlyFd" $
ioctl fd (2148045849) flagsPtr
if readOnly then
setFlags flagsPtr ((2) :: Word64)
else
clearFlags flagsPtr ((2) :: Word64)
throwErrnoIfMinus1_ "setSubvolReadOnlyFd" $
ioctl fd (1074304026) flagsPtr
setSubvolReadOnly :: FILEPATH -> Bool -> IO ()
setSubvolReadOnly path readOnly =
withFd path ReadOnly $ \fd -> setSubvolReadOnlyFd fd readOnly
getSubvolFd :: Fd -> IO SubvolId
getSubvolFd fd = do
(subvolId, _) <- lookupInodeFd fd 0 (256)
return subvolId
getSubvol :: FILEPATH -> IO SubvolId
getSubvol path = withFd path ReadOnly getSubvolFd
lookupSubvolFd :: Fd -> SubvolId -> IO (SubvolId, InodeNum, FILEPATH)
lookupSubvolFd fd subvolId = do
let sk = defaultSearchKey
{ skTreeId = (1)
, skMinObjectId = subvolId
, skMaxObjectId = subvolId
, skMinType = (144)
, skMaxType = (144)
}
findFirstItemFd fd sk $ \sh rr -> do
(dirId, name) <- peekRootRef rr
return (shOffset sh, dirId, name)
lookupSubvol
:: FILEPATH
-> SubvolId
-> IO (SubvolId, InodeNum, FILEPATH)
lookupSubvol path subvolId =
withFd path ReadOnly $ \fd ->
lookupSubvolFd fd subvolId
resolveSubvolFd :: Fd -> SubvolId -> IO FILEPATH
resolveSubvolFd fd subvolId
| subvolId == rootSubvol = return mempty
| otherwise = do
(parentId, dirId, name) <- lookupSubvolFd fd subvolId
parentPath <- resolveSubvolFd fd parentId
if dirId == (256) then
return (parentPath </> name)
else do
(_, dirName) <- lookupInodeFd fd parentId dirId
return (parentPath </> dirName </> name)
resolveSubvol
:: FILEPATH
-> SubvolId
-> IO FILEPATH
resolveSubvol path subvolId =
withFd path ReadOnly $ \fd ->
resolveSubvolFd fd subvolId
rootSubvol :: SubvolId
rootSubvol = (5)
listSubvolsFd :: Fd -> IO [(SubvolId, SubvolId, InodeNum, FILEPATH)]
listSubvolsFd fd = do
let sk = defaultSearchKey
{ skTreeId = (1)
, skMinObjectId = (256)
, skMaxObjectId = (18446744073709551360)
, skMinType = (144)
, skMaxType = (144)
}
treeSearchListFd fd sk unpack
where
unpack sh rr
| shType sh /= (144) =
return Nothing
| otherwise = do
(dirId, name) <- peekRootRef rr
return $ Just (shObjectId sh, shOffset sh, dirId, name)
listSubvols :: FILEPATH -> IO [(SubvolId, SubvolId, InodeNum, FILEPATH)]
listSubvols path =
withFd path ReadOnly listSubvolsFd
listSubvolPathsFd :: Fd -> IO [(SubvolId, SubvolId, FILEPATH)]
listSubvolPathsFd fd = do
subvols <- listSubvolsFd fd
forM subvols $ \(subvolId, parentId, _, _) -> do
path <- resolveSubvolFd fd subvolId
return (subvolId, parentId, path)
listSubvolPaths :: FILEPATH -> IO [(SubvolId, SubvolId, FILEPATH)]
listSubvolPaths path =
withFd path ReadOnly listSubvolPathsFd
childSubvolsFd :: Fd -> SubvolId -> IO [(SubvolId, InodeNum, FILEPATH)]
childSubvolsFd fd subvolId = do
let sk = defaultSearchKey
{ skTreeId = (1)
, skMinObjectId = subvolId
, skMaxObjectId = subvolId
, skMinType = (156)
, skMaxType = (156)
}
treeSearchListFd fd sk unpack
where
unpack sh rr
| shType sh /= (156) =
return Nothing
| otherwise = do
(dirId, name) <- peekRootRef rr
return $ Just (shOffset sh, dirId, name)
childSubvols
:: FILEPATH
-> SubvolId
-> IO [(SubvolId, InodeNum, FILEPATH)]
childSubvols path subvolId =
withFd path ReadOnly $ \fd ->
childSubvolsFd fd subvolId
childSubvolPathsFd :: Fd -> SubvolId -> IO [(SubvolId, FILEPATH)]
childSubvolPathsFd fd subvolId = do
childs <- childSubvolsFd fd subvolId
forM childs $ \(childId, dirId, name) ->
if dirId == (256) then
return (childId, name)
else do
(_, dirName) <- lookupInodeFd fd subvolId dirId
return (childId, dirName </> name)
childSubvolPaths
:: FILEPATH
-> SubvolId
-> IO [(SubvolId, FILEPATH)]
childSubvolPaths path subvolId =
withFd path ReadOnly $ \fd ->
childSubvolPathsFd fd subvolId
data SubvolInfo = SubvolInfo
{ siGeneration :: Word64
, siLastSnapshot :: Maybe Word64
, siParSnapGen :: Maybe Word64
, siReadOnly :: Bool
, siUuid :: Maybe UUID
, siPUuid :: Maybe UUID
, siReceivedUuid :: Maybe UUID
, siCTransId :: Maybe Word64
, siOTransId :: Maybe Word64
, siSTransId :: Maybe Word64
, siRTransId :: Maybe Word64
, siCTime :: Maybe UTCTime
, siOTime :: Maybe UTCTime
, siSTime :: Maybe UTCTime
, siRTime :: Maybe UTCTime
}
deriving (Show, Eq)
getSubvolInfoFd :: Fd -> SubvolId -> IO SubvolInfo
getSubvolInfoFd fd subvolId
| subvolId /= rootSubvol &&
(subvolId < (256) || subvolId > (18446744073709551360)) =
ioError $ mkIOError doesNotExistErrorType
"getSubvolInfoFd"
Nothing Nothing
| otherwise = do
let sk = defaultSearchKey
{ skTreeId = (1)
, skMinObjectId = subvolId
, skMaxObjectId = subvolId
, skMinType = (132)
, skMaxType = (132)
}
findFirstItemFd fd sk unpack
where
unpack sh ri = do
LE64 generation <- ((\hsc_ptr -> peekByteOff hsc_ptr 160)) ri
LE64 lastSnapshot <- ((\hsc_ptr -> peekByteOff hsc_ptr 200)) ri
LE64 flags <- ((\hsc_ptr -> peekByteOff hsc_ptr 208)) ri
LE64 generationV2 <- ((\hsc_ptr -> peekByteOff hsc_ptr 239)) ri
let nv2 = generationV2 < generation
uuid <- ((\hsc_ptr -> peekByteOff hsc_ptr 247)) ri :: IO UUID
pUuid <- ((\hsc_ptr -> peekByteOff hsc_ptr 263)) ri :: IO UUID
receivedUuid <- ((\hsc_ptr -> peekByteOff hsc_ptr 279)) ri :: IO UUID
LE64 cTransId <- ((\hsc_ptr -> peekByteOff hsc_ptr 295)) ri
LE64 oTransId <- ((\hsc_ptr -> peekByteOff hsc_ptr 303)) ri
LE64 sTransId <- ((\hsc_ptr -> peekByteOff hsc_ptr 311)) ri
LE64 rTransId <- ((\hsc_ptr -> peekByteOff hsc_ptr 319)) ri
BtrfsTime cTime <- ((\hsc_ptr -> peekByteOff hsc_ptr 327)) ri
BtrfsTime oTime <- ((\hsc_ptr -> peekByteOff hsc_ptr 339)) ri
BtrfsTime sTime <- ((\hsc_ptr -> peekByteOff hsc_ptr 351)) ri
BtrfsTime rTime <- ((\hsc_ptr -> peekByteOff hsc_ptr 363)) ri
return $ SubvolInfo
{ siGeneration = generation
, siLastSnapshot = nothingIf (lastSnapshot == 0) $ lastSnapshot
, siParSnapGen = nothingIf (shOffset sh == 0) $ shOffset sh
, siReadOnly = flags .&. (2) /= 0
, siUuid = nothingIf nv2 uuid
, siPUuid = nothingIf (nv2 || shOffset sh == 0) pUuid
, siReceivedUuid = nothingIf (nv2 || sTransId == 0) receivedUuid
, siCTransId = nothingIf nv2 cTransId
, siOTransId = nothingIf (nv2 || oTransId == 0) oTransId
, siSTransId = nothingIf (nv2 || sTransId == 0) sTransId
, siRTransId = nothingIf (nv2 || rTransId == 0) rTransId
, siCTime = nothingIf nv2 cTime
, siOTime = nothingIf (nv2 || oTransId == 0) oTime
, siSTime = nothingIf (nv2 || sTransId == 0) sTime
, siRTime = nothingIf (nv2 || rTransId == 0) rTime
}
getSubvolInfo
:: FILEPATH
-> SubvolId
-> IO SubvolInfo
getSubvolInfo path subvolId =
withFd path ReadOnly $ \fd ->
getSubvolInfoFd fd subvolId
searchByUuidFd :: ObjectType -> Fd -> UUID -> IO SubvolId
searchByUuidFd typ fd (UUID hBE lBE) = do
let sk = defaultSearchKey
{ skTreeId = (9)
, skMinObjectId = hLE
, skMaxObjectId = hLE
, skMinType = typ
, skMaxType = typ
, skMinOffset = lLE
, skMaxOffset = lLE
}
findFirstItemFd fd sk $ \_ ptr ->
liftM fromLE64 $ peek ptr
where
lLE = invert64 lBE
hLE = invert64 hBE
getSubvolByUuidFd :: Fd -> UUID -> IO SubvolId
getSubvolByUuidFd =
searchByUuidFd (251)
getSubvolByUuid
:: FILEPATH
-> UUID
-> IO SubvolId
getSubvolByUuid path uuid =
withFd path ReadOnly $ \fd ->
getSubvolByUuidFd fd uuid
getSubvolByReceivedUuidFd :: Fd -> UUID -> IO SubvolId
getSubvolByReceivedUuidFd =
searchByUuidFd (252)
getSubvolByReceivedUuid
:: FILEPATH
-> UUID
-> IO SubvolId
getSubvolByReceivedUuid path uuid =
withFd path ReadOnly $ \fd ->
getSubvolByReceivedUuidFd fd uuid
defragFd :: Fd -> IO ()
defragFd fd =
throwErrnoIfMinus1_ "defragFd" $
withBlockSIGVTALRM $
ioctl fd (1342215170) nullPtr
defrag :: FILEPATH -> IO ()
defrag path = withFd path ReadWrite defragFd
data DefragRangeArgs = DefragRangeArgs
{ draStart :: FileSize
, draLength :: FileSize
, draExtentThreshold :: Word32
, draCompress :: Maybe CompressionType
, draFlush :: Bool
}
defaultDefragRangeArgs :: DefragRangeArgs
defaultDefragRangeArgs = DefragRangeArgs
{ draStart = 0
, draLength = maxBound
, draExtentThreshold = 0
, draCompress = Nothing
, draFlush = False
}
defragRangeFd :: Fd -> DefragRangeArgs -> IO ()
defragRangeFd fd DefragRangeArgs{..} =
allocaBytesZero ((48)) $ \args -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) args draStart
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) args draLength
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) args flags
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) args draExtentThreshold
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) args comp_type
throwErrnoIfMinus1_ "defragRangeFd" $
withBlockSIGVTALRM $
ioctl fd (1076925456) args
where
flags = comp_flags .|. if draFlush then (2) else 0
comp_flags :: Word64
comp_type :: Word32
(comp_flags, comp_type) =
case draCompress of
Nothing -> (0, 0)
Just Zlib -> ((1), (1))
Just LZO -> ((1), (2))
defragRange :: FILEPATH -> DefragRangeArgs -> IO ()
defragRange path args =
withFd path ReadWrite $ \fd ->
defragRangeFd fd args
syncFd :: Fd -> IO ()
syncFd fd =
throwErrnoIfMinus1_ "syncFd" $
ioctl fd (37896) nullPtr
sync :: FILEPATH -> IO ()
sync path = withFd path ReadOnly syncFd
startSyncFd :: Fd -> IO ()
startSyncFd fd =
throwErrnoIfMinus1_ "startSyncFd" $
ioctl_fast fd (2148045848) nullPtr
startSync :: FILEPATH -> IO ()
startSync path = withFd path ReadOnly startSyncFd
waitSyncFd :: Fd -> IO ()
waitSyncFd fd =
throwErrnoIfMinus1_ "waitSyncFd" $
ioctl fd (1074304022) nullPtr
waitSync :: FILEPATH -> IO ()
waitSync path = withFd path ReadOnly waitSyncFd
resolveLogicalFd :: Fd -> FileSize -> IO ([(InodeNum, FileSize, SubvolId)], Int)
resolveLogicalFd rootFd logical =
allocaBytes inodesSize $ \inodes ->
allocaBytesZero ((56)) $ \lia -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) lia logical
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) lia (fromIntegral inodesSize :: Word64)
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) lia inodes
throwErrnoIfMinus1_ "resolveLogical" $ ioctl rootFd (3224933412) lia
elemMissed <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) inodes :: IO Word32
count <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) inodes :: IO Word32
let val = ((\hsc_ptr -> hsc_ptr `plusPtr` 16)) inodes :: Ptr Word64
vals <- peekArray (fromIntegral count) val
return (extractTriplets vals, fromIntegral elemMissed)
where
inodesSize = 64 * 1024 + ((16))
extractTriplets (x1 : x2 : x3 : xs) = (x1, x2, x3) : extractTriplets xs
extractTriplets [] = []
extractTriplets _ = error "extractTriplets: The length of the list must be a multiple of 3"
resolveLogical
:: FILEPATH
-> FileSize
-> IO ([(InodeNum, FileSize, SubvolId)], Int)
resolveLogical rootPath logical =
withFd rootPath ReadOnly $ \fd ->
resolveLogicalFd fd logical
resolveInodeFd :: Fd -> InodeNum -> IO ([FILEPATH], Int)
resolveInodeFd subvolFd inum =
allocaBytes fspathSize $ \fspath ->
allocaBytesZero ((56)) $ \ipa -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ipa inum
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ipa (fromIntegral fspathSize :: Word64)
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) ipa fspath
throwErrnoIfMinus1_ "resolveInode" $ ioctl subvolFd (3224933411) ipa
elemMissed <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) fspath :: IO Word32
count <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) fspath :: IO Word32
let val = ((\hsc_ptr -> hsc_ptr `plusPtr` 16)) fspath :: Ptr Word64
vals <- peekArray (fromIntegral count) val
paths <- mapM (peekCString . plusPtr val . fromIntegral) vals
return (paths, fromIntegral elemMissed)
where
fspathSize = 2 * 1024 + ((16))
resolveInode
:: FILEPATH
-> InodeNum
-> IO ([FILEPATH], Int)
resolveInode subvolPath inum =
withFd subvolPath ReadOnly $ \subvolFd ->
resolveInodeFd subvolFd inum
lookupInodeFd :: Fd -> SubvolId -> InodeNum -> IO (SubvolId, FILEPATH)
lookupInodeFd fd treeId inum =
allocaBytesZero ((4096)) $ \ila -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ila treeId
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ila inum
throwErrnoIfMinus1_ "lookupInodeFd" $
ioctl_fast fd (3489698834) ila
treeId' <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ila :: IO Word64
let cName = ((\hsc_ptr -> hsc_ptr `plusPtr` 16)) ila
name <- peekCString cName
return (treeId', dropTrailingSlash name)
lookupInode
:: FILEPATH
-> SubvolId
-> InodeNum
-> IO (SubvolId, FILEPATH)
lookupInode path treeId inum =
withFd path ReadOnly $ \fd -> lookupInodeFd fd treeId inum
getFileNoCOWFd :: Fd -> IO Bool
getFileNoCOWFd fd =
alloca $ \flagsPtr -> do
throwErrnoIfMinus1_ "getFileNoCOWFd" $
ioctl fd (2148034049) flagsPtr
flags <- peek flagsPtr :: IO CUInt
return (flags .&. (8388608) /= 0)
getFileNoCOW :: FILEPATH -> IO Bool
getFileNoCOW path =
withFd path ReadOnly getFileNoCOWFd
setFileNoCOWFd :: Fd -> Bool -> IO ()
setFileNoCOWFd fd noCOW = do
alloca $ \flagsPtr -> do
throwErrnoIfMinus1_ "setFileNoCOWFd" $
ioctl fd (2148034049) flagsPtr
if noCOW then
setFlags flagsPtr ((8388608) :: CUInt)
else
clearFlags flagsPtr ((8388608) :: CUInt)
throwErrnoIfMinus1_ "setFileNoCOWFd" $
ioctl fd (1074292226) flagsPtr
setFileNoCOW :: FILEPATH -> Bool -> IO ()
setFileNoCOW path noCOW = do
withFd path ReadOnly $ \fd ->
setFileNoCOWFd fd noCOW
data SearchKey = SearchKey
{ skTreeId :: ObjectId
, skMinObjectId :: ObjectId
, skMinType :: ObjectType
, skMinOffset :: Word64
, skMaxObjectId :: ObjectId
, skMaxType :: ObjectType
, skMaxOffset :: Word64
, skMinTransId :: Word64
, skMaxTransId :: Word64
}
deriving (Show, Eq)
defaultSearchKey :: SearchKey
defaultSearchKey = SearchKey
{ skTreeId = 0
, skMinObjectId = minBound
, skMinType = minBound
, skMinOffset = minBound
, skMaxObjectId = maxBound
, skMaxType = maxBound
, skMaxOffset = maxBound
, skMinTransId = minBound
, skMaxTransId = maxBound
}
data SearchHeader = SearchHeader
{ shTransId :: Word64
, shObjectId :: ObjectId
, shOffset :: Word64
, shType :: ObjectType
, shLen :: Word32
}
deriving (Show, Eq)
treeSearchFd :: Fd -> SearchKey -> Int -> (SearchHeader -> Ptr i -> IO ()) -> IO ()
treeSearchFd fd sk maxItemCount0 callback =
allocaBytesZero ((4096)) $ \saPtr -> do
let skPtr = ((\hsc_ptr -> hsc_ptr `plusPtr` 0)) saPtr
pokeSearchKey skPtr sk
loopSingleSearch saPtr skPtr maxItemCount0
where
loopSingleSearch saPtr skPtr maxItemCount
| maxItemCount <= 0 = return ()
| otherwise = do
let nrItems = fromIntegral (min 4096 maxItemCount) :: Word32
((\hsc_ptr -> pokeByteOff hsc_ptr 64)) skPtr nrItems
throwErrnoIfMinus1_ "treeSearchFd" $
ioctl fd (3489698833) saPtr
itemsFound <- ((\hsc_ptr -> peekByteOff hsc_ptr 64)) skPtr :: IO Word32
when (itemsFound > 0) $ do
let shPtr = ((\hsc_ptr -> hsc_ptr `plusPtr` 104)) saPtr
lastSh <- loopItems shPtr itemsFound
case nextKey (shObjectId lastSh, shType lastSh, shOffset lastSh) of
Nothing -> return ()
Just (objectId, iType, offset) -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) skPtr objectId
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) skPtr (fromIntegral iType :: Word32)
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) skPtr offset
loopSingleSearch saPtr skPtr (maxItemCount fromIntegral itemsFound)
loopItems shPtr itemsFound = do
(sh, itemPtr) <- peekSearchItem shPtr
callback sh itemPtr
if itemsFound <= 1 then
return sh
else do
let shPtr' = itemPtr `plusPtr` fromIntegral (shLen sh)
loopItems shPtr' (itemsFound 1)
nextKey (objectId, iType, offset)
| offset < maxBound = Just (objectId, iType, offset + 1)
| iType < skMaxType sk = Just (objectId, iType + 1, skMinOffset sk)
| objectId < skMaxObjectId sk = Just (objectId + 1, skMinType sk, skMinOffset sk)
| otherwise = Nothing
treeSearch :: FILEPATH -> SearchKey -> Int -> (SearchHeader -> Ptr i -> IO ()) -> IO ()
treeSearch path sk maxItemCount callback =
withFd path ReadOnly $ \fd ->
treeSearchFd fd sk maxItemCount callback
treeSearchListFd :: Fd -> SearchKey -> (SearchHeader -> Ptr i -> IO (Maybe a)) -> IO [a]
treeSearchListFd fd sk unpack = do
res <- newIORef []
treeSearchFd fd sk maxBound $ \sh itemPtr -> do
r <- unpack sh itemPtr
case r of
Nothing -> return ()
Just x -> modifyIORef' res (x :)
liftM reverse $ readIORef res
treeSearchList :: FILEPATH -> SearchKey -> (SearchHeader -> Ptr i -> IO (Maybe a)) -> IO [a]
treeSearchList path sk unpack =
withFd path ReadOnly $ \fd ->
treeSearchListFd fd sk unpack
findFirstItemFd :: Fd -> SearchKey -> (SearchHeader -> Ptr i -> IO a) -> IO a
findFirstItemFd fd sk unpack = do
res <- newIORef Nothing
treeSearchFd fd sk 1 $ \sh ptr -> do
r <- unpack sh ptr
modifyIORef' res (`mplus` Just r)
resV <- readIORef res
case resV of
Just x -> return x
Nothing ->
ioError $ mkIOError doesNotExistErrorType
"findFirstItemFd"
Nothing Nothing
findFirstItem :: FILEPATH -> SearchKey -> (SearchHeader -> Ptr i -> IO a) -> IO a
findFirstItem path sk unpack =
withFd path ReadOnly $ \fd ->
findFirstItemFd fd sk unpack
pokeSearchKey :: Ptr a -> SearchKey -> IO ()
pokeSearchKey ptr sk = do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr (skTreeId sk)
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr (skMinObjectId sk)
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) ptr (fromIntegral (skMinType sk) :: Word32)
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr (skMinOffset sk)
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr (skMaxObjectId sk)
((\hsc_ptr -> pokeByteOff hsc_ptr 60)) ptr (fromIntegral (skMaxType sk) :: Word32)
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) ptr (skMaxOffset sk)
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) ptr (skMinTransId sk)
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) ptr (skMaxTransId sk)
peekSearchItem :: Ptr a -> IO (SearchHeader, Ptr i)
peekSearchItem shPtr = do
transId <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) shPtr :: IO Word64
objectId <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) shPtr :: IO Word64
offset <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) shPtr :: IO Word64
iType <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) shPtr :: IO Word32
len <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) shPtr :: IO Word32
let itemPtr = shPtr `plusPtr` ((32))
return (SearchHeader transId objectId offset (fromIntegral iType) len, itemPtr)
peekRootRef :: Ptr a -> IO (InodeNum, FILEPATH)
peekRootRef rrPtr = do
LE64 dirId <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) rrPtr
LE16 nameLen <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) rrPtr
let cName = rrPtr `plusPtr` ((18))
name <- peekCStringLen (cName, fromIntegral nameLen)
return (dirId, name)
withFd :: FILEPATH -> OpenMode -> (Fd -> IO r) -> IO r
withFd path openMode action =
bracket (openFd path openMode Nothing defaultFileFlags {nonBlock = True})
closeFd action
withSplitPathOpenParent :: String -> Int -> FILEPATH -> (CStringLen -> Fd -> IO r) -> IO r
withSplitPathOpenParent loc maxLen path action =
unsafeWithCStringLen name $ \cName @ (_, l) -> do
unless (l <= maxLen) $
ioError $ flip ioeSetErrorString "the subvolume name is too long"
$ mkIOError illegalOperationErrorType loc Nothing (Just (asString name))
withFd dir ReadOnly $ action cName
where
(dir, name) = splitFileName (dropTrailingSlash path)
withBlockSIGVTALRM :: IO a -> IO a
withBlockSIGVTALRM =
bracket_ (blockSignals s) (unblockSignals s)
where
s = addSignal sigVTALRM emptySignalSet
nothingIf :: Bool -> a -> Maybe a
nothingIf f v = if f then Nothing else Just v
modifyPtr :: Storable a => Ptr a -> (a -> a) -> IO ()
modifyPtr ptr f = do
peek ptr >>= (poke ptr . f)
setFlags :: (Storable a, Bits a) => Ptr a -> a -> IO ()
setFlags ptr flags =
modifyPtr ptr (.|. flags)
clearFlags :: (Storable a, Bits a) => Ptr a -> a -> IO ()
clearFlags ptr flags =
modifyPtr ptr (.&. complement flags)
allocaBytesZero :: Int -> (Ptr a -> IO b) -> IO b
allocaBytesZero size action =
allocaBytes size $ \ptr -> do
memset ptr 0 size
action ptr
memset :: Ptr a -> Word8 -> Int -> IO ()
memset p b l = do
_ <- c_memset p (fromIntegral b) (fromIntegral l)
return ()
foreign import ccall unsafe "string.h memset"
c_memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)