{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, RankNTypes #-} module Halfs.CoreAPI where import Control.Exception (assert) import Data.ByteString (ByteString) import Data.Serialize hiding (isEmpty) import Data.Word import Foreign.C.Error hiding (throwErrno) import System.FilePath import qualified Data.ByteString as BS import qualified Data.List as L import qualified Data.Map as M import qualified Data.Traversable as T import Halfs.BlockMap import Halfs.Classes import Halfs.Directory import Halfs.Errors import Halfs.File import Halfs.HalfsState import Halfs.Inode import Halfs.Monad import Halfs.MonadUtils import Halfs.Protection import Halfs.SuperBlock import Halfs.Types import Halfs.Utils import qualified Halfs.File as F import System.Device.BlockDevice -- import Debug.Trace type HalfsM b r l m a = HalfsT HalfsError (Maybe (HalfsState b r l m)) m a data SyncType = Data | Everything data FileSystemStats = FSS { fssBlockSize :: Integer -- ^ fundamental file system block size , fssBlockCount :: Integer -- ^ #data blocks in filesystem , fssBlocksFree :: Integer -- ^ #free blocks in filesystem , fssBlocksAvailable :: Integer -- ^ #free blocks avail to non-root , fssFileCount :: Integer -- ^ #num inodes in filesystem , fssFilesFree :: Integer -- ^ #free inodes in filesystem } deriving (Show) -------------------------------------------------------------------------------- -- Filesystem init, teardown, and check functions -- | Create a new file system on the given device. The new file system -- will use the block size reported by bdBlockSize on the device; if you -- want to increase the file system's block size, you should use -- 'newRescaledBlockDevice' from System.Device.BlockDevice. -- -- Block size has no bearing on the maximum size of a file or directory, but -- will impact the size of certain internal data structures that keep track of -- free blocks. Larger block sizes will decrease the cost of these structures -- per underlying disk megabyte, but may also lead to more wasted space for -- small files and directories. newfs :: (HalfsCapable b t r l m) => BlockDevice m -> UserID -> GroupID -> FileMode -> HalfsM b r l m SuperBlock newfs dev uid gid rdirPerms = do when (superBlockSize > bdBlockSize dev) $ fail "The device's block size is insufficiently large!" blockMap <- lift $ newBlockMap dev initFree <- readRef (bmNumFree blockMap) rdirAddr <- lift (alloc1 blockMap) >>= maybe (fail "Unable to allocate block for rdir inode") return -- Build the root directory inode and persist it; note that we can't use -- Directory.makeDirectory here because this is a special case where we have -- no parent directory (and, furthermore, no filesystem state). let rdirIR = blockAddrToInodeRef rdirAddr dirInode <- lift $ buildEmptyInodeEnc dev Directory rdirPerms rdirIR nilIR uid gid assert (BS.length dirInode == fromIntegral (bdBlockSize dev)) $ do lift $ bdWriteBlock dev rdirAddr dirInode finalFree <- readRef (bmNumFree blockMap) -- Persist the remaining data structures lift $ writeBlockMap dev blockMap lift $ writeSB dev $ SuperBlock { version = 1 , devBlockSize = bdBlockSize dev , devBlockCount = bdNumBlocks dev , unmountClean = True , freeBlocks = finalFree , usedBlocks = initFree - finalFree , fileCount = 0 , rootDir = rdirIR , blockMapStart = blockAddrToInodeRef 1 } -- | Mounts a filesystem from a given block device. After this operation -- completes, the superblock will have its unmountClean flag set to False. mount :: (HalfsCapable b t r l m) => BlockDevice m -> UserID -> GroupID -> FileMode -> HalfsM b r l m (HalfsState b r l m) mount dev usr grp rdirPerms = do -- fsck needs read access some aspects of the HalfsState (e.g. the dev), even -- though there isn't yet a valid state from a mount/successful fsck. Being -- able to log here via logMsg is nice here, too, so we wrap everything in a -- dummy environment with some bits filled in. We'll raise internal errors if -- any of the nonexistent bits are pulled on. let lgr = Nothing -- Just $ \s -> trace s (return ()) dummy <- newHalfsState dev usr grp lgr (error "Internal (mount): dummy state's superblock is invalid!") (error "Internal (mount): dummy state's blockmap is invalid!") either throwError return =<< (lift $ runHalfs dummy $ mount') where newfs' d u g p = newfs d u g p >> mount d u g p -- mount' = do esb <- decode `fmap` lift (bdReadBlock dev 0) case esb of Left _msg -> do -- Unable to read the superblock: for now, we just give up on the mount -- and provide a new filesystem. logMsg "mount: unable to read superblock, creating new filesystem." newfs' dev usr grp rdirPerms Right sb -> do if unmountClean sb then do bm <- lift $ readBlockMap dev sb' <- lift $ writeSB dev sb{ unmountClean = False } newHalfsState dev usr grp Nothing sb' bm else do mfs <- fsck dev sb usr grp rdirPerms case mfs of Just fs -> return fs Nothing -> do logMsg "mount: fsck failed. Creating new filesystem." newfs' dev usr grp rdirPerms -- | Unmounts the given filesystem. After this operation completes, the -- superblock will have its unmountClean flag set to True. unmount :: (HalfsCapable b t r l m) => HalfsM b r l m () unmount = do dhMap <- hasks hsDHMap lk <- hasks hsLock dev <- hasks hsBlockDev sbRef <- hasks hsSuperBlock withLock lk $ withLockedRscRef dhMap $ \dhMapRef -> do -- Grab everything; we do not want to permit other filesystem actions to -- occur in other threads during or after teardown. Needs testing. TODO sb <- readRef sbRef if (unmountClean sb) then throwError HE_UnmountFailed else do -- TODO: -- - Persist all dirty data structures (dirents, files w/ buffered IO, etc.) -- Sync all directories; clean directory state is a no-op mapM_ syncDirectory =<< M.elems `fmap` readRef dhMapRef lift $ bdFlush dev -- Finalize the superblock let sb' = sb{ unmountClean = True } writeRef sbRef sb' _ <- lift $ writeSB dev sb' return () -------------------------------------------------------------------------------- -- FileSystem ChecK (fsck) fsck :: HalfsCapable b t r l m => BlockDevice m -> SuperBlock -> UserID -> GroupID -> FileMode -> HalfsM b r l m (Maybe (HalfsState b r l m)) fsck dev sb usr grp rdirPerms = do used <- lift $ newUsedBitmap dev mbad <- fsck' dev sb used (rootDir sb) (rootDir sb) case mbad of Nothing -> return Nothing Just (bad, fc) -> do bm <- lift $ writeUsedBitmap dev used >> readBlockMap dev finalFree <- readRef (bmNumFree bm) _ <- lift $ writeSB dev $ sb { unmountClean = True , freeBlocks = finalFree , usedBlocks = initFree - finalFree , fileCount = fc } logMsg $ "fsck: OK. Bad inodes found: " ++ show (map unIR bad) Just `fmap` mount dev usr grp rdirPerms where blks = blockMapSizeBlks (bdNumBlocks dev) (bdBlockSize dev) initFree = bdNumBlocks dev - blks - 1 {- -1 for superblock -} fsck' :: HalfsCapable b t r l m => BlockDevice m -> SuperBlock -> b -> InodeRef -> InodeRef -> HalfsM b r l m (Maybe ([InodeRef], Word64)) fsck' dev sb used pinr inr = do whenValid (drefInode inr) val where -- Failed operations result in this inode being marked invalid whenValid act onValid = do eea <- Right `fmap` act `catchError` \e -> Left `fmap` inv e either return onValid eea -- inv err = do logMsg $ "fsck: corrupt inode " ++ show (unIR inr) ++ ".\n\tReason: " ++ show err if pinr /= inr then do -- We have a valid parent directory, so remove the dirent for this inr pdh <- newDirHandle pinr contents <- readRef (dhContents pdh) case L.find (\de -> deInode de == inr) (M.elems contents) of Nothing -> do logMsg "fsck internal: failed to find expected inode" error "fsck internal: failed to find expected inode" Just de -> do rmDirEnt_lckd pdh (deName de) syncDirectory_lckd pdh return $ Just ([inr], 0) else do logMsg "fsck: Critical failure: couldn't decode root directory" return Nothing -- val nd@Inode{ inoExt = ext, inoFileType = ftype } = do assert (inoAddress nd == inr) $ return () whenValid (drop 1 `fmap` expandExts Nothing ext) $ \exts -> do let markUsed = mapM_ (setBit used) $ unIR inr : map (unER . address) exts case ftype of Directory -> do whenValid (newDirHandle inr) $ \thisDH -> do markUsed kids <- M.elems `fmap` readRef (dhContents thisDH) foldM (\(Just (bads, fc)) kid -> do Just (bs, k) <- fsck' dev sb used inr (deInode kid) return $ Just (bads ++ bs, fc + k) ) (Just ([], 0)) kids RegularFile -> do markUsed return $ Just ([], 1) _ -> error "fsck' internal error: filetype not supported" -------------------------------------------------------------------------------- -- Directory manipulation -- | Makes a directory given an absolute path. -- -- * Yields HalfsPathComponentNotFound if any path component on the way down to -- the directory to create does not exist. -- -- * Yields HalfsAbsolutePathExpected if an absolute path is not provided. -- mkdir :: (HalfsCapable b t r l m) => FilePath -> FileMode -> HalfsM b r l m () mkdir fp fm = do parentIR <- fst `fmap` absPathIR path Directory usr <- getUser grp <- getGroup _ <- makeDirectory parentIR dirName usr grp fm return () where (path, dirName) = splitFileName fp rmdir :: (HalfsCapable b t r l m) => FilePath -> HalfsM b r l m () rmdir fp = removeDirectory (Just $ takeFileName fp) =<< fst `fmap` absPathIR fp Directory openDir :: (HalfsCapable b t r l m) => FilePath -> HalfsM b r l m (DirHandle r l) openDir fp = openDirectory =<< fst `fmap` absPathIR fp Directory closeDir :: (HalfsCapable b t r l m) => DirHandle r l -> HalfsM b r l m () closeDir dh = closeDirectory dh readDir :: (HalfsCapable b t r l m) => DirHandle r l -> HalfsM b r l m [(FilePath, FileStat t)] readDir dh = do withDHLock dh $ do inr <- getDHINR_lckd dh contents <- liftM M.toList $ T.mapM (fileStat) =<< fmap deInode `fmap` readRef (dhContents dh) thisStat <- fileStat inr parentStat <- fileStat =<< do withLockedInode inr $ do p <- inoParent `fmap` drefInode inr if isNilIR p then fmap rootDir . readRef =<< hasks hsSuperBlock else return p return $ (dotPath, thisStat) : (dotdotPath, parentStat) : contents -- | Synchronize the given directory to disk. syncDir :: (HalfsCapable b t r l m) => FilePath -> SyncType -> HalfsM b r l m () syncDir = undefined -------------------------------------------------------------------------------- -- File manipulation -- | Creates a file given an absolute path. Raises HE_ObjectExists if the file -- already exists. createFile :: (HalfsCapable b t r l m ) => FilePath -> FileMode -> HalfsM b r l m () createFile fp mode = do -- TODO: permissions withDir ppath $ \pdh -> do findInDir pdh fname RegularFile >>= \rslt -> case rslt of DF_Found _ -> throwError $ HE_ObjectExists fp DF_WrongFileType ft -> throwError $ HE_UnexpectedFileType ft fp _ -> return () usr <- getUser grp <- getGroup _inr <- F.createFile pdh fname usr grp mode return () where (ppath, fname) = splitFileName fp -- | Opens a file given an absolute path. Raises HE_FileNotFound if the named -- file does not exist. Raises HE_UnexpectedFileType if the given path is not a -- file. Otherwise, provides a FileHandle to the requested file -- TODO: modes and flags for open: append, r/w, ronly, truncate, etc., and -- enforcement of the same openFile :: (HalfsCapable b t r l m) => FilePath -- ^ The absolute path of the file -> FileOpenFlags -- ^ open flags / open mode (ronly, wonly, wr) -> HalfsM b r l m (FileHandle r l) openFile fp oflags = do -- TODO: check perms pdh <- openDir ppath fh <- findInDir pdh fname RegularFile >>= \rslt -> case rslt of DF_NotFound -> throwError $ HE_FileNotFound DF_WrongFileType ft -> throwError $ HE_UnexpectedFileType ft fp DF_Found (fir, _ft) -> foundFile fir closeDir pdh return fh where (ppath, fname) = splitFileName fp foundFile = openFilePrim oflags read :: (HalfsCapable b t r l m) => FileHandle r l -- ^ the handle for the open file to read -> Word64 -- ^ the byte offset into the file -> Word64 -- ^ the number of bytes to read -> HalfsM b r l m ByteString -- ^ the data read read fh byteOff len = do -- TODO: Check perms unless (fhReadable fh) $ HE_BadFileHandleForRead `annErrno` eBADF withLock (fhLock fh) $ do inr <- getFHINR_lckd fh readStream inr byteOff (Just len) write :: (HalfsCapable b t r l m) => FileHandle r l -- ^ the handle for the open file to write -> Word64 -- ^ the byte offset into the file -> ByteString -- ^ the data to write -> HalfsM b r l m () write fh byteOff bytes = do -- TODO: Check perms unless (fhWritable fh) $ HE_BadFileHandleForWrite `annErrno` eBADF withLock (fhLock fh) $ do inr <- getFHINR_lckd fh writeStream inr byteOff False bytes flush :: (HalfsCapable b t r l m) => FileHandle r l -> HalfsM b r l m () flush _fh = lift . bdFlush =<< hasks hsBlockDev syncFile :: (HalfsCapable b t r l m) => FilePath -> SyncType -> HalfsM b r l m () syncFile _fp _st = lift . bdFlush =<< hasks hsBlockDev closeFile :: (HalfsCapable b t r l m) => FileHandle r l -- ^ the handle to the open file to close -> HalfsM b r l m () closeFile fh = closeFilePrim fh setFileSize :: (HalfsCapable b t r l m) => FilePath -> Word64 -> HalfsM b r l m () setFileSize fp len = withFile fp (fofWriteOnly True) $ \fh -> do withLock (fhLock fh) $ do inr <- getFHINR_lckd fh let wr = writeStream_lckd inr withLockedInode inr $ do sz <- fsSize `fmap` fileStat_lckd inr if sz > len then wr len True BS.empty -- truncate at len else wr sz False $ bsReplicate (len - sz) 0 -- pad up to len setFileTimes :: (HalfsCapable b t r l m) => FilePath -> t -- ^ access time -> t -- ^ modification time -> HalfsM b r l m () setFileTimes fp accTm modTm = do -- TODO: Check permissions modifyInode fp $ \nd -> nd{ inoModifyTime = modTm, inoAccessTime = accTm } rename :: (HalfsCapable b t r l m) => FilePath -> FilePath -> HalfsM b r l m () rename oldFP newFP = do -- TODO: perms checks, more errno wrapping {- Currently status of unsupported POSIX error behaviors: TODO ---- [EACCES] A component of either path prefix denies search permission. [EACCES] The requested operation requires writing in a directory (e.g., new, new/.., or old/..) whose modes disallow this. [EIO] An I/O error occurs while making or updating a directory entry. [ELOOP] Too many symbolic links are encountered in translating either pathname. This is taken to be indicative of a looping symbolic link. [EPERM] The directory containing old is marked sticky, and neither the containing directory nor old are owned by the effective user ID. [EPERM] The new file exists, the directory containing new is marked sticky, and neither the containing directory nor new are owned by the effective user ID. DEFERRED -------- [EXDEV] The link named by new and the file named by old are on different logical devices (file systems). Note that this error code will not be returned if the implementation permits cross-device links. [EROFS] The requested link requires writing in a directory on a read-only file system. NOT APPLICABLE (but may be reconsidered later) ---------------------------------------------- [EFAULT] Path points outside the process's allocated address space. [EDQUOT] The directory in which the entry for the new name is being placed cannot be extended because the user's quota of disk blocks on the file system containing the directory has been exhausted. [ENAMETOOLONG] A component of a pathname exceeds {NAME_MAX} characters, or an entire path name exceeds {PATH_MAX} characters. -} -- [EINVAL]: An attempt is made to rename `.' or `..'. when (oldFP `equalFilePath` dotPath || oldFP `equalFilePath` dotdotPath) $ HE_RenameFailed `annErrno` eINVAL withDirResources $ \oldParentDH newParentDH -> do -- Begin critical section over old and new parent directory handles mnewDE <- lookupDE newName newParentDH oldDE <- lookupDE oldName oldParentDH >>= (`maybe` return) (HE_PathComponentNotFound oldName `annErrno` eNOENT) -- [ENOENT]: A component of the old path DNE handleErrors oldDE mnewDE let updateContentMaps = do addDirEnt_lckd' True newParentDH oldDE{ deName = newName } rmDirEnt_lckd oldParentDH oldName syncDirectory_lckd newParentDH `catchError` \e -> do case e of -- [ENOSPC]: The directory in which the entry for the new name is -- being placed cannot be extended because there is no space left -- on the file system containing the directory. HE_AllocFailed{} -> e `annErrno` eNOSPC _ -> throwError e -- We try to respect rename(2)'s behavior requirement that "an instance of -- new will always exist, even if the system should crash in the middle of -- the operation." Although there's still a risk here if the crash occurs -- in the middle of the syncDirectory_lckd operation below (we're not -- journaled), the content maps for the parent directories are updated -- completely before any existing files/directories are removed. -- -- The thinking is as follows: if we crash immediately before the newName -> -- oldDE sync'ing is initiated, 'new' is still valid and refers to the old -- file/dir. If we crash immediately after the newName -> oldDE sync'ing, -- 'new' is valid and since the old file/dir won't be a referent of any -- content maps, fsck should be able to identify its resources as available. -- -- Finally, when 'new' is an existing empty directory that we'll replace -- with 'old', it's important that we hold its dh lock for the duration of -- the content map updates so that it doesn't become non-empty underneath -- us. case mnewDE of Nothing -> updateContentMaps Just newDE -> case deType newDE of RegularFile -> updateContentMaps >> removeFile Nothing (deInode newDE) Directory -> do -- New is a directory: ensure that it's empty before updating the -- parent's content map hbracket (openDirectory $ deInode newDE) closeDirectory $ \ndh -> do withDHLock ndh $ do -- begin dirhandle critical section isEmpty <- M.null `fmap` readRef (dhContents ndh) unless isEmpty $ HE_DirectoryNotEmpty `annErrno` eNOTEMPTY updateContentMaps -- end dirhandle critical section -- NB: We remove the replaced new directory's inode outside of its -- locked DH context or we'll deadlock when removeDirectory -- acquires. The unlocked window should be safe here, and it lets -- us avoid writing "removeDirectory_dhlckd". removeDirectory Nothing (deInode newDE) _ -> throwError $ HE_InternalError "rename target type is unsupported" -- End critical section over old and new parent directory handles where [oldName, newName] = map takeFileName [oldFP, newFP] [oldPP, newPP] = map takeDirectory [oldFP, newFP] -- withDirResources f = -- bracket & lock the old and new parent directories, being careful not to -- double-lock when they're the same. withDir' openDir' oldPP $ \opdh -> withDir' openDir' newPP $ \npdh -> (if oldPP == newPP then withDHLock opdh else withDHLock opdh . withDHLock npdh ) $ f opdh npdh -- openDir' dp = openDir dp `catchError` \e -> case e of -- [ENOTDIR]: A component of path prefix is not a directory HE_UnexpectedFileType{} -> e `annErrno` eNOTDIR -- [ENOENT] A component of path does not exist HE_PathComponentNotFound{} -> e `annErrno` eNOENT _ -> throwError e -- handleErrors oldDE mnewDE = do -- [EINVAL]: Old is a parent directory of new when (deType oldDE == Directory && oldFP `isParentOf` newFP) $ HE_RenameFailed `annErrno` eINVAL case mnewDE of Nothing -> return () Just newDE -> do -- [EISDIR]: new is a directory, but old is not a directory. when (nft == Directory && oft /= Directory) $ HE_RenameFailed `annErrno` eISDIR -- [ENOTDIR]: old is a directory, but new is not a directory. when (oft == Directory && nft /= Directory) $ HE_RenameFailed `annErrno` eNOTDIR where nft = deType newDE oft = deType oldDE -- p1 `isParentOf` p2 = length l1 < length l2 && and (zipWith (==) l1 l2) where l1 = splitDirectories p1 l2 = splitDirectories p2 -------------------------------------------------------------------------------- -- Access control chmod :: (HalfsCapable b t r l m) => FilePath -> FileMode -> HalfsM b r l m () chmod fp mode = do -- TODO: Check perms modifyInode fp $ \nd -> nd{ inoMode = mode } chown :: (HalfsCapable b t r l m) => FilePath -> Maybe UserID -- ^ Nothing indicates no change to user -> Maybe GroupID -- ^ Nothing indicates no change to group -> HalfsM b r l m () chown fp musr mgrp = do -- TODO: Check perms modifyInode fp $ \nd -> nd{ inoUser = maybe (inoUser nd) id musr , inoGroup = maybe (inoGroup nd) id mgrp } access :: (HalfsCapable b t r l m) => FilePath -> [AccessRight] -> HalfsM b r l m () access = undefined -------------------------------------------------------------------------------- -- Link manipulation -- | A POSIX link(2)-like operation: makes a hard file link. mklink :: (HalfsCapable b t r l m) => FilePath -> FilePath -> HalfsM b r l m () mklink path1 {-src-} path2 {-dst-} = do {- Currently status of unsupported POSIX error behaviors: TODO ---- [EACCES] A component of either path prefix denies search permission. [EACCES] The requested link requires writing in a directory with a mode that denies write permission. [EACCES] The current process cannot access the existing file. [EIO] An I/O error occurs while reading from or writing to the file system to make the directory entry. [ELOOP] Too many symbolic links are encountered in translating one of the pathnames. This is taken to be indicative of a looping symbolic link. DEFERRED -------- [EROFS] The requested link requires writing in a directory on a read-only file system. [EXDEV] The link named by path2 and the file named by path1 are on different file systems. NOT APPLICABLE (but may be reconsidered later) ---------------------------------------------- [EFAULT] One of the pathnames specified is outside the process's allocated address space. [EDQUOT] The directory in which the entry for the new link is being placed cannot be extended because the user's quota of disk blocks on the file system containing the directory has been exhausted. [EMLINK] The file already has {LINK_MAX} links. [ENAMETOOLONG] A component of a pathname exceeds {NAME_MAX} characters, or an entire path name exceeded {PATH_MAX} characters. -} hbracket openSrcFile closeFile $ \p1fh -> do hbracket openDstDir closeDir $ \p2dh -> do withLock (fhLock p1fh) $ do srcINR <- getFHINR_lckd p1fh addLink p2dh srcINR incLinkCount srcINR where addLink p2dh inr = do let fname = takeFileName path2 linkPerms = FileMode [Read,Write] [Read] [Read] -- TODO: Obtain the proper permissions for the link usr <- getUser grp <- getGroup withDHLock p2dh $ do addDirEnt_lckd p2dh fname inr usr grp linkPerms RegularFile `catchError` \e -> do case e of -- [EEXIST]: The link named by path2 already exists. HE_ObjectExists{} -> e `annErrno` eEXIST _ -> throwError e -- Manual directory sync here in order to catch and wrap errors syncDirectory_lckd p2dh `catchError` \e -> do rmDirEnt_lckd p2dh fname case e of -- [ENOSPC]: The directory in which the entry for the new link is -- being placed cannot be extended because there is no space left -- on the file system containing the directory. HE_AllocFailed{} -> e `annErrno` eNOSPC _ -> throwError e -- openDstDir = openDir (takeDirectory path2) `catchError` \e -> case e of -- [ENOTDIR]: A component of path2's pfx is not a directory HE_UnexpectedFileType{} -> e `annErrno` eNOTDIR -- [ENOENT] A component of path2's pfx does not exist HE_PathComponentNotFound{} -> e `annErrno` eNOENT _ -> throwError e -- openSrcFile = openFile path1 fofReadOnly `catchError` \e -> case e of -- [EPERM]: The file named by path1 is a directory HE_UnexpectedFileType Directory _ -> e `annErrno` ePERM -- [ENOTDIR]: A component of path1's pfx is not a directory HE_UnexpectedFileType _ _ -> e `annErrno` eNOTDIR -- [ENOENT] A component of path1's pfx does not exist HE_PathComponentNotFound _ -> e `annErrno` eNOENT -- [ENOENT] The file named by path1 does not exist HE_FileNotFound -> e `annErrno` eNOENT _ -> throwError e rmlink :: (HalfsCapable b t r l m) => FilePath -> HalfsM b r l m () rmlink fp = removeFile (Just $ takeFileName fp) =<< fst `fmap` absPathIR fp RegularFile createSymLink :: (HalfsCapable b t r l m) => FilePath -> FilePath -> HalfsM b r l m () createSymLink = undefined readSymLink :: (HalfsCapable b t r l m) => FilePath -> HalfsM b r l m FilePath readSymLink = undefined -------------------------------------------------------------------------------- -- Filesystem stats fstat :: (HalfsCapable b t r l m) => FilePath -> HalfsM b r l m (FileStat t) fstat fp = fileStat =<< fst `fmap` absPathIR fp AnyFileType fsstat :: (HalfsCapable b t r l m) => HalfsM b r l m FileSystemStats fsstat = do dev <- hasks hsBlockDev numNodesRsc <- hasks hsNumFileNodes bm <- hasks hsBlockMap fileCnt <- fromIntegral `fmap` withLockedRscRef numNodesRsc readRef freeCnt <- fromIntegral `fmap` numFreeBlocks bm return FSS { fssBlockSize = fromIntegral $ bdBlockSize dev , fssBlockCount = fromIntegral $ bdNumBlocks dev , fssBlocksFree = freeCnt , fssBlocksAvailable = freeCnt -- TODO: blocks avail to non-root , fssFileCount = fileCnt , fssFilesFree = 0 -- TODO: need to supply free inode count } -------------------------------------------------------------------------------- -- Utility functions & consts newHalfsState :: HalfsCapable b t r l m => BlockDevice m -> UserID -> GroupID -> Maybe (String -> m ()) -> SuperBlock -> BlockMap b r l -> HalfsM b r l m (HalfsState b r l m) newHalfsState dev usr grp lgr sb bm = HalfsState dev usr grp lgr `fmap` computeSizes (bdBlockSize dev) -- memoized since it won't change `ap` return bm -- blockmap `ap` newRef sb -- superblock `ap` newLock -- filesystem lock `ap` newLockedRscRef 0 -- Locked file node count `ap` newLockedRscRef M.empty -- Locked map: inr -> DH `ap` newLockedRscRef M.empty -- Locked map: inr -> (l, refcnt) `ap` newLockedRscRef M.empty -- Locked map: inr -> (FH, opencnt) -- | Atomic inode modification wrapper modifyInode :: HalfsCapable b t r l m => FilePath -> (Inode t -> Inode t) -> HalfsM b r l m () modifyInode fp f = withFile fp (fofReadWrite True) $ \fh -> withLock (fhLock fh) $ getFHINR_lckd fh >>= flip atomicModifyInode (return . f) -- | Find the InodeRef corresponding to the given path. On error, raises -- exceptions HE_PathComponentNotFound, HE_AbsolutePathExpected, or -- HE_UnexpectedFileType. absPathIR :: HalfsCapable b t r l m => FilePath -> FileType -> HalfsM b r l m (InodeRef, FileType) absPathIR fp ftype = do if isAbsolute fp then do sbRef <- hasks hsSuperBlock rdirIR <- rootDir `fmap` readRef sbRef mir <- find rdirIR ftype (drop 1 $ splitDirectories fp) case mir of DF_NotFound -> throwError $ HE_PathComponentNotFound fp DF_WrongFileType ft -> throwError $ HE_UnexpectedFileType ft fp DF_Found (ir, ft) -> return (ir, ft) else throwError HE_AbsolutePathExpected -- | Bracketed directory open withDir :: HalfsCapable b t r l m => FilePath -> (DirHandle r l -> HalfsM b r l m a) -> HalfsM b r l m a withDir = withDir' openDir -- | Bracketed directory open, parameterized by a function for opening a dir withDir' :: HalfsCapable b t r l m => (FilePath -> HalfsM b r l m (DirHandle r l)) -> FilePath -> (DirHandle r l -> HalfsM b r l m a) -> HalfsM b r l m a withDir' openF = (`hbracket` closeDir) . openF withFile :: (HalfsCapable b t r l m) => FilePath -> FileOpenFlags -> (FileHandle r l -> HalfsM b r l m a) -> HalfsM b r l m a withFile fp oflags = hbracket (openFile fp oflags) closeFile writeSB :: (HalfsCapable b t r l m) => BlockDevice m -> SuperBlock -> m SuperBlock writeSB dev sb = do let sbdata = encode sb assert (BS.length sbdata <= fromIntegral (bdBlockSize dev)) $ return () bdWriteBlock dev 0 sbdata bdFlush dev return sb getUser :: HalfsCapable b t r l m => HalfsM b r l m UserID getUser = hasks hsUserID getGroup :: HalfsCapable b t r l m => HalfsM b r l m GroupID getGroup = hasks hsGroupID