{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Command line tool for mounting a halfs filesystem from userspace via -- hFUSE/FUSE. module Main where import Control.Applicative import Control.Exception (SomeException(..), assert) import Data.Array.IO (IOUArray) import Data.Bits import Data.IORef (IORef) import Data.Word import System.Console.GetOpt import System.Directory (doesFileExist) import System.Environment import System.IO hiding (openFile) import System.Posix.Types ( ByteCount , DeviceID , EpochTime , FileMode , FileOffset , GroupID , UserID ) import System.Posix.User (getRealUserID, getRealGroupID) import System.Fuse import Halfs.Classes import Halfs.CoreAPI import Halfs.File (FileHandle, openFilePrim) import Halfs.Errors import Halfs.HalfsState import Halfs.Monad import Halfs.MonadUtils import Halfs.Utils import System.Device.BlockDevice import System.Device.File import System.Device.Memory import qualified Data.ByteString as BS import qualified Data.Map as M import qualified Halfs.Protection as HP import qualified Halfs.Types as H import qualified Tests.Utils as TU import qualified Prelude import Prelude hiding (catch, log, read) -- import Debug.Trace -- Halfs-specific stuff we carry around in our FUSE functions; note that the -- FUSE library does this via opaque ptr to user data, but since hFUSE -- reimplements fuse_main and doesn't seem to provide a way to hang onto -- private data, we just carry the data ourselves. type Logger m = String -> m () data HalfsSpecific b r l m = HS { hspLogger :: Logger m , hspState :: HalfsState b r l m -- ^ The filesystem state, as provided by CoreAPI.mount. , hspFpdhMap :: H.LockedRscRef l r (M.Map FilePath (H.DirHandle r l)) -- ^ Tracks DirHandles across halfs{Open,Read,Release}Directory invocations; -- we should be able to do this via HFuse and the fuse_file_info* out -- parameter for the 'open' fuse operation, but the binding doesn't support -- this. However, we'd probably still need something persistent here to go -- from the opaque handle we stored in the fuse_file_info struct to one of -- our DirHandles. } -- This isn't a halfs limit, but we have to pick something for FUSE. maxNameLength :: Integer maxNameLength = 32768 main :: IO () main = do (opts, argv1) <- do argv0 <- getArgs case getOpt RequireOrder options argv0 of (o, n, []) -> return (foldl (flip ($)) defOpts o, n) (_, _, errs) -> ioError $ userError $ concat errs ++ usageInfo hdr options where hdr = "Usage: halfs [OPTION...] " let sz = optSecSize opts; n = optNumSecs opts (exists, dev) <- maybe (fail "Unable to create device") return =<< let wb = (liftM . liftM) . (,) in if optMemDev opts then wb False $ newMemoryBlockDevice n sz <* putStrLn "Created new memdev." else case optFileDev opts of Nothing -> fail "Can't happen" Just fp -> do exists <- doesFileExist fp wb exists $ if exists then newFileBlockDevice fp sz <* putStrLn "Created filedev from existing file." else TU.withFileStore False fp sz n (`newFileBlockDevice` sz) <* putStrLn "Created filedev from new file." uid <- (HP.UID . fromIntegral) `fmap` getRealUserID gid <- (HP.GID . fromIntegral) `fmap` getRealGroupID let perms = H.FileMode [H.Read, H.Write, H.Execute] [H.Read, H.Execute] [ ] when (not exists) $ execNoEnv (newfs dev uid gid perms) >> return () fs <- execNoEnv $ mount dev uid gid perms let withLog act = case optLogFile opts of Nothing -> act $ const $ return () Just lp -> System.IO.withFile lp WriteMode $ \h -> act $ \s -> hPutStrLn h s >> hFlush h withLog $ \log -> do dhMap <- newLockedRscRef M.empty withArgs argv1 $ fuseMain (ops (HS log fs dhMap)) $ \(e :: SomeException) -> do log $ "*** Exception: " ++ show e return eFAULT -------------------------------------------------------------------------------- -- Halfs-hFUSE filesystem operation implementation -- JS: ST monad impls will have to get mapped to hFUSE ops via stToIO? ops :: HalfsSpecific (IOUArray Word64 Bool) IORef IOLock IO -> FuseOperations (FileHandle IORef IOLock) ops hsp = FuseOperations { fuseGetFileStat = halfsGetFileStat hsp , fuseReadSymbolicLink = halfsReadSymbolicLink hsp , fuseCreateDevice = halfsCreateDevice hsp , fuseCreateDirectory = halfsCreateDirectory hsp , fuseRemoveLink = halfsRemoveLink hsp , fuseRemoveDirectory = halfsRemoveDirectory hsp , fuseCreateSymbolicLink = halfsCreateSymbolicLink hsp , fuseRename = halfsRename hsp , fuseCreateLink = halfsCreateLink hsp , fuseSetFileMode = halfsSetFileMode hsp , fuseSetOwnerAndGroup = halfsSetOwnerAndGroup hsp , fuseSetFileSize = halfsSetFileSize hsp , fuseSetFileTimes = halfsSetFileTimes hsp , fuseOpen = halfsOpen hsp , fuseRead = halfsRead hsp , fuseWrite = halfsWrite hsp , fuseGetFileSystemStats = halfsGetFileSystemStats hsp , fuseFlush = halfsFlush hsp , fuseRelease = halfsRelease hsp , fuseSynchronizeFile = halfsSyncFile hsp , fuseOpenDirectory = halfsOpenDirectory hsp , fuseReadDirectory = halfsReadDirectory hsp , fuseReleaseDirectory = halfsReleaseDirectory hsp , fuseSynchronizeDirectory = halfsSyncDirectory hsp , fuseAccess = halfsAccess hsp , fuseInit = halfsInit hsp , fuseDestroy = halfsDestroy hsp } halfsGetFileStat :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> m (Either Errno FileStat) halfsGetFileStat hsp@HS{ hspLogger = _log } fp = do --log $ "halfsGetFileStat: fp = " ++ show fp eestat <- execOrErrno hsp eINVAL id (fstat fp) case eestat of Left en -> do --log $ " (fstat failed w/ " ++ show en ++ ")" return $ Left en Right stat -> Right `fmap` hfstat2fstat stat halfsReadSymbolicLink :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> m (Either Errno FilePath) halfsReadSymbolicLink HS{ hspLogger = _log, hspState = _fs } _fp = do _ <- error "halfsReadSymbolicLink: Not Yet Implemented" -- TODO return (Left eNOSYS) halfsCreateDevice :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> EntryType -> FileMode -> DeviceID -> m Errno halfsCreateDevice hsp@HS{ hspLogger = log } fp etype mode _devID = do log $ "halfsCreateDevice: fp = " ++ show fp ++ ", etype = " ++ show etype ++ ", mode = " ++ show mode case etype of RegularFile -> do --log $ "halfsCreateDevice: Regular file w/ " ++ show hmode execDefault hsp $ hlocal (withLogger log) $ createFile fp hmode _ -> do log $ "halfsCreateDevice: Error: Unsupported EntryType encountered." return eINVAL where hmode = mode2hmode mode halfsCreateDirectory :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> FileMode -> m Errno halfsCreateDirectory hsp@HS{ hspLogger = log } fp mode = do log $ "halfsCreateDirectory: fp = " ++ show fp execDefault hsp $ mkdir fp (mode2hmode mode) halfsRemoveLink :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> m Errno halfsRemoveLink hsp@HS{ hspLogger = log } fp = do log $ "halfsRemoveLink: fp = " ++ show fp execDefault hsp $ rmlink fp halfsRemoveDirectory :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> m Errno halfsRemoveDirectory hsp@HS{ hspLogger = log } fp = do log $ "halfsRemoveDirectory: removing " ++ show fp execDefault hsp $ rmdir fp halfsCreateSymbolicLink :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> FilePath -> m Errno halfsCreateSymbolicLink HS{ hspLogger = _log, hspState = _fs } _src _dst = do _ <- error $ "halfsCreateSymbolicLink: Not Yet Implemented." -- TODO return eNOSYS halfsRename :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> FilePath -> m Errno halfsRename hsp@HS{ hspLogger = log } old new = do log $ "halfsRename: old = " ++ show old ++ ", new = " ++ show new execDefault hsp $ rename old new halfsCreateLink :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> FilePath -> m Errno halfsCreateLink hsp@HS{ hspLogger = log } src dst = do log $ "halfsCreateLink: creating hard link from '" ++ src ++ "' to '" ++ dst ++ "'" execDefault hsp $ mklink src dst halfsSetFileMode :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> FileMode -> m Errno halfsSetFileMode hsp@HS{ hspLogger = log } fp mode = do log $ "halfsSetFileMode: setting " ++ show fp ++ " to mode " ++ show mode execDefault hsp $ chmod fp (mode2hmode mode) halfsSetOwnerAndGroup :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> UserID -> GroupID -> m Errno halfsSetOwnerAndGroup hsp@HS{ hspLogger = log } fp uid' gid' = do -- uid and gid get passed as System.Posix.Types.C[UG]id which are newtype'd -- Word32s. Unfortunately, this means that a user or group argument of -1 -- (which means "unchanged" according to the man page for chown(2)) is only -- visible to us here as maxBound :: Word32. let uid = cvt uid' gid = cvt gid' cvt x = if fromIntegral x == (maxBound :: Word32) then Nothing else Just (fromIntegral x) log $ "halfsSetOwnerAndGroup: setting " ++ show fp ++ " to user = " ++ show uid ++ ", group = " ++ show gid execDefault hsp $ chown fp uid gid halfsSetFileSize :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> FileOffset -> m Errno halfsSetFileSize hsp@HS{ hspLogger = log } fp offset = do log $ "halfsSetFileSize: setting " ++ show fp ++ " to size " ++ show offset execDefault hsp $ setFileSize fp (fromIntegral offset) halfsSetFileTimes :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> EpochTime -> EpochTime -> m Errno halfsSetFileTimes hsp@HS{ hspLogger = log } fp accTm modTm = do -- TODO: Check perms: caller must be file owner w/ write access or -- superuser. accTm' <- fromCTime accTm modTm' <- fromCTime modTm log $ "halfsSetFileTimes fp = " ++ show fp ++ ", accTm = " ++ show accTm' ++ ", modTm = " ++ show modTm' execDefault hsp $ setFileTimes fp accTm' modTm' halfsOpen :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> OpenMode -> OpenFileFlags -> m (Either Errno (FileHandle r l)) halfsOpen hsp@HS{ hspLogger = log } fp omode flags = do log $ "halfsOpen: fp = " ++ show fp ++ ", omode = " ++ show omode ++ ", flags = " ++ show flags rslt <- execOrErrno hsp eINVAL id $ openFile fp halfsFlags return rslt where -- NB: In HFuse 0.2.2, the explicit and truncate are always false, -- so we do not pass them down to halfs. Similarly, halfs does not -- support noctty, so it's ignored here as well. halfsFlags = H.FileOpenFlags { H.append = append flags , H.nonBlock = nonBlock flags , H.openMode = case omode of ReadOnly -> H.ReadOnly WriteOnly -> H.WriteOnly ReadWrite -> H.ReadWrite } halfsRead :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> FileHandle r l -> ByteCount -> FileOffset -> m (Either Errno BS.ByteString) halfsRead hsp@HS{ hspLogger = log } fp fh byteCnt offset = do log $ "halfsRead: Reading " ++ show byteCnt ++ " bytes from " ++ show fp ++ " at offset " ++ show offset execOrErrno hsp eINVAL id $ read fh (fromIntegral offset) (fromIntegral byteCnt) halfsWrite :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> FileHandle r l -> BS.ByteString -> FileOffset -> m (Either Errno ByteCount) halfsWrite hsp@HS{ hspLogger = log } fp fh bytes offset = do log $ "halfsWrite: Writing " ++ show (BS.length bytes) ++ " bytes to " ++ show fp ++ " at offset " ++ show offset execOrErrno hsp eINVAL id $ do write fh (fromIntegral offset) bytes return (fromIntegral $ BS.length bytes) halfsGetFileSystemStats :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> m (Either Errno System.Fuse.FileSystemStats) halfsGetFileSystemStats hsp _fp = do execOrErrno hsp eINVAL fss2fss fsstat where fss2fss (FSS bs bc bf ba fc ff) = System.Fuse.FileSystemStats { fsStatBlockSize = bs , fsStatBlockCount = bc , fsStatBlocksFree = bf , fsStatBlocksAvailable = ba , fsStatFileCount = fc , fsStatFilesFree = ff , fsStatMaxNameLength = maxNameLength } halfsFlush :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> FileHandle r l -> m Errno halfsFlush hsp@HS{ hspLogger = _log } _fp fh = do --log $ "halfsFlush: Flushing " ++ show fp execDefault hsp $ flush fh halfsRelease :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> FileHandle r l -> m () halfsRelease HS{ hspLogger = log, hspState = fs } fp fh = do log $ "halfsRelease: Releasing " ++ show fp exec fs $ closeFile fh halfsSyncFile :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> System.Fuse.SyncType -> m Errno halfsSyncFile HS{ hspLogger = _log, hspState = _fs } _fp _syncType = do _ <- error "halfsSyncFile: Not Yet Implemented." -- TODO return eNOSYS halfsOpenDirectory :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> m Errno halfsOpenDirectory hsp@HS{ hspLogger = log, hspFpdhMap = fpdhMap } fp = do log $ "halfsOpenDirectory: fp = " ++ show fp execDefault hsp $ withLockedRscRef fpdhMap $ \ref -> do mdh <- lookupRM fp ref case mdh of Nothing -> openDir fp >>= \v -> insertRM fp v ref _ -> return () halfsReadDirectory :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> m (Either Errno [(FilePath, FileStat)]) halfsReadDirectory hsp@HS{ hspLogger = log, hspFpdhMap = fpdhMap } fp = do log $ "halfsReadDirectory: fp = " ++ show fp rslt <- execOrErrno hsp eINVAL id $ withLockedRscRef fpdhMap $ \ref -> do mdh <- lookupRM fp ref case mdh of Nothing -> throwError HE_DirectoryHandleNotFound Just dh -> readDir dh >>= mapM (\(p, s) -> (,) p `fmap` hfstat2fstat s) -- log $ " rslt = " ++ show rslt log $ " rslt had " ++ show (length `fmap` rslt) ++ " entries." return rslt halfsReleaseDirectory :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> m Errno halfsReleaseDirectory hsp@HS{ hspLogger = log, hspFpdhMap = fpdhMap} fp = do log $ "halfsReleaseDirectory: fp = " ++ show fp execDefault hsp $ withLockedRscRef fpdhMap $ \ref -> do mdh <- lookupRM fp ref case mdh of Nothing -> throwError HE_DirectoryHandleNotFound Just dh -> closeDir dh >> deleteRM fp ref halfsSyncDirectory :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> System.Fuse.SyncType -> m Errno halfsSyncDirectory HS{ hspLogger = _log, hspState = _fs } _fp _syncType = do _ <- error "halfsSyncDirectory: Not Yet Implemented." -- TODO return eNOSYS halfsAccess :: HalfsCapable b t r l m => HalfsSpecific b r l m -> FilePath -> Int -> m Errno halfsAccess (HS _log _fs _fpdhMap) _fp _n = do --log $ "halfsAccess: fp = " ++ show fp ++ ", n = " ++ show n return eOK -- TODO FIXME currently grants all access! halfsInit :: HalfsCapable b t r l m => HalfsSpecific b r l m -> m () halfsInit (HS log _fs _fpdhMap) = do log $ "halfsInit: Invoked." return () halfsDestroy :: HalfsCapable b t r l m => HalfsSpecific b r l m -> m () halfsDestroy HS{ hspLogger = log, hspState = fs } = do log $ "halfsDestroy: Unmounting..." exec fs $ unmount log "halfsDestroy: Shutting block device down..." exec fs $ lift $ bdShutdown (hsBlockDev fs) log $ "halfsDestroy: Done." return () -------------------------------------------------------------------------------- -- Converters hfstat2fstat :: (Show t, Timed t m) => H.FileStat t -> m FileStat hfstat2fstat stat = do atm <- toCTime $ H.fsAccessTime stat mtm <- toCTime $ H.fsModifyTime stat chtm <- toCTime $ H.fsChangeTime stat let entryType = case H.fsType stat of H.RegularFile -> RegularFile H.Directory -> Directory H.Symlink -> SymbolicLink -- TODO: Represent remaining FUSE entry types H.AnyFileType -> error "Invalid fstat type" return FileStat { statEntryType = entryType , statFileMode = entryTypeToFileMode entryType .|. emode (H.fsMode stat) , statLinkCount = chkb16 $ H.fsNumLinks stat , statFileOwner = chkb32 $ H.fsUID stat , statFileGroup = chkb32 $ H.fsGID stat , statSpecialDeviceID = 0 -- XXX/TODO: Do we need to distinguish by -- blkdev, or is this for something else? , statFileSize = fromIntegral $ H.fsSize stat , statBlocks = fromIntegral $ H.fsNumBlocks stat , statAccessTime = atm , statModificationTime = mtm , statStatusChangeTime = chtm } where chkb16 x = assert (x' <= fromIntegral (maxBound :: Word16)) x' where x' = fromIntegral x chkb32 x = assert (x' <= fromIntegral (maxBound :: Word32)) x' where x' = fromIntegral x emode (H.FileMode o g u) = cvt o * 0o100 + cvt g * 0o10 + cvt u where cvt = foldr (\p acc -> acc + case p of H.Read -> 0o4 H.Write -> 0o2 H.Execute -> 0o1 ) 0 -- NB: Something like this should probably be done by HFuse. TODO: Migrate? mode2hmode :: FileMode -> H.FileMode mode2hmode mode = H.FileMode (perms 6) (perms 3) (perms 0) where msk b = case b of H.Read -> 4; H.Write -> 2; H.Execute -> 1 perms k = chk H.Read ++ chk H.Write ++ chk H.Execute where chk b = if mode .&. msk b `shiftL` k /= 0 then [b] else [] -------------------------------------------------------------------------------- -- Misc exec :: HalfsCapable b t r l m => HalfsState b r l m -> HalfsM b r l m a -> m a exec fs act = runHalfs fs act >>= \ea -> case ea of Left e -> fail $ show e Right x -> return x execNoEnv :: Monad m => HalfsM b r l m a -> m a execNoEnv act = runHalfsNoEnv act >>= \ea -> case ea of Left e -> fail $ show e Right x -> return x -- | Returns the result of the given action on success, otherwise yields an -- Errno for the failed operation. The Errno comes from either a HalfsM -- exception signifying it holds an Errno, or the default provided as the first -- argument. execOrErrno :: Monad m => HalfsSpecific b r l m -> Errno -> (a -> rslt) -> HalfsM b r l m a -> m (Either Errno rslt) execOrErrno HS{ hspLogger = log, hspState = fs } defaultEn f act = do runHalfs fs act >>= \ea -> case ea of Left (HE_ErrnoAnnotated e en) -> do log ("execOrErrno: e = " ++ show e) return $ Left en Left _e@HE_PathComponentNotFound{} -> do --log ("execOrErrno: e = " ++ show e) return $ Left eNOENT Left e -> do log ("execOrErrno: e = " ++ show e) return $ Left defaultEn Right x -> return $ Right (f x) execToErrno :: HalfsCapable b t r l m => HalfsSpecific b r l m -> Errno -> (a -> Errno) -> HalfsM b r l m a -> m Errno execToErrno hsp defaultEn f = liftM (either id id) . execOrErrno hsp defaultEn f execDefault :: HalfsCapable b t r l m => HalfsSpecific b r l m -> HalfsM b r l m a -> m Errno execDefault hsp = execToErrno hsp eINVAL (const eOK) withLogger :: HalfsCapable b t r l m => Logger m -> HalfsState b r l m -> HalfsState b r l m withLogger log fs = fs {hsLogger = Just log} -------------------------------------------------------------------------------- -- Command line stuff data Options = Options { optFileDev :: Maybe FilePath , optMemDev :: Bool , optNumSecs :: Word64 , optSecSize :: Word64 , optLogFile :: Maybe FilePath } deriving (Show) defOpts :: Options defOpts = Options { optFileDev = Nothing , optMemDev = True , optNumSecs = 512 , optSecSize = 512 , optLogFile = Nothing } options :: [OptDescr (Options -> Options)] options = [ Option ['m'] ["memdev"] (NoArg $ \opts -> opts{ optFileDev = Nothing, optMemDev = True }) "use memory device" , Option ['f'] ["filedev"] (ReqArg (\f opts -> opts{ optFileDev = Just f, optMemDev = False }) "PATH" ) "use file-backed device" , Option ['n'] ["numsecs"] (ReqArg (\s0 opts -> let s1 = Prelude.read s0 in opts{ optNumSecs = s1 }) "SIZE" ) "number of sectors (ignored for filedevs; default 512)" , Option ['s'] ["secsize"] (ReqArg (\s0 opts -> let s1 = Prelude.read s0 in opts{ optSecSize = s1 }) "SIZE" ) "sector size in bytes (ignored for existing filedevs; default 512)" , Option ['l'] ["logfile"] (ReqArg (\s opts -> opts{ optLogFile = Just s }) "PATH" ) "filename for halfs logging (default is no logging done)" ] -------------------------------------------------------------------------------- -- Instances for debugging instance Show OpenMode where show ReadOnly = "ReadOnly" show WriteOnly = "WriteOnly" show ReadWrite = "ReadWrite" instance Show OpenFileFlags where show (OpenFileFlags append' exclusive' noctty' nonBlock' trunc') = "OpenFileFlags " ++ "{ append = " ++ show append' ++ ", exclusive = " ++ show exclusive' ++ ", noctty = " ++ show noctty' ++ ", nonBlock = " ++ show nonBlock' ++ ", trunc = " ++ show trunc' ++ "}" -- Get rid of extraneous Halfs.File not-used warning _dummy :: HalfsCapable b t r l m => H.InodeRef -> HalfsM b r l m (FileHandle r l) _dummy = openFilePrim undefined