Network-NineP 0.4.4 → 0.4.5
raw patch · 3 files changed
+59/−42 lines, 3 filesdep +async
Dependencies added: async
Files
- Network-NineP.cabal +5/−4
- Network/NineP/Internal/Msg.hs +36/−35
- Network/NineP/Internal/State.hs +18/−3
Network-NineP.cabal view
@@ -1,5 +1,5 @@ Name: Network-NineP-Version: 0.4.4+Version: 0.4.5 Description: A library providing one with a somewhat higher level interface to 9P2000 protocol than existing implementations. Designed to facilitate rapid development of synthetic filesystems. Synopsis: High-level abstraction over 9P protocol Maintainer: Sergey Alirzaev <zl29ah@gmail.com>@@ -9,7 +9,7 @@ Build-Type: Simple Cabal-Version: >= 1.6 Stability: Experimental-Tested-With: GHC == 8.2.2+Tested-With: GHC == 8.6.3 Source-repository head type: git@@ -18,7 +18,7 @@ Source-repository this type: git location: https://github.com/l29ah/Network-NineP.git- tag: 0.4.4+ tag: 0.4.5 Library Build-Depends:@@ -37,7 +37,8 @@ convertible >= 1.0.11.1 && < 1.2, exceptions >= 0.8.0.2 && < 0.11, monad-peel >= 0.1.1 && < 0.3,- hslogger >= 1.2.9 && < 1.3+ hslogger >= 1.2.9 && < 1.3,+ async >= 2.2.1 && < 2.3 Exposed-modules: Control.Monad.EmbedIO Network.NineP
Network/NineP/Internal/Msg.hs view
@@ -34,9 +34,9 @@ import Network.NineP.Internal.File import Network.NineP.Internal.State -checkPerms :: (Monad m, EmbedIO m) => NineFile m -> Word8 -> Nine m ()-checkPerms f want = do- s <- getStat f+checkPerms :: (Monad m, EmbedIO m) => Word16 -> NineFile m -> Word8 -> Nine m ()+checkPerms tag f want = do+ s <- getStat tag f checkPerms' (st_mode s) want checkPerms' :: (Monad m, EmbedIO m) => Word32 -> Word8 -> Nine m ()@@ -59,9 +59,9 @@ getQidTyp :: Stat -> Word8 getQidTyp s = fromIntegral $ shift (st_mode s) 24 -makeQid :: (Monad m, EmbedIO m) => NineFile m -> Nine m Qid-makeQid x = do- s <- getStat x+makeQid :: (Monad m, EmbedIO m) => Word16 -> NineFile m -> Nine m Qid+makeQid t x = do+ s <- getStat t x return $ Qid (getQidTyp s) 0 42 rversion :: Msg -> Nine m [Msg]@@ -73,7 +73,7 @@ rattach (Msg _ t (Tattach fid _ _ _)) = do root <- asks root insert fid root- q <- makeQid root+ q <- makeQid t root return $ return $ Msg TRattach t $ Rattach q desc :: (Monad m, EmbedIO m) => NineFile m -> String -> m (NineFile m)@@ -84,30 +84,30 @@ Nothing -> f desc f s = descend f s -walk :: (Monad m, EmbedIO m) => [Qid] -> [String] -> NineFile m -> Nine m (NineFile m, [Qid])-walk qs [] f = return (f, qs)-walk qs (x:xs) (RegularFile {}) = throw ENotADir-walk qs (x:xs) d@(Directory {}) = do- f <- call $ desc d x- q <- makeQid f- walk (q:qs) xs f+walk :: (Monad m, EmbedIO m) => [Qid] -> Word16 -> [String] -> NineFile m -> Nine m (NineFile m, [Qid])+walk qs t [] f = return (f, qs)+walk qs t (x:xs) (RegularFile {}) = throw ENotADir+walk qs t (x:xs) d@(Directory {}) = do+ f <- call t $ desc d x+ q <- makeQid t f+ walk (q:qs) t xs f -walk' :: (Monad m, EmbedIO m) => [String] -> NineFile m -> Nine m (NineFile m, [Qid])+walk' :: (Monad m, EmbedIO m) => Word16 -> [String] -> NineFile m -> Nine m (NineFile m, [Qid]) walk' = walk [] rwalk (Msg _ t (Twalk fid newfid path)) = do f <- lookup fid- (nf, qs) <- walk' path f+ (nf, qs) <- walk' t path f insert newfid nf return $ return $ Msg TRwalk t $ Rwalk $ qs -getStat :: (Monad m, EmbedIO m) => NineFile m -> Nine m Stat-getStat f = do+getStat :: (Monad m, EmbedIO m) => Word16 -> NineFile m -> Nine m Stat+getStat t f = do let fixDirBit = (case f of (RegularFile {}) -> flip clearBit 31 (Directory {}) -> flip setBit 31 )- s <- call $ stat f+ s <- call t $ stat f return s { st_mode = fixDirBit $ st_mode s, st_qid = (st_qid s) { qid_typ = getQidTyp s } } @@ -115,10 +115,10 @@ f <- lookup fid case f of RegularFile {} -> do- s <- getStat f+ s <- getStat t f return $ return $ Msg TRstat t $ Rstat $ [s] Directory {} -> do- mys <- getStat f+ mys <- getStat t f return $ return $ Msg TRstat t $ Rstat $ return $ mys rclunk (Msg _ t (Tclunk fid)) = do@@ -128,14 +128,14 @@ rauth (Msg {}) = do throw ENoAuthRequired -open :: (Monad m, EmbedIO m) => NineFile m -> Nine m Qid-open f = do- makeQid $ f+open :: (Monad m, EmbedIO m) => Word16 -> NineFile m -> Nine m Qid+open t f = do+ makeQid t f ropen (Msg _ t (Topen fid mode)) = do f <- lookup fid- checkPerms f mode- qid <- open f+ checkPerms t f mode+ qid <- open t f iou <- iounit return $ return $ Msg TRopen t $ Ropen qid iou @@ -145,9 +145,9 @@ case f of RegularFile {} -> throw ENotADir Directory {} -> do- nf <- call $ (create f) name perm+ nf <- call t $ (create f) name perm insert fid nf- qid <- open f+ qid <- open t f iou <- iounit return $ return $ Msg TRcreate t $ Rcreate qid iou @@ -155,28 +155,28 @@ rread (Msg _ t (Tread fid offset count)) = do f <- lookup fid u <- iounit- checkPerms f 0+ checkPerms t f 0 let splitMsg d s = let r = splitMsg' d s in if null r then [B.empty] else r splitMsg' d s = if B.null d then [] else let (a, b) = B.splitAt s d in a : splitMsg' b s case f of RegularFile {} -> do- d <- call $ (read f) offset count+ d <- call t $ (read f) offset count mapM (return . Msg TRread t . Rread) $ splitMsg d $ fromIntegral u Directory {} -> do- contents <- call $ getFiles f- s <- mapM getStat $ contents+ contents <- call t $ getFiles f+ s <- mapM (getStat t) $ contents let d = runPut $ mapM_ put s mapM (return . Msg TRread t . Rread) $ splitMsg (B.drop (fromIntegral offset) d) $ fromIntegral u --rwrite :: Msg -> Nine m [Msg] rwrite (Msg _ t (Twrite fid offset d)) = do f <- lookup fid- checkPerms f 1+ checkPerms t f 1 case f of Directory {} -> throw EDir RegularFile {} -> do- c <- call $ (write f) offset d+ c <- call t $ (write f) offset d return $ return $ Msg TRwrite t $ Rwrite c rwstat (Msg _ t (Twstat fid stat)) = do@@ -190,4 +190,5 @@ f <- lookup fid throw $ ENotImplemented "remove" -rflush _ = return []+-- TODO meaningful flush behaviour instead of pretending it works+rflush (Msg _ t _) = return $ return $ Msg TRflush t $ Rflush
Network/NineP/Internal/State.hs view
@@ -14,6 +14,7 @@ , call ) where +import Control.Concurrent.Async import Control.Concurrent.MState import Control.Exception (throw) import Control.Exception.Peel as P@@ -52,6 +53,7 @@ data NineState m = NineState { fidMap :: Map Word32 (NineFile m),+ flushMap :: Map Word16 (IO ()), msize :: Word32, protoVersion :: NineVersion, mState :: Content m@@ -59,6 +61,7 @@ emptyState m = NineState { fidMap = M.empty :: Map Word32 (NineFile m),+ flushMap = M.empty :: Map Word16 (IO ()), msize = 0, protoVersion = VerUnknown, mState = m@@ -71,10 +74,12 @@ instance (MonadCatch m, MonadPeelIO m) => MonadCatch (MState s m) where catch = P.catch -call :: (EmbedIO m) => m a -> MState (NineState m) (ReaderT (Config m) IO) a-call x = do+call :: (EmbedIO m) => Word16 -> m a -> MState (NineState m) (ReaderT (Config m) IO) a+call tag x = do s <- (return . mState) =<< get- lift $ lift $ callback x s+ thread <- liftIO $ async $ callback x s+ flushable tag thread+ lift $ lift $ wait thread lookup :: Word32 -> Nine m (NineFile m) lookup fid = do@@ -97,3 +102,13 @@ ms <- (return . msize) =<< get -- 23 is the biggest size of a message (write), but libixp uses 24, so we do too to stay safe return $ ms - 24++flushable :: Word16 -> Async a -> Nine m ()+flushable tag thread = modifyM_ (\s -> s { flushMap = M.insert tag (cancel thread) $ flushMap s })++flush :: Word16 -> Nine m ()+flush tag = do+ m <- (return . flushMap) =<< get+ case M.lookup tag m of+ Nothing -> return ()+ Just handler -> lift $ lift handler