Permalink
Browse files

Initial commit, not working yet

  • Loading branch information...
0 parents commit c75c648d7b1f6fa9944c64180f80382962b7ca60 hirschenberger committed Oct 11, 2012
Showing with 885 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +675 −0 LICENSE
  3. +62 −0 ScratchFs.cabal
  4. +137 −0 ScratchFs.hs
  5. +2 −0 Setup.hs
  6. +8 −0 scratchfs.sublime-project
@@ -0,0 +1 @@
+dist/
675 LICENSE

Large diffs are not rendered by default.

Oops, something went wrong.
@@ -0,0 +1,62 @@
+-- Initial ScratchFs.cabal generated by cabal init. For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+-- The name of the package.
+name: ScratchFs
+
+-- The package version. See the Haskell package versioning policy (PVP)
+-- for standards guiding when and how versions should be incremented.
+-- http://www.haskell.org/haskellwiki/Package_versioning_policy
+-- PVP summary: +-+------- breaking API changes
+-- | | +----- non-breaking API additions
+-- | | | +--- code changes with no API change
+version: 0.1.0.0
+
+-- A short (one-line) description of the package.
+synopsis: Size limited temp filesystem based on fuse
+
+-- A longer description of the package.
+-- description:
+
+-- The license under which the package is released.
+license: GPL-3
+
+-- The file containing the license text.
+license-file: LICENSE
+
+-- The package author(s).
+author: Falco Hirschenberger
+
+-- An email address to which users can send suggestions, bug reports, and
+-- patches.
+maintainer: hirsch@bigfoot.de
+
+-- A copyright notice.
+-- copyright:
+
+category: System
+
+build-type: Simple
+
+-- Constraint on the version of Cabal needed to build this package.
+cabal-version: >=1.8
+
+
+executable ScratchFs
+ -- .hs or .lhs file containing the Main module.
+ main-is: ScratchFs.hs
+
+ -- Modules included in this executable, other than Main.
+ -- other-modules:
+
+ ghc-options: -O2 -threaded
+
+ -- Other library packages from which modules are imported.
+ build-depends: base ==4.5.*,
+ HFuse >=0.2.4,
+ hsyslog >= 1.4,
+ unix >= 2.5,
+ directory >= 1.1,
+ bytestring >= 0.9,
+ filepath >= 1.2
+
@@ -0,0 +1,137 @@
+module Main where
+
+import Control.Exception
+import Control.Monad
+import System.Directory (getDirectoryContents)
+import System.Fuse
+import System.IO
+import System.Posix
+import System.Posix.Syslog
+import System.Environment
+import System.FilePath.Posix ((</>))
+import qualified Data.ByteString.Char8 as B
+
+
+
+main:: IO ()
+main = withSyslog "ScratchFS" [PID, PERROR] USER $ do
+ let rootDir = "/tmp/mnt"
+ syslog Debug ("Starting ScratchFS on" ++ show rootDir)
+ fuseMain (scratchOps rootDir) exceptionHandler
+
+exceptionHandler:: SomeException -> IO Errno
+exceptionHandler e = syslog Error ("Exception: " ++ show e) >> defaultExceptionHandler e
+
+scratchOps:: FilePath -> FuseOperations Fd
+scratchOps root = defaultFuseOps { fuseGetFileStat = scratchGetFileStat root,
+ fuseCreateDirectory = scratchCreateDirectory root,
+ fuseRemoveDirectory = scratchRemoveDirectory root ,
+ fuseOpenDirectory = scratchOpenDirectory root,
+ fuseReadDirectory = scratchReadDirectory root,
+ fuseRename = scratchRename,
+ fuseSetFileMode = scratchSetFileMode,
+ fuseSetOwnerAndGroup = scratchSetOwnerAndGroup,
+ fuseSetFileSize = scratchSetFileSize,
+ fuseSetFileTimes = scratchSetFileTimes,
+ fuseOpen = scratchOpen root,
+ fuseWrite = scratchWrite root,
+ fuseRead = scratchRead root,
+ fuseGetFileSystemStats = scratchGetFileSystemStats,
+ fuseFlush = scratchFlush,
+ fuseRelease = scratchRelease,
+ fuseSynchronizeFile = scratchSynchronizeFile
+ }
+
+
+fileStatusToEntryType :: FileStatus -> EntryType
+fileStatusToEntryType status
+ | isSymbolicLink status = SymbolicLink
+ | isNamedPipe status = NamedPipe
+ | isCharacterDevice status = CharacterSpecial
+ | isDirectory status = Directory
+ | isBlockDevice status = BlockSpecial
+ | isRegularFile status = RegularFile
+ | isSocket status = Socket
+ | otherwise = Unknown
+
+fileStatusToFileStat :: FileStatus -> FileStat
+fileStatusToFileStat status =
+ FileStat { statEntryType = fileStatusToEntryType status
+ , statFileMode = fileMode status
+ , statLinkCount = linkCount status
+ , statFileOwner = fileOwner status
+ , statFileGroup = fileGroup status
+ , statSpecialDeviceID = specialDeviceID status
+ , statFileSize = fileSize status
+ -- fixme: 1024 is not always the size of a block
+ , statBlocks = fromIntegral (fileSize status `div` 1024)
+ , statAccessTime = accessTime status
+ , statModificationTime = modificationTime status
+ , statStatusChangeTime = statusChangeTime status
+ }
+
+scratchGetFileStat:: FilePath -> FilePath -> IO (Either Errno FileStat)
+scratchGetFileStat r s = do
+ stat <- getFileStatus (r </> s)
+ return $ Right $ fileStatusToFileStat stat
+
+
+scratchCreateDirectory:: FilePath -> FilePath -> FileMode -> IO Errno
+scratchCreateDirectory r p m = createDirectory (r </> p) m >> return eOK
+
+scratchRemoveDirectory:: FilePath -> FilePath -> IO Errno
+scratchRemoveDirectory r p = removeDirectory (r </> p) >> return eOK
+
+scratchOpenDirectory:: FilePath -> FilePath -> IO Errno
+scratchOpenDirectory r p = openDirStream (r </> p) >>= closeDirStream >> return eOK
+
+scratchReadDirectory :: FilePath -> FilePath -> IO (Either Errno [(FilePath, FileStat)])
+scratchReadDirectory r p = getDirectoryContents (r </> p) >>= mapM pairType >>= return . Right
+ where pairType name = do
+ status <- getSymbolicLinkStatus ((r </> p) ++ "/" ++ name)
+ return (name, fileStatusToFileStat status)
+
+scratchRename :: FilePath -> FilePath -> IO Errno
+scratchRename src dest = rename src dest >> return eOK
+
+scratchSetFileMode :: FilePath -> FileMode -> IO Errno
+scratchSetFileMode path mode = setFileMode path mode >> return eOK
+
+scratchSetOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO Errno
+scratchSetOwnerAndGroup path uid gid = setOwnerAndGroup path uid gid >> return eOK
+
+scratchSetFileSize :: FilePath -> FileOffset -> IO Errno
+scratchSetFileSize path off = setFileSize path off >> return eOK
+
+scratchSetFileTimes :: FilePath -> EpochTime -> EpochTime -> IO Errno
+scratchSetFileTimes path aTime mTime = setFileTimes path aTime mTime >> return eOK
+
+scratchOpen :: FilePath -> FilePath -> OpenMode -> OpenFileFlags -> IO (Either Errno Fd)
+scratchOpen root path mode flags = openFd (root </> path) mode Nothing flags >>= return.Right
+
+scratchRead :: FilePath -> FilePath -> Fd -> ByteCount -> FileOffset -> IO (Either Errno B.ByteString)
+scratchRead root path fd count off = do
+ newOff <- fdSeek fd AbsoluteSeek off
+ if off /= newOff
+ then return (Left eINVAL)
+ else do (content, bytesRead) <- fdRead fd count
+ return (Right $ B.pack content)
+
+scratchWrite :: FilePath -> FilePath -> Fd -> B.ByteString -> FileOffset -> IO (Either Errno ByteCount)
+scratchWrite root path fd buf off = do
+ newOff <- fdSeek fd AbsoluteSeek off
+ if off /= newOff
+ then return (Left eINVAL)
+ else fdWrite fd (B.unpack buf) >>= return.Right
+
+scratchGetFileSystemStats :: String -> IO (Either Errno FileSystemStats)
+scratchGetFileSystemStats _ = return (Left eOK)
+
+scratchFlush :: FilePath -> Fd -> IO Errno
+scratchFlush _ _ = return eOK
+
+scratchRelease :: FilePath -> Fd -> IO ()
+scratchRelease _ = closeFd
+
+scratchSynchronizeFile :: FilePath -> SyncType -> IO Errno
+scratchSynchronizeFile _ _ = return eOK
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
@@ -0,0 +1,8 @@
+{
+ "folders":
+ [
+ {
+ "path": "System"
+ }
+ ]
+}

0 comments on commit c75c648

Please sign in to comment.