mirror of https://github.com/voidlizard/hbs2
Add read-only mounting of a directory by FUSE.
Vendoring hfuse with relaxed deps.
This commit is contained in:
b0oh
voidlizard
parent
d8c34e3585
commit
571690cb01
|
|
@ -48,6 +48,7 @@ outputs = { self, nixpkgs, flake-utils, ... }@inputs:
|
|||
"db-pipe"
|
||||
"fuzzy-parse"
|
||||
"suckless-conf"
|
||||
"hfuse"
|
||||
];
|
||||
|
||||
jailbreakUnbreak = pkgs: pkg:
|
||||
|
|
|
|||
|
|
@ -67,6 +67,7 @@ common shared-properties
|
|||
, directory
|
||||
, filepath
|
||||
, filepattern
|
||||
, hfuse
|
||||
, interpolatedstring-perl6
|
||||
, memory
|
||||
, microlens-platform
|
||||
|
|
@ -80,6 +81,7 @@ common shared-properties
|
|||
, timeit
|
||||
, transformers
|
||||
, typed-process
|
||||
, unix
|
||||
, unordered-containers
|
||||
, unliftio
|
||||
, zlib
|
||||
|
|
@ -91,23 +93,17 @@ library
|
|||
exposed-modules:
|
||||
HBS2.Sync.Prelude
|
||||
HBS2.Sync.State
|
||||
HBS2.Sync.Mount
|
||||
HBS2.Sync.Internal
|
||||
HBS2.Sync
|
||||
|
||||
other-modules:
|
||||
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: base, hbs2-peer, hbs2-cli
|
||||
hs-source-dirs: src
|
||||
|
||||
executable hbs2-sync
|
||||
import: shared-properties
|
||||
main-is: Main.hs
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
base, hbs2-sync, hbs2-peer
|
||||
|
||||
hs-source-dirs: app
|
||||
default-language: GHC2021
|
||||
|
|
|
|||
|
|
@ -5,5 +5,3 @@ module HBS2.Sync
|
|||
|
||||
import HBS2.Sync.Internal as Exported
|
||||
import HBS2.Sync.State as Exported
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ module HBS2.Sync.Internal
|
|||
|
||||
import HBS2.Sync.Prelude
|
||||
import HBS2.Sync.State
|
||||
import HBS2.Sync.Mount (mountPath)
|
||||
import HBS2.System.Dir
|
||||
import HBS2.Storage.Operations.ByteString
|
||||
import HBS2.Peer.RPC.API.RefChan
|
||||
|
|
@ -105,9 +106,7 @@ syncInit keys = do
|
|||
>>= orThrowUser "invalid hbs2-peer attributes"
|
||||
|
||||
peerKey <-
|
||||
[ x
|
||||
| ListVal [SymbolVal "peer-key:", SignPubKeyLike x] <- poked
|
||||
]
|
||||
[x | ListVal [SymbolVal "peer-key:", SignPubKeyLike x] <- poked]
|
||||
& headMay
|
||||
& orThrowUser "hbs2-peer key not found"
|
||||
|
||||
|
|
@ -234,6 +233,29 @@ hbs2-sync init --refchan 94GF31TtD38yWG6iZLRy1xZBb1dxcAC7BRBJTMyAq8VF
|
|||
_ -> do
|
||||
err "unknown parameters, please use `help init` command"
|
||||
|
||||
brief "mount"
|
||||
$ desc "mount"
|
||||
$ entry $ bindMatch "mount" $ nil_ $ \case
|
||||
[StringLike configPath, StringLike path] -> do
|
||||
config :: [Syntax c] <-
|
||||
try @_ @IOError (liftIO $ readFile configPath)
|
||||
<&> fromRight mempty
|
||||
<&> parseTop
|
||||
<&> either mempty (fmap fixContext)
|
||||
|
||||
void $ evalTop $ [mkList [mkSym "dir", mkStr "."]] ++ config
|
||||
|
||||
dir <- getRunDir
|
||||
env <- getRunDirEnv dir >>= orThrow DirNotSet
|
||||
refchan <-
|
||||
view dirSyncRefChan env
|
||||
& orThrowUser "refchan not found"
|
||||
|
||||
liftIO $ mountPath refchan path
|
||||
|
||||
_ ->
|
||||
err "unknown"
|
||||
|
||||
brief "deleted entries"
|
||||
$ desc "show deleted entries"
|
||||
$ entry $ bindMatch "deleted" $ nil_ $ \_ -> do
|
||||
|
|
|
|||
|
|
@ -0,0 +1,354 @@
|
|||
module HBS2.Sync.Mount
|
||||
( mountPath
|
||||
) where
|
||||
|
||||
import HBS2.Sync.Prelude hiding (SyncEnv(..))
|
||||
import HBS2.Sync.State
|
||||
|
||||
import HBS2.Actors.Peer (makeResponse, runProto)
|
||||
import HBS2.CLI.Run.MetaData (getTreeContents)
|
||||
import HBS2.KeyMan.Keys.Direct qualified as KE
|
||||
import HBS2.Net.Messaging.Unix as Unix
|
||||
import HBS2.Net.Proto.Service qualified as HBS2
|
||||
import HBS2.Net.Proto.Notify (runNotifySink, makeNotifyClient, newNotifySink, runNotifyWorkerClient)
|
||||
import HBS2.Peer.CLI.Detect (detectRPC)
|
||||
import HBS2.Peer.Notify (NotifyData(RefChanUpdated), NotifyKey(..), RefChanEvents)
|
||||
import HBS2.Peer.RPC.API.Peer qualified as Peer
|
||||
import HBS2.Peer.RPC.API.RefChan qualified as RefChan
|
||||
import HBS2.Peer.RPC.API.Storage qualified as Storage
|
||||
import HBS2.Peer.RPC.Client qualified as Client
|
||||
import HBS2.Peer.RPC.Client.StorageClient qualified as Client
|
||||
import HBS2.Peer.RPC.Client.Unix (runServiceClientMulti, Endpoint(Endpoint))
|
||||
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import Data.ByteString.Char8 qualified as BS
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import System.Fuse (FuseOperations(..))
|
||||
import System.Fuse qualified as Fuse
|
||||
import System.Posix.Files qualified as Posix
|
||||
import System.Posix.Types qualified as Posix
|
||||
import Data.Int (Int64)
|
||||
|
||||
type FuseOp a = IO (Either Fuse.Errno a)
|
||||
|
||||
type Tree = Map.Map FilePath Entry
|
||||
|
||||
data MountEnv =
|
||||
MountEnv
|
||||
{ peerAPI :: HBS2.ServiceCaller Peer.PeerAPI UNIX
|
||||
, refChanAPI :: HBS2.ServiceCaller RefChan.RefChanAPI UNIX
|
||||
, storageAPI :: HBS2.ServiceCaller Storage.StorageAPI UNIX
|
||||
, keymanClientEnv :: KeyManClientEnv
|
||||
}
|
||||
|
||||
newtype MountApp m a =
|
||||
MountApp { fromMountApp :: ReaderT MountEnv m a }
|
||||
deriving newtype ( Applicative
|
||||
, Functor
|
||||
, Monad
|
||||
, MonadUnliftIO
|
||||
, MonadIO
|
||||
, MonadReader MountEnv)
|
||||
|
||||
data State =
|
||||
State
|
||||
{ refChan :: MyRefChan
|
||||
, tree :: Tree
|
||||
}
|
||||
|
||||
instance MonadUnliftIO m => HasKeyManClient (MountApp m) where
|
||||
getKeyManClientEnv = ask <&> keymanClientEnv
|
||||
|
||||
instance MonadIO m => Client.HasClientAPI Storage.StorageAPI UNIX (MountApp m) where
|
||||
getClientAPI = ask <&> storageAPI
|
||||
|
||||
instance MonadIO m => Client.HasClientAPI RefChan.RefChanAPI UNIX (MountApp m) where
|
||||
getClientAPI = ask <&> refChanAPI
|
||||
|
||||
instance MonadIO m => Client.HasClientAPI Peer.PeerAPI UNIX (MountApp m) where
|
||||
getClientAPI = ask <&> peerAPI
|
||||
|
||||
instance MonadIO m => HasStorage (MountApp m) where
|
||||
getStorage = do
|
||||
api <- Client.getClientAPI @Storage.StorageAPI @UNIX
|
||||
pure $ AnyStorage (Client.StorageClient api)
|
||||
|
||||
withEnv :: MonadUnliftIO m => MountApp IO a -> m a
|
||||
withEnv action = do
|
||||
soname <- detectRPC >>= orThrowUser "could not detect RPC"
|
||||
flip runContT pure do
|
||||
client <- newMessagingUnix False 1.0 soname
|
||||
void $ ContT $ withAsync $ runMessagingUnix client
|
||||
|
||||
peerAPI <- HBS2.makeServiceCaller @Peer.PeerAPI (fromString soname)
|
||||
refChanAPI <- HBS2.makeServiceCaller @RefChan.RefChanAPI (fromString soname)
|
||||
storageAPI <- HBS2.makeServiceCaller @Storage.StorageAPI (fromString soname)
|
||||
let endpoints = [ Endpoint @UNIX peerAPI
|
||||
, Endpoint @UNIX refChanAPI
|
||||
, Endpoint @UNIX storageAPI
|
||||
]
|
||||
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
|
||||
|
||||
keymanClientEnv <- liftIO $ KE.newKeymanClientEnv
|
||||
|
||||
let env = MountEnv{..}
|
||||
liftIO $ runReaderT (fromMountApp action) env
|
||||
|
||||
rootPath :: FilePath
|
||||
rootPath = "/"
|
||||
|
||||
buildTree :: [Entry] -> Map.Map FilePath Entry
|
||||
buildTree entries =
|
||||
let
|
||||
addDirs entry =
|
||||
if isFile entry then
|
||||
entriesFromFile (getEntryHash entry) (getEntryTimestamp entry) (entryPath entry)
|
||||
else
|
||||
Map.empty
|
||||
|
||||
prependSlash (DirEntry desc path) acc =
|
||||
let
|
||||
newPath = "/" <> path
|
||||
in
|
||||
Map.insert newPath (DirEntry desc newPath) acc
|
||||
in
|
||||
entries
|
||||
& List.sortOn getEntryTimestamp
|
||||
& foldl (\acc entry -> Map.insert (entryPath entry) entry acc) Map.empty
|
||||
& foldr (\entry acc -> Map.unionWith merge (addDirs entry) acc) Map.empty
|
||||
& Map.foldr prependSlash Map.empty
|
||||
|
||||
dirStat :: Fuse.FuseContext -> Fuse.FileStat
|
||||
dirStat ctx =
|
||||
let
|
||||
statEntryType = Fuse.Directory
|
||||
statFileMode =
|
||||
foldr1 Posix.unionFileModes
|
||||
[ Posix.ownerReadMode
|
||||
, Posix.ownerExecuteMode
|
||||
, Posix.groupReadMode
|
||||
, Posix.groupExecuteMode
|
||||
, Posix.otherReadMode
|
||||
, Posix.otherExecuteMode
|
||||
]
|
||||
statLinkCount = 2
|
||||
statFileOwner = Fuse.fuseCtxUserID ctx
|
||||
statFileGroup = Fuse.fuseCtxGroupID ctx
|
||||
statSpecialDeviceID = 0
|
||||
statFileSize = 4096
|
||||
statBlocks = 1
|
||||
statAccessTime = 0
|
||||
statModificationTime = 0
|
||||
statStatusChangeTime = 0
|
||||
in
|
||||
Fuse.FileStat { .. }
|
||||
|
||||
fileStat :: Int64 -> Fuse.FuseContext -> Fuse.FileStat
|
||||
fileStat size ctx =
|
||||
let
|
||||
statEntryType = Fuse.RegularFile
|
||||
statFileMode =
|
||||
foldr1 Posix.unionFileModes
|
||||
[ Posix.ownerReadMode
|
||||
, Posix.groupReadMode
|
||||
, Posix.otherReadMode
|
||||
]
|
||||
statLinkCount = 1
|
||||
statFileOwner = Fuse.fuseCtxUserID ctx
|
||||
statFileGroup = Fuse.fuseCtxGroupID ctx
|
||||
statSpecialDeviceID = 0
|
||||
statFileSize = fromIntegral size
|
||||
statBlocks = 1
|
||||
statAccessTime = 0
|
||||
statModificationTime = 0
|
||||
statStatusChangeTime = 0
|
||||
in
|
||||
Fuse.FileStat { .. }
|
||||
|
||||
onInit :: IORef (Maybe State) -> MyRefChan -> IO ()
|
||||
onInit ref refChan = do
|
||||
rpcSockPath' <- detectRPC >>= orThrowUser "could not detect RPC"
|
||||
refChanNotifyClient <- newMessagingUnix False 1.0 rpcSockPath'
|
||||
sink <- newNotifySink
|
||||
|
||||
async1 <- async $ runMessagingUnix refChanNotifyClient
|
||||
|
||||
async2 <- async $ flip runReaderT refChanNotifyClient $ do
|
||||
runProto @UNIX
|
||||
[ makeResponse (makeNotifyClient @(RefChanEvents L4Proto) sink)
|
||||
]
|
||||
|
||||
async3 <- async $ runNotifySink sink (RefChanNotifyKey refChan) $ \case
|
||||
RefChanUpdated _ _ -> do
|
||||
accepted <- withEnv $ getAccepted refChan
|
||||
let tree = buildTree accepted
|
||||
writeIORef ref $ Just State{..}
|
||||
|
||||
_ -> do
|
||||
return ()
|
||||
|
||||
async4 <- async $ flip runReaderT refChanNotifyClient $ do
|
||||
runNotifyWorkerClient sink
|
||||
|
||||
accepted <- withEnv $ getAccepted refChan
|
||||
let tree = buildTree accepted
|
||||
writeIORef ref $ Just State{..}
|
||||
|
||||
return ()
|
||||
|
||||
onGetFileStat :: IORef (Maybe State) -> FilePath -> FuseOp Fuse.FileStat
|
||||
onGetFileStat ref path
|
||||
| path == rootPath =
|
||||
Right . dirStat <$> Fuse.getFuseContext
|
||||
|
||||
| otherwise = do
|
||||
Just State{..} <- readIORef ref
|
||||
case Map.lookup path tree of
|
||||
Just (DirEntry (EntryDesc { entryType = Dir }) _) ->
|
||||
Right . dirStat <$> Fuse.getFuseContext
|
||||
|
||||
Just entry@(DirEntry (EntryDesc { entryType = File }) _) ->
|
||||
case getEntryHash entry of
|
||||
Just hash -> do
|
||||
size <- withEnv do
|
||||
storage <- getStorage
|
||||
eitherContent <- runExceptT (getTreeContents storage hash)
|
||||
case eitherContent of
|
||||
Right content ->
|
||||
return $ (LBS.length content)
|
||||
|
||||
Right . fileStat size <$> Fuse.getFuseContext
|
||||
|
||||
_ ->
|
||||
return $ Left Fuse.eNOENT
|
||||
|
||||
_ ->
|
||||
return $ Left Fuse.eNOENT
|
||||
|
||||
onOpen :: IORef (Maybe State) -> FilePath -> Fuse.OpenMode -> Fuse.OpenFileFlags -> FuseOp ()
|
||||
onOpen ref path mode _flags = do
|
||||
Just State{..} <- readIORef ref
|
||||
case Map.lookup path tree of
|
||||
Just (DirEntry (EntryDesc { entryType = File }) _) ->
|
||||
case mode of
|
||||
Fuse.ReadOnly ->
|
||||
return $ Right ()
|
||||
|
||||
_ ->
|
||||
return $ Left Fuse.eACCES
|
||||
|
||||
_ ->
|
||||
return $ Left Fuse.eNOENT
|
||||
|
||||
|
||||
onRead :: IORef (Maybe State) -> FilePath -> () -> Posix.ByteCount -> Posix.FileOffset -> FuseOp BS.ByteString
|
||||
onRead ref path _ byteCount offset = do
|
||||
Just State{..} <- readIORef ref
|
||||
withEnv do
|
||||
case Map.lookup path tree of
|
||||
Just entry@(DirEntry (EntryDesc { entryType = File }) _) ->
|
||||
case getEntryHash entry of
|
||||
Just hash -> do
|
||||
storage <- getStorage
|
||||
eitherContent <- runExceptT (getTreeContents storage hash)
|
||||
case eitherContent of
|
||||
Right content ->
|
||||
content
|
||||
& LBS.drop (fromIntegral offset)
|
||||
& LBS.take (fromIntegral byteCount)
|
||||
& LBS.toStrict
|
||||
& Right
|
||||
& return
|
||||
|
||||
_ ->
|
||||
return $ Left Fuse.eNOENT
|
||||
|
||||
_ ->
|
||||
return $ Left Fuse.eNOENT
|
||||
|
||||
_ ->
|
||||
return $ Left Fuse.eNOENT
|
||||
|
||||
|
||||
onOpenDirectory :: IORef (Maybe State) -> String -> IO Fuse.Errno
|
||||
onOpenDirectory ref path
|
||||
| path == rootPath =
|
||||
return Fuse.eOK
|
||||
|
||||
| otherwise = do
|
||||
Just State{..} <- readIORef ref
|
||||
case Map.lookup path tree of
|
||||
Just (DirEntry (EntryDesc { entryType = Dir }) _) ->
|
||||
return Fuse.eOK
|
||||
|
||||
_ ->
|
||||
return Fuse.eNOENT
|
||||
|
||||
stat :: Fuse.FuseContext -> Map.Map FilePath Entry -> FilePath -> FilePath -> [(FilePath, Fuse.FileStat)]
|
||||
stat context tree prefix path =
|
||||
case Map.lookup (prefix <> path) tree of
|
||||
Just (DirEntry (EntryDesc { entryType = Dir }) _) ->
|
||||
[(path, dirStat context)]
|
||||
|
||||
Just (DirEntry (EntryDesc { entryType = File }) _) ->
|
||||
[(path, fileStat 4096 context)]
|
||||
|
||||
_ ->
|
||||
[]
|
||||
|
||||
makeEntries :: Fuse.FuseContext -> Map.Map FilePath Entry -> FilePath -> [(FilePath, Fuse.FileStat)]
|
||||
makeEntries context tree prefix =
|
||||
Map.keys tree
|
||||
& filter (List.isPrefixOf prefix)
|
||||
& map (\path -> takeWhile (/= '/') $ fromMaybe path $ List.stripPrefix prefix path)
|
||||
& List.nub
|
||||
& concatMap (stat context tree prefix)
|
||||
|
||||
onReadDirectory :: IORef (Maybe State) -> FilePath -> FuseOp [(FilePath, Fuse.FileStat)]
|
||||
onReadDirectory ref path =
|
||||
let
|
||||
prefix =
|
||||
if path == rootPath then
|
||||
rootPath
|
||||
else
|
||||
path <> "/"
|
||||
in do
|
||||
Just State{..} <- readIORef ref
|
||||
context <- Fuse.getFuseContext
|
||||
let entries = makeEntries context tree prefix
|
||||
|
||||
return $ Right $
|
||||
[ (".", dirStat context)
|
||||
, ("..", dirStat context)
|
||||
] <> entries
|
||||
|
||||
onGetFileSystemStats :: String -> FuseOp Fuse.FileSystemStats
|
||||
onGetFileSystemStats _ =
|
||||
return $ Right $ Fuse.FileSystemStats
|
||||
{ fsStatBlockSize = 512
|
||||
, fsStatBlockCount = 1
|
||||
, fsStatBlocksFree = 1
|
||||
, fsStatBlocksAvailable = 1
|
||||
, fsStatFileCount = 5
|
||||
, fsStatFilesFree = 10
|
||||
, fsStatMaxNameLength = 255
|
||||
}
|
||||
|
||||
operations :: IORef (Maybe State) -> MyRefChan -> Fuse.FuseOperations ()
|
||||
operations ref refChan =
|
||||
Fuse.defaultFuseOps
|
||||
{ fuseGetFileStat = onGetFileStat ref
|
||||
, fuseGetFileSystemStats = onGetFileSystemStats
|
||||
, fuseInit = onInit ref refChan
|
||||
, fuseOpen = onOpen ref
|
||||
, fuseOpenDirectory = onOpenDirectory ref
|
||||
, fuseRead = onRead ref
|
||||
, fuseReadDirectory = onReadDirectory ref
|
||||
}
|
||||
|
||||
mountPath :: MyRefChan -> FilePath -> IO ()
|
||||
mountPath refChan path = do
|
||||
ref <- newIORef Nothing
|
||||
Fuse.fuseRun "sync mount" [path] (operations ref refChan) Fuse.defaultExceptionHandler
|
||||
|
|
@ -157,6 +157,57 @@ entriesFromFile h ts fn0 = do
|
|||
dirEntry p = DirEntry (EntryDesc Dir ts Nothing) p
|
||||
fileEntry p = DirEntry (EntryDesc File ts h) p
|
||||
|
||||
getEntriesFromRefchan ::
|
||||
forall m . ( MonadUnliftIO m, HasStorage m, HasClientAPI RefChanAPI UNIX m )
|
||||
=> KeyManClientEnv
|
||||
-> AnyStorage
|
||||
-> MyRefChan
|
||||
-> m [Entry]
|
||||
getEntriesFromRefchan keymanEnv storage refchan = do
|
||||
outq <- newTQueueIO
|
||||
tss <- newTVarIO mempty
|
||||
|
||||
let findKey = lift . lift . withKeymanClientRO keymanEnv . findMatchedGroupKeySecret storage
|
||||
|
||||
walkRefChanTx @UNIX (const (pure True)) refchan $ \_ unpacked -> do
|
||||
case unpacked of
|
||||
A (AcceptTran acceptTime _ what) -> do
|
||||
for_ acceptTime $ \timestamp -> do
|
||||
atomically $ modifyTVar tss (HM.insertWith max what (coerce @_ @Word64 timestamp))
|
||||
|
||||
P proposeHash (ProposeTran _ box) -> void $ runMaybeT do
|
||||
(_, unboxed) <- unboxSignedBox0 box & toMPlus
|
||||
AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict unboxed)
|
||||
& toMPlus . either (const Nothing) Just
|
||||
|
||||
meta <- runExceptT (extractMetaData @'HBS2Basic findKey storage href) >>= toMPlus
|
||||
atomically $ writeTQueue outq (proposeHash, href, meta)
|
||||
|
||||
trees <- atomically (flushTQueue outq)
|
||||
tsmap <- readTVarIO tss
|
||||
|
||||
pure $ concatMap (makeEntry tsmap) trees
|
||||
|
||||
where
|
||||
makeEntry tsmap (hash, tree, meta) = do
|
||||
let what = parseTop meta & fromRight mempty
|
||||
let location = headDef "" [ l | ListVal [StringLike "location:", StringLike l] <- what ]
|
||||
|
||||
let maybeFileName = headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ]
|
||||
let maybeTimestamp = HM.lookup hash tsmap
|
||||
case (maybeFileName, maybeTimestamp) of
|
||||
(Just fileName, Just timestamp) -> do
|
||||
let isTombSet = or [ True | TombLikeOpt <- what ]
|
||||
let fullPath = location </> fileName
|
||||
|
||||
if isTombSet then
|
||||
[makeTomb timestamp fullPath (Just tree)]
|
||||
else
|
||||
[DirEntry (EntryDesc File timestamp (Just tree)) fullPath]
|
||||
|
||||
_ ->
|
||||
[]
|
||||
|
||||
-- NOTE: getStateFromDir
|
||||
-- что бы устранить противоречия в "удалённом" стейте и
|
||||
-- локальном, мы должны о них узнать
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
dist
|
||||
cabal-dev
|
||||
*.o
|
||||
*.hi
|
||||
*.chi
|
||||
*.chs.h
|
||||
.virtualenv
|
||||
.hsenv
|
||||
.cabal-sandbox/
|
||||
cabal.sandbox.config
|
||||
cabal.config
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
Changelog
|
||||
=========
|
||||
|
||||
v0.2.4.4
|
||||
--------
|
||||
|
||||
- Fixed handling of exceptions
|
||||
|
||||
v0.2.4.3
|
||||
--------
|
||||
|
||||
- Added documentation
|
||||
- Added HelloFS example
|
||||
|
||||
v0.2.4.2
|
||||
--------
|
||||
|
||||
- Updated dependencies to run on latest base
|
||||
- Updated cabal for FreeBSD support
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
* dsouza <dsouza+hfuse at bitforest.org>
|
||||
* m15k <montezf at gmail>
|
||||
* Ongy
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
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 University nor the names of its contributors
|
||||
may be used to endorse or promote products derived from this software
|
||||
without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``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 REGENTS 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.
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
# Haskell FUSE API
|
||||
|
||||
Filesystem in Userspace ("FUSE") makes it possible to implement a filesystem as a userspace program.
|
||||
|
||||
This library is the Haskell binding to this library.
|
||||
|
||||
## License
|
||||
|
||||
[BSD 3-Clause](./LICENSE)
|
||||
|
||||
## Information
|
||||
|
||||
- Programs using HFuse should be compiled with -threaded.
|
||||
- This now works for base 4.6+
|
||||
- Added build options support for FreeBSD (contribution by https://github.com/pesco)
|
||||
- MacFUSE should also work (https://github.com/mwotton/hfuse)
|
||||
- [OSXFuse](https://osxfuse.github.io/) also works (https://github.com/edyu/hfuse)
|
||||
|
||||
## Installation
|
||||
|
||||
All of the usual methods for installation will be supported.
|
||||
For Mac OS X, you must install [OSXFuse](https://osxfuse.github.io/) first.
|
||||
|
||||
**Installation via Hackage**
|
||||
|
||||
```
|
||||
cabal install hfuse
|
||||
```
|
||||
|
||||
**Installation for development**
|
||||
|
||||
Can either be handled via [Hackage](https://hackage.haskell.org/packages/search?terms=hfuse)
|
||||
|
||||
```
|
||||
cabal unpack hfuse
|
||||
cd HFuse-0.2.5.0
|
||||
cabal sandbox init
|
||||
cabal install --only-dependencies
|
||||
cabal install -fdeveloper
|
||||
```
|
||||
|
||||
Or the library can be installed via Github [repo][2]
|
||||
|
||||
```
|
||||
git clone git://github.com/m15k/hfuse
|
||||
cd hfuse
|
||||
cabal sandbox init
|
||||
cabal install --only-dependencies
|
||||
cabal install -fdeveloper
|
||||
```
|
||||
|
||||
**NOTE!**
|
||||
|
||||
* To use the sandboxes feature in Cabal your version must be higher than 1.18. *highly recommended*
|
||||
|
||||
## Development
|
||||
|
||||
To get a feel for HFuse, there are a number of example applications. They can be built by supplying the `-fdeveloper` [configuration flag][3] to Cabal.
|
||||
|
||||
> git clone https://github.com/m15k/hfuse
|
||||
|
||||
## Examples
|
||||
|
||||
[HelloFS](./examples/HelloFS.hs) is as basic as you get. Haskell version of the canonical [example](https://github.com/libfuse/libfuse/blob/master/example/hello.c) from the FUSE project. Once compiled here is how you run HelloFS.
|
||||
|
||||
```
|
||||
$ mkdir ~/fuseTest
|
||||
$ ./HelloFS ~/fuseTest
|
||||
```
|
||||
|
||||
This creates a file in the *fuseTest* directory. Now to test the application.
|
||||
|
||||
```
|
||||
$ cat ~/fuseTest/hello
|
||||
Hello World, HFuse!
|
||||
```
|
||||
|
||||
To unmount issue the following command:
|
||||
|
||||
```
|
||||
$ fusermount -u ~/fuseTest
|
||||
```
|
||||
|
||||
## Other Samples
|
||||
|
||||
There are other projects on hackage which use HFuse as a dependency. Check [these](https://packdeps.haskellers.com/reverse/HFuse) out for a possibly richer experience than what is included with the [examples](./examples) folder.
|
||||
|
||||
If you lack for inspiration the FUSE [Wiki][4] have amassed quite the list of links to downstream projects.
|
||||
|
||||
## Contributions
|
||||
|
||||
Help is always welcome. Pull requests are appreciated.
|
||||
|
||||
If you run into any problems or bugs, please report the issue on [Github][1]
|
||||
|
||||
## RoadMap
|
||||
|
||||
I would like to create the following examples:
|
||||
|
||||
- MemoryFS.hs := In-memory file system
|
||||
- VBoxFS.hs := Mount VirtualBox disks as filesystem
|
||||
- SSHFS.hs := SSH file system
|
||||
|
||||
[1]: https://github.com/m15k/google-drive-api/issues "Google-Drive-API Library Issues"
|
||||
[2]: https://github.com/m15k/google-drive-api "Google-Drive-API Library"
|
||||
[3]: https://www.haskell.org/cabal/users-guide/developing-packages.html#configurations "Cabal Configurations"
|
||||
[4]: https://github.com/libfuse/libfuse/wiki/Filesystems "Libfuse-Wiki Examples"
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
#! /usr/bin/env runhaskell
|
||||
|
||||
> import Distribution.Simple
|
||||
> main = defaultMain
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,113 @@
|
|||
module Main where
|
||||
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Foreign.C.Error
|
||||
import System.Posix.Types
|
||||
import System.Posix.Files
|
||||
import System.Posix.IO
|
||||
|
||||
import System.Fuse
|
||||
|
||||
type HT = ()
|
||||
|
||||
main :: IO ()
|
||||
main = fuseMain helloFSOps defaultExceptionHandler
|
||||
|
||||
helloFSOps :: FuseOperations HT
|
||||
helloFSOps = defaultFuseOps { fuseGetFileStat = helloGetFileStat
|
||||
, fuseOpen = helloOpen
|
||||
, fuseRead = helloRead
|
||||
, fuseOpenDirectory = helloOpenDirectory
|
||||
, fuseReadDirectory = helloReadDirectory
|
||||
, fuseGetFileSystemStats = helloGetFileSystemStats
|
||||
}
|
||||
helloString :: B.ByteString
|
||||
helloString = B.pack "Hello World, HFuse!\n"
|
||||
|
||||
helloPath :: FilePath
|
||||
helloPath = "/hello"
|
||||
dirStat ctx = 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
|
||||
}
|
||||
|
||||
fileStat ctx = FileStat { statEntryType = RegularFile
|
||||
, statFileMode = foldr1 unionFileModes
|
||||
[ ownerReadMode
|
||||
, groupReadMode
|
||||
, otherReadMode
|
||||
]
|
||||
, statLinkCount = 1
|
||||
, statFileOwner = fuseCtxUserID ctx
|
||||
, statFileGroup = fuseCtxGroupID ctx
|
||||
, statSpecialDeviceID = 0
|
||||
, statFileSize = fromIntegral $ B.length helloString
|
||||
, statBlocks = 1
|
||||
, statAccessTime = 0
|
||||
, statModificationTime = 0
|
||||
, statStatusChangeTime = 0
|
||||
}
|
||||
|
||||
helloGetFileStat :: FilePath -> IO (Either Errno FileStat)
|
||||
helloGetFileStat "/" = do
|
||||
ctx <- getFuseContext
|
||||
return $ Right $ dirStat ctx
|
||||
helloGetFileStat path | path == helloPath = do
|
||||
ctx <- getFuseContext
|
||||
return $ Right $ fileStat ctx
|
||||
helloGetFileStat _ =
|
||||
return $ Left eNOENT
|
||||
|
||||
helloOpenDirectory "/" = return eOK
|
||||
helloOpenDirectory _ = return eNOENT
|
||||
|
||||
helloReadDirectory :: FilePath -> IO (Either Errno [(FilePath, FileStat)])
|
||||
helloReadDirectory "/" = do
|
||||
ctx <- getFuseContext
|
||||
return $ Right [(".", dirStat ctx)
|
||||
,("..", dirStat ctx)
|
||||
,(helloName, fileStat ctx)
|
||||
]
|
||||
where (_:helloName) = helloPath
|
||||
helloReadDirectory _ = return (Left (eNOENT))
|
||||
|
||||
helloOpen :: FilePath -> OpenMode -> OpenFileFlags -> IO (Either Errno HT)
|
||||
helloOpen path mode flags
|
||||
| path == helloPath = case mode of
|
||||
ReadOnly -> return (Right ())
|
||||
_ -> return (Left eACCES)
|
||||
| otherwise = return (Left eNOENT)
|
||||
|
||||
|
||||
helloRead :: FilePath -> HT -> ByteCount -> FileOffset -> IO (Either Errno B.ByteString)
|
||||
helloRead path _ byteCount offset
|
||||
| path == helloPath =
|
||||
return $ Right $ B.take (fromIntegral byteCount) $ B.drop (fromIntegral offset) helloString
|
||||
| otherwise = return $ Left eNOENT
|
||||
|
||||
helloGetFileSystemStats :: String -> IO (Either Errno FileSystemStats)
|
||||
helloGetFileSystemStats str =
|
||||
return $ Right $ FileSystemStats
|
||||
{ fsStatBlockSize = 512
|
||||
, fsStatBlockCount = 1
|
||||
, fsStatBlocksFree = 1
|
||||
, fsStatBlocksAvailable = 1
|
||||
, fsStatFileCount = 5
|
||||
, fsStatFilesFree = 10
|
||||
, fsStatMaxNameLength = 255
|
||||
}
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
Name: hfuse
|
||||
Version: 0.2.5.1
|
||||
License: BSD3
|
||||
License-File: LICENSE
|
||||
Author: Jeremy Bobbio
|
||||
Maintainer: Montez Fitzpatrick <montezf@gmail.com>
|
||||
Synopsis: HFuse is a binding for the Linux FUSE library.
|
||||
Description: Bindings for the FUSE library, compatible with Linux, OSXFUSE and FreeBSD.
|
||||
Homepage: https://github.com/m15k/hfuse
|
||||
Category: System
|
||||
Stability: Experimental
|
||||
Cabal-Version: >= 1.10
|
||||
Build-Type: Simple
|
||||
Extra-source-files:
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
|
||||
flag developer
|
||||
default: False
|
||||
|
||||
Library
|
||||
Build-Depends: base >= 4 && < 5, unix, bytestring
|
||||
Exposed-Modules: System.Fuse
|
||||
Default-Extensions: ForeignFunctionInterface ScopedTypeVariables EmptyDataDecls
|
||||
Includes: dirent.h, fuse.h, fcntl.h
|
||||
Include-Dirs: /usr/include, /usr/local/include, .
|
||||
if os(darwin)
|
||||
CC-Options: "-DMACFUSE"
|
||||
CC-Options: "-DFUSE_USE_VERSION=26"
|
||||
Include-Dirs: /usr/local/include/fuse
|
||||
else
|
||||
if os(freebsd)
|
||||
Includes: sys/param.h, sys/mount.h
|
||||
CC-Options: "-Df_namelen=f_namemax"
|
||||
CC-Options: "-DFUSE_USE_VERSION=26"
|
||||
else
|
||||
Includes: sys/statfs.h
|
||||
Extra-Libraries: fuse
|
||||
Extra-Lib-Dirs: /usr/local/lib
|
||||
CC-Options: "-D_FILE_OFFSET_BITS=64"
|
||||
Default-Language: Haskell2010
|
||||
|
||||
executable HelloFS
|
||||
if flag(developer)
|
||||
buildable: True
|
||||
build-depends: base >= 4 && < 5, hfuse, unix, bytestring
|
||||
else
|
||||
buildable: False
|
||||
main-is: HelloFS.hs
|
||||
hs-source-dirs: examples
|
||||
ghc-options: -threaded
|
||||
Default-Language: Haskell2010
|
||||
Loading…
Reference in New Issue