diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,40 +1,2 @@ import Distribution.Simple -import Distribution.Simple.Setup -import Distribution.Simple.Utils -import Distribution.Simple.BuildPaths -import Distribution.Simple.LocalBuildInfo -import Distribution.PackageDescription -import Distribution.ModuleName (fromString) -import System.IO -import System.FilePath - -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { confHook = customConf - , buildHook = customBuild - } - -customConf gh cFlags = do - lbi <- confHook simpleUserHooks gh cFlags - -- modify the package description to add the auto-generated module - let desc = localPkgDescr lbi - Just lib = library desc - modName = fromString "System.Linux.Btrfs.ByteString" - lib' = lib {exposedModules = exposedModules lib ++ [modName]} - desc' = desc {library = Just lib'} - return lbi {localPkgDescr = desc'} - -customBuild desc lbi hooks bFlags = do - let verbosity = fromFlag (buildVerbosity bFlags) - - -- create System/Linux/Btrfs/ByteString.hsc - let dir = autogenModulesDir lbi "System/Linux/Btrfs" - createDirectoryIfMissingVerbose verbosity True dir - withFile (dir "ByteString.hsc") WriteMode $ \oHdl -> do - hPutStrLn oHdl "#define BTRFS_RAW_PATHS 1" - withFile "System/Linux/Btrfs.hsc" ReadMode $ \iHdl -> do - _ <- hGetLine iHdl -- skip the first line - contents <- hGetContents iHdl - hPutStr oHdl contents - - buildHook simpleUserHooks desc lbi hooks bFlags +main = defaultMain diff --git a/System/Linux/Btrfs/ByteString.hsc b/System/Linux/Btrfs/ByteString.hsc new file mode 100644 --- /dev/null +++ b/System/Linux/Btrfs/ByteString.hsc @@ -0,0 +1,1058 @@ +#define BTRFS_RAW_PATHS 1 +{- | +Module : System.Linux.Btrfs + +Stability : provisional +Portability : non-portable (requires Linux) + +Most functions in this module come in two flavors: one that operates on +file descriptors and another one that operates on file paths. The former +can be distinguished by the @Fd@ suffix in their names. +-} + +{-# LANGUAGE CPP #-} + +#if BTRFS_RAW_PATHS +##define FILEPATH RawFilePath +module System.Linux.Btrfs.ByteString +#else +##define FILEPATH FilePath +module System.Linux.Btrfs +#endif + ( + -- * Basic types + FileSize, ObjectType, ObjectId, InodeNum, SubvolId + -- * File cloning + , cloneFd, clone, cloneNew + , cloneRangeFd, cloneRange + , CloneResult(..) + , cloneRangeIfSameFd, cloneRangeIfSame + -- * Subvolumes and snapshots + , 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 + -- * Defragging + , defragFd, defrag + -- * Sync + , syncFd, sync + , startSyncFd, startSync + , waitSyncFd, waitSync + -- * Inspect internal + , resolveLogicalFd, resolveLogical + , resolveInodeFd, resolveInode + , lookupInodeFd, lookupInode + -- * Miscellaneous + , getFileNoCOWFd, getFileNoCOW + , setFileNoCOWFd, setFileNoCOW + -- * Tree search + -- | Low-level API for tree search using the @BTRFS_IOC_TREE_SEARCH@ + -- @ioctl@. + , 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 + +#include +#define __IOCTL_ +#include + +#include + +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 + +-------------------------------------------------------------------------------- + +cloneFd :: Fd -> Fd -> IO () +cloneFd srcFd dstFd = + throwErrnoIfMinus1_ "cloneFd" $ + ioctl_fast dstFd (#const BTRFS_IOC_CLONE) srcFdP + where + srcFdP = intPtrToPtr (fromIntegral srcFd) + +-- | Clone an entire file to an existing file. +-- +-- Note: calls the @BTRFS_IOC_CLONE@ @ioctl@. +clone + :: FILEPATH -- ^ The source file. + -> FILEPATH -- ^ The destination file. + -> IO () +clone srcPath dstPath = + withFd srcPath ReadOnly $ \srcFd -> + withFd dstPath WriteOnly $ \dstFd -> + cloneFd srcFd dstFd + +-- | Like 'clone' except that it will create or truncate the destination +-- file if necessary. This is similar to @cp --reflink=always@. +-- +-- Note: calls the @BTRFS_IOC_CLONE@ @ioctl@. +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 (#size struct btrfs_ioctl_clone_range_args) $ \cra -> do + (#poke struct btrfs_ioctl_clone_range_args, src_fd ) cra (fromIntegral srcFd :: Int64) + (#poke struct btrfs_ioctl_clone_range_args, src_offset ) cra (srcOff :: Word64) + (#poke struct btrfs_ioctl_clone_range_args, src_length ) cra (srcLen :: Word64) + (#poke struct btrfs_ioctl_clone_range_args, dest_offset) cra (dstOff :: Word64) + throwErrnoIfMinus1_ "cloneRangeFd" $ + ioctl_fast dstFd (#const BTRFS_IOC_CLONE_RANGE) cra + +-- | Clones a range of bytes from a file to another file. All ranges must +-- be block-aligned. +-- +-- Note: calls the @BTRFS_IOC_CLONE_RANGE@ @ioctl@. +cloneRange + :: FILEPATH -- ^ The source file. + -> FileSize -- ^ The offset within the source file. + -> FileSize -- ^ The length of the range. A length of 0 selects the range + -- from the source offset to the end. + -> FILEPATH -- ^ The destination file. + -> FileSize -- ^ The offset within the destination file. + -> IO () +cloneRange srcPath srcOff srcLen dstPath dstOff = + withFd srcPath ReadOnly $ \srcFd -> + withFd dstPath WriteOnly $ \dstFd -> + cloneRangeFd srcFd srcOff srcLen dstFd dstOff + +#ifdef BTRFS_IOC_FILE_EXTENT_SAME +data SameExtentInfoIn = SameExtentInfoIn + Fd -- file descriptor (stored as Int64) + FileSize -- offset + +instance Storable SameExtentInfoIn where + sizeOf _ = (#size struct btrfs_ioctl_same_extent_info) + alignment _ = alignment (undefined :: CInt) + poke ptr (SameExtentInfoIn dstFd dstOff) = do + memset ptr 0 (#size struct btrfs_ioctl_same_extent_info) + let dstFd' = fromIntegral dstFd :: Int64 + (#poke struct btrfs_ioctl_same_extent_info, fd) ptr dstFd' + (#poke struct btrfs_ioctl_same_extent_info, logical_offset) ptr dstOff + peek _ = error "not implemented" + +data SameExtentInfoOut = SameExtentInfoOut + Int32 -- status + FileSize -- bytes deduped + +instance Storable SameExtentInfoOut where + sizeOf _ = (#size struct btrfs_ioctl_same_extent_info) + alignment _ = alignment (undefined :: CInt) + poke _ _ = error "not implemented" + peek ptr = do + status <- (#peek struct btrfs_ioctl_same_extent_info, status ) ptr + bytes <- (#peek struct btrfs_ioctl_same_extent_info, bytes_deduped) ptr + return (SameExtentInfoOut status bytes) +#endif + +-- | The result of a 'cloneRangeIfSame' operation. +data CloneResult + = CRError IOError -- ^ Cloning failed because of an error. + | CRDataDiffers -- ^ No cloning was performed because the contents + -- of the source and the destination file differ. + | CRSuccess FileSize -- ^ Cloning succeeded, the returned integer + -- indicates the number of bytes that were + -- deduped. + deriving (Show, Eq) + +cloneRangeIfSameFd :: Fd -> FileSize -> FileSize -> [(Fd, FileSize)] -> IO [CloneResult] +#ifndef BTRFS_IOC_FILE_EXTENT_SAME +cloneRangeIfSameFd _ _ _ _ = + error "System.Linux.Btrfs.cloneRangeIfSameFd: not supported" +#else +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 (#size struct btrfs_ioctl_same_args) + (#poke struct btrfs_ioctl_same_args, logical_offset) sa srcOff + (#poke struct btrfs_ioctl_same_args, length ) sa srcLen + (#poke struct btrfs_ioctl_same_args, dest_count ) sa dstCount' + let info = (#ptr struct btrfs_ioctl_same_args, info) sa + pokeArray info (map (uncurry SameExtentInfoIn) dsts) + throwErrnoIfMinus1_ "cloneRangeIfSameFd" $ + ioctl srcFd (#const BTRFS_IOC_FILE_EXTENT_SAME) sa + res <- peekArray dstCount info + return $ flip map res $ \(SameExtentInfoOut status bytes) -> + if status == 0 then + CRSuccess bytes + else if status == (#const BTRFS_SAME_DATA_DIFFERS) then + CRDataDiffers + else if status <= 0 then + CRError $ errnoToIOError "cloneRangeIfSameFd" + (Errno $ fromIntegral $ -status) + Nothing Nothing + else + error $ "unknown status value (" ++ show status ++ ")" + where + saSize = (#size struct btrfs_ioctl_same_args) + + dstCount * (#size struct btrfs_ioctl_same_extent_info) + dstCount = length dsts + dstCount' = fromIntegral dstCount :: Word64 + maxCount = fromIntegral (maxBound :: Word16) +#endif + +-- | Similar to 'cloneRange' except that it performs the cloning only if +-- the data ranges contain identical data. +-- Additionally, it accepts multiple destination files. The same thing can +-- be accomplished with 'cloneRange' in conjunction with file locking but +-- this function uses in-kernel locking to guarantee that the deduplicated +-- data is identical at the time of the operation. On the other hand, this +-- function will not clone arbitrarily large ranges; the kernel has an upper +-- limit for the length and if cloning bigger ranges is desired then it +-- has to be called multiple times. Note that cloning may succeed for some +-- of the destination files and fail for others. Because of that, this +-- function returns a list of outcomes, one for each destination file, and +-- no exceptions will be raised for the failed files. +-- +-- Note: calls the @BTRFS_IOC_FILE_EXTENT_SAME@ @ioctl@. +-- +-- /Requires Linux 3.12 or later./ +cloneRangeIfSame + :: FILEPATH -- ^ The source file. + -> FileSize -- ^ The offset within the source file. + -> FileSize -- ^ The length of the range. + -> [(FILEPATH, FileSize)] -- ^ The destination files and corresponding offsets. + -> 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 (#const BTRFS_PATH_NAME_MAX) path $ \(cName, l) dirFd -> + allocaBytesZero (#size struct btrfs_ioctl_vol_args) $ \iva -> do + let ivaName = (#ptr struct btrfs_ioctl_vol_args, name) iva + copyBytes ivaName cName l + throwErrnoIfMinus1_ loc $ + ioctl dirFd req iva + +-- | Create an (initially) empty new subvolume. +-- +-- Note: calls the @BTRFS_IOC_SUBVOL_CREATE@ @ioctl@. +createSubvol :: FILEPATH -> IO () +createSubvol path = + simpleSubvolOp "createSubvol" path (#const BTRFS_IOC_SUBVOL_CREATE) + +-- | Destroy (delete) a subvolume. +-- +-- Note: calls the @BTRFS_IOC_SNAP_DESTROY@ @ioctl@. +destroySubvol :: FILEPATH -> IO () +destroySubvol path = + simpleSubvolOp "destroySubvol" path (#const BTRFS_IOC_SNAP_DESTROY) + +snapshotFd :: Fd -> FILEPATH -> Bool -> IO () +snapshotFd srcFd dstPath readOnly = + withSplitPathOpenParent "snapshotFd" (#const BTRFS_SUBVOL_NAME_MAX) dstPath $ \(cName, l) dirFd -> + allocaBytesZero (#size struct btrfs_ioctl_vol_args_v2) $ \iva -> do + let ivaName = (#ptr struct btrfs_ioctl_vol_args_v2, name) iva + copyBytes ivaName cName l + (#poke struct btrfs_ioctl_vol_args_v2, fd) iva (fromIntegral srcFd :: Int64) + when readOnly $ + setFlags ((#ptr struct btrfs_ioctl_vol_args_v2, flags) iva) + ((#const BTRFS_SUBVOL_RDONLY) :: Word64) + throwErrnoIfMinus1_ "snapshotFd" $ + ioctl dirFd (#const BTRFS_IOC_SNAP_CREATE_V2) iva + +-- | Create a snapshot of an existing subvolume. +-- +-- Note: calls the @BTRFS_IOC_SNAP_CREATE_V2@ @ioctl@. +snapshot + :: FILEPATH -- ^ The source subvolume. + -> FILEPATH -- ^ The destination subvolume (must not exist). + -> Bool -- ^ Make the subvolume read-only? + -> 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 (#const BTRFS_IOC_SUBVOL_GETFLAGS) flagsPtr + flags <- peek flagsPtr :: IO Word64 + return (flags .&. (#const BTRFS_SUBVOL_RDONLY) /= 0) + +-- | Is the subvolume read-only? +-- +-- Note: calls the @BTRFS_IOC_SUBVOL_GETFLAGS@ @ioctl@. +getSubvolReadOnly :: FILEPATH -> IO Bool +getSubvolReadOnly path = withFd path ReadOnly getSubvolReadOnlyFd + +setSubvolReadOnlyFd :: Fd -> Bool -> IO () +setSubvolReadOnlyFd fd readOnly = + alloca $ \flagsPtr -> do + throwErrnoIfMinus1_ "setSubvolReadOnlyFd" $ + ioctl fd (#const BTRFS_IOC_SUBVOL_GETFLAGS) flagsPtr + if readOnly then + setFlags flagsPtr ((#const BTRFS_SUBVOL_RDONLY) :: Word64) + else + clearFlags flagsPtr ((#const BTRFS_SUBVOL_RDONLY) :: Word64) + throwErrnoIfMinus1_ "setSubvolReadOnlyFd" $ + ioctl fd (#const BTRFS_IOC_SUBVOL_SETFLAGS) flagsPtr + +-- | Make a subvolume read-only (or read-write). +-- +-- Note: calls the @BTRFS_IOC_SUBVOL_GETFLAGS@ and +-- @BTRFS_IOC_SUBVOL_SETFLAGS@ @ioctl@s. +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 (#const BTRFS_FIRST_FREE_OBJECTID) + return subvolId + +-- | Find the id of the subvolume where the given file resides. This is +-- merely a wrapper around 'lookupInode' provided for convenience. +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 = (#const BTRFS_ROOT_TREE_OBJECTID) + , skMinObjectId = subvolId + , skMaxObjectId = subvolId + , skMinType = (#const BTRFS_ROOT_BACKREF_KEY) + , skMaxType = (#const BTRFS_ROOT_BACKREF_KEY) + } + findFirstItemFd fd sk $ \sh rr -> do + (dirId, name) <- peekRootRef rr + return (shOffset sh, dirId, name) + +-- | Given the id of a subvolume, find the id of the parent subvolume, the +-- inode number of the directory containing it, and its name. This is +-- a wrapper around 'treeSearch'. +lookupSubvol + :: FILEPATH -- ^ The mount point of the volume (or any file in that volume). + -> SubvolId -- ^ The id of the subvolume. + -> 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 == (#const BTRFS_FIRST_FREE_OBJECTID) then + return (parentPath name) + else do + (_, dirName) <- lookupInodeFd fd parentId dirId + return (parentPath dirName name) + +-- | Given the id of a subvolume, find its path relative to the root of the +-- volume. This function calls 'lookupSubvol' recursively. +resolveSubvol + :: FILEPATH -- ^ The mount point of the volume (or any file in that volume). + -> SubvolId -- ^ The id of the subvolume. + -> IO FILEPATH +resolveSubvol path subvolId = + withFd path ReadOnly $ \fd -> + resolveSubvolFd fd subvolId + +-- | The id the root subvolume. +rootSubvol :: SubvolId +rootSubvol = (#const BTRFS_FS_TREE_OBJECTID) + +listSubvolsFd :: Fd -> IO [(SubvolId, SubvolId, InodeNum, FILEPATH)] +listSubvolsFd fd = do + let sk = defaultSearchKey + { skTreeId = (#const BTRFS_ROOT_TREE_OBJECTID) + , skMinObjectId = (#const BTRFS_FIRST_FREE_OBJECTID) + , skMaxObjectId = (#const BTRFS_LAST_FREE_OBJECTID) + , skMinType = (#const BTRFS_ROOT_BACKREF_KEY) + , skMaxType = (#const BTRFS_ROOT_BACKREF_KEY) + } + treeSearchListFd fd sk unpack + where + unpack sh rr + | shType sh /= (#const BTRFS_ROOT_BACKREF_KEY) = + return Nothing + | otherwise = do + (dirId, name) <- peekRootRef rr + return $ Just (shObjectId sh, shOffset sh, dirId, name) + +-- | Find all subvolumes of the given volume. For each subvolume found, it +-- returns: its id, the id of its parent subvolume, the inode number of the +-- directory containing it, and its name. This is a wrapper around +-- 'treeSearch'. +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) + +-- | Find all subvolumes of the given volume. For each subvolume found, it +-- returns: its id, the id of its parent subvolume, and its path relative +-- to the root of the volume. This is a wrapper around 'treeSearch' and +-- 'resolveSubvol'. +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 = (#const BTRFS_ROOT_TREE_OBJECTID) + , skMinObjectId = subvolId + , skMaxObjectId = subvolId + , skMinType = (#const BTRFS_ROOT_REF_KEY) + , skMaxType = (#const BTRFS_ROOT_REF_KEY) + } + treeSearchListFd fd sk unpack + where + unpack sh rr + | shType sh /= (#const BTRFS_ROOT_REF_KEY) = + return Nothing + | otherwise = do + (dirId, name) <- peekRootRef rr + return $ Just (shOffset sh, dirId, name) + +-- | Find all child subvolumes of the given subvolume. For each child, +-- returns its id, the inode number of the directory containing it, and its +-- name. This is a wrapper around 'treeSearch'. +childSubvols + :: FILEPATH -- ^ The mount point of the volume (or any file in that volume). + -> SubvolId -- ^ The id of the subvolume. + -> 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 == (#const BTRFS_FIRST_FREE_OBJECTID) then + return (childId, name) + else do + (_, dirName) <- lookupInodeFd fd subvolId dirId + return (childId, dirName name) + +-- | Find all child subvolumes of the given subvolume. For each child, +-- returns its id and its path relative to the root of the parent. +-- This is a wrapper around 'treeSearch' and 'lookupInode'. +childSubvolPaths + :: FILEPATH -- ^ The mount point of the volume (or any file in that volume). + -> SubvolId -- ^ The id of the subvolume. + -> IO [(SubvolId, FILEPATH)] +childSubvolPaths path subvolId = + withFd path ReadOnly $ \fd -> + childSubvolPathsFd fd subvolId + +-- | Information about a subvolume. +data SubvolInfo = SubvolInfo + { siGeneration :: Word64 + -- ^ The generation when the subvolume was last modified. + , siLastSnapshot :: Maybe Word64 + -- ^ The generation when the most recent snapshot of this subvolume was taken. + , siParSnapGen :: Maybe Word64 + -- ^ The generation of the snapshot parent at the time when the snapshot + -- was taken. Defined if only if this is a snapshot. + , siReadOnly :: Bool + -- ^ Is this a read-only subvolume? + , siUuid :: Maybe UUID + -- ^ The UUID of the subvolume. + , siPUuid :: Maybe UUID + -- ^ The UUID of the snapshot parent. + , siReceivedUuid :: Maybe UUID + -- ^ The UUID of the source subvolume that this subvolume was + -- received from. This is always defined for received subvolumes. + , siCTransId :: Maybe Word64 + -- ^ The generation when an inode was last modified. + , siOTransId :: Maybe Word64 + -- ^ The generation when the subvolume was created. + , siSTransId :: Maybe Word64 + -- ^ The generation of the source subvolume that this subvolume was + -- received from. This is always defined for received subvolumes. + , siRTransId :: Maybe Word64 + -- ^ The generation when the subvolume was received. This is always + -- defined for received subvolumes. + , siCTime :: Maybe UTCTime + -- ^ The time when an inode was last modified. + , siOTime :: Maybe UTCTime + -- ^ The time when the subvolume was created. + , siSTime :: Maybe UTCTime + -- ^ The timestamp that corresponds to 'siSTransId'. + , siRTime :: Maybe UTCTime + -- ^ The time when the subvolume was received. This is always + -- defined for received subvolumes. + } + deriving (Show, Eq) + +getSubvolInfoFd :: Fd -> SubvolId -> IO SubvolInfo +getSubvolInfoFd fd subvolId + | subvolId /= rootSubvol && + (subvolId < (#const BTRFS_FIRST_FREE_OBJECTID) || subvolId > (#const BTRFS_LAST_FREE_OBJECTID)) = + ioError $ mkIOError doesNotExistErrorType + "getSubvolInfoFd" + Nothing Nothing + | otherwise = do + let sk = defaultSearchKey + { skTreeId = (#const BTRFS_ROOT_TREE_OBJECTID) + , skMinObjectId = subvolId + , skMaxObjectId = subvolId + , skMinType = (#const BTRFS_ROOT_ITEM_KEY) + , skMaxType = (#const BTRFS_ROOT_ITEM_KEY) + } + findFirstItemFd fd sk unpack + where + unpack sh ri = do + LE64 generation <- (#peek struct btrfs_root_item, generation) ri + LE64 lastSnapshot <- (#peek struct btrfs_root_item, last_snapshot) ri + LE64 flags <- (#peek struct btrfs_root_item, flags) ri + LE64 generationV2 <- (#peek struct btrfs_root_item, generation_v2) ri + let nv2 = generationV2 < generation -- not version 2 + uuid <- (#peek struct btrfs_root_item, uuid) ri :: IO UUID + pUuid <- (#peek struct btrfs_root_item, parent_uuid) ri :: IO UUID + receivedUuid <- (#peek struct btrfs_root_item, received_uuid) ri :: IO UUID + LE64 cTransId <- (#peek struct btrfs_root_item, ctransid) ri + LE64 oTransId <- (#peek struct btrfs_root_item, otransid) ri + LE64 sTransId <- (#peek struct btrfs_root_item, stransid) ri + LE64 rTransId <- (#peek struct btrfs_root_item, rtransid) ri + BtrfsTime cTime <- (#peek struct btrfs_root_item, ctime) ri + BtrfsTime oTime <- (#peek struct btrfs_root_item, otime) ri + BtrfsTime sTime <- (#peek struct btrfs_root_item, stime) ri + BtrfsTime rTime <- (#peek struct btrfs_root_item, rtime) ri + return $ SubvolInfo + { siGeneration = generation + , siLastSnapshot = nothingIf (lastSnapshot == 0) $ lastSnapshot + , siParSnapGen = nothingIf (shOffset sh == 0) $ shOffset sh + , siReadOnly = flags .&. (#const BTRFS_SUBVOL_RDONLY) /= 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 + } + +-- | Retrieve information about a subvolume. +getSubvolInfo + :: FILEPATH -- ^ The mount point of the volume (or any file in that volume). + -> SubvolId -- ^ The id of the subvolume. + -> 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 = (#const BTRFS_UUID_TREE_OBJECTID) + , skMinObjectId = hLE + , skMaxObjectId = hLE + , skMinType = typ + , skMaxType = typ + , skMinOffset = lLE + , skMaxOffset = lLE + } + findFirstItemFd fd sk $ \_ ptr -> + liftM fromLE64 $ peek ptr + where + -- UUID is stored as two big-endian integers + -- but in the UUID tree, little-endian integers are used + lLE = invert64 lBE + hLE = invert64 hBE + +getSubvolByUuidFd :: Fd -> UUID -> IO SubvolId +getSubvolByUuidFd = + searchByUuidFd (#const BTRFS_UUID_KEY_SUBVOL) + +-- | Find the id of a subvolume, given its UUID. +-- +-- /Requires Linux 3.12 or later./ +getSubvolByUuid + :: FILEPATH -- ^ The mount point of the volume (or any file in that volume). + -> UUID -- ^ The UUID of the subvolume. + -> IO SubvolId +getSubvolByUuid path uuid = + withFd path ReadOnly $ \fd -> + getSubvolByUuidFd fd uuid + +getSubvolByReceivedUuidFd :: Fd -> UUID -> IO SubvolId +getSubvolByReceivedUuidFd = + searchByUuidFd (#const BTRFS_UUID_KEY_RECEIVED_SUBVOL) + +-- | Find the id of a subvolume, given its 'siReceivedUuid'. +-- +-- /Requires Linux 3.12 or later./ +getSubvolByReceivedUuid + :: FILEPATH -- ^ The mount point of the volume (or any file in that volume). + -> UUID -- ^ The 'siReceivedUuid' of the subvolume. + -> IO SubvolId +getSubvolByReceivedUuid path uuid = + withFd path ReadOnly $ \fd -> + getSubvolByReceivedUuidFd fd uuid + +-------------------------------------------------------------------------------- + +defragFd :: Fd -> IO () +defragFd fd = + throwErrnoIfMinus1_ "defragFd" $ + withBlockSIGVTALRM $ -- this is probably a bad idea + ioctl fd (#const BTRFS_IOC_DEFRAG) nullPtr + +-- | Defrag a single file. +-- +-- Note: calls the @BTRFS_IOC_DEFRAG@ @ioctl@. +defrag :: FILEPATH -> IO () +defrag path = withFd path ReadWrite defragFd + +-------------------------------------------------------------------------------- + +syncFd :: Fd -> IO () +syncFd fd = + throwErrnoIfMinus1_ "syncFd" $ + ioctl fd (#const BTRFS_IOC_SYNC) nullPtr + +-- | Sync the file system identified by the supplied path. +-- The 'FilePath' can refer to any file in the file system. +-- +-- Note: calls the @BTRFS_IOC_SYNC@ @ioctl@. +sync :: FILEPATH -> IO () +sync path = withFd path ReadOnly syncFd + +startSyncFd :: Fd -> IO () +startSyncFd fd = + throwErrnoIfMinus1_ "startSyncFd" $ + ioctl_fast fd (#const BTRFS_IOC_START_SYNC) nullPtr + +-- | Initiate a sync for the file system identified by the supplied path. +-- +-- Note: calls the @BTRFS_IOC_START_SYNC@ @ioctl@. +startSync :: FILEPATH -> IO () +startSync path = withFd path ReadOnly startSyncFd + +waitSyncFd :: Fd -> IO () +waitSyncFd fd = + throwErrnoIfMinus1_ "waitSyncFd" $ + ioctl fd (#const BTRFS_IOC_WAIT_SYNC) nullPtr + +-- | Wait until the sync operation completes. +-- +-- Note: calls the @BTRFS_IOC_WAIT_SYNC@ @ioctl@. +waitSync :: FILEPATH -> IO () +waitSync path = withFd path ReadOnly waitSyncFd + +-------------------------------------------------------------------------------- + +resolveLogicalFd :: Fd -> FileSize -> IO ([(InodeNum, FileSize, SubvolId)], Int) +resolveLogicalFd rootFd logical = + allocaBytes inodesSize $ \inodes -> + allocaBytesZero (#size struct btrfs_ioctl_logical_ino_args) $ \lia -> do + (#poke struct btrfs_ioctl_logical_ino_args, logical) lia logical + (#poke struct btrfs_ioctl_logical_ino_args, size ) lia (fromIntegral inodesSize :: Word64) + (#poke struct btrfs_ioctl_logical_ino_args, inodes ) lia inodes + throwErrnoIfMinus1_ "resolveLogical" $ ioctl rootFd (#const BTRFS_IOC_LOGICAL_INO) lia + elemMissed <- (#peek struct btrfs_data_container, elem_missed) inodes :: IO Word32 + count <- (#peek struct btrfs_data_container, elem_cnt ) inodes :: IO Word32 + let val = (#ptr struct btrfs_data_container, val) inodes :: Ptr Word64 + vals <- peekArray (fromIntegral count) val + return (extractTriplets vals, fromIntegral elemMissed) + where + inodesSize = 64 * 1024 + (#size struct btrfs_data_container) + 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" + +-- | Given a physical offset, look for any inodes that this byte belongs +-- to. For each inode, it returns the inode number, the logical offset +-- (i.e. the offset within the inode), and the subvolume id. If a large +-- number of inodes is found, then not all of them will be returned by this +-- function. This is due to a current limitation in the kernel. The integer +-- returned along with list of inodes indicates the number of inodes found +-- but not included in the list. +-- +-- Note: calls the @BTRFS_IOC_LOGICAL_INO@ @ioctl@. +resolveLogical + :: FILEPATH -- ^ The mount point of the volume (or any file in that volume). + -> FileSize -- ^ The physical byte offset in the underlying block device. + -> 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 (#size struct btrfs_ioctl_ino_path_args) $ \ipa -> do + (#poke struct btrfs_ioctl_ino_path_args, inum ) ipa inum + (#poke struct btrfs_ioctl_ino_path_args, size ) ipa (fromIntegral fspathSize :: Word64) + (#poke struct btrfs_ioctl_ino_path_args, fspath) ipa fspath + throwErrnoIfMinus1_ "resolveInode" $ ioctl subvolFd (#const BTRFS_IOC_INO_PATHS) ipa + elemMissed <- (#peek struct btrfs_data_container, elem_missed) fspath :: IO Word32 + count <- (#peek struct btrfs_data_container, elem_cnt ) fspath :: IO Word32 + let val = (#ptr struct btrfs_data_container, val) fspath :: Ptr Word64 + vals <- peekArray (fromIntegral count) val + paths <- mapM (peekCString . plusPtr val . fromIntegral) vals + return (paths, fromIntegral elemMissed) + where + fspathSize = 2 * 1024 + (#size struct btrfs_data_container) + +-- | Find the file path(s) given an inode number. Returns a list of file paths +-- and an integer indicating the number of path found but not included in +-- the resulting list. This is because of a limitation in the kernel (it +-- will not return an arbitrarily large list). The paths returned are +-- relative to the root of the subvolume. +-- +-- Note: calls the @BTRFS_IOC_INO_PATHS@ @ioctl@. +resolveInode + :: FILEPATH -- ^ The path to the subvolume (or any file in that subvolume). + -> InodeNum -- ^ The inode number. + -> 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 (#size struct btrfs_ioctl_ino_lookup_args) $ \ila -> do + (#poke struct btrfs_ioctl_ino_lookup_args, treeid ) ila treeId + (#poke struct btrfs_ioctl_ino_lookup_args, objectid) ila inum + throwErrnoIfMinus1_ "lookupInodeFd" $ + ioctl_fast fd (#const BTRFS_IOC_INO_LOOKUP) ila + treeId' <- (#peek struct btrfs_ioctl_ino_lookup_args, treeid) ila :: IO Word64 + let cName = (#ptr struct btrfs_ioctl_ino_lookup_args, name) ila + name <- peekCString cName + return (treeId', dropTrailingSlash name) + +-- | Find the path of a file given its inode number and the id of the +-- subvolume. If multiple files share the same inode number, only one of +-- them is returned. The id of the subvolume is also returned. This is +-- useful when 0 is given for the 'SubvolId' argument (also see +-- 'getSubvol' for this case). +-- +-- Note: calls the @BTRFS_IOC_INO_LOOKUP@ @ioctl@. +lookupInode + :: FILEPATH -- ^ The path to any file in the volume. The subvolume where + -- this file resides is ignored unless no 'SubvolId' is + -- provided (see below). + -> SubvolId -- ^ The id of the subvolume. Can be 0. In that case, the + -- subvolume of the 'FilePath' is used (see above). + -> InodeNum -- ^ The inode number. + -> 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 (#const FS_IOC_GETFLAGS) flagsPtr + flags <- peek flagsPtr :: IO CUInt + return (flags .&. (#const FS_NOCOW_FL) /= 0) + +-- | Determine whether the NOCOW flag is enabled for the specified file. +-- +-- Note: calls the @FS_IOC_GETFLAGS@ @ioctl@. +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 (#const FS_IOC_GETFLAGS) flagsPtr + if noCOW then + setFlags flagsPtr ((#const FS_NOCOW_FL) :: CUInt) + else + clearFlags flagsPtr ((#const FS_NOCOW_FL) :: CUInt) + throwErrnoIfMinus1_ "setFileNoCOWFd" $ + ioctl fd (#const FS_IOC_SETFLAGS) flagsPtr + +-- | Set or clear the NOCOW flag for the specified file. If the file is not +-- empty, this has no effect and no error will be reported. +-- +-- Note: calls the @FS_IOC_GETFLAGS@ and @FS_IOC_GETFLAGS@ @ioctl@s. +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 (#size struct btrfs_ioctl_search_args) $ \saPtr -> do + let skPtr = (#ptr struct btrfs_ioctl_search_args, key) 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 + (#poke struct btrfs_ioctl_search_key, nr_items) skPtr nrItems + throwErrnoIfMinus1_ "treeSearchFd" $ + ioctl fd (#const BTRFS_IOC_TREE_SEARCH) saPtr + itemsFound <- (#peek struct btrfs_ioctl_search_key, nr_items) skPtr :: IO Word32 + when (itemsFound > 0) $ do + let shPtr = (#ptr struct btrfs_ioctl_search_args, buf) saPtr + lastSh <- loopItems shPtr itemsFound + case nextKey (shObjectId lastSh, shType lastSh, shOffset lastSh) of + Nothing -> return () + Just (objectId, iType, offset) -> do + (#poke struct btrfs_ioctl_search_key, min_objectid) skPtr objectId + (#poke struct btrfs_ioctl_search_key, min_type ) skPtr (fromIntegral iType :: Word32) + (#poke struct btrfs_ioctl_search_key, min_offset ) skPtr offset + loopSingleSearch saPtr skPtr (maxItemCount - fromIntegral itemsFound) + -- itemsFound must be at least 1 + 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) + -- items are index by keys which are (objectId, iType, offset) + -- they are returned in lexicographical order wrt the keys + 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 + +-- does not initialize nr_items +pokeSearchKey :: Ptr a -> SearchKey -> IO () +pokeSearchKey ptr sk = do + (#poke struct btrfs_ioctl_search_key, tree_id ) ptr (skTreeId sk) + (#poke struct btrfs_ioctl_search_key, min_objectid) ptr (skMinObjectId sk) + (#poke struct btrfs_ioctl_search_key, min_type ) ptr (fromIntegral (skMinType sk) :: Word32) + (#poke struct btrfs_ioctl_search_key, min_offset ) ptr (skMinOffset sk) + (#poke struct btrfs_ioctl_search_key, max_objectid) ptr (skMaxObjectId sk) + (#poke struct btrfs_ioctl_search_key, max_type ) ptr (fromIntegral (skMaxType sk) :: Word32) + (#poke struct btrfs_ioctl_search_key, max_offset ) ptr (skMaxOffset sk) + (#poke struct btrfs_ioctl_search_key, min_transid ) ptr (skMinTransId sk) + (#poke struct btrfs_ioctl_search_key, max_transid ) ptr (skMaxTransId sk) + +peekSearchItem :: Ptr a -> IO (SearchHeader, Ptr i) +peekSearchItem shPtr = do + transId <- (#peek struct btrfs_ioctl_search_header, transid ) shPtr :: IO Word64 + objectId <- (#peek struct btrfs_ioctl_search_header, objectid) shPtr :: IO Word64 + offset <- (#peek struct btrfs_ioctl_search_header, offset ) shPtr :: IO Word64 + iType <- (#peek struct btrfs_ioctl_search_header, type ) shPtr :: IO Word32 + len <- (#peek struct btrfs_ioctl_search_header, len ) shPtr :: IO Word32 + let itemPtr = shPtr `plusPtr` (#size struct btrfs_ioctl_search_header) + return (SearchHeader transId objectId offset (fromIntegral iType) len, itemPtr) + +peekRootRef :: Ptr a -> IO (InodeNum, FILEPATH) +peekRootRef rrPtr = do + LE64 dirId <- (#peek struct btrfs_root_ref, dirid ) rrPtr + LE16 nameLen <- (#peek struct btrfs_root_ref, name_len) rrPtr + let cName = rrPtr `plusPtr` (#size struct btrfs_root_ref) + 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 +{-# INLINE nothingIf #-} + +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 () +{-# INLINE memset #-} + +foreign import ccall unsafe "string.h memset" + c_memset :: Ptr a -> CInt -> CSize -> IO (Ptr a) diff --git a/btrfs.cabal b/btrfs.cabal --- a/btrfs.cabal +++ b/btrfs.cabal @@ -1,5 +1,5 @@ name: btrfs -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Bindings to the btrfs API description: This package provides low-level bindings to the btrfs API (i.e. the @@ -19,7 +19,7 @@ author: Marios Titas maintainer: Marios Titas category: System, Filesystem -build-type: Custom +build-type: Simple cabal-version: >=1.10 extra-source-files: @@ -31,6 +31,7 @@ include/btrfs/list.h include/btrfs/radix-tree.h include/btrfs/rbtree.h + make-bytestring.hs source-repository head type: git @@ -41,7 +42,8 @@ default: False library - exposed-modules: System.Linux.Btrfs, System.Linux.Btrfs.UUID + exposed-modules: System.Linux.Btrfs, System.Linux.Btrfs.ByteString, + System.Linux.Btrfs.UUID other-modules: Data.Word.Endian, System.Linux.Btrfs.Time, System.Linux.Btrfs.FilePathLike build-depends: base >=4.6 && <5, unix >=2.6, diff --git a/make-bytestring.hs b/make-bytestring.hs new file mode 100644 --- /dev/null +++ b/make-bytestring.hs @@ -0,0 +1,18 @@ +#!/usr/bin/runhaskell + +import System.Directory +import System.IO +import Control.Monad + +main :: IO () +main = do + doesFileExist "btrfs.cabal" >>= \f -> + unless f $ fail "could not find btrfs.cabal" + + -- create System/Linux/Btrfs/ByteString.hsc + withFile "System/Linux/Btrfs/ByteString.hsc" WriteMode $ \oHdl -> do + hPutStrLn oHdl "#define BTRFS_RAW_PATHS 1" + withFile "System/Linux/Btrfs.hsc" ReadMode $ \iHdl -> do + _ <- hGetLine iHdl -- skip the first line + contents <- hGetContents iHdl + hPutStr oHdl contents