HFuse (empty) → 0.1
raw patch · 7 files changed
+1111/−0 lines, 7 filesdep +basedep +unixsetup-changed
Dependencies added: base, unix
Files
- HFuse.cabal +39/−0
- LICENSE +29/−0
- README +6/−0
- Setup.lhs +4/−0
- System/Posix/HFuse.hsc +866/−0
- System/Posix/HelloFS.hs +89/−0
- System/Posix/LiveFS.hs +78/−0
+ HFuse.cabal view
@@ -0,0 +1,39 @@+Name: HFuse+Version: 0.1+License: BSD3+License-File: LICENSE+Author: Jérémy Bobbio+Maintainer: Jérémy Bobbio <jeremy.bobbio@etu.upmc.fr>+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+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++ -- When compiling for a 64-bit architecture, we need special flags for hsc2hs+ if arch(x86_64)+ cc-options: -D_FILE_OFFSET_BITS=64
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) Jérémy Bobbio+All rights reserved.++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+ 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+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.
+ README view
@@ -0,0 +1,6 @@+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.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ System/Posix/HFuse.hsc view
@@ -0,0 +1,866 @@+-----------------------------------------------------------------------------+-- |+-- 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 <http://fuse.sourceforge.net/>+--+-- 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 <sys/statfs.h>+#include <dirent.h>+#include <fuse.h>+#include <fcntl.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 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
+ System/Posix/HelloFS.hs view
@@ -0,0 +1,89 @@+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
+ System/Posix/LiveFS.hs view
@@ -0,0 +1,78 @@+-- 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'