{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
module Network.NineP.Internal.Msg
( Config(..)
, rversion
, rattach
, rwalk
, rstat
, rwstat
, rclunk
, rauth
, ropen
, rcreate
, rread
, rwrite
, rremove
, rflush
) where
import Control.Concurrent.MState hiding (put)
import Control.Exception
import Control.Monad.EmbedIO
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 :: (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 ()
checkPerms' have want = do
let checkRead = unless (testBit have 2) $ throw EPermissionDenied
let checkWrite = unless (testBit have 1) $ throw EPermissionDenied
let checkExec = unless (testBit have 0) $ throw EPermissionDenied
when (testBit want 4) $ do
checkWrite
throw $ ENotImplemented "OTRUNC"
when (testBit want 6) $ do
throw $ 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 :: (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]
rversion (Msg _ t (Tversion s v)) = do
let ver = readVersion v
modifyM_ (\st -> st { msize = s, protoVersion = ver })
return $ return $ Msg TRversion t $ Rversion s $ show ver
rattach (Msg _ t (Tattach fid _ _ _)) = do
root <- asks root
insert fid root
q <- makeQid t root
return $ return $ Msg TRattach t $ Rattach q
desc :: (Monad m, EmbedIO m) => NineFile m -> String -> m (NineFile m)
desc f ".." = do
mp <- parent f
return $ case mp of
Just p -> p
Nothing -> f
desc f s = descend f s
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) => 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' t path f
insert newfid nf
return $ return $ Msg TRwalk t $ Rwalk $ qs
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 t $ stat f
return s { st_mode = fixDirBit $ st_mode s,
st_qid = (st_qid s) { qid_typ = getQidTyp s } }
rstat (Msg _ t (Tstat fid)) = do
f <- lookup fid
case f of
RegularFile {} -> do
s <- getStat t f
return $ return $ Msg TRstat t $ Rstat $ [s]
Directory {} -> do
mys <- getStat t f
return $ return $ Msg TRstat t $ Rstat $ return $ mys
rclunk (Msg _ t (Tclunk fid)) = do
delete fid
return $ return $ Msg TRclunk t $ Rclunk
rauth (Msg {}) = do
throw ENoAuthRequired
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 t f mode
qid <- open t f
iou <- iounit
return $ return $ Msg TRopen t $ Ropen qid iou
rcreate (Msg _ t (Tcreate fid name perm mode)) = do
f <- lookup fid
case f of
RegularFile {} -> throw ENotADir
Directory {} -> do
nf <- call t $ (create f) name perm
insert fid nf
qid <- open t f
iou <- iounit
return $ return $ Msg TRcreate t $ Rcreate qid iou
rread :: (Monad m, EmbedIO m) => Msg -> Nine m [Msg]
rread (Msg _ t (Tread fid offset count)) = do
f <- lookup fid
u <- iounit
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 t $ (read f) offset count
mapM (return . Msg TRread t . Rread) $ splitMsg d $ fromIntegral u
Directory {} -> do
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 _ t (Twrite fid offset d)) = do
f <- lookup fid
checkPerms t f 1
case f of
Directory {} -> throw EDir
RegularFile {} -> do
c <- call t $ (write f) offset d
return $ return $ Msg TRwrite t $ Rwrite c
rwstat (Msg _ t (Twstat fid stat)) = do
f <- lookup fid
return $ return $ Msg TRwstat t $ Rwstat
rremove (Msg _ t (Tremove fid)) = do
f <- lookup fid
throw $ ENotImplemented "remove"
rflush (Msg _ t _) = return $ return $ Msg TRflush t $ Rflush