Network-NineP 0.0.2 → 0.1.0
raw patch · 7 files changed
+223/−101 lines, 7 filesdep +transformersdep ~NinePdep ~binarydep ~bytestring
Dependencies added: transformers
Dependency ranges changed: NineP, binary, bytestring, containers, monad-loops, mstate, mtl, network, regex-posix
Files
- Control/Monad/EmbedIO.hs +69/−0
- Network-NineP.cabal +15/−13
- Network/NineP/File.hs +57/−17
- Network/NineP/Internal/File.hs +20/−17
- Network/NineP/Internal/Msg.hs +18/−26
- Network/NineP/Internal/State.hs +31/−20
- Network/NineP/Server.hs +13/−8
+ Control/Monad/EmbedIO.hs view
@@ -0,0 +1,69 @@+-- |+-- Stability : Ultra-Violence+-- Portability : I'm too young to die+-- Provides one with the ability to pass her own monads in the callbacks.+{-# LANGUAGE TypeFamilies, EmptyDataDecls #-}+module Control.Monad.EmbedIO+ ( EmbedIO(..)+ , Void+ , bracketE+ , catchE+ , handleE+ , tryE+ , throwE+ , forkE+ ) where++import Control.Concurrent+import Control.Exception+import Control.Monad.IO.Class+import Prelude hiding (catch)++-- |'MonadIO's that can be collapsed to and restored from a distinct value.+class (MonadIO o) => EmbedIO o where+ -- |Intermediate state storage type.+ type Content o+ -- |Propagate an 'IO' operation over the storage type to the monadic type.+ embed :: (Content o -> IO a) -> o a+ -- |Run the monadic computation using supplied state.+ callback :: o a -> Content o -> IO a++-- |Empty type. Used to represent state for 'IO' monad.+data Void++instance EmbedIO IO where+ type Content IO = Void+ embed f = f undefined+ callback action _ = action++-- |'bracket' equivalent.+bracketE :: EmbedIO m => m r -> (r -> m b) -> (r -> m a) -> m a+bracketE before after during =+ embed $ \x -> bracket (before' x) (\a -> after' a x) (\a -> during' a x)+ where+ before' x = callback before x+ after' a x = callback (after a) x+ during' a x = callback (during a) x++-- |'catch' equivalent.+catchE :: (EmbedIO m, Exception e) => m a -> (e -> m a) -> m a+catchE action handler = embed $ \x -> catch (action' x) (\e -> handler' e x)+ where+ action' x = callback action x+ handler' e x = callback (handler e) x++-- |'handle' equivalent.+handleE :: (EmbedIO m, Exception e) => (e -> m a) -> m a -> m a+handleE = flip catchE++-- |'try' equivalent.+tryE :: (EmbedIO m, Exception e) => m a -> m (Either e a)+tryE action = embed $ \x -> try (callback action x)++-- |'throw' equivalent.+throwE :: (EmbedIO m, Exception e) => e -> m a+throwE = liftIO . throwIO++-- |'forkIO' equivalent.+forkE :: EmbedIO m => m () -> m ThreadId+forkE action = embed $ \x -> forkIO (callback action x)
Network-NineP.cabal view
@@ -1,5 +1,5 @@ Name: Network-NineP-Version: 0.0.2+Version: 0.1.0 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>@@ -13,26 +13,28 @@ Source-repository head type: darcs- location: http://kawais.org.ua/repos/highNineP/+ location: http://patch-tag.com/r/L29Ah/Network-NineP Source-repository this type: darcs- location: http://kawais.org.ua/repos/highNineP/- tag: 0.0.2+ location: http://patch-tag.com/r/L29Ah/Network-NineP+ tag: 0.1.0 Library Build-Depends: base >= 4 && < 5,- bytestring >= 0.9.2.1,- containers >= 0.4.2.1,- NineP >= 0.0.2,- network >= 2.3.0.14,- binary >= 0.5.1.0,- mtl >= 2.1.2,- monad-loops >= 0.3.3.0,- regex-posix >= 0.95.2,- mstate >= 0.2.4+ bytestring >= 0.9.2.1 && < 0.10,+ containers >= 0.4.2.1 && < 0.5,+ NineP >= 0.0.2 && < 0.1,+ network >= 2.3.0.14 && < 2.5,+ binary >= 0.5.1.0 && < 0.7,+ mtl >= 2.1.2 && < 2.2,+ monad-loops >= 0.3.3.0 && < 0.4,+ regex-posix >= 0.95.2 && < 0.96,+ mstate >= 0.2.4 && < 0.3,+ transformers >= 0.3.0.0 && < 0.4 Exposed-modules:+ Control.Monad.EmbedIO Network.NineP Network.NineP.Error Network.NineP.File
Network/NineP/File.hs view
@@ -1,15 +1,20 @@ -- | -- Stability : Ultra-Violence -- Portability : I'm too young to die--- Higher-level file patterns.+-- Higher-level file patterns. Don't support read/write operations at offsets and handling stat changes as for now. +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}+ module Network.NineP.File ( chanFile , mVarFile+ , rwFile ) where import Control.Concurrent.Chan import Control.Concurrent.MVar+import Control.Exception+import Control.Monad.EmbedIO import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as B import Data.Word@@ -18,30 +23,65 @@ import Network.NineP.Error import Network.NineP.Internal.File -simpleRead :: IO ByteString -> Word64 -> Word32 -> ErrorT NineError IO ByteString+simpleRead_ :: (Monad m, EmbedIO m) => m ByteString -> Word64 -> Word32 -> ErrorT NineError m ByteString+simpleRead_ get offset count = case offset of+ _ -> do+ r <- lift $ tryE $ get+ either (throwError . OtherError . (show :: SomeException -> String))+ (return . B.take (fromIntegral count)) r+ --_ -> throwError $ OtherError "can't read at offset"++simpleWrite_ :: (Monad m, EmbedIO m) => (ByteString -> m ()) -> Word64 -> ByteString -> ErrorT NineError m Word32+simpleWrite_ put offset d = case offset of+ _ -> do+ r <- lift $ tryE $ put d+ either (throwError . OtherError . (show :: SomeException -> String))+ (const $ return $ fromIntegral $ B.length d) r+ --_ -> throwError $ OtherError "can't write at offset"++simpleRead :: (Monad m, EmbedIO m) => IO ByteString -> Word64 -> Word32 -> ErrorT NineError m ByteString simpleRead get offset count = case offset of- 0 -> do- d <- lift $ get+ _ -> do+ d <- lift $ liftIO $ get return $ B.take (fromIntegral count) $ d- _ -> throwError $ OtherError "can't read at offset"+ --_ -> throwError $ OtherError "can't read at offset" -simpleWrite :: (ByteString -> IO ()) -> Word64 -> ByteString -> ErrorT NineError IO Word32+simpleWrite :: (Monad m, EmbedIO m) => (ByteString -> IO ()) -> Word64 -> ByteString -> ErrorT NineError m Word32 simpleWrite put offset d = case offset of- 0 -> do- lift $ put d+ _ -> do+ lift $ liftIO $ put d return $ fromIntegral $ B.length d- _ -> throwError $ OtherError "can't write at offset"+ --_ -> throwError $ OtherError "can't write at offset" +-- |A file that reads and writes using simple user-specified callbacks+rwFile :: forall m. (EmbedIO m)+ => String -- ^File name+ -> Maybe (m ByteString) -- ^Read handler+ -> Maybe (ByteString -> m ()) -- ^Write handler+ -> NineFile m+rwFile name rc wc = (boringFile name :: NineFile m) {+ read = maybe (read $ (boringFile "" :: NineFile m)) (simpleRead_) rc,+ write = maybe (write $ (boringFile "" :: NineFile m)) (simpleWrite_) wc+ }+ -- |A file that reads from and writes to the specified Chans-chanFile :: String -> Maybe (Chan ByteString) -> Maybe (Chan ByteString) -> NineFile-chanFile name rc wc = (boringFile name) {- read = maybe (read $ boringFile "") (simpleRead . readChan) rc,- write = maybe (write $ boringFile "") (simpleWrite . writeChan) wc+chanFile :: forall m. (Monad m, EmbedIO m)+ => String -- ^File name+ -> Maybe (Chan ByteString) -- ^@Chan@ to read from+ -> Maybe (Chan ByteString) -- ^@Chan@ to write to+ -> NineFile m+chanFile name rc wc = (boringFile name :: NineFile m) {+ read = maybe (read $ (boringFile "" :: NineFile m)) (simpleRead . readChan) rc,+ write = maybe (write $ (boringFile "" :: NineFile m)) (simpleWrite . writeChan) wc } -- |A file that reads from and writes to the specified MVars-mVarFile :: String -> Maybe (MVar ByteString) -> Maybe (MVar ByteString) -> NineFile-mVarFile name rc wc = (boringFile name) {- read = maybe (read $ boringFile "") (simpleRead . takeMVar) rc,- write = maybe (write $ boringFile "") (simpleWrite . putMVar) wc+mVarFile :: forall m. (Monad m, EmbedIO m)+ => String -- ^File name+ -> Maybe (MVar ByteString) -- ^@MVar@ to read from+ -> Maybe (MVar ByteString) -- ^@MVar@ to write to+ -> NineFile m+mVarFile name rc wc = (boringFile name :: NineFile m) {+ read = maybe (read $ (boringFile "" :: NineFile m)) (simpleRead . takeMVar) rc,+ write = maybe (write $ (boringFile "" :: NineFile m)) (simpleWrite . putMVar) wc }
Network/NineP/Internal/File.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Network.NineP.Internal.File ( NineFile(..)@@ -6,6 +6,7 @@ , boringDir ) where +import Control.Monad.EmbedIO import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Map as M import Data.Word@@ -13,35 +14,36 @@ import Data.NineP import Network.NineP.Error -data NineFile =+data NineFile m = RegularFile { read :: Word64 -- Offset -> Word32 -- Length- -> ErrorT NineError IO (B.ByteString), -- Resulting data+ -> ErrorT NineError m (B.ByteString), -- Resulting data write :: Word64 -- Offset -> B.ByteString -- The written data- -> ErrorT NineError IO (Word32), -- Number of bytes written successfully. Should return @0@ in case of an error.- remove :: IO (),- stat :: IO Stat,- wstat :: Stat -> IO (),- version :: IO Word32+ -> ErrorT NineError m (Word32), -- Number of bytes written successfully. Should return @0@ in case of an error.+ remove :: m (),+ stat :: m Stat,+ wstat :: Stat -> m (),+ version :: m Word32 } | Directory { -- |A callback to get the list of the files this directory contains. Must not contain @.@ and @..@ entries.- getFiles :: IO [NineFile],- parent :: IO (Maybe NineFile),+ getFiles :: m [NineFile m],+ parent :: m (Maybe (NineFile m)), -- |A callback to address a specific file by its name. @.@ and @..@ are handled in the library.- descend :: String -> ErrorT NineError IO NineFile,- remove :: IO (),+ descend :: String -> ErrorT NineError m (NineFile m),+ remove :: m (), -- |The directory stat must return only stat for @.@.- stat :: IO Stat,- wstat :: Stat -> IO (),- version :: IO Word32+ stat :: m Stat,+ wstat :: Stat -> m (),+ version :: m Word32 } boringStat :: Stat boringStat = Stat 0 0 (Qid 0 0 0) 0o0777 0 0 0 "boring" "root" "root" "root" -boringFile :: String -> NineFile+-- |A dumb file that can't do anything.+boringFile :: (Monad m, EmbedIO m) => String -> NineFile m boringFile name = RegularFile (\_ _ -> return "") (\_ _ -> return 0)@@ -50,7 +52,8 @@ (const $ return ()) (return 0) -boringDir :: String -> [(String, NineFile)] -> NineFile+-- |A dumb directory that can't do anything but provide the files it contains.+boringDir :: (Monad m, EmbedIO m) => String -> [(String, NineFile m)] -> NineFile m boringDir name contents = let m = M.fromList contents in Directory { getFiles = (return $ map snd $ contents), descend = (\x -> case M.lookup x m of
Network/NineP/Internal/Msg.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Network.NineP.Internal.Msg ( Config(..)@@ -18,6 +18,7 @@ ) where import Control.Concurrent.MState hiding (put)+import Control.Monad.EmbedIO import Control.Monad.Reader import Data.Binary.Put import Data.Bits@@ -32,12 +33,12 @@ import Network.NineP.Internal.File import Network.NineP.Internal.State -checkPerms :: NineFile -> Word8 -> Nine ()+checkPerms :: (Monad m, EmbedIO m) => NineFile m -> Word8 -> Nine m () checkPerms f want = do s <- getStat f checkPerms' (st_mode s) want -checkPerms' :: Word32 -> Word8 -> Nine ()+checkPerms' :: (Monad m, EmbedIO m) => Word32 -> Word8 -> Nine m () checkPerms' have want = do -- TODO stop presuming we are owners let checkRead = unless (testBit have 2) $ throwError EPermissionDenied@@ -57,25 +58,24 @@ getQidTyp :: Stat -> Word8 getQidTyp s = fromIntegral $ shift (st_mode s) 24 -makeQid :: NineFile -> Nine Qid+makeQid :: (Monad m, EmbedIO m) => NineFile m -> Nine m Qid makeQid x = do s <- getStat x return $ Qid (getQidTyp s) 0 42 -rversion :: Msg -> Nine [Msg]+rversion :: Msg -> Nine m [Msg] rversion (Msg _ t (Tversion s v)) = do let ver = readVersion v lift $ modifyM_ (\st -> st { msize = s, protoVersion = ver }) return $ return $ Msg TRversion t $ Rversion s $ show ver -rattach :: Msg -> Nine [Msg] rattach (Msg _ t (Tattach fid _ _ _)) = do root <- asks root insert fid root q <- makeQid root return $ return $ Msg TRattach t $ Rattach q -desc :: NineFile -> String -> ErrorT NineError IO NineFile+desc :: (Monad m, EmbedIO m) => NineFile m -> String -> ErrorT NineError m (NineFile m) desc f ".." = do mp <- lift $ parent f return $ case mp of@@ -83,34 +83,33 @@ Nothing -> f desc f s = descend f s -walk :: [Qid] -> [String] -> NineFile -> Nine (NineFile, [Qid])+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 {}) = throwError ENotADir walk qs (x:xs) d@(Directory {}) = do- f <- mapErrorT (lift . lift) $ desc d x+ f <- mapErrorT call $ desc d x q <- makeQid f walk (q:qs) xs f +walk' :: (Monad m, EmbedIO m) => [String] -> NineFile m -> Nine m (NineFile m, [Qid]) walk' = walk [] -rwalk :: Msg -> Nine [Msg] rwalk (Msg _ t (Twalk fid newfid path)) = do f <- lookup fid (nf, qs) <- walk' path f insert newfid nf return $ return $ Msg TRwalk t $ Rwalk $ qs -getStat :: NineFile -> Nine Stat+getStat :: (Monad m, EmbedIO m) => NineFile m -> Nine m Stat getStat f = do let fixDirBit = (case f of (RegularFile {}) -> flip clearBit 31 (Directory {}) -> flip setBit 31 )- s <- lift $ lift $ lift $ stat f+ s <- lift $ call $ stat f return s { st_mode = fixDirBit $ st_mode s, st_qid = (st_qid s) { qid_typ = getQidTyp s } } -rstat :: Msg -> Nine [Msg] rstat (Msg _ t (Tstat fid)) = do f <- lookup fid case f of@@ -121,20 +120,17 @@ mys <- getStat f return $ return $ Msg TRstat t $ Rstat $ return $ mys -rclunk :: Msg -> Nine [Msg] rclunk (Msg _ t (Tclunk fid)) = do delete fid return $ return $ Msg TRclunk t $ Rclunk -rauth :: Msg -> Nine [Msg] rauth (Msg {}) = do throwError ENoAuthRequired -open :: NineFile -> Nine Qid+open :: (Monad m, EmbedIO m) => NineFile m -> Nine m Qid open f = do makeQid $ f -ropen :: Msg -> Nine [Msg] ropen (Msg _ t (Topen fid mode)) = do f <- lookup fid checkPerms f mode@@ -142,7 +138,7 @@ iou <- iounit return $ return $ Msg TRopen t $ Ropen q iou -rread :: Msg -> Nine [Msg]+rread :: (Monad m, EmbedIO m) => Msg -> Nine m [Msg] rread (Msg _ t (Tread fid offset count)) = do f <- lookup fid u <- iounit@@ -152,37 +148,34 @@ let (a, b) = B.splitAt s d in a : splitMsg' b s case f of RegularFile {} -> do- d <- mapErrorT (lift . lift) $ (read f) offset count+ d <- mapErrorT call $ (read f) offset count mapM (return . Msg TRread t . Rread) $ splitMsg d $ fromIntegral u Directory {} -> do- contents <- lift $ lift $ lift $ getFiles f+ contents <- lift $ call $ getFiles f s <- mapM getStat $ contents let d = runPut $ mapM_ put s mapM (return . Msg TRread t . Rread) $ splitMsg (B.drop (fromIntegral offset) d) $ fromIntegral u -rwrite :: Msg -> Nine [Msg]+--rwrite :: Msg -> Nine m [Msg] rwrite (Msg _ t (Twrite fid offset d)) = do f <- lookup fid checkPerms f 1 case f of Directory {} -> throwError EDir RegularFile {} -> do- c <- mapErrorT (lift . lift) $ (write f) offset d+ c <- mapErrorT call $ (write f) offset d return $ return $ Msg TRwrite t $ Rwrite c -rwstat :: Msg -> Nine [Msg] rwstat (Msg _ t (Twstat fid stat)) = do -- TODO check perms f <- lookup fid throwError $ ENotImplemented "wstat" -rremove :: Msg -> Nine [Msg] rremove (Msg _ t (Tremove fid)) = do -- TODO check perms f <- lookup fid throwError $ ENotImplemented "remove" -rcreate :: Msg -> Nine [Msg] rcreate (Msg _ t (Tcreate fid name perm mode)) = do -- TODO check perms --dir <- lookup fid@@ -195,5 +188,4 @@ -- TODO iounit --return $ return $ Msg TRcreate t $ Rcreate -rflush :: Msg -> Nine [Msg] rflush _ = return []
Network/NineP/Internal/State.hs view
@@ -1,20 +1,21 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-} module Network.NineP.Internal.State ( Nine , NineVersion(..) , readVersion , Config(..)+ , NineState(..) , emptyState- , msize- , protoVersion , lookup , insert , delete , iounit+ , call ) where import Control.Concurrent.MState+import Control.Monad.EmbedIO import Control.Monad.Reader import Control.Monad.State.Class import Data.List (isPrefixOf)@@ -36,43 +37,53 @@ readVersion s = if isPrefixOf "9P2000" s then Ver9P2000 else VerUnknown -- |Server configuration.-data Config = Config {- -- |The @/@ directory of the hosted filesystem- root :: NineFile,- -- |The listening address. The syntax is taken from @Plan 9@ operating system and has the form @unix!/path/to/socket@ for unix socket files, and @tcp!hostname!port@ for tcp sockets.- addr :: String+data Config m = Config {+ -- |The @/@ directory of the hosted filesystem.+ root :: NineFile m,+ -- |The listening address. The syntax is taken from @Plan 9@ operating system and has the form @unix!\/path\/to\/socket@ for unix socket files, and @tcp!hostname!port@ for tcp sockets.+ addr :: String,+ -- |The initial state for the user-supplied monad. Use 'Void' for 'IO'.+ monadState :: Content m } -data NineState = NineState {- fidMap :: Map Word32 NineFile,+data NineState m = NineState {+ fidMap :: Map Word32 (NineFile m), msize :: Word32,- protoVersion :: NineVersion+ protoVersion :: NineVersion,+ mState :: Content m } -emptyState = NineState- (M.empty :: Map Word32 NineFile)- 0- VerUnknown+emptyState m = NineState {+ fidMap = M.empty :: Map Word32 (NineFile m),+ msize = 0,+ protoVersion = VerUnknown,+ mState = m+} -type Nine x = ErrorT NineError (MState NineState (ReaderT Config IO)) x+type Nine m x = ErrorT NineError (MState (NineState m) (ReaderT (Config m) IO)) x -lookup :: Word32 -> Nine NineFile+call :: (EmbedIO m) => m a -> MState (NineState m) (ReaderT (Config m) IO) a+call x = do+ s <- (return . mState) =<< get+ lift $ lift $ callback x s++lookup :: Word32 -> Nine m (NineFile m) lookup fid = do m <- (return . fidMap) =<< get case M.lookup fid m of Nothing -> throwError $ ENoFid fid Just f -> return f -insert :: Word32 -> NineFile -> Nine ()+insert :: Word32 -> NineFile m -> Nine m () insert fid f = do m <- (return . fidMap) =<< get lift $ modifyM_ (\s -> s { fidMap = M.insert fid f $ fidMap s }) -delete :: Word32 -> Nine ()+delete :: Word32 -> Nine m () delete fid = do lift $ modifyM_ (\s -> s { fidMap = M.delete fid $ fidMap s }) -iounit :: Nine Word32+iounit :: Nine m Word32 iounit = do ms <- (return . msize) =<< get -- 23 is the biggest size of a message (write), but libixp uses 24, so we do too to stay safe
Network/NineP/Server.hs view
@@ -14,6 +14,7 @@ import Control.Concurrent.MState hiding (get, put) import Control.Exception import Control.Monad+import Control.Monad.EmbedIO import Control.Monad.Loops import Control.Monad.Reader import Control.Monad.Trans@@ -34,13 +35,16 @@ import System.IO import Text.Regex.Posix ((=~)) -import Debug.Trace- import Network.NineP.Error import Network.NineP.Internal.File import Network.NineP.Internal.Msg import Network.NineP.Internal.State +--import Debug.Trace+traceShow a b = b+traceIO :: String -> IO ()+traceIO a = return ()+ maybeRead :: Read a => String -> Maybe a maybeRead = fmap fst . listToMaybe . reads @@ -66,16 +70,16 @@ return sock) -- |Run the actual server-run9PServer :: Config -> IO ()+run9PServer :: (EmbedIO m) => Config m -> IO () run9PServer cfg = do s <- connection $ addr cfg serve s cfg -serve :: Socket -> Config -> IO ()+serve :: (EmbedIO m) => Socket -> Config m -> IO () serve s cfg = forever $ accept s >>= ( \(s, _) -> (doClient cfg) =<< (liftIO $ socketToHandle s ReadWriteMode)) -doClient :: Config -> Handle -> IO ()+doClient :: (EmbedIO m) => Config m -> Handle -> IO () doClient cfg h = do hSetBuffering h NoBuffering chan <- (newChan :: IO (Chan Msg))@@ -91,14 +95,14 @@ let l = fromIntegral $ runGet getWord32le $ assert (B.length s == 4) s p <- B.hGet h $ l - 4 let m = runGet (get :: Get Msg) (B.append s p)- print m+ traceIO $ show m return m sender :: IO Msg -> (ByteString -> IO ()) -> IO () sender get say = forever $ do (say . runPut . put . join traceShow) =<< get -receiver :: Config -> Handle -> (Msg -> IO ()) -> IO ()+receiver :: (EmbedIO m) => Config m -> Handle -> (Msg -> IO ()) -> IO () receiver cfg h say = runReaderT (runMState (iterateUntil id (do mp <- liftIO $ try $ recvPacket h case mp of@@ -109,8 +113,9 @@ forkM $ handleMsg say p return False ) >> return ()- ) emptyState) cfg >> return ()+ ) (emptyState $ monadState cfg)) cfg >> return () +handleMsg :: (EmbedIO m) => (Msg -> IO ()) -> Msg -> MState (NineState m) (ReaderT (Config m) IO) () handleMsg say p = do let Msg typ t m = p r <- runErrorT (case typ of