diff --git a/HFuse.cabal b/HFuse.cabal --- a/HFuse.cabal +++ b/HFuse.cabal @@ -1,39 +1,29 @@ Name: HFuse -Version: 0.1 +Version: 0.2.1 License: BSD3 -License-File: LICENSE -Author: Jérémy Bobbio -Maintainer: Jérémy Bobbio -Synopsis: HFuse is a binding for the Linux FUSE library -Description: HFuse is a binding to the Linux C library, FUSE ('Filesystems in Userspace'); - FUSE allows you to construct interesting filesystems which can be used in many ways, - such as a filesystem in which the files are Wikipedia files, or SSHFS where one mounts remote - directories over SSH, or FlickrFS which represents your Flickr account as directories and files. -Homepage: http://darcs.haskell.org/hfuse +License-File: LICENSE +Author: Jeremy Bobbio +Maintainer: Taru Karttunen +Synopsis: HFuse is a binding for the Linux FUSE library. +Homepage: http://code.haskell.org/hfuse Category: System Stability: Experimental - Cabal-Version: >= 1.2 Build-Type: Simple --- Examples -Extra-Source-Files: System/Posix/HelloFS.hs, System/Posix/LiveFS.hs -Data-Files: README - Library - exposed-Modules: System.Posix.HFuse - - -- FIX: Remove this: - Includes: sys/statfs.h, dirent.h, fuse.h, fcntl.h - Include-Dirs: /usr/include, /usr/local/include - Extra-Libraries: fuse - Extra-Lib-Dirs: /usr/local/lib - - Build-Depends: base, unix - Extensions: ForeignFunctionInterface, PatternSignatures, EmptyDataDecls - Ghc-Options: -threaded -O2 -Wall -optl-Wl,-s - Ghc-Prof-Options: -prof -auto-all + Build-Depends: base, unix, bytestring + exposed-Modules: System.Fuse + Extensions: ForeignFunctionInterface PatternSignatures EmptyDataDecls + Includes: sys/statfs.h, dirent.h, fuse.h, fcntl.h + Include-Dirs: /usr/include, /usr/local/include, . + Extra-Libraries: fuse + Extra-Lib-Dirs: /usr/local/lib + Includes: fuse_wrappers.h + Install-Includes: fuse_wrappers.h + C-Sources: fuse_wrappers.c + CC-Options: -D_FILE_OFFSET_BITS=64 + if os(darwin) { + CC-Options: "-DMACFUSE" + } - -- When compiling for a 64-bit architecture, we need special flags for hsc2hs - if arch(x86_64) - cc-options: -D_FILE_OFFSET_BITS=64 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -4,26 +4,23 @@ Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors +3. Neither the name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,6 +0,0 @@ -HelloFS seems to work with: -* Linux 2.4.26 -* The Glorious Glasgow Haskell Compilation System, version 6.2.2 -* fuse-2.3 - -BindFS (?) is known to have a deadlock problem. diff --git a/System/Fuse.hsc b/System/Fuse.hsc new file mode 100644 --- /dev/null +++ b/System/Fuse.hsc @@ -0,0 +1,916 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Fuse +-- Copyright : (c) Jérémy Bobbio +-- License : BSD-style +-- +-- Maintainer : jeremy.bobbio@etu.upmc.fr +-- Stability : experimental +-- Portability : GHC 6.4 +-- +-- A binding for the FUSE (Filesystem in USErspace) library +-- (), which allows filesystems to be implemented +-- as userspace processes. +-- +-- The binding tries to follow as much as possible current Haskell POSIX +-- interface in "System.Posix.Files" and "System.Posix.Directory". +-- +-- FUSE uses POSIX threads, so any Haskell application using this library must +-- be linked against a threaded runtime system (eg. using the @threaded@ GHC +-- option). +-- +----------------------------------------------------------------------------- +module System.Fuse + ( -- * Using FUSE + + -- $intro + + module Foreign.C.Error + , FuseOperations(..) + , defaultFuseOps + , fuseMain -- :: FuseOperations -> (Exception -> IO Errno) -> IO () + , defaultExceptionHandler -- :: Exception -> IO Errno + -- * Operations datatypes + , FileStat(..) + , EntryType(..) + , FileSystemStats(..) + , SyncType(..) + -- * FUSE Context + , getFuseContext -- :: IO FuseContext + , FuseContext(fuseCtxUserID, fuseCtxGroupID, fuseCtxProcessID) + -- * File modes + , entryTypeToFileMode -- :: EntryType -> FileMode + , OpenMode(..) + , OpenFileFlags(..) + , intersectFileModes -- :: FileMode + , unionFileModes -- :: FileMode + ) where + +import Prelude hiding ( Read ) + +import Control.Exception as E( Exception, handle, finally ) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B +import Foreign +import Foreign.C +import Foreign.C.Error +import Foreign.Marshal +import System.Environment ( getProgName, getArgs ) +import System.IO ( hPutStrLn, stderr ) +import System.Posix.Types +import System.Posix.Files ( accessModes, intersectFileModes, unionFileModes ) +import System.Posix.IO ( OpenMode(..), OpenFileFlags(..) ) + +-- TODO: FileMode -> Permissions +-- TODO: Arguments ! +-- TODO: implement binding to fuse_invalidate +-- TODO: bind fuse_*xattr + +#define FUSE_USE_VERSION 26 + +#ifdef MACFUSE +#include +#else +#include +#endif + +#include +#include +#include + +#include "fuse_wrappers.h" + +{- $intro +'FuseOperations' contains a field for each filesystem operations that can be called +by FUSE. Think like if you were implementing a file system inside the Linux kernel. + +Each actions must return a POSIX error code, also called 'Errno' reflecting +operation result. For actions not using 'Either', you should return 'eOK' in case +of success. + +Read and writes are done with Haskell 'ByteString' type. + +-} + +{- All operations should return the negated error value (-errno) on + error. +-} + +{- | Used by 'fuseGetFileStat'. Corresponds to @struct stat@ from @stat.h@; + @st_dev@, @st_ino@ and @st_blksize@ are omitted, since (from the libfuse + documentation): \"the @st_dev@ and @st_blksize@ fields are ignored. The + @st_ino@ field is ignored except if the use_ino mount option is given.\" + + /TODO: at some point the inode field will probably be needed./ +-} +data FileStat = FileStat { statEntryType :: EntryType + , statFileMode :: FileMode + , statLinkCount :: LinkCount + , statFileOwner :: UserID + , statFileGroup :: GroupID + , statSpecialDeviceID :: DeviceID + , statFileSize :: FileOffset + , statBlocks :: Integer + , statAccessTime :: EpochTime + , statModificationTime :: EpochTime + , statStatusChangeTime :: EpochTime + } + deriving Show + +{- FIXME: I don't know how to determine the alignment of struct stat without + - making unportable assumptions about the order of elements within it. Hence, + - FileStat is not an instance of Storable. But it should be, rather than this + - next function existing! + -} + +fileStatToCStat :: FileStat -> Ptr CStat -> IO () +fileStatToCStat stat pStat = do + let mode = (entryTypeToFileMode (statEntryType stat) + `unionFileModes` + (statFileMode stat `intersectFileModes` accessModes)) + let block_count = (fromIntegral (statBlocks stat) :: (#type blkcnt_t)) + (#poke struct stat, st_mode) pStat mode + (#poke struct stat, st_nlink) pStat (statLinkCount stat) + (#poke struct stat, st_uid) pStat (statFileOwner stat) + (#poke struct stat, st_gid) pStat (statFileGroup stat) + (#poke struct stat, st_rdev) pStat (statSpecialDeviceID stat) + (#poke struct stat, st_size) pStat (statFileSize stat) + (#poke struct stat, st_blocks) pStat block_count + (#poke struct stat, st_atime) pStat (statAccessTime stat) + (#poke struct stat, st_mtime) pStat (statModificationTime stat) + (#poke struct stat, st_ctime) pStat (statStatusChangeTime stat) + + +-- | The Unix type of a node in the filesystem. +data EntryType + = Unknown -- ^ Unknown entry type + | NamedPipe + | CharacterSpecial + | Directory + | BlockSpecial + | RegularFile + | SymbolicLink + | Socket + deriving(Show) + +entryTypeToDT :: EntryType -> Int +entryTypeToDT Unknown = (#const DT_UNKNOWN) +entryTypeToDT NamedPipe = (#const DT_FIFO) +entryTypeToDT CharacterSpecial = (#const DT_CHR) +entryTypeToDT Directory = (#const DT_DIR) +entryTypeToDT BlockSpecial = (#const DT_BLK) +entryTypeToDT RegularFile = (#const DT_REG) +entryTypeToDT SymbolicLink = (#const DT_LNK) +entryTypeToDT Socket = (#const DT_SOCK) + +fileTypeModes :: FileMode +fileTypeModes = (#const S_IFMT) + +blockSpecialMode :: FileMode +blockSpecialMode = (#const S_IFBLK) + +characterSpecialMode :: FileMode +characterSpecialMode = (#const S_IFCHR) + +namedPipeMode :: FileMode +namedPipeMode = (#const S_IFIFO) + +regularFileMode :: FileMode +regularFileMode = (#const S_IFREG) + +directoryMode :: FileMode +directoryMode = (#const S_IFDIR) + +symbolicLinkMode :: FileMode +symbolicLinkMode = (#const S_IFLNK) + +socketMode :: FileMode +socketMode = (#const S_IFSOCK) + +-- | Converts an 'EntryType' into the corresponding POSIX 'FileMode'. +entryTypeToFileMode :: EntryType -> FileMode +entryTypeToFileMode Unknown = 0 +entryTypeToFileMode NamedPipe = namedPipeMode +entryTypeToFileMode CharacterSpecial = characterSpecialMode +entryTypeToFileMode Directory = directoryMode +entryTypeToFileMode BlockSpecial = blockSpecialMode +entryTypeToFileMode RegularFile = regularFileMode +entryTypeToFileMode SymbolicLink = symbolicLinkMode +entryTypeToFileMode Socket = socketMode + +fileModeToEntryType :: FileMode -> EntryType +fileModeToEntryType mode + | fileType == namedPipeMode = NamedPipe + | fileType == characterSpecialMode = CharacterSpecial + | fileType == directoryMode = Directory + | fileType == blockSpecialMode = BlockSpecial + | fileType == regularFileMode = RegularFile + | fileType == symbolicLinkMode = SymbolicLink + | fileType == socketMode = Socket + where fileType = mode .&. (#const S_IFMT) + +{- + There is no create() operation, mknod() will be called for + creation of all non directory, non symlink nodes. +-} + +-- | Type used by the 'fuseGetFileSystemStats'. +data FileSystemStats = FileSystemStats + { fsStatBlockSize :: Integer + -- ^ Optimal transfer block size. FUSE default is 512. + , fsStatBlockCount :: Integer + -- ^ Total data blocks in file system. + , fsStatBlocksFree :: Integer + -- ^ Free blocks in file system. + , fsStatBlocksAvailable :: Integer + -- ^ Free blocks available to non-superusers. + , fsStatFileCount :: Integer + -- ^ Total file nodes in file system. + , fsStatFilesFree :: Integer + -- ^ Free file nodes in file system. + , fsStatMaxNameLength :: Integer + -- ^ Maximum length of filenames. FUSE default is 255. + } + + +-- | Used by 'fuseSynchronizeFile' and 'fuseSynchronizeDirectory'. +data SyncType + = FullSync + -- ^ Synchronize all in-core parts of a file to disk: file content and + -- metadata. + | DataSync + -- ^ Synchronize only the file content. + deriving (Eq, Enum) + + +-- | Returned by 'getFuseContext'. +data FuseContext = FuseContext + { fuseCtxUserID :: UserID + , fuseCtxGroupID :: GroupID + , fuseCtxProcessID :: ProcessID + } + +-- | Returns the context of the program doing the current FUSE call. +getFuseContext :: IO FuseContext +getFuseContext = + do pCtx <- fuse_get_context + userID <- (#peek struct fuse_context, uid) pCtx + groupID <- (#peek struct fuse_context, gid) pCtx + processID <- (#peek struct fuse_context, pid) pCtx + return $ FuseContext { fuseCtxUserID = userID + , fuseCtxGroupID = groupID + , fuseCtxProcessID = processID + } + +-- | This record, given to 'fuseMain', binds each required file system +-- operations. +-- +-- Each field is named against 'System.Posix' names. Matching Linux system +-- calls are also given as a reference. +-- +-- @fh@ is the file handle type returned by 'fuseOpen' and subsequently passed +-- to all other file operations. +data FuseOperations fh = FuseOperations + { -- | Implements 'System.Posix.Files.getSymbolicLinkStatus' operation + -- (POSIX @lstat(2)@). + fuseGetFileStat :: FilePath -> IO (Either Errno FileStat), + + -- | Implements 'System.Posix.Files.readSymbolicLink' operation (POSIX + -- @readlink(2)@). The returned 'FilePath' might be truncated + -- depending on caller buffer size. + fuseReadSymbolicLink :: FilePath -> IO (Either Errno FilePath), + + -- | Implements 'System.Posix.Files.createDevice' (POSIX @mknod(2)@). + -- This function will also be called for regular file creation. + fuseCreateDevice :: FilePath -> EntryType -> FileMode + -> DeviceID -> IO Errno, + + -- | Implements 'System.Posix.Directory.createDirectory' (POSIX + -- @mkdir(2)@). + fuseCreateDirectory :: FilePath -> FileMode -> IO Errno, + + -- | Implements 'System.Posix.Files.removeLink' (POSIX @unlink(2)@). + fuseRemoveLink :: FilePath -> IO Errno, + + -- | Implements 'System.Posix.Directory.removeDirectory' (POSIX + -- @rmdir(2)@). + fuseRemoveDirectory :: FilePath -> IO Errno, + + -- | Implements 'System.Posix.Files.createSymbolicLink' (POSIX + -- @symlink(2)@). + fuseCreateSymbolicLink :: FilePath -> FilePath -> IO Errno, + + -- | Implements 'System.Posix.Files.rename' (POSIX @rename(2)@). + fuseRename :: FilePath -> FilePath -> IO Errno, + + -- | Implements 'System.Posix.Files.createLink' (POSIX @link(2)@). + fuseCreateLink :: FilePath -> FilePath -> IO Errno, + + -- | Implements 'System.Posix.Files.setFileMode' (POSIX @chmod(2)@). + fuseSetFileMode :: FilePath -> FileMode -> IO Errno, + + -- | Implements 'System.Posix.Files.setOwnerAndGroup' (POSIX + -- @chown(2)@). + fuseSetOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO Errno, + + -- | Implements 'System.Posix.Files.setFileSize' (POSIX @truncate(2)@). + fuseSetFileSize :: FilePath -> FileOffset -> IO Errno, + + -- | Implements 'System.Posix.Files.setFileTimes' + -- (POSIX @utime(2)@). + fuseSetFileTimes :: FilePath -> EpochTime -> EpochTime -> IO Errno, + + -- | Implements 'System.Posix.Files.openFd' (POSIX @open(2)@). On + -- success, returns 'Right' of a filehandle-like value that will be + -- passed to future file operations; on failure, returns 'Left' of the + -- appropriate 'Errno'. + -- + -- No creation, exclusive access or truncating flags will be passed. + -- This should check that the operation is permitted for the given + -- flags. + fuseOpen :: FilePath -> OpenMode -> OpenFileFlags -> IO (Either Errno fh), + + -- | Implements Unix98 @pread(2)@. It differs from + -- 'System.Posix.Files.fdRead' by the explicit 'FileOffset' argument. + -- The @fuse.h@ documentation stipulates that this \"should return + -- exactly the number of bytes requested except on EOF or error, + -- otherwise the rest of the data will be substituted with zeroes.\" + fuseRead :: FilePath -> fh -> ByteCount -> FileOffset + -> IO (Either Errno B.ByteString), + + -- | Implements Unix98 @pwrite(2)@. It differs + -- from 'System.Posix.Files.fdWrite' by the explicit 'FileOffset' argument. + fuseWrite :: FilePath -> fh -> B.ByteString -> FileOffset + -> IO (Either Errno ByteCount), + + -- | Implements @statfs(2)@. + fuseGetFileSystemStats :: String -> IO (Either Errno FileSystemStats), + + -- | Called when @close(2)@ has been called on an open file. + -- Note: this does not mean that the file is released. This function may be + -- called more than once for each @open(2)@. The return value is passed on + -- to the @close(2)@ system call. + fuseFlush :: FilePath -> fh -> IO Errno, + + -- | Called when an open file has all file descriptors closed and all + -- memory mappings unmapped. For every @open@ call there will be + -- exactly one @release@ call with the same flags. It is possible to + -- have a file opened more than once, in which case only the last + -- release will mean that no more reads or writes will happen on the + -- file. + fuseRelease :: FilePath -> fh -> IO (), + + -- | Implements @fsync(2)@. + fuseSynchronizeFile :: FilePath -> SyncType -> IO Errno, + + -- | Implements @opendir(3)@. This method should check if the open + -- operation is permitted for this directory. + fuseOpenDirectory :: FilePath -> IO Errno, + + -- | Implements @readdir(3)@. The entire contents of the directory + -- should be returned as a list of tuples (corresponding to the first + -- mode of operation documented in @fuse.h@). + fuseReadDirectory :: FilePath -> IO (Either Errno [(FilePath, FileStat)]), + + -- | Implements @closedir(3)@. + fuseReleaseDirectory :: FilePath -> IO Errno, + + -- | Synchronize the directory's contents; analogous to + -- 'fuseSynchronizeFile'. + fuseSynchronizeDirectory :: FilePath -> SyncType -> IO Errno, + + -- | Check file access permissions; this will be called for the + -- access() system call. If the @default_permissions@ mount option + -- is given, this method is not called. This method is also not + -- called under Linux kernel versions 2.4.x + fuseAccess :: FilePath -> Int -> IO Errno, -- FIXME present a nicer type to Haskell + + -- | Initializes the filesystem. This is called before all other + -- operations. + fuseInit :: IO (), + + -- | Called on filesystem exit to allow cleanup. + fuseDestroy :: IO () + } + +-- | Empty \/ default versions of the FUSE operations. +defaultFuseOps :: FuseOperations fh +defaultFuseOps = + FuseOperations { fuseGetFileStat = \_ -> return (Left eNOSYS) + , fuseReadSymbolicLink = \_ -> return (Left eNOSYS) + , fuseCreateDevice = \_ _ _ _ -> return eNOSYS + , fuseCreateDirectory = \_ _ -> return eNOSYS + , fuseRemoveLink = \_ -> return eNOSYS + , fuseRemoveDirectory = \_ -> return eNOSYS + , fuseCreateSymbolicLink = \_ _ -> return eNOSYS + , fuseRename = \_ _ -> return eNOSYS + , fuseCreateLink = \_ _ -> return eNOSYS + , fuseSetFileMode = \_ _ -> return eNOSYS + , fuseSetOwnerAndGroup = \_ _ _ -> return eNOSYS + , fuseSetFileSize = \_ _ -> return eNOSYS + , fuseSetFileTimes = \_ _ _ -> return eNOSYS + , fuseOpen = \_ _ _ -> return (Left eNOSYS) + , fuseRead = \_ _ _ _ -> return (Left eNOSYS) + , fuseWrite = \_ _ _ _ -> return (Left eNOSYS) + , fuseGetFileSystemStats = \_ -> return (Left eNOSYS) + , fuseFlush = \_ _ -> return eOK + , fuseRelease = \_ _ -> return () + , fuseSynchronizeFile = \_ _ -> return eNOSYS + , fuseOpenDirectory = \_ -> return eNOSYS + , fuseReadDirectory = \_ -> return (Left eNOSYS) + , fuseReleaseDirectory = \_ -> return eNOSYS + , fuseSynchronizeDirectory = \_ _ -> return eNOSYS + , fuseAccess = \_ _ -> return eNOSYS + , fuseInit = return () + , fuseDestroy = return () + } + + +-- | Main function of FUSE. +-- This is all that has to be called from the @main@ function. On top of +-- the 'FuseOperations' record with filesystem implementation, you must give +-- an exception handler converting Haskell exceptions to 'Errno'. +-- +-- This function does the following: +-- +-- * parses command line options (@-d@, @-s@ and @-h@) ; +-- +-- * passes all options after @--@ to the fusermount program ; +-- +-- * mounts the filesystem by calling @fusermount@ ; +-- +-- * installs signal handlers for 'System.Posix.Signals.keyboardSignal', +-- 'System.Posix.Signals.lostConnection', +-- 'System.Posix.Signals.softwareTermination' and +-- 'System.Posix.Signals.openEndedPipe' ; +-- +-- * registers an exit handler to unmount the filesystem on program exit ; +-- +-- * registers the operations ; +-- +-- * calls FUSE event loop. +fuseMain :: FuseOperations fh -> (Exception -> IO Errno) -> IO () +fuseMain ops handler = + allocaBytes (#size struct fuse_operations) $ \ pOps -> do + mkGetAttr wrapGetAttr >>= (#poke struct fuse_operations, getattr) pOps + mkReadLink wrapReadLink >>= (#poke struct fuse_operations, readlink) pOps + -- getdir is deprecated and thus unsupported + (#poke struct fuse_operations, getdir) pOps nullPtr + mkMkNod wrapMkNod >>= (#poke struct fuse_operations, mknod) pOps + mkMkDir wrapMkDir >>= (#poke struct fuse_operations, mkdir) pOps + mkUnlink wrapUnlink >>= (#poke struct fuse_operations, unlink) pOps + mkRmDir wrapRmDir >>= (#poke struct fuse_operations, rmdir) pOps + mkSymLink wrapSymLink >>= (#poke struct fuse_operations, symlink) pOps + mkRename wrapRename >>= (#poke struct fuse_operations, rename) pOps + mkLink wrapLink >>= (#poke struct fuse_operations, link) pOps + mkChMod wrapChMod >>= (#poke struct fuse_operations, chmod) pOps + mkChOwn wrapChOwn >>= (#poke struct fuse_operations, chown) pOps + mkTruncate wrapTruncate >>= (#poke struct fuse_operations, truncate) pOps + -- TODO: Deprecated, use utimens() instead. + mkUTime wrapUTime >>= (#poke struct fuse_operations, utime) pOps + mkOpen wrapOpen >>= (#poke struct fuse_operations, open) pOps + mkRead wrapRead >>= (#poke struct fuse_operations, read) pOps + mkWrite wrapWrite >>= (#poke struct fuse_operations, write) pOps + mkStatFS wrapStatFS >>= (#poke struct fuse_operations, statfs) pOps + mkFlush wrapFlush >>= (#poke struct fuse_operations, flush) pOps + mkRelease wrapRelease >>= (#poke struct fuse_operations, release) pOps + mkFSync wrapFSync >>= (#poke struct fuse_operations, fsync) pOps + -- TODO: Implement these + (#poke struct fuse_operations, setxattr) pOps nullPtr + (#poke struct fuse_operations, getxattr) pOps nullPtr + (#poke struct fuse_operations, listxattr) pOps nullPtr + (#poke struct fuse_operations, removexattr) pOps nullPtr + mkOpenDir wrapOpenDir >>= (#poke struct fuse_operations, opendir) pOps + mkReadDir wrapReadDir >>= (#poke struct fuse_operations, readdir) pOps + mkReleaseDir wrapReleaseDir >>= (#poke struct fuse_operations, releasedir) pOps + mkFSyncDir wrapFSyncDir >>= (#poke struct fuse_operations, fsyncdir) pOps + mkAccess wrapAccess >>= (#poke struct fuse_operations, access) pOps + mkInit wrapInit >>= (#poke struct fuse_operations, init) pOps + mkDestroy wrapDestroy >>= (#poke struct fuse_operations, destroy) pOps + prog <- getProgName + args <- getArgs + let allArgs = (prog:args) + argc = length allArgs + withMany withCString allArgs $ \ pAddrs -> + withArray pAddrs $ \ pArgv -> + do fuse_main_wrapper argc pArgv pOps + where fuseHandler :: Exception -> IO CInt + fuseHandler e = handler e >>= return . unErrno + wrapGetAttr :: CGetAttr + wrapGetAttr pFilePath pStat = handle fuseHandler $ + do filePath <- peekCString pFilePath + eitherFileStat <- (fuseGetFileStat ops) filePath + case eitherFileStat of + Left (Errno errno) -> return (- errno) + Right stat -> do fileStatToCStat stat pStat + return okErrno + + wrapReadLink :: CReadLink + wrapReadLink pFilePath pBuf bufSize = handle fuseHandler $ + do filePath <- peekCString pFilePath + return (- unErrno eNOSYS) + eitherTarget <- (fuseReadSymbolicLink ops) filePath + case eitherTarget of + Left (Errno errno) -> return (- errno) + Right target -> + -- This will truncate target if it's longer than the buffer + -- can hold, which is correct according to fuse.h + do pokeCStringLen0 (pBuf, (fromIntegral bufSize)) target + return okErrno + + wrapMkNod :: CMkNod + wrapMkNod pFilePath mode dev = handle fuseHandler $ + do filePath <- peekCString pFilePath + (Errno errno) <- (fuseCreateDevice ops) filePath + (fileModeToEntryType mode) mode dev + return (- errno) + wrapMkDir :: CMkDir + wrapMkDir pFilePath mode = handle fuseHandler $ + do filePath <- peekCString pFilePath + (Errno errno) <- (fuseCreateDirectory ops) filePath mode + return (- errno) + wrapUnlink :: CUnlink + wrapUnlink pFilePath = handle fuseHandler $ + do filePath <- peekCString pFilePath + (Errno errno) <- (fuseRemoveLink ops) filePath + return (- errno) + wrapRmDir :: CRmDir + wrapRmDir pFilePath = handle fuseHandler $ + do filePath <- peekCString pFilePath + (Errno errno) <- (fuseRemoveDirectory ops) filePath + return (- errno) + wrapSymLink :: CSymLink + wrapSymLink pSource pDestination = handle fuseHandler $ + do source <- peekCString pSource + destination <- peekCString pDestination + (Errno errno) <- (fuseCreateSymbolicLink ops) source destination + return (- errno) + wrapRename :: CRename + wrapRename pOld pNew = handle fuseHandler $ + do old <- peekCString pOld + new <- peekCString pNew + (Errno errno) <- (fuseRename ops) old new + return (- errno) + wrapLink :: CLink + wrapLink pSource pDestination = handle fuseHandler $ + do source <- peekCString pSource + destination <- peekCString pDestination + (Errno errno) <- (fuseCreateLink ops) source destination + return (- errno) + wrapChMod :: CChMod + wrapChMod pFilePath mode = handle fuseHandler $ + do filePath <- peekCString pFilePath + (Errno errno) <- (fuseSetFileMode ops) filePath mode + return (- errno) + wrapChOwn :: CChOwn + wrapChOwn pFilePath uid gid = handle fuseHandler $ + do filePath <- peekCString pFilePath + (Errno errno) <- (fuseSetOwnerAndGroup ops) filePath uid gid + return (- errno) + wrapTruncate :: CTruncate + wrapTruncate pFilePath off = handle fuseHandler $ + do filePath <- peekCString pFilePath + (Errno errno) <- (fuseSetFileSize ops) filePath off + return (- errno) + wrapUTime :: CUTime + wrapUTime pFilePath pUTimBuf = handle fuseHandler $ + do filePath <- peekCString pFilePath + accessTime <- (#peek struct utimbuf, actime) pUTimBuf + modificationTime <- (#peek struct utimbuf, modtime) pUTimBuf + (Errno errno) <- (fuseSetFileTimes ops) filePath + accessTime modificationTime + return (- errno) + wrapOpen :: COpen + wrapOpen pFilePath pFuseFileInfo = handle fuseHandler $ + do filePath <- peekCString pFilePath + (flags :: CInt) <- (#peek struct fuse_file_info, flags) pFuseFileInfo + let append = (#const O_APPEND) .&. flags == (#const O_APPEND) + noctty = (#const O_NOCTTY) .&. flags == (#const O_NOCTTY) + nonBlock = (#const O_NONBLOCK) .&. flags == (#const O_NONBLOCK) + how | (#const O_RDWR) .&. flags == (#const O_RDWR) = ReadWrite + | (#const O_WRONLY) .&. flags == (#const O_WRONLY) = WriteOnly + | otherwise = ReadOnly + openFileFlags = OpenFileFlags { append = append + , exclusive = False + , noctty = noctty + , nonBlock = nonBlock + , trunc = False + } + result <- (fuseOpen ops) filePath how openFileFlags + case result of + Left (Errno errno) -> return (- errno) + Right cval -> do + sptr <- newStablePtr cval + (#poke struct fuse_file_info, fh) pFuseFileInfo $ castStablePtrToPtr sptr + return okErrno + + wrapRead :: CRead + wrapRead pFilePath pBuf bufSiz off pFuseFileInfo = handle fuseHandler $ + do filePath <- peekCString pFilePath + cVal <- getFH pFuseFileInfo + eitherRead <- (fuseRead ops) filePath cVal bufSiz off + case eitherRead of + Left (Errno errno) -> return (- errno) + Right bytes -> + do let len = fromIntegral bufSiz `min` B.length bytes + bsToBuf pBuf bytes len + return (fromIntegral len) + wrapWrite :: CWrite + wrapWrite pFilePath pBuf bufSiz off pFuseFileInfo = handle fuseHandler $ + do filePath <- peekCString pFilePath + cVal <- getFH pFuseFileInfo + buf <- B.packCStringLen (pBuf, fromIntegral bufSiz) + eitherBytes <- (fuseWrite ops) filePath cVal buf off + case eitherBytes of + Left (Errno errno) -> return (- errno) + Right bytes -> return (fromIntegral bytes) + wrapStatFS :: CStatFS + wrapStatFS pStr pStatFS = handle fuseHandler $ + do str <- peekCString pStr + eitherStatFS <- (fuseGetFileSystemStats ops) str + case eitherStatFS of + Left (Errno errno) -> return (- errno) + Right stat -> + do (#poke struct statfs, f_bsize) pStatFS + (fromIntegral (fsStatBlockSize stat) :: (#type long)) + (#poke struct statfs, f_blocks) pStatFS + (fromIntegral (fsStatBlockCount stat) :: (#type long)) + (#poke struct statfs, f_bfree) pStatFS + (fromIntegral (fsStatBlocksFree stat) :: (#type long)) + (#poke struct statfs, f_bavail) pStatFS + (fromIntegral (fsStatBlocksAvailable + stat) :: (#type long)) + (#poke struct statfs, f_files) pStatFS + (fromIntegral (fsStatFileCount stat) :: (#type long)) + (#poke struct statfs, f_ffree) pStatFS + (fromIntegral (fsStatFilesFree stat) :: (#type long)) +#ifndef MACFUSE +-- OSX doesn't support 'max name length' + (#poke struct statfs, f_namelen) pStatFS + (fromIntegral (fsStatMaxNameLength stat) :: (#type long)) +#endif + return 0 + wrapFlush :: CFlush + wrapFlush pFilePath pFuseFileInfo = handle fuseHandler $ + do filePath <- peekCString pFilePath + cVal <- getFH pFuseFileInfo + (Errno errno) <- (fuseFlush ops) filePath cVal + return (- errno) + wrapRelease :: CRelease + wrapRelease pFilePath pFuseFileInfo = E.finally (handle fuseHandler $ + do filePath <- peekCString pFilePath + cVal <- getFH pFuseFileInfo + -- TODO: deal with these flags? +-- flags <- (#peek struct fuse_file_info, flags) pFuseFileInfo + (fuseRelease ops) filePath cVal + return 0) (delFH pFuseFileInfo) + wrapFSync :: CFSync + wrapFSync pFilePath isFullSync pFuseFileInfo = handle fuseHandler $ + do filePath <- peekCString pFilePath + (Errno errno) <- (fuseSynchronizeFile ops) + filePath (toEnum isFullSync) + return (- errno) + wrapOpenDir :: COpenDir + wrapOpenDir pFilePath pFuseFileInfo = handle fuseHandler $ + do filePath <- peekCString pFilePath + -- XXX: Should we pass flags from pFuseFileInfo? + (Errno errno) <- (fuseOpenDirectory ops) filePath + return (- errno) + + wrapReadDir :: CReadDir + wrapReadDir pFilePath pBuf pFillDir off pFuseFileInfo = + handle fuseHandler $ do + filePath <- peekCString pFilePath + let fillDir = mkFillDir pFillDir + let filler :: (FilePath, FileStat) -> IO () + filler (fileName, fileStat) = + withCString fileName $ \ pFileName -> + allocaBytes (#size struct stat) $ \ pFileStat -> + do fileStatToCStat fileStat pFileStat + fillDir pBuf pFileName pFileStat 0 + -- Ignoring return value of pFillDir, namely 1 if + -- pBuff is full. + return () + eitherContents <- (fuseReadDirectory ops) filePath -- XXX fileinfo + case eitherContents of + Left (Errno errno) -> return (- errno) + Right contents -> mapM filler contents >> return okErrno + + wrapReleaseDir :: CReleaseDir + wrapReleaseDir pFilePath pFuseFileInfo = handle fuseHandler $ + do filePath <- peekCString pFilePath + (Errno errno) <- (fuseReleaseDirectory ops) filePath + return (- errno) + wrapFSyncDir :: CFSyncDir + wrapFSyncDir pFilePath isFullSync pFuseFileInfo = handle fuseHandler $ + do filePath <- peekCString pFilePath + (Errno errno) <- (fuseSynchronizeDirectory ops) + filePath (toEnum isFullSync) + return (- errno) + wrapAccess :: CAccess + wrapAccess pFilePath at = handle fuseHandler $ + do filePath <- peekCString pFilePath + (Errno errno) <- (fuseAccess ops) filePath (fromIntegral at) + return (- errno) + wrapInit :: CInit + wrapInit pFuseConnInfo = + handle (\e -> hPutStrLn stderr (show e) >> return nullPtr) $ + do fuseInit ops + return nullPtr + wrapDestroy :: CDestroy + wrapDestroy _ = handle (\e -> hPutStrLn stderr (show e)) $ + do fuseDestroy ops + +-- | Default exception handler. +-- Print the exception on error output and returns 'eFAULT'. +defaultExceptionHandler :: (Exception -> IO Errno) +defaultExceptionHandler e = hPutStrLn stderr (show e) >> return eFAULT + + +----------------------------------------------------------------------------- +-- Miscellaneous utilities + +unErrno :: Errno -> CInt +unErrno (Errno errno) = errno + +okErrno :: CInt +okErrno = unErrno eOK + +pokeCStringLen :: CStringLen -> String -> IO () +pokeCStringLen (pBuf, bufSize) src = + pokeArray pBuf $ take bufSize $ map castCharToCChar src + +pokeCStringLen0 :: CStringLen -> String -> IO () +pokeCStringLen0 (pBuf, bufSize) src = + pokeArray0 0 pBuf $ take (bufSize - 1) $ map castCharToCChar src + +----------------------------------------------------------------------------- +-- C land + +--- +-- exported C called from Haskell +--- + +data CFuseOperations +foreign import ccall threadsafe "fuse_wrappers.h fuse_main_wrapper" + fuse_main_wrapper :: Int -> Ptr CString -> Ptr CFuseOperations -> IO () + +data StructFuse +foreign import ccall threadsafe "fuse.h fuse_get_context" + fuse_get_context :: IO (Ptr StructFuse) + +--- +-- dynamic Haskell called from C +--- + +data CFuseFileInfo -- struct fuse_file_info +data CFuseConnInfo -- struct fuse_conn_info + +data CStat -- struct stat +type CGetAttr = CString -> Ptr CStat -> IO CInt +foreign import ccall threadsafe "wrapper" + mkGetAttr :: CGetAttr -> IO (FunPtr CGetAttr) + +type CReadLink = CString -> CString -> CSize -> IO CInt +foreign import ccall threadsafe "wrapper" + mkReadLink :: CReadLink -> IO (FunPtr CReadLink) + +type CMkNod = CString -> CMode -> CDev -> IO CInt +foreign import ccall threadsafe "wrapper" + mkMkNod :: CMkNod -> IO (FunPtr CMkNod) + +type CMkDir = CString -> CMode -> IO CInt +foreign import ccall threadsafe "wrapper" + mkMkDir :: CMkDir -> IO (FunPtr CMkDir) + +type CUnlink = CString -> IO CInt +foreign import ccall threadsafe "wrapper" + mkUnlink :: CUnlink -> IO (FunPtr CUnlink) + +type CRmDir = CString -> IO CInt +foreign import ccall threadsafe "wrapper" + mkRmDir :: CRmDir -> IO (FunPtr CRmDir) + +type CSymLink = CString -> CString -> IO CInt +foreign import ccall threadsafe "wrapper" + mkSymLink :: CSymLink -> IO (FunPtr CSymLink) + +type CRename = CString -> CString -> IO CInt +foreign import ccall threadsafe "wrapper" + mkRename :: CRename -> IO (FunPtr CRename) + +type CLink = CString -> CString -> IO CInt +foreign import ccall threadsafe "wrapper" + mkLink :: CLink -> IO (FunPtr CLink) + +type CChMod = CString -> CMode -> IO CInt +foreign import ccall threadsafe "wrapper" + mkChMod :: CChMod -> IO (FunPtr CChMod) + +type CChOwn = CString -> CUid -> CGid -> IO CInt +foreign import ccall threadsafe "wrapper" + mkChOwn :: CChOwn -> IO (FunPtr CChOwn) + +type CTruncate = CString -> COff -> IO CInt +foreign import ccall threadsafe "wrapper" + mkTruncate :: CTruncate -> IO (FunPtr CTruncate) + +data CUTimBuf -- struct utimbuf +type CUTime = CString -> Ptr CUTimBuf -> IO CInt +foreign import ccall threadsafe "wrapper" + mkUTime :: CUTime -> IO (FunPtr CUTime) + +type COpen = CString -> Ptr CFuseFileInfo -> IO CInt +foreign import ccall threadsafe "wrapper" + mkOpen :: COpen -> IO (FunPtr COpen) + +type CRead = CString -> CString -> CSize -> COff -> Ptr CFuseFileInfo -> IO CInt +foreign import ccall threadsafe "wrapper" + mkRead :: CRead -> IO (FunPtr CRead) + +type CWrite = CString -> CString -> CSize -> COff -> Ptr CFuseFileInfo -> IO CInt +foreign import ccall threadsafe "wrapper" + mkWrite :: CWrite -> IO (FunPtr CWrite) + +data CStructStatFS -- struct fuse_stat_fs +type CStatFS = CString -> Ptr CStructStatFS -> IO CInt +foreign import ccall threadsafe "wrapper" + mkStatFS :: CStatFS -> IO (FunPtr CStatFS) + +type CFlush = CString -> Ptr CFuseFileInfo -> IO CInt +foreign import ccall threadsafe "wrapper" + mkFlush :: CFlush -> IO (FunPtr CFlush) + +type CRelease = CString -> Ptr CFuseFileInfo -> IO CInt +foreign import ccall threadsafe "wrapper" + mkRelease :: CRelease -> IO (FunPtr CRelease) + +type CFSync = CString -> Int -> Ptr CFuseFileInfo -> IO CInt +foreign import ccall threadsafe "wrapper" + mkFSync :: CFSync -> IO (FunPtr CFSync) + +-- XXX add *xattr bindings + +type COpenDir = CString -> Ptr CFuseFileInfo -> IO CInt +foreign import ccall threadsafe "wrapper" + mkOpenDir :: COpenDir -> IO (FunPtr COpenDir) + +type CReadDir = CString -> Ptr CFillDirBuf -> FunPtr CFillDir -> COff + -> Ptr CFuseFileInfo -> IO CInt +foreign import ccall threadsafe "wrapper" + mkReadDir :: CReadDir -> IO (FunPtr CReadDir) + +type CReleaseDir = CString -> Ptr CFuseFileInfo -> IO CInt +foreign import ccall threadsafe "wrapper" + mkReleaseDir :: CReleaseDir -> IO (FunPtr CReleaseDir) + +type CFSyncDir = CString -> Int -> Ptr CFuseFileInfo -> IO CInt +foreign import ccall threadsafe "wrapper" + mkFSyncDir :: CFSyncDir -> IO (FunPtr CFSyncDir) + +type CAccess = CString -> CInt -> IO CInt +foreign import ccall threadsafe "wrapper" + mkAccess :: CAccess -> IO (FunPtr CAccess) + +-- CInt because anything would be fine as we don't use them +type CInit = Ptr CFuseConnInfo -> IO (Ptr CInt) +foreign import ccall threadsafe "wrapper" + mkInit :: CInit -> IO (FunPtr CInit) + +type CDestroy = Ptr CInt -> IO () +foreign import ccall threadsafe "wrapper" + mkDestroy :: CDestroy -> IO (FunPtr CDestroy) + +---- + +bsToBuf :: Ptr a -> B.ByteString -> Int -> IO () +bsToBuf dst bs len = do + let l = fromIntegral $ min len $ B.length bs + B.unsafeUseAsCString bs $ \src -> B.memcpy (castPtr dst) (castPtr src) l + return () + +-- Get filehandle +getFH pFuseFileInfo = do + sptr <- (#peek struct fuse_file_info, fh) pFuseFileInfo + cVal <- deRefStablePtr $ castPtrToStablePtr sptr + return cVal + +delFH pFuseFileInfo = do + sptr <- (#peek struct fuse_file_info, fh) pFuseFileInfo + freeStablePtr $ castPtrToStablePtr sptr + + +--- +-- dynamic C called from Haskell +--- + +data CDirHandle -- fuse_dirh_t +type CDirFil = Ptr CDirHandle -> CString -> Int -> IO CInt -- fuse_dirfil_t +foreign import ccall threadsafe "dynamic" + mkDirFil :: FunPtr CDirFil -> CDirFil + +data CFillDirBuf -- void +type CFillDir = Ptr CFillDirBuf -> CString -> Ptr CStat -> COff -> IO CInt +foreign import ccall threadsafe "dynamic" + mkFillDir :: FunPtr CFillDir -> CFillDir diff --git a/System/Posix/HFuse.hsc b/System/Posix/HFuse.hsc deleted file mode 100644 --- a/System/Posix/HFuse.hsc +++ /dev/null @@ -1,866 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : System.Posix.HFuse --- Copyright : (c) Jérémy Bobbio --- License : BSD-style --- --- Maintainer : jeremy.bobbio@etu.upmc.fr --- Stability : experimental --- Portability : GHC 6.8 --- --- HFuse is a binding for the FUSE (Filesystem in USErspace) library. --- --- See --- --- This library allow new filesystem implementation as simple user-land --- programs. --- --- The binding tries to follow as much as possible current Haskell POSIX --- interface in "System.Posix.Files" and "System.Posix.Directory". --- --- FUSE uses POSIX thread, thus Haskell implementation needs to be linked --- against a threaded runtime system (eg. using the @threaded@ GHC option). --- ------------------------------------------------------------------------------ -module System.Posix.HFuse - ( -- * Using FUSE - - -- $intro - - module Foreign.C.Error - , FuseOperations(..) - , defaultFuseOps - , fuseMain -- :: FuseOperations -> (Exception -> IO Errno) -> IO () - , defaultExceptionHandler -- :: Exception -> IO Errno - -- * Operations datatypes - , FileStat(..) - , EntryType(..) - , FileSystemStats(..) - , SyncType(..) - -- * FUSE Context - , getFuseContext -- :: IO FuseContext - , FuseContext(fuseCtxUserID, fuseCtxGroupID, fuseCtxProcessID) - -- * File modes - , entryTypeToFileMode -- :: EntryType -> FileMode - , OpenMode(..) - , OpenFileFlags(..) - , intersectFileModes -- :: FileMode - , unionFileModes -- :: FileMode - ) where - -import Prelude hiding ( Read ) - -import Control.Exception ( Exception, handle ) -import Foreign -import Foreign.C -import Foreign.C.Error -import Foreign.Marshal -import System.Environment ( getProgName, getArgs ) -import System.IO ( hPutStrLn, stderr ) -import System.Posix.Types -import System.Posix.Files ( accessModes, intersectFileModes, unionFileModes ) -import System.Posix.IO ( OpenMode(..), OpenFileFlags(..) ) - --- TODO: FileMode -> Permissions --- TODO: Arguments ! --- TODO: implement binding to fuse_invalidate --- TODO: bind fuse_*xattr - -#define FUSE_USE_VERSION 22 - -#include -#include -#include -#include - -{- $intro -'FuseOperations' contains a field for each filesystem operations that can be called -by FUSE. Think like if you were implementing a file system inside the Linux kernel. - -Each actions must return a POSIX error code, also called 'Errno' reflecting -operation relult. For actions not using 'Either', you should return 'eOK' in case -of success. - -Read and writes are done with Haskell 'String' type. Even if this representation -is known to have drawbacks, the binding try to be coherent with current -Haskell libraries. - --} - -{- All operations should return the negated error value (-errno) on - error. --} - --- | Used by 'fuseGetFileStat'. -data FileStat = FileStat { statEntryType :: EntryType - , statFileMode :: FileMode - , statLinkCount :: LinkCount - , statFileOwner :: UserID - , statFileGroup :: GroupID - , statSpecialDeviceID :: DeviceID - , statFileSize :: FileOffset - , statBlocks :: Integer - , statAccessTime :: EpochTime - , statModificationTime :: EpochTime - , statStatusChangeTime :: EpochTime - } - -{- getattr() doesn't need to fill in the following fields: - st_ino - st_dev - st_blksize --} - -{- readlink() should fill the buffer with a null terminated string. The - buffer size argument includes the space for the terminating null - character. If the linkname is too long to fit in the buffer, it should - be truncated. The return value should be 0 for success. --} - --- | Used by 'fuseGetDirectoryContents' implementation to specify the type of --- a directory entry. -data EntryType - = Unknown -- ^ Unknown entry type - | NamedPipe - | CharacterSpecial - | Directory - | BlockSpecial - | RegularFile - | SymbolicLink - | Socket - -entryTypeToDT :: EntryType -> Int -entryTypeToDT Unknown = (#const DT_UNKNOWN) -entryTypeToDT NamedPipe = (#const DT_FIFO) -entryTypeToDT CharacterSpecial = (#const DT_CHR) -entryTypeToDT Directory = (#const DT_DIR) -entryTypeToDT BlockSpecial = (#const DT_BLK) -entryTypeToDT RegularFile = (#const DT_REG) -entryTypeToDT SymbolicLink = (#const DT_LNK) -entryTypeToDT Socket = (#const DT_SOCK) - -fileTypeModes :: FileMode -fileTypeModes = (#const S_IFMT) - -blockSpecialMode :: FileMode -blockSpecialMode = (#const S_IFBLK) - -characterSpecialMode :: FileMode -characterSpecialMode = (#const S_IFCHR) - -namedPipeMode :: FileMode -namedPipeMode = (#const S_IFIFO) - -regularFileMode :: FileMode -regularFileMode = (#const S_IFREG) - -directoryMode :: FileMode -directoryMode = (#const S_IFDIR) - -symbolicLinkMode :: FileMode -symbolicLinkMode = (#const S_IFLNK) - -socketMode :: FileMode -socketMode = (#const S_IFSOCK) - --- | Converts an 'EntryType' into the corresponding POSIX 'FileMode'. -entryTypeToFileMode :: EntryType -> FileMode -entryTypeToFileMode Unknown = 0 -entryTypeToFileMode NamedPipe = namedPipeMode -entryTypeToFileMode CharacterSpecial = characterSpecialMode -entryTypeToFileMode Directory = directoryMode -entryTypeToFileMode BlockSpecial = blockSpecialMode -entryTypeToFileMode RegularFile = regularFileMode -entryTypeToFileMode SymbolicLink = symbolicLinkMode -entryTypeToFileMode Socket = socketMode - -fileModeToEntryType :: FileMode -> EntryType -fileModeToEntryType mode - | fileType == namedPipeMode = NamedPipe - | fileType == characterSpecialMode = CharacterSpecial - | fileType == directoryMode = Directory - | fileType == blockSpecialMode = BlockSpecial - | fileType == regularFileMode = RegularFile - | fileType == symbolicLinkMode = SymbolicLink - | fileType == socketMode = Socket - where fileType = mode .&. (#const S_IFMT) - -{- getdir() is the opendir(), readdir(), ..., closedir() sequence - in one call. For each directory entry the filldir parameter should - be called. --} - - -{- - There is no create() operation, mknod() will be called for - creation of all non directory, non symlink nodes. --} - -{- open() should not return a filehandle, but 0 on success. No - creation, or trunctation flags (O_CREAT, O_EXCL, O_TRUNC) will be - passed to open(). Open should only check if the operation is - permitted for the given flags. --} - -{- read(), write() are not passed a filehandle, but rather a - pathname. The offset of the read and write is passed as the last - argument, like the pread() and pwrite() system calls. (NOTE: - read() should always return the number of bytes requested, except - at end of file) - - TODO: String type was used to mimic System.Posix.IO but it should change - after inclusion of better I/O system in Haskell libraries. --} --- | Type used by the 'fuseGetFileSystemStats'. -data FileSystemStats = FileSystemStats - { fsStatBlockSize :: Integer - -- ^ Optimal transfer block size. FUSE default is 512. - , fsStatBlockCount :: Integer - -- ^ Total data blocks in file system. - , fsStatBlocksFree :: Integer - -- ^ Free blocks in file system. - , fsStatBlocksAvailable :: Integer - -- ^ Free blocks available to non-superusers. - , fsStatFileCount :: Integer - -- ^ Total file nodes in file system. - , fsStatFilesFree :: Integer - -- ^ Free file nodes in file system. - , fsStatMaxNameLength :: Integer - -- ^ Maximum length of filenames. FUSE default is 255. - } - - -{- release() is called when an open file has: - 1) all file descriptors closed - 2) -all memory mappings unmapped - This call need only be implemented if this information is required, - otherwise set this function to NULL. - - TODO: Find out what these "flags" are (Int here). --} - --- | Used by 'fuseSynchronizeFile'. -data SyncType - = FullSync - -- ^ Synchronize all in-core parts of a file to disk: file content and - -- metadata. - | DataSync - -- ^ Synchronize only the file content. - deriving (Eq, Enum) -{- fsync() has a boolean 'datasync' parameter which if TRUE then do - an fdatasync() operation. --} - - --- | Returned by 'getFuseContext'. -data FuseContext = FuseContext - { fuseCtxUserID :: UserID - , fuseCtxGroupID :: GroupID - , fuseCtxProcessID :: ProcessID - } - --- | Returns the context of the program doing the current FUSE call. -getFuseContext :: IO FuseContext -getFuseContext = - do pCtx <- fuse_get_context - userID <- (#peek struct fuse_context, uid) pCtx - groupID <- (#peek struct fuse_context, gid) pCtx - processID <- (#peek struct fuse_context, pid) pCtx - return $ FuseContext { fuseCtxUserID = userID - , fuseCtxGroupID = groupID - , fuseCtxProcessID = processID - } - --- | This record, given to 'fuseMain', binds each required file system operations. --- --- Each field is named against 'System.Posix' names. Matching Linux system calls --- are also given as a reference. --- --- * 'fuseGetFileStat' implements --- 'System.Posix.Files.getSymbolicLinkStatus' operation (POSIX @lstat(2)@). --- --- * 'fuseReadSymbolicLink' implements --- 'System.Posix.Files.readSymbolicLink' operation (POSIX @readlink(2)@). --- The returned 'FilePath' might be truncated depending on caller --- buffer size. --- --- * 'fuseGetDirectoryContents' implements --- 'System.Directory.getDirectoryContents' (POSIX @readddir(2)@). --- --- * 'fuseCreateDevice' implements 'System.Posix.Files.createDevice' --- (POSIX @mknod(2)@). --- This function will also be called for regular file creation. --- --- * 'fuseCreateDirectory' implements 'System.Posix.Directory.createDirectory' --- (POSIX @mkdir(2)@). --- --- * 'fuseRemoveLink' implements 'System.Posix.Files.removeLink' --- (POSIX @unlink(2)@). --- --- * 'fuseRemoveDirectory' implements 'System.Posix.Directory.removeDirectory' --- (POSIX @rmdir(2)@). --- --- * 'fuseCreateSymbolicLink' implements --- 'System.Posix.Files.createSymbolicLink' (POSIX @symlink(2)@). --- --- * 'fuseRename' implements 'System.Posix.Files.rename' (POSIX @rename(2)@). --- --- * 'fuseCreateLink' implements 'System.Posix.Files.createLink' --- (POSIX @link(2)@). --- --- * 'fuseSetFileMode' implements 'System.Posix.Files.setFileMode' --- (POSIX @chmod(2)@). --- --- * 'fuseSetOwnerAndGroup' implements 'System.Posix.Files.setOwnerAndGroup' --- (POSIX @chown(2)@). --- --- * 'fuseSetFileSize' implements 'System.Posix.Files.setFileSize' --- (POSIX @truncate(2)@). --- --- * 'fuseSetFileTimes' implements 'System.Posix.Files.setFileTimes' --- (POSIX @utime(2)@). --- --- * 'fuseOpen' implements 'System.Posix.Files.openFd' --- (POSIX @open(2)@), but this does not actually returns a file handle --- but 'eOK' if the operation is permitted with the given flags. --- No creation, exclusive access or truncating flags will be passed. --- --- * 'fuseRead' implements Unix98 @pread(2)@. It differs --- from 'System.Posix.Files.fdRead' by the explicit 'FileOffset' argument. --- --- * 'fuseWrite' implements Unix98 @pwrite(2)@. It differs --- from 'System.Posix.Files.fdWrite' by the explicit 'FileOffset' argument. --- --- * 'fuseGetFileSystemStats' implements @statfs(2)@. --- --- * 'fuseFlush' is called when @close(2)@ has been called on an open file. --- Note: this does not mean that the file is released. This function may be --- called more than once for each @open(2)@. The return value is passed on --- to the @close(2)@ system call. --- --- * 'fuseRelease' is called when an open file has all file descriptors closed --- and all memory mappings unmapped. For every @open@ call there will be --- exactly one @release@ call with the same flags. It is possible to have --- a file opened more than once, in which case only the last release will --- mean, that no more reads or writes will happen on the file. --- --- * 'fuseSynchronizeFile' implements @fsync(2)@. --- -data FuseOperations = FuseOperations - { fuseGetFileStat :: FilePath -> IO (Either Errno FileStat) - , fuseReadSymbolicLink :: FilePath -> IO (Either Errno FilePath) - , fuseGetDirectoryContents :: FilePath - -> IO (Either Errno [(FilePath, EntryType)]) - , fuseCreateDevice :: FilePath -> EntryType -> FileMode - -> DeviceID -> IO Errno - , fuseCreateDirectory :: FilePath -> FileMode -> IO Errno - , fuseRemoveLink :: FilePath -> IO Errno - , fuseRemoveDirectory :: FilePath -> IO Errno - , fuseCreateSymbolicLink :: FilePath -> FilePath -> IO Errno - , fuseRename :: FilePath -> FilePath -> IO Errno - , fuseCreateLink :: FilePath -> FilePath -> IO Errno - , fuseSetFileMode :: FilePath -> FileMode -> IO Errno - , fuseSetOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO Errno - , fuseSetFileSize :: FilePath -> FileOffset -> IO Errno - , fuseSetFileTimes :: FilePath -> EpochTime -> EpochTime -> IO Errno - , fuseOpen :: FilePath -> OpenMode -> OpenFileFlags -> IO Errno - , fuseRead :: FilePath -> ByteCount -> FileOffset - -> IO (Either Errno (String, ByteCount)) - , fuseWrite :: FilePath -> String -> FileOffset - -> IO (Either Errno ByteCount) - , fuseGetFileSystemStats :: String -> IO (Either Errno FileSystemStats) - , fuseFlush :: FilePath -> IO Errno - , fuseRelease :: FilePath -> Int -> IO () - , fuseSynchronizeFile :: FilePath -> SyncType -> IO Errno - , fuseOpenDirectory :: FilePath -> IO Errno - , fuseReleaseDirectory :: FilePath -> IO Errno - , fuseSynchronizeDirectory :: FilePath -> SyncType -> IO Errno - , fuseInit :: IO () - , fuseDestroy :: IO () - } - --- |Empty / default versions of the FUSE operations. -defaultFuseOps :: FuseOperations -defaultFuseOps = - FuseOperations { fuseGetFileStat = \_ -> return (Left eNOSYS) - , fuseReadSymbolicLink = \_ -> return (Left eNOSYS) - , fuseGetDirectoryContents = \_ -> return (Left eNOSYS) - , fuseCreateDevice = \_ _ _ _ -> return eNOSYS - , fuseCreateDirectory = \_ _ -> return eNOSYS - , fuseRemoveLink = \_ -> return eNOSYS - , fuseRemoveDirectory = \_ -> return eNOSYS - , fuseCreateSymbolicLink = \_ _ -> return eNOSYS - , fuseRename = \_ _ -> return eNOSYS - , fuseCreateLink = \_ _ -> return eNOSYS - , fuseSetFileMode = \_ _ -> return eNOSYS - , fuseSetOwnerAndGroup = \_ _ _ -> return eNOSYS - , fuseSetFileSize = \_ _ -> return eNOSYS - , fuseSetFileTimes = \_ _ _ -> return eNOSYS - , fuseOpen = \_ _ _ -> return eNOSYS - , fuseRead = \_ _ _ -> return (Left eNOSYS) - , fuseWrite = \_ _ _ -> return (Left eNOSYS) - , fuseGetFileSystemStats = \_ -> return (Left eNOSYS) - , fuseFlush = \_ -> return eOK - , fuseRelease = \_ _ -> return () - , fuseSynchronizeFile = \_ _ -> return eNOSYS - , fuseOpenDirectory = \_ -> return eNOSYS - , fuseReleaseDirectory = \_ -> return eNOSYS - , fuseSynchronizeDirectory = \_ _ -> return eNOSYS - , fuseInit = return () - , fuseDestroy = return () - } - - --- | Main function of FUSE. --- This is all that has to be called from the @main@ function. On top of --- the 'FuseOperations' record with filesystem implementation, you must give --- an exception handler converting Haskell exceptions to 'Errno'. --- --- This function does the following: --- --- * parses command line options (@-d@, @-s@ and @-h@) ; --- --- * passes all options after @--@ to the fusermount program ; --- --- * mounts the filesystem by calling @fusermount@ ; --- --- * installs signal handlers for 'System.Posix.Signals.keyboardSignal', --- 'System.Posix.Signals.lostConnection', --- 'System.Posix.Signals.softwareTermination' and --- 'System.Posix.Signals.openEndedPipe' ; --- --- * registers an exit handler to unmount the filesystem on program exit ; --- --- * registers the operations ; --- --- * calls FUSE event loop. -fuseMain :: FuseOperations -> (Exception -> IO Errno) -> IO () -fuseMain ops handler = - allocaBytes (#size struct fuse_operations) $ \ pOps -> do - mkGetAttr wrapGetAttr >>= (#poke struct fuse_operations, getattr) pOps - mkReadLink wrapReadLink >>= (#poke struct fuse_operations, readlink) pOps - -- FIXME: getdir is deprecated - mkGetDir wrapGetDir >>= (#poke struct fuse_operations, getdir) pOps - mkMkNod wrapMkNod >>= (#poke struct fuse_operations, mknod) pOps - mkMkDir wrapMkDir >>= (#poke struct fuse_operations, mkdir) pOps - mkUnlink wrapUnlink >>= (#poke struct fuse_operations, unlink) pOps - mkRmDir wrapRmDir >>= (#poke struct fuse_operations, rmdir) pOps - mkSymLink wrapSymLink >>= (#poke struct fuse_operations, symlink) pOps - mkRename wrapRename >>= (#poke struct fuse_operations, rename) pOps - mkLink wrapLink >>= (#poke struct fuse_operations, link) pOps - mkChMod wrapChMod >>= (#poke struct fuse_operations, chmod) pOps - mkChOwn wrapChOwn >>= (#poke struct fuse_operations, chown) pOps - mkTruncate wrapTruncate >>= (#poke struct fuse_operations, truncate) pOps - mkUTime wrapUTime >>= (#poke struct fuse_operations, utime) pOps - mkOpen wrapOpen >>= (#poke struct fuse_operations, open) pOps - mkRead wrapRead >>= (#poke struct fuse_operations, read) pOps - mkWrite wrapWrite >>= (#poke struct fuse_operations, write) pOps - mkStatFS wrapStatFS >>= (#poke struct fuse_operations, statfs) pOps - mkFlush wrapFlush >>= (#poke struct fuse_operations, flush) pOps - mkRelease wrapRelease >>= (#poke struct fuse_operations, release) pOps - mkFSync wrapFSync >>= (#poke struct fuse_operations, fsync) pOps - -- TODO: Implement these - (#poke struct fuse_operations, setxattr) pOps nullPtr - (#poke struct fuse_operations, getxattr) pOps nullPtr - (#poke struct fuse_operations, listxattr) pOps nullPtr - (#poke struct fuse_operations, removexattr) pOps nullPtr - mkOpenDir wrapOpenDir >>= (#poke struct fuse_operations, opendir) pOps - -- TODO: Implement mkReadDir - -- mkReadDir wrapReadDir >>= (#poke struct fuse_operations, readdir) pOps - (#poke struct fuse_operations, readdir) pOps nullPtr - mkReleaseDir wrapReleaseDir >>= (#poke struct fuse_operations, releasedir) pOps - mkFSyncDir wrapFSyncDir >>= (#poke struct fuse_operations, fsyncdir) pOps - mkInit wrapInit >>= (#poke struct fuse_operations, init) pOps - mkDestroy wrapDestroy >>= (#poke struct fuse_operations, destroy) pOps - prog <- getProgName - args <- getArgs - let allArgs = (prog:args) - argc = length allArgs - withMany withCString allArgs $ \ pAddrs -> - withArray pAddrs $ \ pArgv -> - do fuse_main_real argc pArgv pOps (#size struct fuse_operations) - where fuseHandler :: Exception -> IO CInt - fuseHandler e = handler e >>= return . unErrno - wrapGetAttr :: CGetAttr - wrapGetAttr pFilePath pStat = handle fuseHandler $ - do filePath <- peekCString pFilePath - eitherFileStat <- (fuseGetFileStat ops) filePath - case eitherFileStat of - Left (Errno errno) -> return (- errno) - Right stat -> - do (#poke struct stat, st_mode) pStat - (entryTypeToFileMode (statEntryType stat) - `unionFileModes` - (statFileMode stat `intersectFileModes` accessModes)) - (#poke struct stat, st_nlink) pStat (statLinkCount stat) - (#poke struct stat, st_uid) pStat (statFileOwner stat) - (#poke struct stat, st_gid) pStat (statFileGroup stat) - (#poke struct stat, st_rdev) pStat - (statSpecialDeviceID stat) - (#poke struct stat, st_size) pStat (statFileSize stat) - (#poke struct stat, st_blocks) pStat - (fromIntegral (statBlocks stat) :: (#type blkcnt_t)) - (#poke struct stat, st_atime) pStat (statAccessTime stat) - (#poke struct stat, st_mtime) pStat - (statModificationTime stat) - (#poke struct stat, st_ctime) pStat - (statStatusChangeTime stat) - return okErrno - wrapReadLink :: CReadLink - wrapReadLink pFilePath pBuf bufSize = handle fuseHandler $ - do filePath <- peekCString pFilePath - return (- unErrno eNOSYS) - eitherTarget <- (fuseReadSymbolicLink ops) filePath - case eitherTarget of - Left (Errno errno) -> return (- errno) - Right target -> - do pokeCStringLen0 (pBuf, (fromIntegral bufSize)) target - return okErrno - wrapGetDir :: CGetDir - wrapGetDir pFilePath pDirHandle pDirFil = handle fuseHandler $ - do filePath <- peekCString pFilePath - let filler (entryFilePath, entryType) = - withCString entryFilePath $ \ pEntryFilePath -> - (mkDirFil pDirFil) pDirHandle pEntryFilePath - (entryTypeToDT entryType) >>= return . Errno - eitherContents <- (fuseGetDirectoryContents ops) filePath - case eitherContents of - Left (Errno errno) -> return (- errno) - Right contents -> - do mapM_ filler contents - return okErrno - wrapMkNod :: CMkNod - wrapMkNod pFilePath mode dev = handle fuseHandler $ - do filePath <- peekCString pFilePath - (Errno errno) <- (fuseCreateDevice ops) filePath - (fileModeToEntryType mode) mode dev - return (- errno) - wrapMkDir :: CMkDir - wrapMkDir pFilePath mode = handle fuseHandler $ - do filePath <- peekCString pFilePath - (Errno errno) <- (fuseCreateDirectory ops) filePath mode - return (- errno) - wrapUnlink :: CUnlink - wrapUnlink pFilePath = handle fuseHandler $ - do filePath <- peekCString pFilePath - (Errno errno) <- (fuseRemoveLink ops) filePath - return (- errno) - wrapRmDir :: CRmDir - wrapRmDir pFilePath = handle fuseHandler $ - do filePath <- peekCString pFilePath - (Errno errno) <- (fuseRemoveDirectory ops) filePath - return (- errno) - wrapSymLink :: CSymLink - wrapSymLink pSource pDestination = handle fuseHandler $ - do source <- peekCString pSource - destination <- peekCString pDestination - (Errno errno) <- (fuseCreateSymbolicLink ops) source destination - return (- errno) - wrapRename :: CRename - wrapRename pOld pNew = handle fuseHandler $ - do old <- peekCString pOld - new <- peekCString pNew - (Errno errno) <- (fuseRename ops) old new - return (- errno) - wrapLink :: CLink - wrapLink pSource pDestination = handle fuseHandler $ - do source <- peekCString pSource - destination <- peekCString pDestination - (Errno errno) <- (fuseCreateLink ops) source destination - return (- errno) - wrapChMod :: CChMod - wrapChMod pFilePath mode = handle fuseHandler $ - do filePath <- peekCString pFilePath - (Errno errno) <- (fuseSetFileMode ops) filePath mode - return (- errno) - wrapChOwn :: CChOwn - wrapChOwn pFilePath uid gid = handle fuseHandler $ - do filePath <- peekCString pFilePath - (Errno errno) <- (fuseSetOwnerAndGroup ops) filePath uid gid - return (- errno) - wrapTruncate :: CTruncate - wrapTruncate pFilePath off = handle fuseHandler $ - do filePath <- peekCString pFilePath - (Errno errno) <- (fuseSetFileSize ops) filePath off - return (- errno) - wrapUTime :: CUTime - wrapUTime pFilePath pUTimBuf = handle fuseHandler $ - do filePath <- peekCString pFilePath - accessTime <- (#peek struct utimbuf, actime) pUTimBuf - modificationTime <- (#peek struct utimbuf, modtime) pUTimBuf - (Errno errno) <- (fuseSetFileTimes ops) filePath - accessTime modificationTime - return (- errno) - wrapOpen :: COpen - wrapOpen pFilePath pFuseFileInfo = handle fuseHandler $ - do filePath <- peekCString pFilePath - (flags :: CInt) <- (#peek struct fuse_file_info, flags) pFuseFileInfo - let append = (#const O_APPEND) .&. flags == (#const O_APPEND) - noctty = (#const O_NOCTTY) .&. flags == (#const O_NOCTTY) - nonBlock = (#const O_NONBLOCK) .&. flags == (#const O_NONBLOCK) - how | (#const O_RDWR) .&. flags == (#const O_RDWR) = ReadWrite - | (#const O_WRONLY) .&. flags == (#const O_WRONLY) = WriteOnly - | otherwise = ReadOnly - openFileFlags = OpenFileFlags { append = append - , exclusive = False - , noctty = noctty - , nonBlock = nonBlock - , trunc = False - } - (Errno errno) <- (fuseOpen ops) filePath how openFileFlags - return (- errno) - wrapRead :: CRead - wrapRead pFilePath pBuf bufSiz off pFuseFileInfo = handle fuseHandler $ - do filePath <- peekCString pFilePath - eitherRead <- (fuseRead ops) filePath bufSiz off - case eitherRead of - Left (Errno errno) -> return (- errno) - Right (bytes, byteCount) -> - do pokeCStringLen (pBuf, fromIntegral byteCount) bytes - return (fromIntegral byteCount) - wrapWrite :: CWrite - wrapWrite pFilePath pBuf bufSiz off pFuseFileInfo = handle fuseHandler $ - do filePath <- peekCString pFilePath - buf <- peekCStringLen (pBuf, fromIntegral bufSiz) - eitherBytes <- (fuseWrite ops) filePath buf off - case eitherBytes of - Left (Errno errno) -> return (- errno) - Right bytes -> return (fromIntegral bytes) - wrapStatFS :: CStatFS - wrapStatFS pStr pStatFS = handle fuseHandler $ - do str <- peekCString pStr - eitherStatFS <- (fuseGetFileSystemStats ops) str - case eitherStatFS of - Left (Errno errno) -> return (- errno) - Right stat -> - do (#poke struct statfs, f_bsize) pStatFS - (fromIntegral (fsStatBlockSize stat) :: (#type long)) - (#poke struct statfs, f_blocks) pStatFS - (fromIntegral (fsStatBlockCount stat) :: (#type long)) - (#poke struct statfs, f_bfree) pStatFS - (fromIntegral (fsStatBlocksFree stat) :: (#type long)) - (#poke struct statfs, f_bavail) pStatFS - (fromIntegral (fsStatBlocksAvailable - stat) :: (#type long)) - (#poke struct statfs, f_files) pStatFS - (fromIntegral (fsStatFileCount stat) :: (#type long)) - (#poke struct statfs, f_ffree) pStatFS - (fromIntegral (fsStatFilesFree stat) :: (#type long)) - (#poke struct statfs, f_namelen) pStatFS - (fromIntegral (fsStatMaxNameLength stat) :: (#type long)) - return 0 - wrapFlush :: CFlush - wrapFlush pFilePath pFuseFileInfo = handle fuseHandler $ - do filePath <- peekCString pFilePath - (Errno errno) <- (fuseFlush ops) filePath - return (- errno) - wrapRelease :: CRelease - wrapRelease pFilePath pFuseFileInfo = handle fuseHandler $ - do filePath <- peekCString pFilePath - flags <- (#peek struct fuse_file_info, flags) pFuseFileInfo - (fuseRelease ops) filePath flags - return 0 - wrapFSync :: CFSync - wrapFSync pFilePath isFullSync pFuseFileInfo = handle fuseHandler $ - do filePath <- peekCString pFilePath - (Errno errno) <- (fuseSynchronizeFile ops) - filePath (toEnum isFullSync) - return (- errno) - wrapOpenDir :: COpenDir - wrapOpenDir pFilePath pFuseFileInfo = handle fuseHandler $ - do filePath <- peekCString pFilePath - -- XXX: Should we pass flags from pFuseFileInfo? - (Errno errno) <- (fuseOpenDirectory ops) filePath - return (- errno) - -- TODO: wrapReadDir - wrapReleaseDir :: CReleaseDir - wrapReleaseDir pFilePath pFuseFileInfo = handle fuseHandler $ - do filePath <- peekCString pFilePath - (Errno errno) <- (fuseReleaseDirectory ops) filePath - return (- errno) - wrapFSyncDir :: CFSyncDir - wrapFSyncDir pFilePath isFullSync pFuseFileInfo = handle fuseHandler $ - do filePath <- peekCString pFilePath - (Errno errno) <- (fuseSynchronizeDirectory ops) - filePath (toEnum isFullSync) - return (- errno) - wrapInit :: CInit - wrapInit = handle (\e -> hPutStrLn stderr (show e) >> return nullPtr) $ - do fuseInit ops - return nullPtr - wrapDestroy :: CDestroy - wrapDestroy _ = handle (\e -> hPutStrLn stderr (show e)) $ - do fuseDestroy ops - --- | Default exception handler. --- Print the exception on error output and returns 'eFAULT'. -defaultExceptionHandler :: (Exception -> IO Errno) -defaultExceptionHandler e = hPutStrLn stderr (show e) >> return eFAULT - - ------------------------------------------------------------------------------ --- Miscelaneous utilities - -unErrno :: Errno -> CInt -unErrno (Errno errno) = errno - -okErrno :: CInt -okErrno = 0 - -pokeCStringLen :: CStringLen -> String -> IO () -pokeCStringLen (pBuf, bufSize) src = - pokeArray pBuf $ take bufSize $ map castCharToCChar src - -pokeCStringLen0 :: CStringLen -> String -> IO () -pokeCStringLen0 (pBuf, bufSize) src = - pokeArray0 0 pBuf $ take (bufSize - 1) $ map castCharToCChar src - ------------------------------------------------------------------------------ --- C land - ---- --- exported C called from Haskell ---- - -data CFuseOperations -foreign import ccall threadsafe "fuse.h fuse_main_real" - fuse_main_real :: Int -> Ptr CString -> Ptr CFuseOperations -> CSize -> IO () - -data StructFuse -foreign import ccall threadsafe "fuse.h fuse_get_context" - fuse_get_context :: IO (Ptr StructFuse) - ---- --- dynamic Haskell called from C ---- - -data CFuseFileInfo -- struct fuse_file_info - -data CStat -- struct stat -type CGetAttr = CString -> Ptr CStat -> IO CInt -foreign import ccall threadsafe "wrapper" - mkGetAttr :: CGetAttr -> IO (FunPtr CGetAttr) - -type CReadLink = CString -> CString -> CSize -> IO CInt -foreign import ccall threadsafe "wrapper" - mkReadLink :: CReadLink -> IO (FunPtr CReadLink) - -type CGetDir = CString -> Ptr CDirHandle -> FunPtr CDirFil -> IO CInt -foreign import ccall threadsafe "wrapper" - mkGetDir :: CGetDir -> IO (FunPtr CGetDir) - -type CMkNod = CString -> CMode -> CDev -> IO CInt -foreign import ccall threadsafe "wrapper" - mkMkNod :: CMkNod -> IO (FunPtr CMkNod) - -type CMkDir = CString -> CMode -> IO CInt -foreign import ccall threadsafe "wrapper" - mkMkDir :: CMkDir -> IO (FunPtr CMkDir) - -type CUnlink = CString -> IO CInt -foreign import ccall threadsafe "wrapper" - mkUnlink :: CUnlink -> IO (FunPtr CUnlink) - -type CRmDir = CString -> IO CInt -foreign import ccall threadsafe "wrapper" - mkRmDir :: CRmDir -> IO (FunPtr CRmDir) - -type CSymLink = CString -> CString -> IO CInt -foreign import ccall threadsafe "wrapper" - mkSymLink :: CSymLink -> IO (FunPtr CSymLink) - -type CRename = CString -> CString -> IO CInt -foreign import ccall threadsafe "wrapper" - mkRename :: CRename -> IO (FunPtr CRename) - -type CLink = CString -> CString -> IO CInt -foreign import ccall threadsafe "wrapper" - mkLink :: CLink -> IO (FunPtr CLink) - -type CChMod = CString -> CMode -> IO CInt -foreign import ccall threadsafe "wrapper" - mkChMod :: CChMod -> IO (FunPtr CChMod) - -type CChOwn = CString -> CUid -> CGid -> IO CInt -foreign import ccall threadsafe "wrapper" - mkChOwn :: CChOwn -> IO (FunPtr CChOwn) - -type CTruncate = CString -> COff -> IO CInt -foreign import ccall threadsafe "wrapper" - mkTruncate :: CTruncate -> IO (FunPtr CTruncate) - -data CUTimBuf -- struct utimbuf -type CUTime = CString -> Ptr CUTimBuf -> IO CInt -foreign import ccall threadsafe "wrapper" - mkUTime :: CUTime -> IO (FunPtr CUTime) - -type COpen = CString -> Ptr CFuseFileInfo -> IO CInt -foreign import ccall threadsafe "wrapper" - mkOpen :: COpen -> IO (FunPtr COpen) - -type CRead = CString -> CString -> CSize -> COff -> Ptr CFuseFileInfo -> IO CInt -foreign import ccall threadsafe "wrapper" - mkRead :: CRead -> IO (FunPtr CRead) - -type CWrite = CString -> CString -> CSize -> COff -> Ptr CFuseFileInfo -> IO CInt -foreign import ccall threadsafe "wrapper" - mkWrite :: CWrite -> IO (FunPtr CWrite) - -data CStructStatFS -- struct fuse_stat_fs -type CStatFS = CString -> Ptr CStructStatFS -> IO CInt -foreign import ccall threadsafe "wrapper" - mkStatFS :: CStatFS -> IO (FunPtr CStatFS) - -type CFlush = CString -> Ptr CFuseFileInfo -> IO CInt -foreign import ccall threadsafe "wrapper" - mkFlush :: CFlush -> IO (FunPtr CFlush) - -type CRelease = CString -> Ptr CFuseFileInfo -> IO CInt -foreign import ccall threadsafe "wrapper" - mkRelease :: CRelease -> IO (FunPtr CRelease) - -type CFSync = CString -> Int -> Ptr CFuseFileInfo -> IO CInt -foreign import ccall threadsafe "wrapper" - mkFSync :: CFSync -> IO (FunPtr CFSync) - --- XXX add *xattr bindings - -type COpenDir = CString -> Ptr CFuseFileInfo -> IO CInt -foreign import ccall threadsafe "wrapper" - mkOpenDir :: COpenDir -> IO (FunPtr COpenDir) - -type CReadDir = CString -> Ptr CFillDirBuf -> Ptr CFillDir -> COff -> Ptr CFuseFileInfo -> IO CInt -foreign import ccall threadsafe "wrapper" - mkReadDir :: CReadDir -> IO (FunPtr CReadDir) - -type CReleaseDir = CString -> Ptr CFuseFileInfo -> IO CInt -foreign import ccall threadsafe "wrapper" - mkReleaseDir :: CReleaseDir -> IO (FunPtr CReleaseDir) - -type CFSyncDir = CString -> Int -> Ptr CFuseFileInfo -> IO CInt -foreign import ccall threadsafe "wrapper" - mkFSyncDir :: CFSyncDir -> IO (FunPtr CFSyncDir) - --- CInt because anything would be fine as we don't use them -type CInit = IO (Ptr CInt) -foreign import ccall threadsafe "wrapper" - mkInit :: CInit -> IO (FunPtr CInit) - -type CDestroy = Ptr CInt -> IO () -foreign import ccall threadsafe "wrapper" - mkDestroy :: CDestroy -> IO (FunPtr CDestroy) - ---- --- dynamic C called from Haskell ---- - -data CDirHandle -- fuse_dirh_t -type CDirFil = Ptr CDirHandle -> CString -> Int -> IO CInt -- fuse_dirfil_t -foreign import ccall threadsafe "dynamic" - mkDirFil :: FunPtr CDirFil -> CDirFil - -data CFillDirBuf -- void -type CFillDir = Ptr CFillDirBuf -> CString -> Ptr CStat -> COff -> IO CInt -foreign import ccall threadsafe "dynamic" - mkFillDir :: FunPtr CFillDir -> CFillDir diff --git a/System/Posix/HelloFS.hs b/System/Posix/HelloFS.hs deleted file mode 100644 --- a/System/Posix/HelloFS.hs +++ /dev/null @@ -1,89 +0,0 @@ -module Main where - --- import Foreign.C.Error -import System.Posix.Types -import System.Posix.Files --- import System.Posix.IO - -import System.Posix.HFuse - -main :: IO () -main = fuseMain helloFSOps defaultExceptionHandler - -helloFSOps :: FuseOperations -helloFSOps = defaultFuseOps { fuseGetFileStat = helloGetFileStat - , fuseGetDirectoryContents = helloGetDirectoryContents - , fuseOpen = helloOpen - , fuseRead = helloRead - } -helloString :: String -helloString = "Hello World, HFuse!\n" - -helloPath :: FilePath -helloPath = "/hello" - -helloGetFileStat :: FilePath -> IO (Either Errno FileStat) -helloGetFileStat "/" = do - ctx <- getFuseContext - return $ Right $ FileStat { statEntryType = Directory - , statFileMode = foldr1 unionFileModes - [ ownerReadMode - , ownerExecuteMode - , groupReadMode - , groupExecuteMode - , otherReadMode - , otherExecuteMode - ] - , statLinkCount = 2 - , statFileOwner = fuseCtxUserID ctx - , statFileGroup = fuseCtxGroupID ctx - , statSpecialDeviceID = 0 - , statFileSize = 4096 - , statBlocks = 1 - , statAccessTime = 0 - , statModificationTime = 0 - , statStatusChangeTime = 0 - } -helloGetFileStat path | path == helloPath = do - ctx <- getFuseContext - return $ Right $ FileStat { statEntryType = RegularFile - , statFileMode = foldr1 unionFileModes - [ ownerReadMode - , groupReadMode - , otherReadMode - ] - , statLinkCount = 1 - , statFileOwner = fuseCtxUserID ctx - , statFileGroup = fuseCtxGroupID ctx - , statSpecialDeviceID = 0 - , statFileSize = fromIntegral $ length helloString - , statBlocks = 1 - , statAccessTime = 0 - , statModificationTime = 0 - , statStatusChangeTime = 0 - } -helloGetFileStat _ = - return $ Left eNOENT - -helloGetDirectoryContents :: FilePath -> IO (Either Errno [(FilePath, EntryType)]) -helloGetDirectoryContents "/" = - return $ Right [ (".", Directory) - , ("..", Directory) - , (tail helloPath, RegularFile) ] -helloGetDirectoryContents _ = return (Left (eNOENT)) - -helloOpen :: FilePath -> OpenMode -> OpenFileFlags -> IO Errno -helloOpen path mode _ - | path == helloPath = case mode of - ReadOnly -> return eOK - _ -> return eACCES - | otherwise = return eNOENT - - -helloRead :: FilePath -> ByteCount -> FileOffset - -> IO (Either Errno (String, ByteCount)) -helloRead path byteCount _ - | path == helloPath = - let count = max (length helloString) (fromIntegral byteCount) - in return $ Right (take count helloString, fromIntegral count) - | otherwise = return $ Left eNOENT diff --git a/System/Posix/LiveFS.hs b/System/Posix/LiveFS.hs deleted file mode 100644 --- a/System/Posix/LiveFS.hs +++ /dev/null @@ -1,78 +0,0 @@ --- Currently broken experiment -module Main where - -import Control.Concurrent.MVar - -import System.Posix.HFuse - -type FileName = String - -type Permissions = (FileMode, UserID, GroupID) - -type FSMap = FiniteMap FilePath FSObject - -data FSObject - = FSRegularFile Permissions String - | FSDirectory Permissions [(FileName, FSObject)] - -fsObjectPersmissions :: FSObject -> Persmissions -fsObjectPersmissions (FSRegularFile perms _) = perms -fsObjectPersmissions (FSDirectory perms _) = perms - -main :: IO () -main = - do mvRoot <- newMVar $ Directory [] - let liveFSOps :: FuseOperations - liveFSOps = - FuseOperations { fuseGetFileStat = liveGetFileStat - , fuseReadSymbolicLink = liveReadSymbolicLink - , fuseGetDirectoryContents = liveGetDirectoryContents - , fuseCreateDevice = liveCreateDevice - , fuseCreateDirectory = liveCreateDirectory - , fuseRemoveLink = liveRemoveLink - , fuseRemoveDirectory = liveRemoveDirectory - , fuseCreateSymbolicLink = liveCreateSymbolicLink - , fuseRename = liveRename - , fuseCreateLink = liveCreateLink - , fuseSetFileMode = liveSetFileMode - , fuseSetOwnerAndGroup = liveSetOwnerAndGroup - , fuseSetFileSize = liveSetFileSize - , fuseSetFileTimes = liveSetFileTimes - , fuseOpen = liveOpen - , fuseRead = liveRead - , fuseWrite = liveWrite - , fuseGetFileSystemStats = liveGetFileSystemStats - , fuseFlush = liveFlush - , fuseRelease = liveRelease - , fuseSynchronizeFile = liveSynchronizeFile - } - withPath :: FilePath -> (Maybe FSObject -> a) -> IO a - withPath path f = - withMVar mvRoot $ \ root -> - f (foldl digPath root (paths path)) - digPath :: Maybe FSObject -> FileName -> Maybe FSObject - digPath (Just (Directory entries)) name = lookup name entries - digPath _ _ = Nothing - liveGetFileStat :: FilePath -> IO (Either Errno FileStat) - liveGetFileStat path = - withPath path $ \ mbObj -> case mbObj of - Nothing -> return (Left eNOENT) - Just obj -> let entryType = case obj of FSRegularFile _ -> RegularFile - Directory _ -> Directory - (mode, owner, group) = fsObjectPermissions obj - size = undefined - in return $ Right $ FileStat - { statEntryType = entryType - , statFileMode = mode - , statLinkCount = 1 - , statFileOwner = owner - , statFileGroup = group - , statSpecialDeviceID = 0 - , statFileSize = undefined } - fuseMain liveFSOps (\e -> print e >> defaultExceptionHandler e) - -paths :: FilePath -> [FileName] -paths s = case dropWhile (== '/') s of - "" -> [] - s' -> w : words s'' - where (w, s'') = break (== '/') s' diff --git a/fuse_wrappers.c b/fuse_wrappers.c new file mode 100644 --- /dev/null +++ b/fuse_wrappers.c @@ -0,0 +1,11 @@ +#define FUSE_USE_VERSION 26 + +#include "fuse_wrappers.h" + +int +fuse_main_wrapper (int argc, + char *argv[], + const struct fuse_operations *op) +{ + return (fuse_main (argc, argv, op, NULL)); +} diff --git a/fuse_wrappers.h b/fuse_wrappers.h new file mode 100644 --- /dev/null +++ b/fuse_wrappers.h @@ -0,0 +1,3 @@ +#include + +int fuse_main_wrapper (int argc, char *argv[], const struct fuse_operations *op);