packages feed

Network-NineP (empty) → 0.0.2

raw patch · 11 files changed

+657/−0 lines, 11 filesdep +NinePdep +basedep +binarysetup-changed

Dependencies added: NineP, base, binary, bytestring, containers, monad-loops, mstate, mtl, network, regex-posix

Files

+ LICENSE view
@@ -0,0 +1,14 @@+            DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+                    Version 2, December 2004++ Copyright (C) 2004 Sam Hocevar+  22 rue de Plaisance, 75014 Paris, France+ Everyone is permitted to copy and distribute verbatim or modified+ copies of this license document, and changing it is allowed as long+ as the name is changed.++            DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. You just DO WHAT THE FUCK YOU WANT TO.+
+ Network-NineP.cabal view
@@ -0,0 +1,46 @@+Name:                Network-NineP+Version:             0.0.2+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>+License:             OtherLicense+Category:            Network+License-file:        LICENSE+Build-Type:          Simple+Cabal-Version:       >= 1.6+Stability:           Experimental+Tested-With:         GHC == 7.4.2++Source-repository head+  type:              darcs+  location:          http://kawais.org.ua/repos/highNineP/++Source-repository this+  type:              darcs+  location:          http://kawais.org.ua/repos/highNineP/+  tag:               0.0.2++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+  Exposed-modules:+    Network.NineP+    Network.NineP.Error+    Network.NineP.File+    Network.NineP.Server+  Other-modules:+    Network.NineP.Internal.File+    Network.NineP.Internal.Msg+    Network.NineP.Internal.State+ +Executable test+  Main-is: Test.hs
+ Network/NineP.hs view
@@ -0,0 +1,10 @@+-- |+-- Stability   :  Ultra-Violence+-- Portability :  I'm too young to die+-- A library providing one with a somewhat higher level interface to 9P2000 protocol. Designed to facilitate rapid development of synthetic filesystems.++module Network.NineP+	( module Network.NineP.Server+	) where++import Network.NineP.Server
+ Network/NineP/Error.hs view
@@ -0,0 +1,36 @@+-- |+-- Stability   :  Ultra-Violence+-- Portability :  I'm too young to die++module Network.NineP.Error+	( NineError(..)+	, module Control.Monad.Error+	) where++import Control.Monad.Error+import Data.Word++-- |Throwable errors+data NineError = +	ENotImplemented String |+	ENotADir |+	EDir |+	ENoFile String |+	ENoFid Word32 |+	ENoAuthRequired |+	EPermissionDenied |+	OtherError String++instance Error NineError where+	noMsg = undefined+	strMsg = OtherError++instance Show NineError where+	show (ENotImplemented s) = s ++ " is not implemented"+	show ENotADir = "tried to walk into a non-directory"+	show EDir = "tried to write to a directory"+	show (ENoFile s) = "file " ++ s ++ " not found"+	show (ENoFid i) = "fid " ++ show i ++ " is not registered on the server"+	show ENoAuthRequired = "the server doesn't require any kind of authentication"+	show EPermissionDenied = "permission denied"+	show (OtherError s) = s
+ Network/NineP/File.hs view
@@ -0,0 +1,47 @@+-- |+-- Stability   :  Ultra-Violence+-- Portability :  I'm too young to die+-- Higher-level file patterns.++module Network.NineP.File+	( chanFile+	, mVarFile+	) where++import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Word+import Prelude hiding (read)++import Network.NineP.Error+import Network.NineP.Internal.File++simpleRead :: IO ByteString -> Word64 -> Word32 -> ErrorT NineError IO ByteString+simpleRead get offset count = case offset of+	0 -> do+		d <- lift $ get+		return $ B.take (fromIntegral count) $ d+	_ -> throwError $ OtherError "can't read at offset"++simpleWrite :: (ByteString -> IO ()) -> Word64 -> ByteString -> ErrorT NineError IO Word32+simpleWrite put offset d = case offset of+	0 -> do+		lift $ put d+		return $ fromIntegral $ B.length d+	_ -> throwError $ OtherError "can't write at offset"++-- |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+	}++-- |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+	}
+ Network/NineP/Internal/File.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.NineP.Internal.File+	( NineFile(..)+	, boringFile+	, boringDir+	) where++import qualified Data.ByteString.Lazy.Char8 as B+import qualified Data.Map as M+import Data.Word++import Data.NineP+import Network.NineP.Error++data NineFile =+	RegularFile {+        	read :: Word64	-- Offset+			-> Word32 -- Length+			-> ErrorT NineError IO (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+	} | 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),+		-- |A callback to address a specific file by its name. @.@ and @..@ are handled in the library.+		descend :: String -> ErrorT NineError IO NineFile,+		remove :: IO (),+		-- |The directory stat must return only stat for @.@.+		stat :: IO Stat,+		wstat :: Stat -> IO (),+		version :: IO Word32+	}++boringStat :: Stat+boringStat = Stat 0 0 (Qid 0 0 0) 0o0777 0 0 0 "boring" "root" "root" "root"++boringFile :: String -> NineFile+boringFile name = RegularFile+        (\_ _ -> return "")+        (\_ _ -> return 0)+        (return ())+        (return $ boringStat {st_name = name})+        (const $ return ())+	(return 0)++boringDir :: String -> [(String, NineFile)] -> NineFile+boringDir name contents = let m = M.fromList contents in Directory {+	getFiles = (return $ map snd $ contents),+	descend = (\x -> case M.lookup x m of+		Nothing -> throwError $ ENoFile x+		Just f -> return f),+        remove = (return ()),+        stat = (return $ boringStat {st_name = name}),+        wstat = (const $ return ()),+	version = (return 0),+	parent = return Nothing }+
+ Network/NineP/Internal/Msg.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.NineP.Internal.Msg+	( Config(..)+	, rversion+	, rattach+	, rwalk+	, rstat+	, rwstat+	, rclunk+	, rauth+	, ropen+	, rread+	, rwrite+	, rremove+	, rcreate+	, rflush+	) where++import Control.Concurrent.MState hiding (put)+import Control.Monad.Reader+import Data.Binary.Put+import Data.Bits+import qualified Data.ByteString.Lazy as B+import Data.NineP+import Data.Map (Map)+import Data.Maybe+import Data.Word+import Prelude hiding (lookup, read)++import Network.NineP.Error+import Network.NineP.Internal.File+import Network.NineP.Internal.State++checkPerms :: NineFile -> Word8 -> Nine ()+checkPerms f want = do+	s <- getStat f+	checkPerms' (st_mode s) want++checkPerms' :: Word32 -> Word8 -> Nine ()+checkPerms' have want = do+	-- TODO stop presuming we are owners+	let checkRead = unless (testBit have 2) $ throwError EPermissionDenied+	let checkWrite = unless (testBit have 1) $ throwError EPermissionDenied+	let checkExec = unless (testBit have 0) $ throwError EPermissionDenied+	when (testBit want 4) $ do+		checkWrite+		throwError $ ENotImplemented "OTRUNC"+	when (testBit want 6) $ do+		throwError $ ENotImplemented "ORCLOSE"+	case want of+		0 -> checkRead+		1 -> checkWrite+		2 -> checkRead >> checkWrite+		3 -> checkExec++getQidTyp :: Stat -> Word8+getQidTyp s = fromIntegral $ shift (st_mode s) 24++makeQid :: NineFile -> Nine Qid+makeQid x = do+	s <- getStat x+	return $ Qid (getQidTyp s) 0 42++rversion :: Msg -> Nine [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 f ".." = do+	mp <- lift $ parent f+	return $ case mp of+		Just p -> p+		Nothing -> f+desc f s = descend f s++walk :: [Qid] -> [String] -> NineFile -> Nine (NineFile, [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+	q <- makeQid f+	walk (q:qs) xs f++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 f = do+	let fixDirBit = (case f of+				(RegularFile {}) -> flip clearBit 31+				(Directory {}) -> flip setBit 31+			)+	s <- lift $ lift $ lift $ 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+		RegularFile {} -> do+			s <- getStat f+			return $ return $ Msg TRstat t $ Rstat $ [s]+		Directory {} -> do+			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 f = do+	makeQid $ f++ropen :: Msg -> Nine [Msg]+ropen (Msg _ t (Topen fid mode)) = do+	f <- lookup fid+	checkPerms f mode+	q <- open f+	iou <- iounit+	return $ return $ Msg TRopen t $ Ropen q iou++rread :: Msg -> Nine [Msg]+rread (Msg _ t (Tread fid offset count)) = do+	f <- lookup fid+	u <- iounit+	checkPerms 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 <- mapErrorT (lift . lift) $ (read f) offset count+			mapM (return . Msg TRread t . Rread) $ splitMsg d $ fromIntegral u+		Directory {} -> do+			contents <- lift $ lift $ lift $ 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 _ 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+			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+	if testBit mode 31+		then do +			throwError $ ENotImplemented "create directory"+		else do+			throwError $ ENotImplemented "create file"+	--q <- open f+	-- TODO iounit+	--return $ return $ Msg TRcreate t $ Rcreate++rflush :: Msg -> Nine [Msg]+rflush _ = return []
+ Network/NineP/Internal/State.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TemplateHaskell #-}++module Network.NineP.Internal.State+	( Nine+	, NineVersion(..)+	, readVersion+	, Config(..)+	, emptyState+	, msize+	, protoVersion+	, lookup+	, insert+	, delete+	, iounit+	) where++import Control.Concurrent.MState+import Control.Monad.Reader+import Control.Monad.State.Class+import Data.List (isPrefixOf)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Word+import Prelude hiding (lookup)++import Network.NineP.Error+import Network.NineP.Internal.File++data NineVersion = VerUnknown | Ver9P2000++instance Show NineVersion where+	show VerUnknown = "unknown"+	show Ver9P2000 = "9P2000"++readVersion :: String -> NineVersion+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 NineState = NineState {+		fidMap :: Map Word32 NineFile,+		msize :: Word32,+		protoVersion :: NineVersion+	}++emptyState = NineState+	(M.empty :: Map Word32 NineFile)+	0+	VerUnknown++type Nine x = ErrorT NineError (MState NineState (ReaderT Config IO)) x++lookup :: Word32 -> Nine NineFile+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 fid f = do+	m <- (return . fidMap) =<< get +	lift $ modifyM_ (\s -> s { fidMap = M.insert fid f $ fidMap s })++delete :: Word32 -> Nine ()+delete fid = do+	lift $ modifyM_ (\s -> s { fidMap = M.delete fid $ fidMap s })++iounit :: Nine 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+	return $ ms - 24
+ Network/NineP/Server.hs view
@@ -0,0 +1,133 @@+-- |+-- Stability   :  Ultra-Violence+-- Portability :  I'm too young to die+-- Listening on sockets for the incoming requests.+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}++module Network.NineP.Server+	( module Network.NineP.Internal.File+	, Config(..)+	, run9PServer+	) where++import Control.Concurrent+import Control.Concurrent.MState hiding (get, put)+import Control.Exception+import Control.Monad+import Control.Monad.Loops+import Control.Monad.Reader+import Control.Monad.Trans+import Data.Binary.Get+import Data.Binary.Put+import Data.Bits+import qualified Data.ByteString as BS+import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.NineP+import Data.Word+import Network hiding (accept)+import Network.BSD+import Network.Socket hiding (send, sendTo, recv, recvFrom)+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++maybeRead :: Read a => String -> Maybe a+maybeRead = fmap fst . listToMaybe . reads++connection :: String -> IO Socket+connection s = let	pat = "tcp!(.*)!([0-9]*)|unix!(.*)" :: ByteString+			wrongAddr = ioError $ userError $ "wrong 9p connection address: " ++ s+			(bef, _, aft, grps) = s =~ pat :: (String, String, String, [String])+	in if (bef /= "" || aft /= "" || grps == [])+		then wrongAddr+		else case grps of+			[addr, port, ""] -> listen' addr $ toEnum $ (fromMaybe 2358 $ maybeRead port :: Int)+			["", "", addr]  -> listenOn $ UnixSocket addr+			_ -> wrongAddr++listen' :: HostName -> PortNumber -> IO Socket+listen' hostname port = do+	proto <- getProtocolNumber "tcp"+	bracketOnError (socket AF_INET Stream proto) sClose (\sock -> do+		setSocketOption sock ReuseAddr 1+		he <- getHostByName hostname+		bindSocket sock (SockAddrInet port (hostAddress he))+		listen sock maxListenQueue+		return sock)++-- |Run the actual server+run9PServer :: Config -> IO ()+run9PServer cfg = do+	s <- connection $ addr cfg+	serve s cfg++serve :: Socket -> Config -> IO ()+serve s cfg = forever $ accept s >>= (+		\(s, _) -> (doClient cfg) =<< (liftIO $ socketToHandle s ReadWriteMode))++doClient :: Config -> Handle -> IO ()+doClient cfg h = do+	hSetBuffering h NoBuffering+	chan <- (newChan :: IO (Chan Msg))+	st <- forkIO $ sender (readChan chan) (BS.hPut h . BS.concat . B.toChunks) -- make a strict bytestring+	receiver cfg h (writeChan chan)+	killThread st+	hClose h++recvPacket :: Handle -> IO Msg+recvPacket h = do+	-- TODO error reporting+	s <- B.hGet h 4+	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+	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 cfg h say = runReaderT (runMState (iterateUntil id (do+			mp <- liftIO $ try $ recvPacket h+			case mp of+				Left (e :: SomeException) -> do+					return $ putStrLn $ show e+					return True+				Right p -> do+					forkM $ handleMsg say p+					return False+		) >> return ()+	) emptyState) cfg >> return ()++handleMsg say p = do+	let Msg typ t m = p+	r <- runErrorT (case typ of+			TTversion -> rversion p+			TTattach -> rattach p+			TTwalk -> rwalk p+			TTstat -> rstat p+			TTwstat -> rwstat p+			TTclunk -> rclunk p+			TTauth -> rauth p+			TTopen -> ropen p+			TTread -> rread p+			TTwrite -> rwrite p+			TTremove -> rremove p+			TTcreate -> rcreate p+			TTflush -> rflush p+		)+	case r of+		(Right response) -> liftIO $ mapM_ say $ response+		(Left fail) -> liftIO $ say $ Msg TRerror t $ Rerror $ show $ fail
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ Test.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad.Error+import Control.Monad.Trans+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Word++import Network.NineP+import Network.NineP.Error+import Network.NineP.File++--cfg = Config $ boringDir "/" [("boring", boringFile "boring"),("nyak", boringFile "nyak")]+spamwr :: Word64 -> B.ByteString -> ErrorT NineError IO (Word32)+spamwr _ d = do+	lift $ B.putStr d+	return $ fromIntegral $ B.length d++boringwr _ c = return $ B.take (fromIntegral c) "i am so very boring"++cfg = Config {+	root = boringDir "/" [("lol", (boringFile "lol") { write = spamwr })],+	addr = "unix!/tmp/h9pt"+}++main = run9PServer cfg