diff --git a/HFuse.cabal b/HFuse.cabal new file mode 100644 --- /dev/null +++ b/HFuse.cabal @@ -0,0 +1,39 @@ +Name: HFuse +Version: 0.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 +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/System/Posix/HFuse.hsc b/System/Posix/HFuse.hsc new file mode 100644 --- /dev/null +++ b/System/Posix/HFuse.hsc @@ -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 +-- +-- 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 new file mode 100644 --- /dev/null +++ b/System/Posix/HelloFS.hs @@ -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 diff --git a/System/Posix/LiveFS.hs b/System/Posix/LiveFS.hs new file mode 100644 --- /dev/null +++ b/System/Posix/LiveFS.hs @@ -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'